!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
SUBROUTINE SOBSPROF 1
#if defined (DOC)
*
***s/r SOBSPROF
*
*Author : J. St-James October 2002
* - Based on the subroutine sobsraob. Adapt to
* Profiler data
*
** Purpose:
* Refuse elements which are too far away from the surface of the model
* Refuse elements which are considered in the free atmosphere of
* the RAOB but fall in the surface boundary layer of the model atmosphere.
*
*Revision
* C. Charette ARMA/SMC jan. 2005
* - Removed debug statements
*Arguments:
*
* none
#endif
IMPLICIT NONE
*implicits
#include "comlun.cdk"
#include "comdimo.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "commvohr.cdk"
#include "comcst.cdk"
#include "cvcord.cdk"
#include "comnumbr.cdk"
*
INTEGER JPINEL,JPRANGE
PARAMETER(JPINEL=7,JPRANGE=10)
INTEGER IJ,J,JD,JF,JOBS,JDATA,IOBS1,IOBS2,IBAD,IFLG
LOGICAL LLREJ,LLNOIR,LLSFC(JPINEL),LLALTOK(JPINEL),LLFOUND
REAL*8 ZVAL,ZLEV,ZCRIT,ZDIFF,ZDIFALT,ZPCRIT,ZPMAX(JPINEL)
REAL*8 ZLAT,ZLON,ZRADDEG,ZGZG,ZSTNALT,ZPB,ZPT,ZDELP
INTEGER ITYP,IDATA,IDATEND,IASS,ICOUNT
INTEGER ICOUNTAL,ICOUNTAH,ICOUNTBL,ICOUNTBH
INTEGER ILEM,IELGZ,IBEGIN,ILAST
INTEGER ILISTEL(JPINEL),INDXEL(JPINEL),IFLGEL(JPINEL)
INTEGER ITOTACC(JPINEL),ITOTREJ(JPINEL),IKOUNTT
INTEGER ISFCACC(JPINEL),ISFCREJ(JPINEL),ISBLREJ(JPINEL)
INTEGER IGZACC(JPINEL),IGZREJ(JPINEL),IBNDREJ(JPINEL)
INTEGER INEARACC(JPINEL),IRANGE(JPRANGE)
REAL*8 ZLMINF(JPRANGE),ZLMSUP(JPRANGE),ZDIFGZ
REAL*8 RLISTCRIT(JPINEL),RSBLCRIT(JPINEL),JPMAX(JPINEL)
LOGICAL LLPRINT,LLOK
DATA RLISTCRIT/50.,50.,50.,50.,50.,50.,800./
DATA RSBLCRIT /400.0,400.0,400.0,400.0,400.0,400.0,400.0 /
DATA ZLMINF /-9999.,-300.,-200.,-100.,-50.,
& 0.,50.,100.,200.,300./
DATA ZLMSUP /-300.,-200.,-100.,-50.,
& 0.,50.,100.,200.,300.,9999./
ILISTEL(1)=NEDD
ILISTEL(2)=NEFF
ILISTEL(3)=NEUU
ILISTEL(4)=NEVV
ILISTEL(5)=NEES
ILISTEL(6)=NETT
ILISTEL(7)=NEGZ
C
C
C LLPRINT = .TRUE.
LLPRINT = .FALSE.
C
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* ) ' SUBROUTINE SOBSPROF '
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* ) '************************************************'
WRITE(NULOUT,222)'%PR ELEMENTS '
& ,( ILISTEL(J),J=1,jpinel)
WRITE(NULOUT,223)'%PR REJECTION BOUNDARY(METRE) '
& ,(RLISTCRIT(J),J=1,jpinel)
WRITE(NULOUT,223)'%PR REJECTION SBL (METRE) '
& ,(RSBLCRIT(J),J=1,jpinel)
WRITE(NULOUT,* ) '************************************************'
WRITE(NULOUT,* ) ' '
IELGZ = ILISTEL(JPINEL)
ZRADDEG = 180./RPI
C
C SET COUNTERS TO ZERO
C
DO J=1,JPRANGE
IRANGE(J) = 0
ENDDO
DO J=1,JPINEL
ITOTREJ(J)=0
ITOTACC(J)=0
ISFCACC(J)=0
INEARACC(J)=0
ISFCREJ(J)=0
ISBLREJ(J)=0
IGZACC(J)=0
IGZREJ(J)=0
IBNDREJ(J)=0
END DO
IKOUNTT=0
ICOUNT =0
ICOUNTAL =0
ICOUNTAH =0
ICOUNTBL =0
ICOUNTBH =0
C
C LOOP OVER OBSERVATIONS
C
DO JF = 1,NFILES
IF ( (CFAMTYP(JF) .EQ. 'PR') .AND. (NBEGINTYP(JF) .GT. 0) ) THEN
IBEGIN=NBEGINTYP(JF)
ILAST=NENDTYP(JF)
IOBS1=MOBDATA(NCMOBS,NBEGINTYP(JF))
IOBS2=MOBDATA(NCMOBS,NENDTYP(JF))
WRITE(NULOUT,'(2x,A10,2x,A2)')'FAMILY = ',CFAMTYP(JF)
C
C
DO JOBS=IOBS1,IOBS2
IDATA = MOBHDR(NCMRLN,JOBS)
IDATEND = MOBHDR(NCMNLV,JOBS) + IDATA - 1
ZLAT=ROBHDR(NCMLAT,JOBS)*ZRADDEG
ZLON=ROBHDR(NCMLON,JOBS)*ZRADDEG
ZSTNALT=ROBHDR(NCMALT,JOBS)
ZDIFALT= ZSTNALT- GOMGZHR(NLEVTRL,JOBS)/RG
DO J=1,JPINEL
LLALTOK(J) = .FALSE.
IF(ABS(ZDIFALT).LE.RLISTCRIT(J)) LLALTOK(J)=.TRUE.
ENDDO
C
C REJECT ELEMENTS OF U,V,T-TD,T BELOW THE MODEL SURFACE
C AND THOSE NON SURFACE ELEMENTS PRESENT IN THE SURFACE
C BOUNDARY LAYER OF THE RAOB OR OF THE MODEL.
C AT THIS POINT WE WANT TO KEEP OBSERVATIONS IN THE FREE
C ATMOSPHERE
C
C
C--------------Special case if station elevation is above model elevation
C we want to define zpt at a level above the station.
C To approximate that value, we will transform the difference
C between the 2 elevations into a difference in pressure using
C the rule of thumb (1Mb =8 metres)
C--------------Even though TT(element=12001) is not assimmilated
C it is treated as if it were for the evaluation step.
C Otherwise we use observations of TT that are too far
C from the model topography in the verification.
DO JDATA= IDATA, IDATEND
ITYP=MOBDATA(NCMVNM,JDATA)
IJ = -1
DO J=1,JPINEL-1
IF(ITYP.EQ.ILISTEL(J))IJ = J
ENDDO
LLOK = MOBDATA(NCMVCO,JDATA) .EQ. 1
& .AND. ITYP .NE.ILISTEL(JPINEL)
& .AND. IJ .NE. -1
IF (LLOK ) THEN
ZLEV=ROBDATA8(NCMPPP,JDATA)
ZPB =GOMGZHR(NLEVTRL,JOBS)/RG
ZPT =GOMGZHR(NLEVTRL,JOBS)/RG + RSBLCRIT(IJ)
IF (ZDIFALT .GT. 0.0) THEN
ZPT=GOMGZHR(NLEVTRL,JOBS)/RG
& + (ZDIFALT+RSBLCRIT(IJ))
ENDIF
IF(LLALTOK(IJ)) THEN
C--------------------Model surface and station altitude are very close
C Accept observation if zlev is within the domain
C of the trial field
ZPB = GOMGZHR(NLEVTRL,JOBS)/RG
ZPT = GOMGZHR(NLEVTRL-1,JOBS)/RG
IF(LLPRINT) THEN
WRITE(NULOUT,*) 'LLALTOK .EQ. .TRUE. '
& ,JOBS,ITYP,CSTNID(JOBS),ZLAT,ZLON,ZLEV
& ,GOMGZHR(NLEVTRL,JOBS)/RG,
& GOMGZHR(NLEVTRL-1,JOBS)/RG,ZDIFALT
ENDIF
ENDIF
IF(ZLEV .LT. ZPB ) THEN
MOBDATA(NCMFLG,JDATA)=
& ibset( MOBDATA(NCMFLG,JDATA) , 18 )
ZGZG = GOMGZHR(NLEVTRL,JOBS)/RG
IF(LLPRINT) THEN
WRITE(NULOUT,*) 'Rej Obs below model sfc '
& ,JOBS,ITYP,CSTNID(JOBS),ZLAT,ZLON
& ,ZLEV,GOMGZHR(NLEVTRL-1,JOBS)/RG,ZPT
& ,JDATA,ZPB,ZDIFALT
ENDIF
MOBDATA(NCMASS,JDATA)=0
ITOTREJ(IJ)=ITOTREJ(IJ)+1
IBNDREJ(IJ)=IBNDREJ(IJ)+1
ELSEIF(ZLEV.GE.ZPB .AND. ZLEV.LT.ZPT ) THEN
MOBDATA(NCMFLG,JDATA)=
& ibset( MOBDATA(NCMFLG,JDATA) , 18 )
ZGZG = GOMGZHR(NLEVTRL,JOBS)/RG
IF(LLPRINT) THEN
WRITE(NULOUT,*) '%PR REJ SBL ITYP,DALT '
& ,ITYP,ZDIFALT
WRITE(NULOUT,*) 'Reject LEV IN SBL LYR '
& ,JOBS,ITYP,CSTNID(JOBS),ZLAT,ZLON,ZLEV
& ,ZPB,ZPT,RSBLCRIT(IJ),ZDELP,ZDIFALT
ENDIF
MOBDATA(NCMASS,JDATA)=0
ITOTREJ(IJ)=ITOTREJ(IJ)+1
ISBLREJ(IJ)=ISBLREJ(IJ)+1
ENDIF
ENDIF
END DO
END DO
C
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* ) '%PR***************************************'
WRITE(NULOUT,222 )'%PR ELEMENTS '
& , ( ILISTEL(J),J=1,JPINEL)
WRITE(NULOUT,222)'%PR ACC OB NEAR ',(INEARACC(J),J=1,JPINEL)
WRITE(NULOUT,222)'%PR ACC TOTAL ',(ITOTACC(J),J=1,JPINEL)
WRITE(NULOUT,* ) '%PR***************************************'
WRITE(NULOUT,222)'%PR REJ OUT BND ',(IBNDREJ(J),J=1,JPINEL)
WRITE(NULOUT,222)'%PR REJ SBL ',(ISBLREJ(J),J=1,JPINEL)
WRITE(NULOUT,222)'%PR REJ TOTAL ',(ITOTREJ(J),J=1,JPINEL)
WRITE(NULOUT,* ) '%PR***************************************'
WRITE(NULOUT,* ) ' '
222 FORMAT(2x,a29,5(2x,i5))
223 FORMAT(2x,a29,5(2x,f6.0))
224 FORMAT(2x,a31,2x,I6,2X,I5,2(2x,f9.2))
C
ENDIF
END DO
C
IKOUNTT=0
DO JDATA=1,NDATA
IF ( MOBDATA(NCMASS,JDATA) .EQ. 1) IKOUNTT=IKOUNTT+1
END DO
WRITE(NULOUT,'(1X,"%PR NUMBER OF DATA ASSIMILATED BY 3D-VAR"
& ," AFTER ADJUSTMENTS:",i10)')IKOUNTT
WRITE(NULOUT,* ) ' '
RETURN
END