!--------------------------------------- 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,lobsSpaceData) 9,42
!*
!***s/r BGCDATA - Computation OF BACKGROUND CHECK FLAGS
!*
!*Author : P. Koclas *CMC/CMDA January 1999
!*
!** Purpose: -Calculate a background check for a data family
!* AND SET the appropriate quality control flags in
!* the CMA
!*
use MathPhysConstants_mod
use bufr
use obsSpaceData_mod
use modgpsztd_mod
IMPLICIT NONE
!*
!C NOTE 1: YSFERRWGT IN MODGPSZTD_MOD (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
!C NOTE 2: GPS ZTD OBS ERROR SIGMAO IS BASED ON STD(O-P) SO INCLUDES CONTRIBUTION FROM
!C BACKGROUND ERROR SIGMAP. THUS A MAX LIMIT IS PLACED ON SIGMAO (12 MM).
!C
!C
type(struct_obs) :: lobsSpaceData
REAL*8 PJO,zsum,zsumo
CHARACTER*2 CDFAM
INTEGER IFLAG,INAM,ISETFLAG,INDEX_HEADER,IDBURP
INTEGER IBEGIN,ILAST,ierr,fclos,fnom,ITYP
INTEGER J,J2,JJ,JD,INDEX_BODY,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
! MAX LIMIT IS PLACED ON ZTD SIGMAO (12 MM)
REAL*8 ZDSIGMAO
DATA ZDSIGMAO / 0.012D0 /
lmodif1020=.false.
WRITE(*,*)' '
WRITE(*,*)' ------------------------------'
WRITE(*,*)' BACKGROUND CHECK FOR'
WRITE(*,*)' ',CDFAM, ' DATA'
WRITE(*,*)' ------------------------------'
WRITE(*,*)' '
WRITE(*,'(a55,a74)')' STNID LATITU LONGITU ID Elem Level ', &
' Value Sigmao Sigmap O-P SigmaOP qcflag '
WRITE(*,'(a55,a74)')' ----- ------ ------- -- ---- ----- ', &
' ----- ------ ------ --- ------- ------ '
icoun=0
zsum=0.D0
zsumo=0.D0
PJO=-99.99D0
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
! loop over all header indices of the CDFAM family
call obs_set_current_header_list(lobsSpaceData,CDFAM)
HEADER: do
index_header = obs_getHeaderIndex(lobsSpaceData)
if (index_header < 0) exit HEADER
!C
!C* 1. Computation of (HX - Z)**2/(SIGMAo**2 +SIGMAp**2)
!C . ----------------------------------------------------
!C
! loop over all body indices for this index_header
call obs_set_current_body_list(lobsSpaceData, index_header)
BODY: do
index_body = obs_getBodyIndex(lobsSpaceData)
if (index_body < 0) exit BODY
ITYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,index_body)
LLOK=( obs_bodyElem_i(lobsSpaceData,OBS_ASS,index_body) .EQ. 1)
IF ( LLOK ) THEN
INOBS = INOBS + 1
IF (CDFAM .EQ. 'GP') THEN
IF (ITYP .EQ. BUFR_NEZD) INZOBS = INZOBS+1
IF (ITYP .EQ. BUFR_NEPS) INPOBS = INPOBS+1
IF (ITYP .EQ. BUFR_NETS) INTOBS = INTOBS+1
IF (ITYP .EQ. BUFR_NESS) INDOBS = INDOBS+1
ENDIF
ZVAR = obs_bodyElem_r(lobsSpaceData,OBS_VAR,index_body)
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,index_body)
ZOER = obs_bodyElem_r(lobsSpaceData,OBS_OER,index_body)
ZLAT = obs_headElem_r(lobsSpaceData,OBS_LAT,index_header) &
* MPC_DEGREES_PER_RADIAN_R8
ZLON = obs_headElem_r(lobsSpaceData,OBS_LON,index_header) &
* MPC_DEGREES_PER_RADIAN_R8
!C
!C BACK GROUND CHECK
!C
ZOMP = obs_bodyElem_r(lobsSpaceData,OBS_OMP,index_body)
ZFGE = obs_bodyElem_r(lobsSpaceData,OBS_HPHT,index_body)
IF ( CDFAM .EQ. 'GP' ) THEN
IF (ITYP .EQ. BUFR_NEZD) THEN
ZOER = ZOER/YZDERRWGT
!C IF YZTDERR (FROM modgpsztd_mod) = 0 THEN ZTD ERROR MODEL IS REGRESSION-BASED
!C (WHERE ERROR IS A FUNCTION OF ZWD) SO WE LIMIT THE OBSERVATION ERROR
IF (YZTDERR .EQ. 0.0D0) THEN
ZOER = MIN(ZDSIGMAO, ZOER)
ENDIF
ELSE
ZOER = ZOER/YSFERRWGT
ENDIF
IF (ZFGE .LT. 1.D-3 .OR. ZOER .LT. 1.D-3 ) THEN
WRITE(*,*)' Problem for STNID FGE ZOER=', &
obs_elem_c(lobsSpaceData,'STID',index_header),ZFGE,ZOER
CALL ABORT3D('BGCDATA: PROBLEM WITH FGE, OER.')
ENDIF
ELSE
IF ( ZFGE**2 + ZOER**2 .LT. 1.D-5)THEN
WRITE(*,*)' Problem for STNID FGE ZOER=', &
obs_elem_c(lobsSpaceData,'STID',index_header),ZFGE,ZOER
ZFGE=1.D-5
ZOER=1.D-5
ENDIF
ENDIF
ZBGCHK=(ZOMP)**2/(ZFGE**2 + ZOER**2)
ZSOP = SQRT(ZFGE**2 + ZOER**2)
!C
!C UPDATE QUALITY CONTROL FLAGS
!C ( ELEMENT FLAGS + GLOBAL HEADER FLAGS)
!C
INAM =obs_bodyElem_i(lobsSpaceData,OBS_VNM,index_body)
if( inam.eq.12192 .and. obs_bodyElem_i(lobsSpaceData,OBS_XTR,index_body).eq.0)then
zsum=zsum+zfge*zfge
zsumo=zsumo+zoer*zoer
icoun=icoun+1
endif
IDBURP=obs_headElem_i(lobsSpaceData,OBS_ITY,INDEX_HEADER)
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. BUFR_NEZD) THEN
ZVAR = ZVAR * 1000.0D0
ZOER = ZOER * 1000.0D0
ZFGE = ZFGE * 1000.0D0
ZOMP = ZOMP * 1000.0D0
ZSOP = ZSOP * 1000.0D0
LLZD = .TRUE.
ENDIF
IF (IFLAG .GE. 2 .OR. (LLZD .AND. LTESTOP)) THEN
WRITE(*,122) &
obs_elem_c(lobsSpaceData,'STID',index_header), &
zlat,zlon,IDBURP,INAM,ZLEV,ZVAR,ZOER &
,ZFGE,ZOMP,ZSOP,ZBGCHK,IFLAG
IF (IFLAG .GE. 2) INREJ = INREJ + 1
IF (IFLAG .GE. 2 .AND. CDFAM .EQ. 'GP') THEN
IF (ITYP .EQ. BUFR_NEZD) INZREJ = INZREJ+1
IF (ITYP .EQ. BUFR_NEPS) INPREJ = INPREJ+1
IF (ITYP .EQ. BUFR_NETS) INTREJ = INTREJ+1
IF (ITYP .EQ. BUFR_NESS) INDREJ = INDREJ+1
ENDIF
ENDIF
IF ( IFLAG .EQ. 1 ) THEN
call obs_bodySet_i(lobsSpaceData,OBS_FLG,index_body,IBSET(obs_bodyElem_i(lobsSpaceData,OBS_FLG,index_body),13))
ELSEIF ( IFLAG .EQ. 2 ) THEN
call obs_bodySet_i(lobsSpaceData,OBS_FLG,index_body,IBSET(obs_bodyElem_i(lobsSpaceData,OBS_FLG,index_body),14))
call obs_bodySet_i(lobsSpaceData,OBS_FLG,index_body,IBSET(obs_bodyElem_i(lobsSpaceData,OBS_FLG,index_body),16))
call obs_bodySet_i(lobsSpaceData,OBS_FLG,index_body,IBSET(obs_bodyElem_i(lobsSpaceData,OBS_FLG,index_body),09))
call obs_headSet_i(lobsSpaceData,OBS_ST1,index_header,ibset(obs_headElem_i(lobsSpaceData,OBS_ST1,index_header),06))
ELSEIF ( IFLAG .EQ. 3 ) THEN
call obs_bodySet_i(lobsSpaceData,OBS_FLG,index_body,IBSET(obs_bodyElem_i(lobsSpaceData,OBS_FLG,index_body),15))
call obs_bodySet_i(lobsSpaceData,OBS_FLG,index_body,IBSET(obs_bodyElem_i(lobsSpaceData,OBS_FLG,index_body),16))
call obs_bodySet_i(lobsSpaceData,OBS_FLG,index_body,IBSET(obs_bodyElem_i(lobsSpaceData,OBS_FLG,index_body),09))
call obs_headSet_i(lobsSpaceData,OBS_ST1,index_header,ibset(obs_headElem_i(lobsSpaceData,OBS_ST1,index_header),06))
ENDIF
ENDIF
ENDDO BODY
122 FORMAT(2x,a9,1x,f6.2,1x,f7.2,1x,I3,1x,I5,7(2x,F11.2),I3 )
ENDDO HEADER
IF ( INOBS .GT. 0 ) THEN
WRITE(*,*)' '
WRITE(*,*) ' BGCDATA: FINISHED BGCHECK OF ',CDFAM, ' DATA'
WRITE(*,123) 'BGCDATA: ',INREJ, ' OBSERVATIONS REJECTED OUT OF ', INOBS
WRITE(*,*)' '
ENDIF
IF ( (INOBS .GT. 0) .AND. (CDFAM .EQ. 'GP') ) THEN
WRITE(*,*)' '
WRITE(*,*) ' BGCDATA: REPORT FOR GP FAMILY OF OBSERVATIONS'
WRITE(*,123) 'BGCDATA: ',INZREJ, ' ZTD OBSERVATIONS REJECTED OUT OF ', INZOBS
WRITE(*,123) 'BGCDATA: ',INPREJ, ' PSFC OBSERVATIONS REJECTED OUT OF ', INPOBS
WRITE(*,123) 'BGCDATA: ',INTREJ, ' TSFC OBSERVATIONS REJECTED OUT OF ', INTOBS
WRITE(*,123) 'BGCDATA: ',INDREJ, ' DPDS OBSERVATIONS REJECTED OUT OF ', INDOBS
WRITE(*,*)' '
ENDIF
123 FORMAT(2X,A,I0,A,I0)
WRITE(*,*)' '
WRITE(*,*)' ---------------------------'
WRITE(*,*)' DONE BGCDATA '
WRITE(*,*)' ---------------------------'
WRITE(*,*)' '
if ( icoun .gt. 0) then
write(*,*) ' icoun meanfge=',icoun,zsum/icoun
write(*,*) ' icoun meanzoer',icoun,zsumo/icoun
endif
RETURN
END SUBROUTINE BGCDATA