!-------------------------------------- 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 SETFGEGPS 3,1
#if defined (DOC)
*
***s/r -SETFGEGPS Sets first-guess error for all GB-GPS ZTD observations
*
*
*Author : S. Macpherson *ARMA/MSC December 2004
*
*Revisions:
*
* -------------------
** Purpose: Set FGE for all GPS ZTD observations using
* adjoint of gpsztdop to get Jacobians
*
*Arguments
* None
*
*
#endif
IMPLICIT NONE
*implicits
#include "comlun.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comgem.cdk"
#include "comcst.cdk"
#include "comphy.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "commvo.cdk"
#include "commvog.cdk"
#include "cvcord.cdk"
#include "comnumbr.cdk"
#include "comstate.cdk"
#include "comgpsgb.cdk"
*
C
REAL*8 ZTODEG
REAL*8 ZLAT
REAL*8 ZLON
REAL*8 ZETA(NFLEV)
REAL*8 ZTT (NFLEV)
REAL*8 ZHU (NFLEV)
REAL*8 ZGZ (NFLEV)
REAL*8 ZTTB (NFLEV)
REAL*8 ZHUB (NFLEV)
REAL*8 ZP0
REAL*8 ZP0B
REAL*8 ZPT
REAL*8 ZMT
REAL*8 ZP0S
c REAL*8 ZSBLCRIT(2)
REAL*8 ZTTS(NFLEV), ZHUS(NFLEV), ZGZS(NFLEV)
C
REAL*8 ZOER, ZINC, ZHX, ZLEV
REAL*8 ZDZ
REAL*8 ZHXB, ZVAR
C
REAL*8 ZJTT (NFLEV)
REAL*8 ZJHU (NFLEV)
REAL*8 ZJP0, ZLSUM
C
INTEGER JF
INTEGER IBEGIN , ILAST
INTEGER IBEGINOB, ILASTOB, JO
INTEGER IDATYP, ITYP
INTEGER IDATA , IDATEND, JDATA
INTEGER JL, JK
C
LOGICAL ASSIM, LLSHIFT, LLOK
INTEGER NH, NH1
C
C * 1. Initializations
C * ---------------
C
ZTODEG = 180.0 / RPI
C * Depth of PBL in Pa for (1) TT and (2) HU
c ZSBLCRIT(1) = 5000.0
c ZSBLCRIT(2) = 5000.0
C
C * . 1.1 Eta vector
C * . ----------
C
DO JL = 1, NFLEV
ZETA(JL) = VLEV(JL)
ENDDO
C
C Loop over all observation files (all observation types)
C
DO JF = 1, NFILES
C
C * Process only GPS observation files (family = GP)
C
IF ( CFAMTYP(JF).EQ.'GP' .AND. NBEGINTYP(JF).GT.0 ) THEN
IBEGIN = NBEGINTYP(JF)
ILAST = NENDTYP (JF)
IBEGINOB = MOBDATA(NCMOBS,IBEGIN)
ILASTOB = MOBDATA(NCMOBS,ILAST )
C
C * Loop over all GPS observations (locations) of the file
C
DO JO = IBEGINOB, ILASTOB
C
C * . Process only zenith delay data (codtyp 189 and NEZD)
C
IDATYP = MOD(MOBHDR(NCMITY,JO),1000)
IF ( IDATYP .EQ. 189 ) THEN
C
C Loop over data in the observations
C
IDATA = MOBHDR(NCMRLN,JO)
IDATEND = MOBHDR(NCMNLV,JO) + IDATA - 1
ASSIM = .FALSE.
C
C Scan for requested assimilations, and count them.
C
NH = 0
DO JDATA= IDATA, IDATEND
ITYP = MOBDATA(NCMVNM,JDATA)
LLOK = ( (ITYP .EQ. NEZD) .AND.
& (MOBDATA(NCMASS,JDATA) .EQ. 1) )
IF ( LLOK ) THEN
ASSIM = .TRUE.
NH = NH + 1
ENDIF
ENDDO
C
C * If assimilations are requested, apply the AD observation operator
C
IF (ASSIM) THEN
C
C * LR background profile and background errors at the observation location x :
C
ZLAT = ROBHDR(NCMLAT,JO) * ZTODEG
ZLON = ROBHDR(NCMLON,JO) * ZTODEG
DO JL = 1, NFLEV
ZTTB(JL) = GOMTG(JL,JO)
ZTT(JL) = GOMT(JL,JO)
ZHUB(JL) = EXP(GOMQG(JL,JO))
ZHU(JL) = GOMQ(JL,JO)
ZGZ(JL) = GOMGZG(JL,JO)
ENDDO
ZP0B = GOMPSG(1,JO)
ZP0 = GOMPS(1,JO)
ZPT = RPPOBS(1,JO)
ZMT = ZGZ(NFLEV)/GRAV
C
C * Call AD of ZTD observation operator to get Jacobians dH/dX
C
C
C
NH1 = 0
DO JDATA= IDATA, IDATEND
ITYP = MOBDATA(NCMVNM,JDATA)
IF ( MOBDATA(NCMASS,JDATA).EQ.1 .AND.
+ ITYP.EQ.NEZD ) THEN
NH1 = NH1 + 1
C
C * Observation error SDERR
c ZOER = ROBDATA8(NCMOER,JDATA)
C
ZHX = 1.0
C
C * Observation height (m)
ZLEV = ROBDATA8(NCMPPP,JDATA)
C
CALL GPSZTDOPAD(ZLAT,ZLON,ZLEV,ZETA,ZTTB,
+ ZHUB,ZP0B,ZPT,ZMT,ZGZ,ZHXB,ZJTT,ZJHU,ZJP0,ZHX)
C
C dH/dQ ---> dH/d(lnQ)
ZJHU(:) = ZHUB(:)*ZJHU(:)
C
C * Compute the background ZTD error (HBHt)
ZLSUM = 0.0
DO JL = 1, NFLEV
ZLSUM = ZLSUM + (ZJTT(JL)*ZTT(JL))**2 +
+ (ZJHU(JL)*ZHU(JL))**2
ENDDO
ZLSUM = ZLSUM + (ZJP0*ZP0)**2
ROBDATA(NCMFGE,JDATA) = SQRT(ZLSUM)
C
IF (JO.EQ.IBEGINOB .AND. NH1.LE.3) THEN
WRITE(NULOUT,
+ '(A11,A9,3(1x,f7.2))')
+ 'SETFGEGPS: ',CSTNID(JO),ZLAT,ZLON,ZLEV
WRITE(NULOUT,*) 'JL JACT JACQ FGE_T FGE_LQ'
DO JL = 1, NFLEV
WRITE(NULOUT,
+ '(1X,I2,4(1x,E13.6))') JL,ZJTT(JL),ZJHU(JL)/ZHUB(JL),ZTT(JL), ZHU(JL)
ENDDO
WRITE(NULOUT,*) 'JACPS FGE_PS'
WRITE(NULOUT,'(2(1x,E13.6))') ZJP0, ZP0
ENDIF
C
ENDIF
ENDDO
ENDIF
ENDIF
ENDDO
ENDIF
ENDDO
C
C WRITE(NULOUT, *) ' '
C
RETURN
END