!-------------------------------------- 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 SOBSRAOB 1
#if defined (DOC)
*
***s/r SOBSRAOB
*
*Author : P. Koclas *CMC/AES October 1998
*Revision: C. Charette *ARMA/AES Mar 1999
* - Refine algorithm to recognize sfc observation if present.
* Exclude observations considered in the free atmosphere from being
* used in the model sfc boundary layer when the topographies
* are too far apart.
* C. Charette *ARMA/AES Jan 2000
* - Added llprint for diagnostics
* C. Charette *ARMA/AES Feb 2000
* - Remove algorithm to recognize sfc observation. It was
* always commented out.Keep observations of TT, T-Td
* near the surface when the topographies are close
* to each other. This was inadvertaintly left out.
* C. Charette *ARMA/AES Mar 2000
* - Remove setting of quality control flags 6 and 9
* Added stnid in print of diagnostics
* P. Koclas *CMC/CMDA JAN 2000
* -INCLUDE raobadjustt.ftn__Version11002 (ff,DD) elements
* -LLPRINT=.FALSE.
* -CHANGE HEADER FLAG IN CASE OF REJECT
* C. Charette ARMA/AES JUN 2000
* - Added check on type of vertical coordinate
* MOBDATA(NCMVCO,)=2 --> PRESSURE COORDINATE is considered
* - Move adjustement of surface observations in RAOB
* reports to SFCADJUSTZ
*
** 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.
*
*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 /5000.0,5000.0,5000.0,5000.0,5000.0,5000.0,5000.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
ccc LLPRINT = .TRUE.
LLPRINT = .FALSE.
C
ccc debug
ccc print *,'SOBSRAOB: apres llprint:nulout',NULOUT
ccc debug
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* ) ' SUBROUTINE SOBSRAOB '
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* ) '************************************************'
WRITE(NULOUT,222)'%UA ELEMENTS '
& ,( ILISTEL(J),J=1,jpinel)
WRITE(NULOUT,223)'%UA REJECTION BOUNDARY(METRE) '
& ,(RLISTCRIT(J),J=1,jpinel)
WRITE(NULOUT,223)'%UA REJECTION SBL (PASCAL) '
& ,(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. 'UA') .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--------HEIGHT GZ
DO JDATA= IDATA, IDATEND
ITYP=MOBDATA(NCMVNM,JDATA)
IASS=MOBDATA(NCMASS,JDATA)
LLOK = MOBDATA(NCMVCO,JDATA) .EQ. 2
& .AND. ITYP.EQ.ILISTEL(JPINEL)
& .AND. IASS.EQ.1
IF (LLOK ) THEN
IKOUNTT=IKOUNTT+1
IFLG = MOBDATA(NCMFLG,JDATA)
ITYP=MOBDATA(NCMVNM,JDATA)
ZDIFF=99999.
ZLEV=ROBDATA8(NCMPPP,JDATA)
IASS=MOBDATA(NCMASS,JDATA)
ZVAL=ROBDATA8(NCMVAR,JDATA)
ZDIFF= ( ZVAL-GOMGZHR(NLEVTRL,JOBS) )/RG
ZCRIT= -RLISTCRIT(JPINEL)
IF ( ZDIFF .LT. 0.0 ) THEN
IF(ZDIFF .GE. ZCRIT) THEN
ITOTACC(JPINEL)=ITOTACC(JPINEL)+1
IGZACC(JPINEL)=IGZACC(JPINEL)+1
IF(LLPRINT) THEN
WRITE(NULOUT,*) 'Keep GZ BELOW MODEL SFC '
& ,JOBS,ITYP,CSTNID(JOBS),ZLAT,ZLON,ZLEV
& ,ZVAL/RG,GOMGZHR(NLEVTRL,JOBS)/RG,ZDIFF,ZCRIT
ENDIF
ELSE
IF ( MOBDATA(NCMASS,JDATA) .EQ. 1) THEN
MOBDATA(NCMFLG,JDATA)=
& ibset( MOBDATA(NCMFLG,JDATA) , 18 )
IF(LLPRINT) THEN
WRITE(NULOUT,*)'REJ GZ BELOW MODEL SFC '
& ,JOBS,ITYP,CSTNID(JOBS),ZLAT,ZLON,ZLEV
& ,ZVAL/RG,GOMGZHR(NLEVTRL,JOBS)/RG,ZDIFF
& ,ZCRIT
ENDIF
MOBDATA(NCMASS,JDATA)=0
ITOTREJ(JPINEL)=ITOTREJ(JPINEL)+1
IGZREJ(JPINEL)=IGZREJ(JPINEL)+1
ENDIF
ENDIF
ENDIF
ENDIF
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. 2
& .AND. ITYP .NE.ILISTEL(JPINEL)
& .AND. IJ .NE. -1
IF (LLOK ) THEN
ZLEV=ROBDATA8(NCMPPP,JDATA)
ZPB =GOMPSHR(1,JOBS)
ZPT =GOMPSHR(1,JOBS)-RSBLCRIT(IJ)
ZDELP = 999999.0
IF (ZDIFALT .GT. 0.0) THEN
ZDELP = ZDIFALT * 100. / 8.0
ZPT = GOMPSHR(1,JOBS)-(ZDELP+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 = GOMPSHR(1,JOBS)
ZPT = RPPOBSHR(NLEVTRL-1,JOBS)
IF(LLPRINT) THEN
WRITE(NULOUT,*) 'LLALTOK .EQ. .TRUE. '
& ,JOBS,ITYP,CSTNID(JOBS),ZLAT,ZLON,ZLEV
& ,GOMPSHR(1,JOBS),RPPOBSHR(NLEVTRL-1,JOBS)
& ,ZDIFALT
ENDIF
ENDIF
IF(ZLEV .GT. 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,GOMPSHR(1,JOBS)
ENDIF
MOBDATA(NCMASS,JDATA)=0
ITOTREJ(IJ)=ITOTREJ(IJ)+1
IBNDREJ(IJ)=IBNDREJ(IJ)+1
ELSEIF(ZLEV.LE.ZPB .AND. ZLEV.GT.ZPT ) THEN
MOBDATA(NCMFLG,JDATA)=
& ibset( MOBDATA(NCMFLG,JDATA) , 18 )
ZGZG = GOMGZHR(NLEVTRL,JOBS)/RG
IF(LLPRINT) THEN
WRITE(NULOUT,*) '%UA 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,* ) '%UA***************************************'
WRITE(NULOUT,222 )'%UA ELEMENTS '
& , ( ILISTEL(J),J=1,JPINEL)
WRITE(NULOUT,222)'%UA ACC OB NEAR ',(INEARACC(J),J=1,JPINEL)
WRITE(NULOUT,222)'%UA ACC GZ EXT ',(IGZACC(J),J=1,JPINEL)
WRITE(NULOUT,222)'%UA ACC TOTAL ',(ITOTACC(J),J=1,JPINEL)
WRITE(NULOUT,* ) '%UA***************************************'
WRITE(NULOUT,222)'%UA REJ GZ EXT ',(IGZREJ(J),J=1,JPINEL)
WRITE(NULOUT,222)'%UA REJ OUT BND ',(IBNDREJ(J),J=1,JPINEL)
WRITE(NULOUT,222)'%UA REJ SBL ',(ISBLREJ(J),J=1,JPINEL)
WRITE(NULOUT,222)'%UA REJ TOTAL ',(ITOTREJ(J),J=1,JPINEL)
WRITE(NULOUT,* ) '%UA***************************************'
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,"%UA NUMBER OF DATA ASSIMILATED BY 3D-VAR"
& ," AFTER ADJUSTMENTS:",i10)')IKOUNTT
WRITE(NULOUT,* ) ' '
RETURN
END