SUBROUTINE BGCDATA(PJO,CDFAM) 8,2
#if defined (DOC)
*
***s/r BGCDATA - Computation OF BACKGROUND CHECK FLAGS
*
*
*Author : P. Koclas *CMC/CMDA January 1999
*Revision:
* P. Koclas February 2002
* -add argument to isetflag call sequence
* C. Charette ARMA February 2002
* -remove conflicting ikount* unit.
* Y. Yang - Oct. 2004
* - Switchd order of "cvcord.cdk" and "comnumbr.cdk"
* due to the dependence of the former on JPNBRELEM
* Y.J. Rochon *ARQX March 2006
* - Added check on ROBDATA(NCMFGE,JDATA)
* C.Charette *ARMA Oct 2006
* - Adapted to version V10.0.0 (new combgchk.cdk,new call readnml)
*
** Purpose: -Calculate a background check for a data family
* AND SET the appropriate quality control flags in
* the CMA
*
*
#endif
IMPLICIT NONE
*implicits
#include "comlun.cdk"
#include "comdimo.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "comnumbr.cdk"
#include "cvcord.cdk"
#include "comcst.cdk"
#include "combgchk.cdk"
#include "cparbrp.cdk"
*
REAL*8 PJO,zsum,zsumo
c REAL*8 PJO
CHARACTER*2 CDFAM
INTEGER IFLAG,INAM,ISETFLAG,IOBS,ILEM,IFIND,ITY,IDBURP
INTEGER IBEGIN,ILAST,ierr,fclos,fnom,ITYP
INTEGER J,J2,JJ,JD,JDATA,ibgc,icoun
REAL*8 ZOER,ZOMP,ZFGE,ZBGCHK,ZVAR,ZLEV,ZLAT,ZLON
LOGICAL LLOK,LMODIF1020
C
C
C * . Read the NAMELIST NAMBGCHK to get user specified BACKGROUND CHECK LIMITS
C . -----------------------------------------------------------------------
CMODEL='GEM'
lmodif1020=.false.
CALL READNML('NAMBGCHK',IERR)
if ( CMODEL(1:8) .eq. 'GEM-MESO') then
lmodif1020=.true.
WRITE(NULOUT,*)' BACKGROUND CHECK : APPLYING GEM-MESO CRITERIA AT 10-20 Mbs'
endif
*
WRITE(NULOUT,*)' '
WRITE(NULOUT,*)' ------------------------------'
WRITE(NULOUT,*)' BACKGROUND CHECK FOR'
WRITE(NULOUT,*)' ',CDFAM, ' DATA'
WRITE(NULOUT,*)' ------------------------------'
WRITE(NULOUT,*)' '
WRITE(NULOUT,'(a55,a61)')' STNID LATITU LONGITU ID Elem Level ',
+' Value Sigmao Sigmap O-P qcflag '
WRITE(NULOUT,'(a55,a61)')' ----- ------ ------- -- ---- ----- ',
+' ----- ------ ------ --- ------ '
icoun=0
zsum=0.
zsumo=0.
PJO=-99.99
DO J = 1,NFILES
IF ( (CFAMTYP(J) .EQ. CDFAM) .AND.( NBEGINTYP(J) .GT. 0) ) THEN
IBEGIN=NBEGINTYP(J)
ILAST=NENDTYP(J)
C
C* 1. Computation of (HX - Z)**2/(SIGMAo**2 +SIGMAp**2)
C . ----------------------------------------------------
C
100 CONTINUE
C
DO JDATA=IBEGIN,ILAST
ITYP = MOBDATA(NCMVNM,JDATA)
LLOK=( MOBDATA(NCMASS,JDATA) .EQ. 1)
IF ( LLOK ) THEN
IOBS = MOBDATA(NCMOBS,JDATA)
ZVAR = ROBDATA(NCMVAR,JDATA)
ZLEV = ROBDATA(NCMPPP,JDATA)
ZOER = ROBDATA(NCMOER,JDATA)
ZLAT = ROBHDR(NCMLAT,IOBS)*180./RPI
ZLON = ROBHDR(NCMLON,IOBS)*180./RPI
C
C BACKGROUND CHECK
C
ZOMP =-ROBDATA(NCMOMF,JDATA)*ROBDATA(NCMOER,JDATA)
IF (ABS(ROBDATA(NCMFGE,JDATA)-PPMIS).LT.0.01*PPMIS) THEN
C
C May not be available due to obs type.
C
ZFGE = 0.0
ELSE
ZFGE = ROBDATA(NCMFGE,JDATA)
END IF
IF (ZFGE**2+ZOER**2.LT.1.e-5.and.CFAMTYP(J).NE.'TR')THEN
WRITE(NULOUT,*)' Problem for STNID FGE ZOER='
& ,CSTNID(IOBS),ZFGE,ZOER
ZFGE=1.E-5
ZOER=1.E-5
ENDIF
ZBGCHK=(ZOMP)**2/(ZFGE**2 + ZOER**2)
ibgc=ZBGCHK/1.
ibgc=min(ibgc,99)
C
C UPDATE QUALITY CONTROL FLAGS
C ( ELEMENT FLAGS + GLOBAL HEADER FLAGS)
C
IOBS =MOBDATA(NCMOBS,JDATA)
INAM =MOBDATA(NCMVNM,JDATA)
if( inam.eq.12192 .and. MOBDATA(NCMXTR,JDATA).eq.0)then
zsum=zsum+zfge*zfge
zsumo=zsumo+zoer*zoer
icoun=icoun+1
endif
ILEM =IFIND(INAM)
ITY=MOBHDR(NCMITY,IOBS)
IDBURP=MOD(ITY,1000)
IFLAG=ISETFLAG(CDFAM,IDBURP,INAM,ZLEV,ZBGCHK,LMODIF1020)
IF(IFLAG .GE. 2 )WRITE(NULOUT ,122)
& CSTNID(IOBS),zlat,zlon,IDBURP,INAM,ZLEV,ZVAR,ZOER
& ,ZFGE,ZOMP,ZBGCHK,IFLAG
IF ( IFLAG .EQ. 1 ) THEN
MOBDATA(NCMFLG,JDATA)=IBSET(MOBDATA(NCMFLG,JDATA),13)
ELSEIF ( IFLAG .EQ. 2 ) THEN
MOBDATA(NCMFLG,JDATA)=IBSET(MOBDATA(NCMFLG,JDATA),14)
MOBDATA(NCMFLG,JDATA)=IBSET(MOBDATA(NCMFLG,JDATA),16)
MOBDATA(NCMFLG,JDATA)=IBSET(MOBDATA(NCMFLG,JDATA),09)
MOBHDR(NCMST1,IOBS)= ibset(MOBHDR(NCMST1,IOBS),06)
ELSEIF ( IFLAG .EQ. 3 ) THEN
MOBDATA(NCMFLG,JDATA)=IBSET(MOBDATA(NCMFLG,JDATA),15)
MOBDATA(NCMFLG,JDATA)=IBSET(MOBDATA(NCMFLG,JDATA),16)
MOBDATA(NCMFLG,JDATA)=IBSET(MOBDATA(NCMFLG,JDATA),09)
MOBHDR(NCMST1,IOBS)= ibset(MOBHDR(NCMST1,IOBS),06)
ENDIF
444 continue
ENDIF
C
END DO
200 CONTINUE
122 FORMAT(2x,a9,1x,f6.2,1x,f7.2,1x,I3,1x,I5,6(2x,G11.3),I3 )
C
cpik ENDIF
cpik END DO
ENDIF
END DO
WRITE(NULOUT,*)' '
WRITE(NULOUT,*)' ---------------------------'
WRITE(NULOUT,*)' DONE '
WRITE(NULOUT,*)' ---------------------------'
WRITE(NULOUT,*)' '
if ( icoun .gt. 0) then
write(nulout,*) ' icoun meanfge=',icoun,zsum/icoun
write(nulout,*) ' icoun meanzoer',icoun,zsumo/icoun
endif
RETURN
END