!-------------------------------------- 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 SETERRGPSRO 1,11
#if defined (DOC)
*
***s/r SETERRGPSRO - Computation of the estimated errors for GPSRO observations
*
*
*Author : J. M. Aparicio Apr 2008
* -------------------
** Purpose:
*
*Arguments
* None
*
#endif
use modgps04profile
use modgps05refstruct
use modgps06gravity
use modgps07geostruct
use modgps08refop
IMPLICIT NONE
*implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comcva.cdk"
#include "comgem.cdk"
#include "comdimo.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comct0.cdk"
#include "comnumbr.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "commvo.cdk"
#include "commvohr.cdk"
#include "cvcord.cdk"
#include "comphy.cdk"
#include "comvarqc.cdk"
#include "comgpsro.cdk"
#include "namgpsro.cdk"
*
REAL*8 PJO, PJOB, PJOM, PJOX, PJO1
C
REAL*8 ZTODEG
REAL*8 ZLAT, Lat
REAL*8 ZLON, Lon
REAL*8 ZETA(JPNFLEV)
REAL*8 ZTT (JPNFLEV)
REAL*8 ZHU (JPNFLEV)
REAL*8 ZGZ (JPNFLEV)
REAL*8 ZP0
REAL*8 ZPT, ZPR, ZCF
REAL*8 ZMT
REAL*8 DH,DDH
REAL*8 HNH1, ZOBS, SUM0, SUM1
C
REAL*8 ZMHX
C
INTEGER JF
INTEGER IBEGIN , ILAST
INTEGER IBEGINOB, ILASTOB, JO, JD
INTEGER IDATYP
INTEGER IDATA , IDATEND, JDATA
INTEGER JL, JH, NQCVAR, NGPSLEV
C
LOGICAL ASSIM
INTEGER NH, NH1, IERR
TYPE(GPSPROFILE) :: PRF
REAL(DP) , ALLOCATABLE :: H (:), HGT(:)
REAL(DP) , ALLOCATABLE :: ZOFF(:),ZERR(:)
TYPE(GPSDIFF), ALLOCATABLE :: RSTV(:)
WRITE(NULOUT,*)'ENTER SETERRGPSRO'
C
C * 1. Initializations
C * ---------------
C
ZTODEG = 180.0 / RPI
C
C * . 1.1 Eta vector
C * . ----------
C
NGPSLEV=NLEVTRL
DO JL = 1, NLEVTRL
ZETA(JL) = VLEVHR(JL)
ENDDO
C
C* * 1.2 Read the NAMELIST NAMGGPSRO
C * ---------------------------------------
CALL READNML('NAMGPSRO',IERR)
write(NULOUT,*)'NAMGPSRO',SURFMIN,HSFMIN,HTPMAX,BGCKBAND
C
C * QC VAR
C
IF (LVARQC) THEN
NQCVAR = 1
ELSE
NQCVAR = 0
ENDIF
C
C Loop over all files
C
DO JF = 1, NFILES
IF ( CFAMTYP(JF).EQ.'RO' .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 observations of the file
C
DO JO = IBEGINOB, ILASTOB
C
C * Process only refractivity data (codtyp 169)
C
IDATYP = MOD(MOBHDR(NCMITY,JO),1000)
IF ( IDATYP .EQ. 169 ) THEN
C
C Loops over data in the observation
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
HNH1 = ROBDATA8(NCMPPP,JDATA)
IF ( HNH1.GE.0. .AND. HNH1.LE.HTPMAX ) THEN
ASSIM = .TRUE.
NH = NH + 1
ENDIF
ENDDO
C
C * If assimilations are requested, apply the observation operator
C
IF (ASSIM) THEN
C
C * Profile at the observation location:
C
Lat = ROBHDR(NCMLAT,JO)
Lon = ROBHDR(NCMLON,JO)
ZLAT = Lat * ZTODEG
ZLON = Lon * ZTODEG
DO JL = 1, NLEVTRL
C
C * Profile x
C
ZTT(JL) = GOMTHR (JL,JO)-273.15
ZHU(JL) = GOMQHR (JL,JO)
ZGZ(JL) = GOMGZHR(JL,JO)
ENDDO
ZP0 = GOMPSHR(1,JO)
ZPT = RPPOBSHR(1,JO)
ZMT = ZGZ(NLEVTRL)/RG
ZMT = gpsgeopotential(Lat, ZMT)/RG
ZPR = rprefinc
ZCF = rcoefinc
C
C * GPS profile structure:
C
CALL GPSSTRUCT1H(NGPSLEV,ZLAT,ZLON,ZETA,
+ ZTT,ZHU,ZP0,ZMT,ZPT,ZPR,ZCF,PRF)
CALL GPSGEO(PRF)
C
C * Prepare the vector of all the observations:
C
ALLOCATE( HGT (NH) )
ALLOCATE( H (NH) )
ALLOCATE( ZOFF (NH) )
ALLOCATE( ZERR (NH) )
ALLOCATE( RSTV (NH) )
NH1 = 0
DO JDATA= IDATA, IDATEND
HNH1 = ROBDATA8(NCMPPP,JDATA)
IF ( HNH1.GE.0. .AND. HNH1.LE.HTPMAX ) THEN
NH1 = NH1 + 1
HNH1 = ROBDATA8(NCMPPP,JDATA)
HGT(NH1)= HNH1
H(NH1)= gpsgeopotential(Lat,HNH1)/9.80616
ENDIF
ENDDO
C
C * Apply the observation operator:
C
DH = 5000._dp
CALL GPSREFOPV (H, PRF, RSTV)
C
C * Perform the (H(x)-Y)/S operation
C
NH1 = 0
DO JDATA= IDATA, IDATEND
HNH1 = ROBDATA8(NCMPPP,JDATA)
IF ( HNH1.GE.0. .AND. HNH1.LE.HTPMAX ) THEN
NH1 = NH1 + 1
C
C * Observation operator H(x)
C
ZMHX = RSTV(NH1)%VAR
C
C * Observation value Y
C
ZOBS = ROBDATA8(NCMVAR,JDATA)
C
C * Normalized increment
C
ZOFF(NH1) = (ZOBS - ZMHX) / ZMHX
ENDIF
ENDDO
C
C * The procedure below is well tested to collectively
C * create error profiles FROM data below 40 km, and
C * intended to be used FOR data below 40 km. The procedure
C * creates also a reasonable estimate for the error
C * profiles FOR data above, but only uses data FROM below
C * HTPMAX as input. Extending input for all HGT requires
C * research on the error characteristics of data above 40 km.
C
DO NH1 = 1, NH
SUM0=0.
SUM1=0.
DO JH = 1, NH
IF ( HGT(JH) .LT. HTPMAX ) THEN
DDH=H(JH)-H(NH1)
SUM0=SUM0+EXP(-(DDH/DH)**2)
SUM1=SUM1+EXP(-(DDH/DH)**2)*ZOFF(JH)**2
ENDIF
ENDDO
ZERR(NH1)=SQRT(SUM1/SUM0)
IF ( ZERR(NH1) < 0.002 ) ZERR(NH1) = 0.002
ENDDO
NH1 = 0
DO JDATA= IDATA, IDATEND
HNH1 = ROBDATA8(NCMPPP,JDATA)
IF ( HNH1.GE.0. .AND. HNH1.LE.HTPMAX ) THEN
NH1 = NH1 + 1
C
C * Observation operator H(x)
C
ZMHX = RSTV(NH1)%VAR
C
C * Observation error S
C
ROBDATA8(NCMOER,JDATA) = ZERR(NH1) * ZMHX
ENDIF
ENDDO
DEALLOCATE( RSTV )
DEALLOCATE( ZERR )
DEALLOCATE( ZOFF )
DEALLOCATE( H )
DEALLOCATE( HGT )
ENDIF
ENDIF
ENDDO
ENDIF
ENDDO
WRITE(NULOUT,*)'EXIT SETERRGPSRO'
RETURN
END