SUBROUTINE CH_SUPREP 1,7
#if defined (DOC)
*
*s/r CH_SUPREP -FILTER CMA BEFORE 3D-VAR ANALYSIS
*
*Author : P. Koclas *CMC/AES September 1994
*Revision:
* P. Koclas *CMC/AES August 1995
* -Exclude T-Td ABOVE 300 Mbs
* P. Koclas *CMC/AES April 1996
* -print more information on rejected elements
* -set NCMLOBS
* -replace comstat by comtstato
* C.Charette *ARMA/AES Jan 1997
* -remove readnml. remove default values
* now done in suobs.ftn
* S. Pellerin *ARMA/AES Sept 97.
* -Control of the different model state of the 3Dvar
* through COMSTATE, COMSTATEC and COMSTNUM common
* blocks variables (comstate.cdk).
* C. Charette *ARMA/AES Oct 98.
* -Adapt code to the fact that pressure coordinate
* is in Pascal instead of Millibar in the CMA
* J. Halle *CMDA/AES Oct 1999
* -processing of TOVS data
* P. KOCLAS *CMC/CMDA JAN 2000
* -PRINT REJECT DATA IN MORE DETAIL
* C. Charette *ARMA/AES Jun 2000.
* -Added pointers and tables for surface elements
* J. Halle *CMC/CMDA Dec 2000
* - TOVS level 1B data.
* JM Belanger *CMDA/SMC june 2001.
* - 32 bits conversion.
* P. KOCLAS *cmda Sept 2001 .
* -changes to loops that set NCMLOBS PARAMETER
* -allow bogus gz data to analysis ( conf =141)
* S. Pellerin *ARMA/SMC Nov. 2001
* - Comment out conflicting ikout* unit
* C. Charette *ARMA/SMC Feb. 2002
* - Removed conflicting ikout* unit
* J. Halle *CMDA/SMC May 2002
* - allow T-Td observations up to 70mbs.
* - adapt to RTTOV-7
* N. Wagneur *CMDA/MSC June 2002
* -processing of GOES data
* J. Halle *CMDA/SMC april 2003
* -use RLIMLVHU, which is the top level of humidity analysis (mbs).
* C. Charette - ARMA/SMC - Jun. 2003
* - Conversion to hybrid vertical coordinate
* D. Anselmo *ARMA/SMC October 2004
* -set NCMASS to exclude assimilation of RAOBS and surface ln q
* added to CMA by estohu.ftn
* -define NCMPOS for ln q, ln q at surface
* Y. Yang Oct. 2003
* - Accommodate multiple species
* Y. Yang Aug. 2004
* - Add filtering for chemistry data that are above model top
* For this, add calculation of model top level pressure
* - Filter out satellite data with solar zenith angle
* larger than a specific value
* - Separate output of summary of species observation
* - Special treatment for species when recording the pointer
* NCMPOS that indicates the position of the trial field
* variable within GOMOBS
* Y. Yang Feb. 2005
* - Removal of 'OZ' as it is now part of 'TR'.
* Y.J. Rochon *ARQX/MSC July 2005, Feb 2006
* - Adjustments of rejection and selection criteria and
* output for 'TR' family.
* - Added consideration of MODATA(NCMCORD1,*). Its value
* is only set for 'TR' obs and would be
* zero by default (for dynamics).
* C. Charette *ARMA/AES Jun 2006.
* -Introduced JPNNIV and split the layer 10-0 mb
* into the layers 10-1 and 1-0 mb in the
* statistical tables
* Y.J. Rochon *ARQX/EC June 2008
* -Addition of NEDW, IKNTDWA, IKNTDWR, DW, and 011200 for
* Doppler wind speed obs.
* -Removed OZ, IKNTOA, IKNTOR
* Y.J. Rochon *ARQX/EC Jan 2010
* -Added use if CH_KGETPOS
*
** Purpose:
* -Select the data in the CMA file which is to be
C assimilated
* by the 3D-var.
* -Set "NCMPOS" of CMA as pointers to U V and T of GOMOBS
* -Set "Transformed latitude" with ISRCHILA
* -Set NCMLOBS: RELATIVE POSTION OF DATA WITH RESPECT TO A
* FULL SOUNDING. (Dependent on data family)
*
*Arguments
* none
*
#endif
use mod_tovs
*
IMPLICIT NONE
*implicits
*
#include "comct0.cdk"
#include "partov.cdk"
#include "comtov.cdk"
#include "comdimo.cdk"
#include "comlun.cdk"
#include "comdim.cdk"
#include "comleg.cdk"
#include "comnumbr.cdk"
#include "cparbrp.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comchem.cdk"
#include "comoba.cdk"
#include "commvo.cdk"
#include "comfilt.cdk"
#include "comstato.cdk"
#include "cvcord.cdk"
#include "pardim.cdk"
#include "comgem.cdk"
#include "comcst.cdk"
#include "comstate.cdk"
#include "comtovst.cdk"
#include "comvfiles.cdk"
#include "cparamgoes.cdk"
#include "comgoes.cdk"
#include "comgoesst.cdk"
#include "comvarqc.cdk"
#include "comgd0.cdk"
#include "rpnstd.cdk"
C
C ....... DEFINITION OF A FEW BUFR ELEMENTS ..........................
C ....
C NAME BUFR CODE
C HEIGHT 0 10 194
C TEMPERATURE 0 12 001
C TEMPERATURE AT 2M 0 12 004
C T - TD 0 12 192
C T - TD AT 2M 0 12 203
C WIND DIRECTION 0 11 001
C WIND SPEED 0 11 002
C U-COMPONENT 0 11 003
C V-COMPONENT 0 11 004
C WIND DIRECTION AT 10M 0 11 011
C WIND SPEED AT 10M 0 11 012
C U-COMPONENT AT 10M 0 11 215
C V-COMPONENT AT 10M 0 11 216
C PRESSURE 0 07 004
C MSL PRESSURE 0 10 051
C STATION PRESSURE 0 10 004
C BRIGHTNESS TEMPERATURE 0 12 062
C BRIGHTNESS TEMPERATURE 0 12 063
C BRIGHTNESS TEMPERATURE 0 12 163
C Doppler wind speed 0 11 200
C
C ........ Quality control flags bit definitions (see ADE BANCO
C document)
C BIT #
C 1 'RESERVED '
C 2 'RESERVED '
C 3 'GENERATED OI'
C 4 'REJECTION OI'
C 5 'BLACK LIST '
C 6 'RESERVED '
C 7 'RESERVED '
C 8 'INTERPOL EL'
C 9 'DOUBTFUL EL'
C 10 'MODIFIED EL'
C 11 'CLIMAT XTRM'
C 12 'ERRONEOUS EL'
C 13 'RESERVED '
C
INTEGER JPNNIV
PARAMETER (JPNNIV=18)
REAL*8 ZZLAT, ZLON, ZLEV, ZVAR
REAL*8 ZLAT
REAL*8 DLLAO
INTEGER IZLEV,IZP1,IZXI
INTEGER LL,JJ,JI
CHARACTER*2 CLFAM,CLFAMSAV
CHARACTER*8 CLFILNAM
CHARACTER*35 CREASON(-7:13)
CHARACTER*90 CELLIST, CSFLIST
CHARACTER*120 CTRPROFLIST, CLIST
CHARACTER*120 CTRTCOLLIST
INTEGER IOBS,IDATYP,IVCO,IOBSTYP
INTEGER ILA,ISRCHILA,IPRES,IPRESMB
INTEGER IERR, JD,JDATA,JO,JJO,JK,J
INTEGER IJ,ITY,IDBURP,ITYP,IFLG,IBIT,IBAD,IKNT,IBEGIN,ILAST
INTEGER IDATA,IDATEND,FNOM,FCLOS
INTEGER ILANSEA,IPROCES,INDXREG,INDXCLD,ICHN
INTEGER INDXSAT,ISAT,INDCH,INDXM
integer index,ibin(JPNNIV),IBINS,isum,INIV(JPNNIV)
LOGICAL LLOK,LLREJ,LLEV,LLBOGUS
INTEGER ISRCHEQ
INTEGER ISOLARZA,CH_KGETPOS
EXTERNAL ISRCHEQ,CH_KGETPOS
INTEGER vfstlir, ezgprm, fstinf, fstprm
REAL*8 pmodtop, ptop, pbtm, pobs
INTEGER IP1, IP2, IP3
REAL*8 et
LOGICAL LFILT
REAL*8 BUFS(1,1)
pointer (pbufs,bufs)
integer key, ip0id
integer inbitstr
INTEGER itrcode, npos
C
INTEGER IKNTDSA,IKNTFSA,IKNTUSA,IKNTVSA,IKNTTSA,IKNTESSA,IKNTPSA
& ,IKNTPNA
INTEGER IKNTDSR,IKNTFSR,IKNTUSR,IKNTVSR,IKNTTSR,IKNTESSR,IKNTPSR
& ,IKNTPNR
INTEGER IKNTFFR(JPNNIV),IKNTDDR(JPNNIV),IKNTUR(JPNNIV)
& ,IKNTVR(JPNNIV),IKNTZR(JPNNIV),IKNTTR(JPNNIV),IKNTER(JPNNIV)
& ,IKNTDR(JPNNIV),IKNTBTR(JPNNIV),IKNTDWR(JPNNIV)
INTEGER IKNTFFA(JPNNIV),IKNTDDA(JPNNIV),IKNTUA(JPNNIV)
& ,IKNTVA(JPNNIV),IKNTZA(JPNNIV),IKNTTA(JPNNIV),IKNTEA(JPNNIV)
& ,IKNTDA(JPNNIV),IKNTBTA(JPNNIV),IKNTDWA(JPNNIV)
INTEGER IKNTTRR(JPNNIV,NCMTMAX), IKNTTRCOLR(NCMTMAX)
INTEGER IKNTTRA(JPNNIV,NCMTMAX), IKNTTRCOLA(NCMTMAX)
C
DATA INIV/1000,925,850,700,500,400,300,250,200,150,100,070,050,
& 030,020,010,001,000/
DATA CREASON/'ABS OROGRAPH-PHI ','MASQUE TERRE-MER '
& ,'OROGRAPHIE ','REJECTED BY QCVAR '
& ,'REJECTED BY BACKGROUND GCHECK '
& ,'BACKGROUND CHECK LEVEL 3 ','BACKGROUND CHECK LEVEL 2 '
& ,'BACKGROUND GHECK LEVEL 1 ','RESERVED '
& ,'REJECTED BY SELECTION PROCESS ','GENERATED BY OI '
& ,'REJECTION BY OI','ELEMENT ON BLACK LIST ','RESERVED '
& ,'CORRECTED ELEMENT','INTERPOLATED ELEMENT'
& ,'DOUBTFUL ELEMENT','POSSIBLY ERRONEOUS ELEMENT '
& ,'ERRONEOUS ELEMENT','ELEMENT EXCEEDS CLIMATE EXTREME'
& ,'ELEMENT MODIFIED OR GEN BY ADE'/
C-----------------------------------------------------------------------
DO JK=1,JPNNIV
IKNTFFR(JK)=0
IKNTDDR(JK)=0
IKNTUR(JK)=0
IKNTVR(JK)=0
IKNTZR(JK)=0
IKNTTR(JK)=0
IKNTER(JK)=0
IKNTDR(JK)=0
IKNTBTR(JK)=0
IKNTDWR(JK)=0
DO LL = 1,NCMTMAX
IKNTTRR(JK,LL)=0
ENDDO
C
IKNTFFA(JK)=0
IKNTDDA(JK)=0
IKNTUA(JK)=0
IKNTVA(JK)=0
IKNTZA(JK)=0
IKNTTA(JK)=0
IKNTEA(JK)=0
IKNTDA(JK)=0
IKNTBTA(JK)=0
IKNTDWA(JK)=0
DO LL = 1,NCMTMAX
IKNTTRA(JK,LL)=0
ENDDO
C
IBIN(JK)=0.
ENDDO
C
IKNTDSA =0
IKNTFSA =0
IKNTUSA =0
IKNTVSA =0
IKNTTSA =0
IKNTESSA=0
IKNTPSA =0
IKNTPNA =0
DO LL = 1,NCMTMAX
IKNTTRCOLA(LL) = 0
ENDDO
C
IKNTDSR =0
IKNTFSR =0
IKNTUSR =0
IKNTVSR =0
IKNTTSR =0
IKNTESSR=0
IKNTPSR =0
IKNTPNR =0
DO LL = 1,NCMTMAX
IKNTTRCOLR(LL)=0
ENDDO
IBINS =0
C
WRITE(NULOUT,'(1X,"SUBROUTINE CH_SUPREP")')
WRITE(NULOUT,'(1X,"-----------------",/)')
WRITE(NULOUT,'(1X,"***********************************")')
WRITE(NULOUT,'(1X," ELEMENTS SELECTED FOR ASSIMILATION:",/)')
WRITE(NULOUT,'(1X,"***********************************")')
DO JD=1,NELEMS
WRITE(NULOUT,'(15X,I5,/)') NLIST(JD)
END DO
WRITE(NULOUT,'(1X,"***********************************")')
WRITE(NULOUT,*) ' REJECT ELEMENTS WITH REJECT FLAG '
WRITE(NULOUT,*)' BIT : '
DO JD=1,NFLAGS
IBIT= NLISTFLG(JD)
WRITE(NULOUT,*) IBIT,' ',CREASON(IBIT)
END DO
WRITE(NULOUT,'(1X,"***********************************")')
C
100 CONTINUE
C
C 2. Put observation number in each data of CMA file. Find
C largest number of data contained in any observation(NMAXLEN).
C
C Displace observations located between poles and the last row
C of the grid being used to the last row when cvcord not equal to MAM.
C For MAM the wind observations are removed.
IF (CVCORD(1:3).NE.'MAM') THEN
DO JO = 1, NOBTOT
ZLAT = ROBHDR(NCMLAT,JO)
IF(ZLAT .GT. RLATI(1)) THEN
ROBHDR(NCMLAT,JO) = RLATI(1)
ELSEIF(ZLAT .LT. RLATI(NJ)) THEN
ROBHDR(NCMLAT,JO) = RLATI(NJ)
ENDIF
END DO
ENDIF
C
IJ=0
NMAXLEN=0
DO JJO = 1, NOBTOT
IDATA = MOBHDR(NCMRLN,JJO)
IDATEND = MOBHDR(NCMNLV,JJO) + IDATA - 1
NMAXLEN = MAX( MOBHDR(NCMNLV,JJO),NMAXLEN )
DO JDATA= IDATA, IDATEND
IJ = IJ+1
MOBDATA(NCMOBS,IJ)= JJO
END DO
C
DLLAO=DBLE(ROBHDR(NCMLAT,JJO))
ILA = ISRCHILA (DLLAO)
MOBHDR(NCMTLA,JJO)=ILA
END DO
C
200 CONTINUE
C
C 3. filter data in CMA file
C . -----------------------
IKNT=0
CLFAMSAV=CFAMTYP(1)
CELLIST
& =' FF DD UU VV GZ TT ES DZ'
& //' BT DW '
CSFLIST
& =' FS DS US VS TS ES PS PN '
CTRPROFLIST = ''
NPOS = 2
DO JJ = 1, NCMTASSI
IF (NETR(JJ).EQ.nvnumb(58)) THEN
CTRPROFLIST(NPOS:NPOS+7) = ' '//'DW'//' '
ELSE
CTRPROFLIST(NPOS:NPOS+7) = ' '//CNAMANAL(JJ)//' '
END IF
NPOS = NPOS +8
ENDDO
C
CTRTCOLLIST = ''
NPOS = 2
DO JJ = 1, NCMTASSI
IF (NETR(JJ).EQ.nvnumb(58)) THEN
CTRPROFLIST(NPOS:NPOS+7) = ' '//'DW'//' '
ELSE
CTRPROFLIST(NPOS:NPOS+7) = ' '//CNAMANAL(JJ)//' '
END IF
NPOS = NPOS +8
ENDDO
C
C get surface pressure for use in calculating top pressure
C
c suface pressure at model points -- gomps has not been filled yet
c so first read in P0 from trial field
C
IP1 = -1
IP2 = -1
IP3 = -1
IDATEO = -1
CLTYPVAR = ' '
CLETIKET = ' '
c
ip0id = FSTINF(ninmpg,INI,INJ,INK,idateo
& ,cletiket,ip1,ip2,ip3,cltypvar,'P0')
if (ip0id.lt.0) then
write(nulout,*) ' in suprep, Problems finding variable P0'
stop
else
call hpalloc(pbufs,max(ini*inj,1),ierr,8)
KEY = VFSTLIR(BUFS,ninmpg,INI,INJ,INK,IDATEO,CLETIKET,
+ IP1,IP2,IP3,CLTYPVAR,'P0')
C
C get field info
C
c ierr = ezgprm(ip0id,TYPVAR,ini,inj,iig1,iig2,iig3,iig4)
ierr = FSTPRM(ip0id, IDATEO, IDEET, IPAS, INI, INJ, INK, INBITSTR,
& IDATYP,IP1,IP2, IP3, CLTYPVAR, CLNOMVAR, CLETIKET, CLGRTYP,
& IG1, IG2,IG3,IG4, ISWA, ILENGTH, IDLTF, IUBC, IEXTR1,
& IEXTR2,IEXTR3)
endif
if(NGEXIST(ngps).eq.1) then
CALL INITGD0(BUFS,1,INI,INJ,IG2,'P0')
call gd2mvo('PS',1)
else
write(nulout, *) '!!! warning !!! in suprep: ps should be a model variable! '
endif
et=rptopinc/rprefinc
C
DO J = 1,NFILES
CLFILNAM='KOUNTR'//CFAMTYP(J)
IF ( NBEGINTYP(J) .GT. 0) THEN
IBEGIN=NBEGINTYP(J)
ILAST=NENDTYP(J)
CLFAMSAV =CFAMTYP(J)
C
DO JK=1,JPNNIV
IKNTFFR(JK)=0
IKNTDDR(JK)=0
IKNTUR(JK)=0
IKNTVR(JK)=0
IKNTZR(JK)=0
IKNTTR(JK)=0
IKNTER(JK)=0
IKNTDR(JK)=0
IKNTBTR(JK)=0
IKNTDWR(JK)=0
DO LL = 1, NCMTMAX
IKNTTRR(JK,LL)=0
ENDDO
IKNTFFA(JK)=0
IKNTDDA(JK)=0
IKNTUA(JK)=0
IKNTVA(JK)=0
IKNTZA(JK)=0
IKNTTA(JK)=0
IKNTEA(JK)=0
IKNTDA(JK)=0
IKNTBTA(JK)=0
IKNTDWA(JK)=0
DO LL = 1, NCMTMAX
IKNTTRA(JK,LL)=0
ENDDO
END DO
IKNTDSA =0
IKNTFSA =0
IKNTUSA =0
IKNTVSA =0
IKNTTSA =0
IKNTESSA=0
IKNTPSA =0
IKNTPNA =0
DO LL = 1, NCMTMAX
IKNTTRCOLA(LL) =0
ENDDO
C
IKNTDSR =0
IKNTFSR =0
IKNTUSR =0
IKNTVSR =0
IKNTTSR =0
IKNTESSR=0
IKNTPSR =0
IKNTPNR =0
DO LL = 1, NCMTMAX
IKNTTRCOLR(LL) =0
ENDDO
C
DO JDATA=IBEGIN,ILAST
ITYP = MOBDATA(NCMVNM,JDATA)
IFLG = MOBDATA(NCMFLG,JDATA)
IPRES= NINT(ROBDATA8(NCMPPP,JDATA))
IOBS = MOBDATA(NCMOBS,JDATA)
IVCO = MOBDATA(NCMVCO,JDATA)
IOBSTYP = MOBDATA(NCMCORD1,JDATA)
ITRCODE =MOBDATA(NCMSPEC,JDATA)
ITY=MOBHDR(NCMITY,IOBS)
IDBURP=MOD(ITY,1000)
C
C a. Unwanted data types via types specified in NLIST
C
LLEV=.TRUE.
LLOK = .FALSE.
LLBOGUS=(IDBURP .eq. 150 .or. IDBURP .eq. 151 .or. IDBURP
& .eq. 152 .or. IDBURP .eq. 153)
DO JD =1,NELEMS
LLOK=( (ITYP .EQ. NLIST(JD)) .AND. LLEV ) .OR. LLOK
END DO
*
*pik ALLOW GZ FOR BOGUS DATA ONLY in analysis case ( nconf 141)
*
if ( nconf .eq. 141 .and. llok .and. (ityp .eq. negz) .and.
& .not. llbogus ) then
llok=.false.
endif
*
*pik
C
C Process data reported in pressure coordinate
C
IF (IVCO.EQ.2.AND.(IOBSTYP.EQ.0.OR.IOBSTYP.EQ.1)) THEN
C
C b. Exclude T-Td above level RLIMLVHU (mbs)
C
IF ( (ITYP .EQ. NEES) .AND.
& (IPRES .LT. NINT(RLIMLVHU*100)) ) LLOK=.FALSE.
C
C c. Bad data with quality control flags via bit list
C specified in NLISTFLG
C
IPRESMB=ipres/100
DO INDEX=JPNNIV-1,1,-1
if (IPRESMB.le.INIV(INDEX)) EXIT
END DO
if (ipresmb.gt.iniv(1)) index=1
ibin(index)=ibin(index) +1
ENDIF
C
LLREJ = .FALSE.
C
DO JD=1,NFLAGS
IBAD= 13-NLISTFLG(JD)
LLREJ=( BTEST(IFLG,IBAD) ) .OR. LLREJ
END DO
C
C d. Filter TOVS data
C
ITYP = MOBDATA(NCMVNM,JDATA)
IF ( ITYP .EQ. NBT1 .OR.
S ITYP .EQ. NBT2 .OR.
S ITYP .EQ. NBT3 .AND.
S (IDATYP .EQ. 164 .OR. IDATYP .EQ. 181) ) THEN
C
C d.1 Valid channel?
C
ICHN = NINT(ROBDATA8(NCMPPP,JDATA))
IF ( ICHN .LE. 0 .OR.
S ICHN .GT. JPCH ) THEN
LLOK = .FALSE.
ENDIF
C
C d.2 Data from this satellite to be assimilated?
C
C .....this check not done anymore, jh may 2002....
C
C d.3 Invalid land/sea/sea-ice flag, processing technique
C
ILANSEA = MOBHDR(NCMOFL,IOBS)
INDXM = ILANSEA
IF (INDXM .EQ. 2 ) INDXM = 0
INDXREG = ISRCHEQ(MLISREG,NREGST,INDXM)
IPROCES = MOBHDR(NCMITY,IOBS)/1000000
INDXCLD = ISRCHEQ(MLISCLD,NCLDST,IPROCES)
IF ( INDXREG .EQ.0 .OR. INDXCLD .EQ.0 ) THEN
LLOK = .FALSE.
ENDIF
C
C d.4 Channel not included in list of channels to
C be assimilated
C
C .....this check not done anymore, jh may 2002....
ENDIF
C
C
C e. Filter GOES data
C
ITYP = MOBDATA(NCMVNM,JDATA)
IDATYP = MOD(MOBHDR(NCMITY,IOBS),1000)
IF ( ITYP .EQ. NBT1
S .OR. ITYP .EQ. NBT2
S .OR. ITYP .EQ. NBT3
S .AND. IDATYP .EQ. 180 ) THEN
C
C e.1 Valid channel?
C
ICHN = NINT(ROBDATA8(NCMPPP,JDATA))
IF ( ICHN .LE. 0 .OR.
S ICHN .GT. JPCHGO ) THEN
LLOK = .FALSE.
ENDIF
C
C e.2 Data from this satellite to be assimilated?
C
ISAT = MOD(MOBHDR(NCMITY,IOBS)/1000,1000)
ISAT = ISAT-244
INDXSAT = ISRCHEQ(NIDSATGO,NSATGO,ISAT)
IF ( INDXSAT .EQ. 0 ) THEN
LLOK = .FALSE.
ENDIF
C
C
C
C e.3 Invalid land/sea flag
C
C A modifier selon le canal
C
ILANSEA = MOBHDR(NCMOFL,IOBS)
INDXREG = ISRCHEQ(MLISREGGO,NREGSTGO,ILANSEA)
IPROCES = MOBHDR(NCMITY,IOBS)/1000000
INDXCLD = ISRCHEQ(MLISCLDGO,NCLDSTGO,IPROCES)
C
C e.4 Channel not included in list of channels to
C be assimilated
C
IF (LLOK) THEN
INDCH=ISRCHEQ(MLISCHNAGO(1,INDXCLD,INDXREG,INDXSAT),
S NCHNAGO(INDXCLD,INDXREG,INDXSAT),ICHN)
IF ( INDCH .EQ. 0 ) THEN
LLOK = .FALSE.
ENDIF
ENDIF
ENDIF
C
C f. Exclude measurements with very large solar zenith angles.
C
IF (.NOT.LLREJ.AND.CFAMTYP(J).EQ.'TR') THEN
ITYP = MOBDATA(NCMVNM,JDATA)
IDATYP = MOD(MOBHDR(NCMITY,IOBS),1000)
DO LL= 1,NCMTASSI
IF (ITYP .EQ. NETR(LL)
S .AND. MOBHDR(NCMBOX,IOBS) .GT. 0 ) THEN
ISOLARZA = MOBHDR(NCMBOX,IOBS)/10000
IF (ISOLARZA .GT. INT(MAXFILTSZA*100)) THEN
LLREJ = .TRUE.
ENDIF
go to 700
ENDIF
ENDDO
700 continue
END IF
C
C g. Filter out the observations that are higher than the top model level
C
c g.1 Determine which obs. family should be filtered. for now only the
C species data are to be filtered.
C
LFILT = .FALSE.
IF (.NOT.LLREJ.AND.CFAMTYP(J).EQ.'TR') THEN
DO LL= 1,NCMTASSI
IF( ITYP .EQ. NETR(LL)) LFILT = .TRUE.
ENDDO
END IF
if (.NOT.LLREJ.AND.LFILT) then
C
C g.2. Set flag
C
IF (MOBDATA(NCMASS,JDATA).EQ.0) THEN
C
C Obs rejected in CH_CMABDY
C
LLREJ=.TRUE.
C
ELSE IF (IVCO.eq.2.AND.(IOBSTYP.EQ.0.OR.IOBSTYP.EQ.1)) THEN
C
c Calculate the model top pressure
C
pmodtop = rprefinc*vhybinc(1)+(gomps(1,iobs)-rprefinc)
+ *((vhybinc(1)-et)/(1.0-et))**rcoefinc
C
C Observation element in presure coordinate
C
IF (ROBDATA8(NCMPOB,JDATA).lt.0.0) then
C
C Observation element is point value.
C
LLREJ = .FALSE.
POBS = ROBDATA8(NCMPPP, JDATA)
if (pobs .lt. pmodtop) then
LLREJ = .TRUE.
MOBDATA(NCMFLG,JDATA)=2048+MOBDATA(NCMFLG,JDATA)
endif
else
C
C Observation element is layer average or integral.
C Have upper and lower boundaries.
C
PTOP = ROBDATA8(NCMPPP, JDATA)
PBTM = ROBDATA8(NCMPOB,JDATA)
if (ptop.lt.pmodtop.and.pbtm.lt.pmodtop*10.0) then
LLREJ = .TRUE.
MOBDATA(NCMFLG,JDATA)=2048+MOBDATA(NCMFLG,JDATA)
endif
END IF
END IF
C
endif !(LFILT)
C
IF ( ITYP .EQ. NEHU .or. ITYP .EQ. NEHS ) LLOK=.FALSE.
C
IF ( LLOK .AND..NOT. LLREJ ) THEN
IF (IVCO .EQ. 2.AND.(IOBSTYP.EQ.0.OR.IOBSTYP.EQ.1)) THEN
IF (CFAMTYP(J).NE.'TR') THEN
IF( ITYP .EQ. NEFF) IKNTFFA(INDEX)=IKNTFFA(INDEX) + 1
IF( ITYP .EQ. NEDD) IKNTDDA(INDEX)=IKNTDDA(INDEX) + 1
IF( ITYP .EQ. NEUU) IKNTUA(INDEX)=IKNTUA(INDEX) + 1
IF( ITYP .EQ. NEVV) IKNTVA(INDEX)=IKNTVA(INDEX) + 1
IF( ITYP .EQ. NEGZ) IKNTZA(INDEX)=IKNTZA(INDEX) + 1
IF( ITYP .EQ. NETT) IKNTTA(INDEX)=IKNTTA(INDEX) + 1
IF( ITYP .EQ. NEES) IKNTEA(INDEX)=IKNTEA(INDEX) + 1
IF( ITYP .EQ. NEDZ) IKNTDA(INDEX)=IKNTDA(INDEX) + 1
IF( ITYP .EQ. NBT1) IKNTBTA(INDEX)=IKNTBTA(INDEX) + 1
IF( ITYP .EQ. NBT2) IKNTBTA(INDEX)=IKNTBTA(INDEX) + 1
IF( ITYP .EQ. NBT3) IKNTBTA(INDEX)=IKNTBTA(INDEX) + 1
IF( ITYP .EQ. NEDW) IKNTDWA(INDEX)=IKNTDWA(INDEX) + 1
ELSE
LL=CH_KGETPOS(ITYP,ITRCODE,CSTNID(IOBS))
IF (LL.GT.0) IKNTTRA(INDEX,LL)=IKNTTRA(INDEX,LL) + 1
END IF
ELSE IF (IVCO.GT.0) THEN
IF (CFAMTYP(J).NE.'TR') THEN
IF( ITYP .EQ. NEDS) IKNTDSA=IKNTDSA + 1
IF( ITYP .EQ. NEFS) IKNTFSA=IKNTFSA + 1
IF( ITYP .EQ. NEUS) IKNTUSA=IKNTUSA + 1
IF( ITYP .EQ. NEVS) IKNTVSA=IKNTVSA + 1
IF( ITYP .EQ. NETS) IKNTTSA=IKNTTSA + 1
IF( ITYP .EQ. NESS) IKNTESSA=IKNTESSA + 1
IF( ITYP .EQ. NEPS) IKNTPSA=IKNTPSA + 1
IF( ITYP .EQ. NEPN) IKNTPNA=IKNTPNA + 1
ELSE
LL=CH_KGETPOS(ITYP,ITRCODE,CSTNID(IOBS))
IF (LL.GT.0) IKNTTRCOLA(LL)=IKNTTRCOLA(LL) + 1
END IF
IBINS = IBINS + 1
ENDIF
ELSE IF ( LLOK .AND. LLREJ ) THEN
IF (IVCO.EQ.2.AND.(IOBSTYP.EQ.0.OR.IOBSTYP.EQ.1)) THEN
IF (CFAMTYP(J).NE.'TR') THEN
IF( ITYP .EQ. NEFF) IKNTFFR(INDEX)=IKNTFFR(INDEX) + 1
IF( ITYP .EQ. NEDD) IKNTDDR(INDEX)=IKNTDDR(INDEX) + 1
IF( ITYP .EQ. NEUU) IKNTUR(INDEX)=IKNTUR(INDEX) + 1
IF( ITYP .EQ. NEVV) IKNTVR(INDEX)=IKNTVR(INDEX) + 1
IF( ITYP .EQ. NEGZ) IKNTZR(INDEX)=IKNTZR(INDEX) + 1
IF( ITYP .EQ. NETT) IKNTTR(INDEX)=IKNTTR(INDEX) + 1
IF( ITYP .EQ. NEES) IKNTER(INDEX)=IKNTER(INDEX) + 1
IF( ITYP .EQ. NEDZ) IKNTDR(INDEX)=IKNTDR(INDEX) + 1
IF( ITYP .EQ. NBT1) IKNTBTR(INDEX)=IKNTBTR(INDEX) + 1
IF( ITYP .EQ. NBT2) IKNTBTR(INDEX)=IKNTBTR(INDEX) + 1
IF( ITYP .EQ. NBT3) IKNTBTR(INDEX)=IKNTBTR(INDEX) + 1
IF( ITYP .EQ. NEDW) IKNTDWR(INDEX)=IKNTDWR(INDEX) + 1
ELSE
LL=CH_KGETPOS(ITYP,ITRCODE,CSTNID(IOBS))
IF (LL.GT.0) IKNTTRR(INDEX,LL)=IKNTTRR(INDEX,LL) + 1
END IF
ELSEIF (IVCO.GT.0) THEN
IF (CFAMTYP(J).NE.'TR') THEN
IF( ITYP .EQ. NEDS) IKNTDSR=IKNTDSR + 1
IF( ITYP .EQ. NEFS) IKNTFSR=IKNTFSR + 1
IF( ITYP .EQ. NEUS) IKNTUSR=IKNTUSR + 1
IF( ITYP .EQ. NEVS) IKNTVSR=IKNTVSR + 1
IF( ITYP .EQ. NETS) IKNTTSR=IKNTTSR + 1
IF( ITYP .EQ. NESS) IKNTESSR=IKNTESSR + 1
IF( ITYP .EQ. NEPS) IKNTPSR=IKNTPSR + 1
IF( ITYP .EQ. NEPN) IKNTPNR=IKNTPNR + 1
ELSE
LL=CH_KGETPOS(ITYP,ITRCODE,CSTNID(IOBS))
IF (LL.GT.0) IKNTTRCOLR(LL)=IKNTTRCOLR(LL) + 1
END IF
IBINS = IBINS + 1
ENDIF
ENDIF
C
IF (LLOK .AND. .NOT. LLREJ) THEN
MOBDATA(NCMASS,JDATA)=1
IKNT= IKNT + 1
ELSE
MOBDATA(NCMASS,JDATA)=0
ENDIF
CSMP
CSMP e. Filter UU, VV data close to poles FOR MAM (June 18, 2001)
CSMP
IF (CVCORD(1:3).EQ.'MAM') THEN
ZLAT = ROBHDR(NCMLAT,IOBS)
ZZLAT = ZLAT*180./RPI
ZLON = ROBHDR(NCMLON,IOBS)*180./RPI
ZVAR = ROBDATA(NCMVAR,JDATA)
ZLEV = ROBDATA(NCMPPP,JDATA)*0.01
IF(ZLAT .GT. RLATI(1) .or. ZLAT .LT. RLATI(NJ)) THEN
IF (ITYP .EQ. NEUU .OR. ITYP .EQ. NEVV ) THEN
write(NULOUT,98) IOBS,ZZLAT,ZLON,ZLEV,ZVAR,ITYP
MOBDATA(NCMASS,JDATA) = 0
ENDIF
ENDIF
98 format(1x,'CH_SUPREP REMOVED: IOBS,ZLAT,ZLON,ZLEV,ZVAR= '
& ,I5,2x,2(F8.2,2x),F5.0,2x,F11.4,2x,I6)
ENDIF
C
END DO
C
ENDIF
cpik END DO
C
write(NULOUT,'(5x,a8,2x,a2,2x,a12)')CBURP(j), CFAMTYP(j)
& ,'DATA FAMILY'
WRITE(NULOUT
& ,'(12x," ")')
WRITE(NULOUT
& ,'(12x," NUMBER OF REJECTED DATA PRESSURE COORD")')
WRITE(NULOUT
& ,'(12x," =======================================================================")')
IF (CFAMTYP(J).NE.'TR') THEN
WRITE(NULOUT,'(12x,A90)')CELLIST
WRITE(NULOUT,'(12x,10(" ------"))' )
C
DO JK=1,JPNNIV-1
WRITE(NULOUT,888)iniv(jk),'-',iniv(jk+1),
& IKNTFFR(JK),IKNTDDR(JK),IKNTUR(JK),IKNTVR(JK),IKNTZR(JK)
& ,IKNTTR(JK),IKNTER(JK),IKNTDR(JK),IKNTBTR(JK),IKNTDWR(JK),'rej'
END DO
WRITE(NULOUT
& ,'(12x," =======================================================================")')
ELSE
WRITE(NULOUT,'(12x,A80)')CTRPROFLIST
WRITE(NULOUT,'(12x,11(" ------"))' )
C
DO JK=1,JPNNIV-1
WRITE(NULOUT,999)iniv(jk),'-',iniv(jk+1),
& (IKNTTRR(JK,JJ), JJ =1,10), 'rej'
END DO
C
WRITE(NULOUT
& ,'(12x," =======================================================================",/)')
WRITE(NULOUT
& ,'(12x," ")'
& )
WRITE(NULOUT,'(12x," NUMBER OF OTHER REJECTED DATA")')
WRITE(NULOUT
& ,'(12x," =======================================================================")')
WRITE(NULOUT,'(12x,A80)')CTRTCOLLIST
WRITE(NULOUT,'(12x,4(" ------"))' )
WRITE(NULOUT,990)' col ', (IKNTTRCOLR(JJ), JJ =1,10),'rej'
WRITE(NULOUT
& ,'(12x," =======================================================================",/)')
END IF
if ( cfamtyp(j) .eq. 'UA' .or. cfamtyp(j) .eq. 'SF' ) then
WRITE(NULOUT
& ,'(12x," =======================================================================",/)')
WRITE(NULOUT
& ,'(12x," ")'
& )
WRITE(NULOUT,'(12x," NUMBER OF REJECTED SURFACE DATA")')
WRITE(NULOUT
& ,'(12x," =======================================================================")')
WRITE(NULOUT,'(12x,A90)')CSFLIST
WRITE(NULOUT,'(12x,8(" ------"))' )
WRITE(NULOUT,890)' sfc ',
& IKNTFSR,IKNTDSR,IKNTUSR,IKNTVSR,IKNTTSR,IKNTESSR,IKNTPSR
& ,IKNTPNR,'rej'
WRITE(NULOUT
& ,'(12x," =======================================================================",/)')
endif
C
WRITE(NULOUT
& ,'(12x," ")')
WRITE(NULOUT
& ,'(12x," NUMBER OF ACCEPTED DATA PRESSURE COORD")')
WRITE(NULOUT
& ,'(12x," =======================================================================")')
IF (CFAMTYP(J).NE.'TR') THEN
WRITE(NULOUT,'(12x,A90)')CELLIST
WRITE(NULOUT,'(12x,10(" ------"))' )
DO JK=1,JPNNIV-1
WRITE(NULOUT,888)iniv(jk),'-',iniv(jk+1),
& IKNTFFA(JK),IKNTDDA(JK),IKNTUA(JK),IKNTVA(JK),IKNTZA(JK)
& ,IKNTTA(JK),IKNTEA(JK),IKNTDA(JK),IKNTBTA(JK),IKNTDWA(JK),'acc'
END DO
WRITE(NULOUT
& ,'(12x," =======================================================================")')
ELSE
WRITE(NULOUT,'(12x,A80)')CTRPROFLIST
WRITE(NULOUT,'(12x,11(" ------"))' )
C
DO JK=1,JPNNIV-1
WRITE(NULOUT,999)iniv(jk),'-',iniv(jk+1),
& (IKNTTRA(JK, JJ), JJ =1,10) ,'acc'
END DO
WRITE(NULOUT
& ,'(12x," =======================================================================",/)')
C
WRITE(NULOUT
& ,'(12x," =======================================================================",/)')
WRITE(NULOUT
& ,'(12x," ")'
& )
WRITE(NULOUT,'(12x," NUMBER OF OTHER ACCEPTED DATA")')
WRITE(NULOUT
& ,'(12x," =======================================================================")')
WRITE(NULOUT,'(12x,A80)')CTRTCOLLIST
WRITE(NULOUT,'(12x,4(" ------"))' )
WRITE(NULOUT,990)' col ', (IKNTTRCOLA(JJ), JJ =1,10), 'acc'
WRITE(NULOUT
& ,'(12x," =======================================================================",/)')
END IF
C
if ( cfamtyp(j) .eq. 'UA' .or. cfamtyp(j) .eq. 'SF' ) then
WRITE(NULOUT
& ,'(12x," ")'
& )
WRITE(NULOUT,'(12x," NUMBER OF ACCEPTED SURFACE DATA")')
WRITE(NULOUT
& ,'(12x," =======================================================================")')
WRITE(NULOUT,'(12x,A90)')CSFLIST
WRITE(NULOUT,'(12x,8(" ------"))' )
WRITE(NULOUT,890)' sfc ',
& IKNTFSA,IKNTDSA,IKNTUSA,IKNTVSA,IKNTTSA,IKNTESSA,IKNTPSA
& ,IKNTPNA,'acc'
WRITE(NULOUT
& ,'(12x," =======================================================================",/)')
endif
888 FORMAT(1X,i4,a1,i4,10(2x,i6),3x,a3)
890 FORMAT(1X,a9,8(2x,i6),3x,a3)
999 FORMAT(1X,i4,a1,i4,10(2x,i6),3x,a3)
990 FORMAT(1X,a9,10(2x,i6),3x,a3)
END DO
300 CONTINUE
C
C-----------------------------------------------------------------------
WRITE(NULOUT,'(1x," Number of data assimilated by 3d-var:",i10)')
& IKNT
C
C
C-----------------------------------------------------------------------
C
DO JDATA=1,NDATA
ITYP = MOBDATA(NCMVNM,JDATA)
IOBS = MOBDATA(NCMOBS,JDATA)
ITRCODE = MOBDATA(NCMSPEC,JDATA)
C
IF ( ITYP .EQ. NEUU) MOBDATA(NCMPOS,JDATA) = nouu - 1
IF ( ITYP .EQ. NEVV) MOBDATA(NCMPOS,JDATA) = novv - 1
IF ( ITYP .EQ. NETT) MOBDATA(NCMPOS,JDATA) = nott - 1
IF ( ITYP .EQ. NEDZ) MOBDATA(NCMPOS,JDATA) = nogz - 1
IF ( ITYP .EQ. NEES) MOBDATA(NCMPOS,JDATA) = noes - 1
IF ( ITYP .EQ. NEHU) MOBDATA(NCMPOS,JDATA) = noq - 1
IF ( ITYP .EQ. NEGZ) MOBDATA(NCMPOS,JDATA) = nogz - 1
IF ( ITYP .EQ. NEUS) MOBDATA(NCMPOS,JDATA) = nouu - 1
IF ( ITYP .EQ. NEVS) MOBDATA(NCMPOS,JDATA) = novv - 1
IF ( ITYP .EQ. NETS) MOBDATA(NCMPOS,JDATA) = nott - 1
IF ( ITYP .EQ. NESS) MOBDATA(NCMPOS,JDATA) = noes - 1
IF ( ITYP .EQ. NEHS) MOBDATA(NCMPOS,JDATA) = noq - 1
IF ( ITYP .EQ. NEPS) MOBDATA(NCMPOS,JDATA) = nops - 1
IF ( ITYP .EQ. NEPN) MOBDATA(NCMPOS,JDATA) = nops - 1
IF ( ITYP .EQ. NEDW) MOBDATA(NCMPOS,JDATA) = nouu - 1
C
C Chemical species.
C Note: MOBDATA(NCMPOS,*) for dynamics or water vapour
C provided in 'TR' family should not be set from notr.
C
DO JJ = 1, NCMTASSI
IF(ITYP .EQ. NETR(JJ).and.ITRCODE.EQ.NTRCODELIST(JJ).AND.
& ITRCODE.NE.0) then
C
IF (CNAMANAL(JJ).EQ.'LQ'.OR.CNAMANAL(JJ).EQ.'HU') THEN
C
MOBDATA(NCMPOS,JDATA) = noq - 1
go to 800
C
ELSE
C
C Look for index of the trial field corresponding to obs. variable
C
DO JI = 1, NOCMT
if (CNAMANAL(JJ) .eq.CMVOCMT(JI)) then
MOBDATA(NCMPOS,JDATA) = (notr(1) + JI -1)-1
go to 800
endif
ENDDO
END IF
ENDIF
ENDDO
800 continue
C
END DO
500 CONTINUE
C-----------------------------------------------------------------------
C
C SET NCMLOBS PARAMETER FOR:
C
if ( nconf .ne. 121 .and. nconf .ne. 101) then
DO J = 1,NFILES
IF ( NBEGINTYP(J) .GT. 0) THEN
IBEGIN=NBEGINTYP(J)
ILAST=NENDTYP(J)
DO JDATA= IBEGIN,ILAST
MOBDATA(NCMLOBS,JDATA)=0
END DO
C
C 1. RAOB LEVELS
C
IF (CFAMTYP(J) .EQ. 'UA' ) THEN
C
DO JK=1,JPRLEV
IZP1 = NILV(JK )
DO JDATA= IBEGIN,ILAST
IZLEV = ROBDATA8(NCMPPP,JDATA)
IOBS = MOBDATA(NCMOBS,JDATA)
IDATYP=MOBHDR (NCMOTP,IOBS)
CLFAM =CFAMTYP(IDATYP)
LLOK = (MOBDATA(NCMASS,JDATA) .EQ. 1) .AND. (CLFAM .EQ
& . 'UA')
IF ( LLOK ) THEN
IZXI=ISIGN( 1,(IZLEV-IZP1) )
MOBDATA(NCMLOBS,JDATA)=MOBDATA(NCMLOBS,JDATA)+MAX(0
& ,IZXI)
ENDIF
END DO
END DO
ENDIF
C
C 2. HUMSAT LEVELS
C
IF (CFAMTYP(J) .EQ. 'HU' ) THEN
DO JK=1,JPHLEV
IZP1 = NIHULV(JK )
DO JDATA= IBEGIN,ILAST
IZLEV = ROBDATA8(NCMPPP,JDATA)
IOBS = MOBDATA(NCMOBS,JDATA)
IDATYP=MOBHDR (NCMOTP,IOBS)
CLFAM =CFAMTYP(IDATYP)
LLOK = (MOBDATA(NCMASS,JDATA) .EQ. 1) .AND. (CLFAM .EQ
& . 'HU')
IF ( LLOK ) THEN
IZXI=ISIGN( 1,(IZLEV-IZP1) )
MOBDATA(NCMLOBS,JDATA)=MOBDATA(NCMLOBS,JDATA)+MAX(0
& ,IZXI)
ENDIF
END DO
END DO
ENDIF
C
C 3. SATEM LEVELS
C
IF (CFAMTYP(J) .EQ. 'ST' ) THEN
DO JK=1,JPSALEV
IZP1 = NISLV(JK)
DO JDATA= IBEGIN,ILAST
IZLEV = ANINT( ROBDATA8(NCMPPP,JDATA) )
IOBS = MOBDATA(NCMOBS,JDATA)
IDATYP=MOBHDR (NCMOTP,IOBS)
CLFAM =CFAMTYP(IDATYP)
LLOK = (MOBDATA(NCMASS,JDATA) .EQ. 1) .AND. (CLFAM .EQ
& . 'ST')
IF ( LLOK ) THEN
IZXI=ISIGN( 1,(IZLEV-IZP1) )
MOBDATA(NCMLOBS,JDATA)=MOBDATA(NCMLOBS,JDATA)+MAX(0
& ,IZXI)
ENDIF
END DO
END DO
ENDIF
ENDIF
enddo
endif
600 CONTINUE
C
WRITE(NULOUT,'(1X,"****************************************** ")')
WRITE(NULOUT,'(1X," ---END OF CH_SUPREP---")')
WRITE(NULOUT,'(1X,"****************************************** ",/)')
C
C SUM OVER ALL BINS SHOULD BE EQUAL TO NDATA
C
isum=0
do jk=1,JPNNIV-1
isum=isum+ibin(jk)
enddo
ISUM = ISUM + IBINS
write(nulout,*) ' isum ndata ',isum,ndata
C
C ABORT IF THERE IS NO DATA TO BE ASSIMILATED
C
IF (IKNT .EQ. 0 ) THEN
write(nulout,*) 'CH_SUPREP. NO DATA TO BE ASSIMILATED'
C call abort3d(nulout,'CH_SUPREP. NO DATA TO BE ASSIMILATED')
ENDIF
C
RETURN
END