!-------------------------------------- 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 BGCDATA(PJO,CDFAM) 9,4
#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.
* S. Macpherson ARMA September 2009
* -added separate error check for GP family (GB-GPS)
* -added more output information from routine
* -added GP family specific output
*
** 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 "cvcord.cdk"
#include "comcst.cdk"
#include "combgchk.cdk"
#include "comnumbr.cdk"
#include "comgpsgb.cdk"
*
C NOTE: YSFERRWGT IN COMGPSGB.CDK (FROM NML FILE) IS USED HERE FOR ERROR WEIGHTING
C OF TIME SERIES (FGAT) GPS MET OBSERVATIONS PS, TS, DPDS. IT IS APPLIED
C (ALONG WITH YZDERRWGT FOR ZTD) IN S/R SETERR AS A MULT. FACTOR TO ERRORS.
C YZDERRWGT AND YSFERRWGT = 1 FOR NORMAL 3D-VAR (3D-THINNING).
C
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
INTEGER INOBS, INREJ, INZOBS, INZREJ
INTEGER INPOBS, INTOBS, INDOBS, INPREJ, INTREJ, INDREJ
REAL*8 ZOER,ZOMP,ZFGE,ZBGCHK,ZVAR,ZLEV,ZLAT,ZLON,ZSOP
LOGICAL LLOK, LLZD, LMODIF1020
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,a74)')' STNID LATITU LONGITU ID Elem Level ',
+' Value Sigmao Sigmap O-P SigmaOP qcflag '
WRITE(NULOUT,'(a55,a74)')' ----- ------ ------- -- ---- ----- ',
+' ----- ------ ------ --- ------- ------ '
icoun=0
zsum=0.
zsumo=0.
PJO=-99.99
INOBS=0
INREJ=0
C
C* Initialize counters for GP family observations
C
IF (CDFAM .EQ. 'GP') THEN
INZOBS=0
INPOBS=0
INTOBS=0
INDOBS=0
INZREJ=0
INPREJ=0
INTREJ=0
INDREJ=0
ENDIF
C
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
INOBS = INOBS + 1
IF (CDFAM .EQ. 'GP') THEN
IF (ITYP .EQ. NEZD) INZOBS = INZOBS+1
IF (ITYP .EQ. NEPS) INPOBS = INPOBS+1
IF (ITYP .EQ. NETS) INTOBS = INTOBS+1
IF (ITYP .EQ. NESS) INDOBS = INDOBS+1
ENDIF
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 BACK GROUND CHECK
C
ZOMP =-ROBDATA(NCMOMF,JDATA)*ROBDATA(NCMOER,JDATA)
ZFGE = ROBDATA(NCMFGE,JDATA)
IF ( CDFAM .EQ. 'GP' ) THEN
IF (ITYP .EQ. NEZD) THEN
ZOER = ZOER/YZDERRWGT
ELSE
ZOER = ZOER/YSFERRWGT
ENDIF
IF (ZFGE .LT. 1.E-3 .OR. ZOER .LT. 1.E-3 ) THEN
WRITE(NULOUT,*)' Problem for STNID FGE ZOER=',CSTNID(IOBS),ZFGE,ZOER
CALL ABORT3D(NULOUT,'BGCDATA: PROBLEM WITH FGE, OER.')
ENDIF
ELSE
IF ( ZFGE**2 + ZOER**2 .LT. 1.e-5)THEN
WRITE(NULOUT,*)' Problem for STNID FGE ZOER=',CSTNID(IOBS),ZFGE,ZOER
ZFGE=1.E-5
ZOER=1.E-5
ENDIF
ENDIF
ZBGCHK=(ZOMP)**2/(ZFGE**2 + ZOER**2)
ibgc=ZBGCHK/1.
ibgc=min(ibgc,99)
ZSOP = SQRT(ZFGE**2 + ZOER**2)
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)
C
C CONVERT ZTD VALUES FROM M TO MM FOR PRINTOUT
C
LLZD = .FALSE.
IF ( CDFAM .EQ. 'GP' .AND. ITYP .EQ. NEZD) THEN
ZVAR = ZVAR * 1000.0
ZOER = ZOER * 1000.0
ZFGE = ZFGE * 1000.0
ZOMP = ZOMP * 1000.0
ZSOP = ZSOP * 1000.0
LLZD = .TRUE.
ENDIF
C
IF (IFLAG .GE. 2 ) THEN
WRITE(NULOUT,122)
& CSTNID(IOBS),zlat,zlon,IDBURP,INAM,ZLEV,ZVAR,ZOER
& ,ZFGE,ZOMP,ZSOP,ZBGCHK,IFLAG
INREJ = INREJ + 1
IF (CDFAM .EQ. 'GP') THEN
IF (ITYP .EQ. NEZD) INZREJ = INZREJ+1
IF (ITYP .EQ. NEPS) INPREJ = INPREJ+1
IF (ITYP .EQ. NETS) INTREJ = INTREJ+1
IF (ITYP .EQ. NESS) INDREJ = INDREJ+1
ENDIF
ENDIF
C
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,7(2x,F11.2),I3 )
C
cpik ENDIF
cpik END DO
ENDIF
END DO
C
IF ( INOBS .GT. 0 ) THEN
WRITE(NULOUT,*)' '
WRITE(NULOUT,*) ' BGCDATA: FINISHED BGCHECK OF ',CDFAM, ' DATA'
WRITE(NULOUT,123) 'BGCDATA: ',INREJ, ' OBSERVATIONS REJECTED OUT OF ', INOBS
WRITE(NULOUT,*)' '
ENDIF
C
IF ( (INOBS .GT. 0) .AND. (CDFAM .EQ. 'GP') ) THEN
WRITE(NULOUT,*)' '
WRITE(NULOUT,*) ' BGCDATA: REPORT FOR GP FAMILY OF OBSERVATIONS'
WRITE(NULOUT,123) 'BGCDATA: ',INZREJ, ' ZTD OBSERVATIONS REJECTED OUT OF ', INZOBS
WRITE(NULOUT,123) 'BGCDATA: ',INPREJ, ' PSFC OBSERVATIONS REJECTED OUT OF ', INPOBS
WRITE(NULOUT,123) 'BGCDATA: ',INTREJ, ' TSFC OBSERVATIONS REJECTED OUT OF ', INTOBS
WRITE(NULOUT,123) 'BGCDATA: ',INDREJ, ' DPDS OBSERVATIONS REJECTED OUT OF ', INDOBS
WRITE(NULOUT,*)' '
ENDIF
C
123 FORMAT(2X,A,I0,A,I0)
C
WRITE(NULOUT,*)' '
WRITE(NULOUT,*)' ---------------------------'
WRITE(NULOUT,*)' DONE BGCDATA '
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