!-------------------------------------- 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(lcolumnhr,lobsSpaceData) 1,44
#if defined (DOC)
*
***s/r SETERRGPSRO - Compute estimated errors for GPSRO observations
*
*
*Author : J. M. Aparicio Apr 2008
* Adapted Nov 2012 for both refractivity and bending angle data
* -------------------
*
*Arguments
*
#endif
use EarthConstants_mod
use MathPhysConstants_mod
use modgps01ctphys , only : p_TC, p_knot
use modgps02wgs84grav , only : gpsgravitysrf
use modgps03diff , only : gpsdiff
use modgps04profile , only : gpsprofile, gpsstruct1sw
use modgps08refop , only : gpsrefopv
use modgps09bend , only : gpsbndopv1
use modgpsro_mod
use obsSpaceData_mod
use columnData_mod
IMPLICIT NONE
C
type(struct_columnData) :: lcolumnhr
type(struct_obs) :: lobsSpaceData
C
INTEGER INDEX_HEADER, IDATYP, INDEX_BODY, iProfile
REAL*8 zLat, Lat, sLat
REAL*8 zLon, Lon
REAL*8 zAzm, Azm
REAL*8, allocatable :: ZPP(:)
REAL*8, allocatable :: ZDP(:)
REAL*8, allocatable :: ZTT(:)
REAL*8, allocatable :: ZHU(:)
REAL*8, allocatable :: ZUU(:)
REAL*8, allocatable :: ZVV(:)
C
REAL*8 DH,DDH
INTEGER JL, IAZM, ISAT, JH, NGPSLEV, NWNDLEV
REAL*8 zMT, Rad, Geo
REAL*8 HNH1, SUM0, SUM1, ZMIN
C
LOGICAL ASSIM, L1, L2, L3
INTEGER NH, NH1
TYPE(GPSPROFILE) :: PRF
REAL*8 , allocatable :: H (:),AZMV(:)
REAL*8 , allocatable :: ZOBS(:),ZREF(:),ZOFF(:),ZERR(:), ZMHX(:)
TYPE(GPSDIFF), allocatable :: RSTV(:)
WRITE(*,*)'ENTER SETERRGPSRO'
C
C * 1. Initializations
C * ---------------
C
NGPSLEV=col_getNumLev(LCOLUMNHR,'TH')
NWNDLEV=col_getNumLev(LCOLUMNHR,'MM')
allocate(ZPP (NGPSLEV))
allocate(ZDP (NGPSLEV))
allocate(ZTT (NGPSLEV))
allocate(ZHU (NGPSLEV))
allocate(ZUU (NGPSLEV))
allocate(ZVV (NGPSLEV))
C
allocate( H (GPSRO_MAXPRFSIZE) )
allocate( AZMV (GPSRO_MAXPRFSIZE) )
allocate( ZOBS (GPSRO_MAXPRFSIZE) )
allocate( ZREF (GPSRO_MAXPRFSIZE) )
allocate( ZOFF (GPSRO_MAXPRFSIZE) )
allocate( ZERR (GPSRO_MAXPRFSIZE) )
allocate( RSTV (GPSRO_MAXPRFSIZE) )
allocate( ZMHX (GPSRO_MAXPRFSIZE) )
C
C Loop over all header indices of the 'RO' family:
C
call obs_set_current_header_list(lobsSpaceData,'RO')
HEADER: do
INDEX_HEADER = obs_getHeaderIndex(lobsSpaceData)
if (INDEX_HEADER < 0) exit HEADER
C
C * Process only refractivity data (codtyp 169)
C
IDATYP = obs_headElem_i(lobsSpaceData,OBS_ITY,INDEX_HEADER)
IF ( IDATYP .EQ. 169 ) THEN
C
C * Scan for requested data values of the profile, and count them
C
ASSIM = .FALSE.
NH = 0
call obs_set_current_body_list(lobsSpaceData, INDEX_HEADER)
BODY: do
index_body = obs_getBodyIndex(lobsSpaceData)
if (index_body < 0) exit BODY
IF ( obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY).EQ.1 ) THEN
ASSIM = .TRUE.
NH = NH + 1
ENDIF
ENDDO BODY
C
C * If assimilations are requested, prepare and apply the observation operator
C
IF (ASSIM) THEN
iProfile=iProfile_from_index(INDEX_HEADER)
C
C * Basic geometric variables of the profile:
C
IAZM = obs_headElem_i(lobsSpaceData,OBS_AZA,INDEX_HEADER)
ISAT = obs_headElem_i(lobsSpaceData,OBS_SAT,INDEX_HEADER)
Rad = obs_headElem_r(lobsSpaceData,OBS_TRAD,INDEX_HEADER)
Geo = obs_headElem_r(lobsSpaceData,OBS_GEOI,INDEX_HEADER)
zAzm = 0.01d0*IAZM / MPC_DEGREES_PER_RADIAN_R8
zMT = col_getHeight(lcolumnhr,NGPSLEV,INDEX_HEADER,'TH')/RG
C
C * Profile at the observation location:
C
zLat = obs_headElem_r(lobsSpaceData,OBS_LAT,INDEX_HEADER)
zLon = obs_headElem_r(lobsSpaceData,OBS_LON,INDEX_HEADER)
Lat = zLat * MPC_DEGREES_PER_RADIAN_R8
Lon = zLon * MPC_DEGREES_PER_RADIAN_R8
Azm = zAzm * MPC_DEGREES_PER_RADIAN_R8
sLat = sin(zLat)
zMT = zMT * RG / gpsgravitysrf(sLat)
DO JL = 1, NGPSLEV
C
C * Profile x
C
ZPP(JL) = col_getPressure(LCOLUMNHR,JL,INDEX_HEADER,'TH')
C * True implementation of ZDP (dP/dP0)
ZDP(JL) = col_getPressureDeriv(LCOLUMNHR,JL,INDEX_HEADER,'TH')
ZTT(JL) = col_getElem(lcolumnhr,JL,INDEX_HEADER,'TT') - p_TC
ZHU(JL) = col_getElem(lcolumnhr,JL,INDEX_HEADER,'HU')
ZUU(JL) = 0.d0
ZVV(JL) = 0.d0
ENDDO
DO JL = 1, NWNDLEV
ZUU(JL) = col_getElem(lcolumnhr,JL,INDEX_HEADER,'UU') * p_knot
ZVV(JL) = col_getElem(lcolumnhr,JL,INDEX_HEADER,'VV') * p_knot
ENDDO
ZUU(NGPSLEV) = ZUU(NWNDLEV)
ZVV(NGPSLEV) = ZUU(NWNDLEV)
C
C * GPS profile structure:
C
call gpsstruct1sw(ngpslev,zLat,zLon,zAzm,zMT,Rad,geo,zPP,zDP,zTT,zHU,zUU,zVV,prf)
C
C * Prepare the vector of all the observations:
C
NH1 = 0
C
C * Loop over all body indices for this index_header:
C * (start at the beginning of the list)
C
call obs_set_current_body_list(lobsSpaceData, index_header)
BODY_2: do
index_body = obs_getBodyIndex(lobsSpaceData)
if (index_body < 0) exit BODY_2
IF ( obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY).EQ.1 ) THEN
NH1 = NH1 + 1
H(NH1) = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)
AZMV(NH1)= zAzm
ZOBS(NH1)= obs_bodyElem_r(lobsSpaceData,OBS_VAR,INDEX_BODY)
C * Reference value:
IF (LEVELGPSRO.EQ.1) THEN
ZREF(NH1) = 0.025d0*exp(-(H(NH1)-Rad)/6500.d0)
ELSE
ZREF(NH1) = 300.d0*exp(-H(NH1)/6500.d0)
ENDIF
ENDIF
ENDDO BODY_2
C
C * Apply the observation operator:
C
IF (LEVELGPSRO.EQ.1) THEN
CALL GPSBNDOPV1(H, AZMV, NH, PRF, RSTV)
ELSE
CALL GPSREFOPV (H, NH, PRF, RSTV)
ENDIF
C
C * Perform the (H(x)-Y)/R operation:
C
DO NH1 = 1, NH
ZMHX(NH1) = RSTV(NH1)%VAR
C
C * Normalized offset:
C
IF ( NUMGPSSATS .GE. 1 ) THEN
ZOFF(NH1) = (ZOBS(NH1) - ZMHX(NH1)) / ZREF(NH1)
ELSE
ZOFF(NH1) = (ZOBS(NH1) - ZMHX(NH1)) / ZMHX(NH1)
ENDIF
ENDDO
C
C * The procedure below is well tested to collectively
C * create error profiles from the data profile, and
C * intended to be used for these data.
C
DH = 5000.d0
IF (LEVELGPSRO.EQ.1) THEN
ZMIN=0.01D0
ELSE
ZMIN=0.002D0
ENDIF
IF (LEVELGPSRO.EQ.2) THEN
DO NH1 = 1, NH
SUM0=0.d0
SUM1=0.d0
DO JH = 1, NH
DDH=H(JH)-H(NH1)
SUM0=SUM0+EXP(-(DDH/DH)**2)
SUM1=SUM1+EXP(-(DDH/DH)**2)*ZOFF(JH)**2
ENDDO
ZERR(NH1)=(SUM1/SUM0)**0.5D0
IF ( NUMGPSSATS .GE. 1 ) THEN
IF (ISAT.EQ.3 .OR. ISAT.EQ.4) ZERR(NH1) = 2*ZERR(NH1)
ENDIF
IF ( ZERR(NH1) < ZMIN ) ZERR(NH1) = ZMIN
ENDDO
ELSE
DO NH1 = 1, NH
ZERR(NH1)=0.05d0
HNH1=H(NH1)-Rad
L1=( HNH1.LE.10000.d0 )
L2=( HNH1.GT.10000.d0 .AND. HNH1.LT.30000.d0 )
L3=( HNH1.GT.30000.d0 )
IF ( L1 ) ZERR(NH1)=0.02d0+0.08d0*(10000.d0-HNH1)/10000.d0
IF ( L2 ) ZERR(NH1)=0.02d0
IF ( L3 ) ZERR(NH1)=0.02d0+0.13d0*(HNH1-30000.d0)/30000.d0
IF (ISAT.EQ.3 .OR. ISAT.EQ.4 .OR. ISAT.EQ.5) ZERR(NH1) = 2*ZERR(NH1)
IF ( ZERR(NH1) < ZMIN ) ZERR(NH1) = ZMIN
ENDDO
ENDIF
NH1 = 0
C
C * Loop over all body indices for this index_header:
C * (start at the beginning of the list)
C
call obs_set_current_body_list(lobsSpaceData, index_header)
BODY_4: do
index_body = obs_getBodyIndex(lobsSpaceData)
if (index_body < 0) exit BODY_4
IF ( obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY).EQ.1 ) THEN
NH1 = NH1 + 1
C
C * Observation error S
C
IF ( NUMGPSSATS .GE. 1 ) THEN
call obs_bodySet_r(lobsSpaceData,OBS_OER,index_body, ZERR(NH1) * ZREF(NH1))
ELSE
call obs_bodySet_r(lobsSpaceData,OBS_OER,index_body, ZERR(NH1) * ZMHX(NH1))
ENDIF
ENDIF
ENDDO BODY_4
ENDIF
ENDIF
ENDDO HEADER
deallocate( RSTV )
deallocate( ZERR )
deallocate( ZOFF )
deallocate( ZREF )
deallocate( ZOBS )
deallocate( AZMV )
deallocate( H )
deallocate( ZMHX )
deallocate(zVV)
deallocate(zUU)
deallocate(zHU)
deallocate(zTT)
deallocate(zDP)
deallocate(zPP)
WRITE(*,*)'EXIT SETERRGPSRO'
RETURN
END SUBROUTINE SETERRGPSRO