!-------------------------------------- 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 SETERRGPSGB(lobsSpaceData,ldata) 1,24
*
*s/r SETERRGPSGB - SET OBSERVATION ERROR COVARIANCES FOR GB-GPS ZTD DATA
*
*Author : S. Macpherson March 2013
*Revision:
*
*
** Purpose:
* - initialize observation error standard deviations for GB-GPS ZTD data
* (GPS sfc met errors are set before in s/r SUCOVO (SETERR))
* - returns ldata=.false. if no GPS ZTD data to assimilate
* and also sets modgpsztd_mod variable numGPSZTD = 0.
*
use EarthConstants_mod
use MathPhysConstants_mod
use obsSpaceData_mod
use bufr
use modgpsztd_mod
IMPLICIT NONE
C
C NOTE: YZDERRWGT IN modgpsztd_mod (FROM NML FILE) IS USED FOR ERROR WEIGHTING
C OF TIME SERIES (FGAT) GPS ZTD OBSERVATIONS TO ACCOUNT FOR TEMPORAL ERROR
C CORRELATIONS.
C
type(struct_obs) :: lobsSpaceData
logical :: ldata
INTEGER INDEX_BODY, INDEX_HEADER, ITYP, IASS, IZTDJ, NBRPDATE, ICOUNT
integer ielem, imonth
LOGICAL LLCZTDE, LLFER, LLFZTDE, LLZTD, LLRZTDE, ASSIM, ERRSET, DEBUG
C
REAL*8 ZTDERR, ZZTD, ZMINZDE, ZPSFC, ZHD, ZWD, ZTDOER, ZLEV, ZVAL
C
C ZZDERMIN = MIN ZTD OER VALUE (M), ZZFERREJ = MAX FERR VALUE (M) FOR REJECTION
C ZZDERMAX = MAX ZTD OER VALUE (M)
C ZTDERFAC = MULTIPLICATION FACTOR FOR FORMAL ZTD MEASUREMENT ERROR
C ZOPEFAC = FRACTION OF REGRESSION EQUATION SD(O-P) TO USE AS ZTD OBSERVATION ERROR
C ----------------------------------------------------------------------------------
C
REAL*8 ZZDERMIN, ZZFERREJ, ZZDERMAX, ZTDERFAC, ZOPEFAC
DATA ZZDERMIN /0.004D0/
DATA ZZFERREJ /0.015D0/
DATA ZZDERMAX /0.030D0/
DATA ZTDERFAC /3.0D0/
DATA ZOPEFAC /1.0D0/
C
C FOR ESTIMATION OF PSFC (IF MISSING)
C ZGAMMA = (NEG. OF) TEMPERATURE LAPSE RATE (K/M)
C ZPSMSL = STANDARD ATMOSPHERE MEAN SEA LEVEL PRESSURE (Pa)
C ZTSFC = REFERENCE SURFACE TEMPERATURE (K)
C
REAL*8 ZGAMMA, ZPSMSL, ZTSFC
DATA ZGAMMA /0.0065D0/
DATA ZPSMSL /101300.0D0/
DATA ZTSFC /280.0D0/
C
C MONTHLY LINEAR REGRESSION EQUATION CONSTANTS AND COEFF FOR ZTD ERROR (SD(O-P))
c - Gives ZTDerror (mm) [SD(O-P)] as function of ZWD (m).
C - From NOAA network NRT monthly monitoring stats 2008-2010
c
REAL*8 ZRCONST(12), ZRCOEFF(12)
DATA ZRCONST / 2.6D0, 2.8D0, 2.1D0, 3.3D0, 5.1D0, 8.4D0, 12.8D0,
& 9.9D0, 7.8D0, 2.6D0, 2.4D0, 2.5D0 /
DATA ZRCOEFF / 102.4D0, 96.5D0, 110.3D0, 101.2D0, 83.9D0,
& 73.5D0, 54.3D0, 64.0D0, 62.4D0, 98.0D0,
& 99.4D0, 101.5D0 /
C
C
WRITE(*,*) 'ENTER SETERRGPSGB'
C
DEBUG = .FALSE.
LLCZTDE = .FALSE.
LLRZTDE = .FALSE.
LLFZTDE = .FALSE.
IF (YZTDERR .LT. 0.0D0) THEN
LLFZTDE = .TRUE.
ELSE IF (YZTDERR .GT. 0.0D0) THEN
LLCZTDE = .TRUE.
ELSE
LLRZTDE = .TRUE.
ENDIF
ldata = .false.
ICOUNT = 0
C
C Loop over all header indices of the 'GP' family:
C
call obs_set_current_header_list(lobsSpaceData,'GP')
HEADER: DO
index_header = obs_getHeaderIndex(lobsSpaceData)
if (index_header < 0) exit HEADER
NBRPDATE = obs_headElem_i(lobsSpaceData,OBS_DAT,INDEX_HEADER)
LLZTD = .FALSE.
LLFER = .FALSE.
ASSIM = .FALSE.
ERRSET = .FALSE.
ZZTD = -1.0D0
ZPSFC = -1.0D0
c Get the month
imonth = INT(nbrpdate/100.0)
imonth = MOD(imonth,100)
if ( imonth .lt. 1 .or. imonth .gt. 12 ) then
CALL ABORT3D('SETERRGPSGB: imonth is out of range!')
endif
c
C Loop over all body indices of current report; Set the ZTD error if
C constant value specified (LLCZTDE=true).
c
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)
IASS = obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY)
ZVAL = obs_bodyElem_r(lobsSpaceData,OBS_VAR,INDEX_BODY)
C Store Psfc
IF ( ITYP .EQ. BUFR_NEPS ) THEN
IF ( ZVAL .GT. 0.0D0 ) ZPSFC = ZVAL
ENDIF
C Set ZTDOER to constant value (if LLCZTDE); get value of ZTD,
C ZTD formal error and antenna height.
IF ( ITYP .EQ. BUFR_NEZD ) THEN
IF ( LLCZTDE ) THEN
ZTDOER = YZTDERR
ERRSET = .TRUE.
ENDIF
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)
ZTDERR = obs_bodyElem_r(lobsSpaceData,OBS_OER,INDEX_BODY)
IF ( ZTDERR .NE. 1.0D0 ) LLFER = .TRUE.
IZTDJ = INDEX_BODY
IF ( ZVAL .GT. 0.0D0 ) THEN
ZZTD = ZVAL
LLZTD = .TRUE.
ENDIF
IF ( IASS .EQ. 1 ) ASSIM = .TRUE.
ENDIF
ENDDO BODY
c Replace formal ZTD error with real error for all ZTD to be assimilated
IF ( ASSIM ) THEN
IF ( LLZTD ) THEN
ldata = .true.
ICOUNT = ICOUNT + 1
IF ( .NOT. ERRSET ) THEN
c If Psfc is missing, estimate the pressure based on station height using
c hydrostatic approx. and assumed MSL pressure ZPSMSL and temperature ZTSFC
IF ( ZPSFC .LT. 0.0D0 ) THEN
ZPSFC = ZPSMSL *
& (1.0D0-(ZGAMMA/ZTSFC)*ZLEV)**(RG/(MPC_RGAS_DRY_AIR_R8*ZGAMMA))
ENDIF
c Compute the hydrostatic delay ZHD (m) from Psfc (Pa)
ZHD = 2.2766D-05 * ZPSFC
c Compute the wet delay (m) from ZTD and ZHD
IF ( ZHD .GT. ZZTD ) THEN
ZWD = 0.0D0
ELSE
ZWD = ZZTD - ZHD
ENDIF
C Compute ZTD error as a function of ZWD using regression coeff (SD(O-P) vs ZWD).
c Take fraction ZOPEFAC of computed error and convert from mm to m.
c Ensure error is > ZZDERMIN and < ZZDERMAX
ZMINZDE = ZRCONST(imonth) + ZRCOEFF(imonth)*ZWD
ZMINZDE = ZMINZDE * ZOPEFAC * 0.001D0
IF (LLRZTDE) THEN
ZTDOER = MAX(ZZDERMIN, ZMINZDE)
ZTDOER = MIN(ZZDERMAX, ZTDOER)
ELSE
IF (LLFER) THEN
ZTDOER = MAX(ZZDERMIN, ZTDERR*ZTDERFAC)
ELSE
ZTDOER = MAX(ZZDERMIN, ZMINZDE)
ZTDOER = MIN(ZZDERMAX, ZTDOER)
ENDIF
ENDIF
C Ensure that error is not less than formal error ZTDERR
IF (LLFER) THEN
IF (DEBUG .AND. ICOUNT .LE. 50) THEN
WRITE(*,*) obs_elem_c(lobsSpaceData,'STID',INDEX_HEADER),
& ' FORMAL ERR, OBS ERROR (mm) = ',
& ZTDERR*1000.D0, ZTDOER*1000.D0
ENDIF
ZTDOER = MAX(ZTDOER, ZTDERR)
ENDIF
ENDIF
C *** APPLY TIME-SERIES WEIGHTING FACTOR TO OBSERVATION ERROR (YZDERRWGT=1 FOR 3D THINNING)
call obs_bodySet_r(lobsSpaceData,OBS_OER,IZTDJ, ZTDOER*YZDERRWGT)
ELSE
CALL ABORT3D('SETERRGPSGB: ERROR:NEGATIVE ZTD VALUE!')
ENDIF
ENDIF
IF (DEBUG .AND. ICOUNT .LE. 50) THEN
WRITE(*,*) 'TAG SITE ITYP IASS VAR OER'
call obs_set_current_body_list(lobsSpaceData, INDEX_HEADER)
BODY2: DO
index_body = obs_getBodyIndex(lobsSpaceData)
if (index_body < 0) exit BODY2
ITYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY)
IASS = obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY)
ZVAL = obs_bodyElem_r(lobsSpaceData,OBS_VAR,INDEX_BODY)
ZTDERR = obs_bodyElem_r(lobsSpaceData,OBS_OER,INDEX_BODY)
WRITE(*,*) 'ERRDEBUG ', obs_elem_c(lobsSpaceData,'STID',INDEX_HEADER),
& ITYP, IASS, ZVAL, ZTDERR
ENDDO BODY2
ENDIF
c
ENDDO HEADER
c IF (DEBUG) CALL ABORT3D('******DEBUG STOP*******')
IF (.not.ldata) numGPSZTD = 0
IF (ldata) WRITE(*,*) ' numGPSZTD = ', ICOUNT
WRITE(*,*) 'EXIT SETERRGPSGB'
RETURN
END SUBROUTINE SETERRGPSGB