!-------------------------------------- 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 oda_H(lcolumn,lcolumng,lobsSpaceData) 3,19
use mpivar_mod
use topLevelControl_mod
use EarthConstants_mod
use MathPhysConstants_mod
use obsSpaceData_mod
use columnData_mod
use bufr
use modgpsro_mod
use modgpsztd_mod
use minimization_mod
use timeCoord_mod
use filterObs_mod
implicit none
!
!Purpose:
!Compute simulated observations from profiled model
!increments.
!It returns Hdx in OBS_WORK
!Calls the several linear observation operators
!
!Author : S. Pellerin *ARMA/MRB January 2009
!
!Revision:
! L. Fillion, ARMA/EC, 5 Jun 2009. Introduce 1 Obs experiment.
! S. Macpherson ARMA 11 Sep 2009
! - added ground-based GPS (ZTD) observation operator
! S. Macpherson ARMA 5 Oct 2012
! - update oda_Hgp for new ZTD operator
! S. Macpherson ARMA 14 Jan 2013
! - use numGPSZTD (from new modgpsztd_mod) to determine if call oda_Hgp needed
! - modified oda_Hgp
! - use new ZTD-specific GPS modules modgps04profilezd, modgps08ztdop
! - merged with latest version (oda_Hro) from Josep (Rev.213M)
! - like oda_Hro, use OpenMP and Jacobian storage for GPS ZTD
!
!Local declarations
integer, save :: nl_ncall = 0
real*8 :: dl_bidon
type(struct_columnData) :: lcolumn,lcolumng
type(struct_obs) :: lobsSpaceData
type(struct_vco), pointer :: vco_anl
IF(mpi_myid == 0) THEN
write(*,*)'ODA_H- Linearized observation operators'
endif
vco_anl => col_getVco(lcolumng)
nl_ncall = nl_ncall + 1
call tmg_start(42,'OBS_PPP_TLAD') !
call oda_Hpp ! fill in OBS_WORK : Hdx
call tmg_stop(42)
call tmg_start(43,'OBS_SFC_TLAD')
call oda_Hsf ! fill in OBS_WORK : Hdx
call tmg_stop (43)
call tmg_start(44,'OBS_TOV_TLAD') !
call oda_Hto ! fill in OBS_WORK : Hdx
call tmg_stop (44)
call tmg_start(45,'OBS_GPSRO_TLAD') !
call oda_Hro
call tmg_stop (45) !
call tmg_start(46,'OBS_ZZZ_TLAD') !
call oda_Hzp
call tmg_stop (46) !
call tmg_start(47,'OBS_GPSGB_TLAD') !
if (numGPSZTD > 0) call oda_Hgp
call tmg_stop (47) !
CONTAINS
SUBROUTINE oda_Hpp 1,55
!*
!* Purpose: Compute simulated Upper Air observations from profiled model
!* increments.
!* It returns Hdx in OBS_WORK
!* Interpolate vertically the contents of commvo to
!* the pressure levels of the observations.
!* A linear interpolation in ln(p) is performed.
!*
!*implicits
implicit none
INTEGER IPB,IPT
INTEGER INDEX_HEADER,INDEX_FAMILY,IK
INTEGER J,INDEX_BODY,ITYP,nlev_T
REAL*8 ZDADPS,ZCON
REAL*8 ZWB,ZWT, ZEXP, ZGAMMA,ZLTV,ZTVG,ZPPOST
REAL*8 ZLEV,ZPT,ZPB,ZLAT,ZLON,ZTORAD
REAL*8 dPdPsT,dPdPsB
REAL*8 columnVarB,columnVarT,columngVarB,columngVarT,lqtoes,lqtoes_tl
LOGICAL LLASSIM,LLDIAG
INTEGER, PARAMETER :: numFamily=3
CHARACTER(len=2) :: list_family(numFamily),varType
!
! Temperature lapse rate for extrapolation of gz below model surface
!
zgamma = 0.0065D0 / GRAV
zexp = MPC_RGAS_DRY_AIR_R8*zgamma
list_family(1) = 'UA'
list_family(2) = 'AI'
list_family(3) = 'SW'
FAMILY: do index_family=1,numFamily
call obs_set_current_body_list(lobsSpaceData,list_family(index_family))
BODY: DO
index_body = obs_getBodyIndex(lobsSpaceData)
if (index_body < 0) exit BODY
llassim= (obs_bodyElem_i(lobsSpaceData,OBS_ASS,index_body) .EQ. 1) &
.AND. (obs_bodyElem_i(lobsSpaceData,OBS_XTR,index_body) .EQ. 0) &
.AND. (obs_bodyElem_i(lobsSpaceData,OBS_VCO,index_body) .EQ. 2)
lldiag = (obs_bodyElem_i(lobsSpaceData,OBS_ASS,index_body) .EQ. -1) &
.AND. (obs_bodyElem_i(lobsSpaceData,OBS_VCO,index_body) .EQ. 2)
IF (llassim .or. lldiag) THEN
index_header = obs_bodyElem_i(lobsSpaceData,OBS_HIND,INDEX_BODY)
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)
ITYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY)
varType = vnl_varTypeFromVarnum(ityp)
IK = obs_bodyElem_i(lobsSpaceData,OBS_LYR,INDEX_BODY)
IPT = IK + col_getOffsetFromVarno(lcolumng,ityp)
IPB = IPT+1
ZPT = col_getPressure(LCOLUMNG,IK ,INDEX_HEADER,varType)
ZPB = col_getPressure(LCOLUMNG,IK+1,INDEX_HEADER,varType)
dPdPsT = col_getPressureDeriv(LCOLUMNG,IK ,INDEX_HEADER,varType)
dPdPsB = col_getPressureDeriv(LCOLUMNG,IK+1,INDEX_HEADER,varType)
ZWB = LOG(ZLEV/ZPT)/LOG(ZPB/ZPT)
ZWT = 1.0D0 - ZWB
ZDADPS = ( LOG(ZLEV/ZPB)*dPdPsT/ZPT - &
LOG(ZLEV/ZPT)*dPdPsB/ZPB )/ &
LOG(ZPB/ZPT)**2
if(ityp.eq.bufr_nees) then
columnVarB=lqtoes_tl(col_getElem(lcolumn,IK+1,INDEX_HEADER,'HU'), &
col_getElem(lcolumn,IK+1,INDEX_HEADER,'TT'), &
col_getElem(lcolumn,1,INDEX_HEADER,'P0'), &
col_getElem(lcolumng,IK+1,INDEX_HEADER,'HU'), &
col_getPressure(lcolumng,IK+1,INDEX_HEADER,'TH'), &
dPdPsB)
columnVarT=lqtoes_tl(col_getElem(lcolumn,IK ,INDEX_HEADER,'HU'), &
col_getElem(lcolumn,IK ,INDEX_HEADER,'TT'), &
col_getElem(lcolumn,1,INDEX_HEADER,'P0'), &
col_getElem(lcolumng,IK ,INDEX_HEADER,'HU'), &
col_getPressure(lcolumng,IK ,INDEX_HEADER,'TH'), &
dPdPsT)
columngVarB=lqtoes(col_getElem(lcolumng,IK+1,INDEX_HEADER,'HU'), &
col_getElem(lcolumng,IK+1,INDEX_HEADER,'TT'), &
col_getPressure(lcolumng,IK+1,INDEX_HEADER,'TH'))
columngVarT=lqtoes(col_getElem(lcolumng,IK ,INDEX_HEADER,'HU'), &
col_getElem(lcolumng,IK ,INDEX_HEADER,'TT'), &
col_getPressure(lcolumng,IK ,INDEX_HEADER,'TH'))
else
columnVarB=col_getElem(lcolumn,IPB,INDEX_HEADER)
columnVarT=col_getElem(lcolumn,IPT,INDEX_HEADER)
columngVarB=col_getElem(lcolumng,IPB,INDEX_HEADER)
columngVarT=col_getElem(lcolumng,IPT,INDEX_HEADER)
endif
call obs_bodySet_r(lobsSpaceData,OBS_WORK,INDEX_BODY, &
ZWB*columnVarB + ZWT*columnVarT+ &
(columngVarB - columngVarT)* &
ZDADPS*col_getElem(LCOLUMN,1,INDEX_HEADER,'P0'))
elseif( (obs_bodyElem_i(lobsSpaceData,OBS_ASS,index_body) .EQ. 1) &
.AND. (obs_bodyElem_i(lobsSpaceData,OBS_XTR,index_body) .EQ. 2) &
.AND. (obs_bodyElem_i(lobsSpaceData,OBS_VCO,index_body) .EQ. 2) ) then
INDEX_HEADER = obs_bodyElem_i(lobsSpaceData,OBS_HIND,INDEX_BODY)
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)
!
! TL model for height data below model's orography
!
nlev_T = col_getNumLev(LCOLUMN,'TH')
ZLTV = lcolumng%OLTV(1,nlev_T,INDEX_HEADER)*col_getElem(LCOLUMN,nlev_T,INDEX_HEADER,'TT') &
+ lcolumng%OLTV(2,nlev_T,INDEX_HEADER)*col_getElem(LCOLUMN,nlev_T,INDEX_HEADER,'HU')
ZTVG = lcolumng%OLTV(1,nlev_T,INDEX_HEADER)*col_getElem(lcolumng,nlev_T,INDEX_HEADER,'TT')
ZCON =(ZLEV/col_getElem(lcolumng,1,INDEX_HEADER,'P0'))**ZEXP
call obs_bodySet_r(lobsSpaceData,OBS_WORK,index_body, (1.d0-zcon)/zgamma*ZLTV &
+ MPC_RGAS_DRY_AIR_R8*ZTVG*zcon*col_getElem(lcolumn,1,index_header,'P0') &
/col_getElem(lcolumng,1,index_header,'P0'))
endif
enddo BODY
enddo FAMILY
end subroutine oda_Hpp
SUBROUTINE oda_Hsf 1,50
!*
!* Purpose: Compute simulated surface observations from profiled model
!* increments.
!* It returns Hdx in OBS_WORK
!*
IMPLICIT NONE
INTEGER IPB,IPT,IXTR
INTEGER INDEX_HEADER,IK
INTEGER J,INDEX_BODY,ITYP,INDEX_FAMILY,nlev
REAL*8 ZCON
REAL*8 ZWB,ZWT, ZEXP,ZEXPGZ,ZGAMMA,ZLTV,ZTVG,ZPPOST
REAL*8 ZLEV,ZPT,ZPB,ZDELPS,ZDELTV,ZGAMAZ,ZHHH
REAL*8 columnVarB,lqtoes_tl
REAL*8 dPdPsfc
INTEGER, PARAMETER :: numFamily=4
CHARACTER(len=2) :: list_family(numFamily),varType
!C
!C Temperature lapse rate for extrapolation of gz below model surface
!C
zgamma = 0.0065d0 / GRAV
zexp = 1.0d0/(MPC_RGAS_DRY_AIR_R8*zgamma)
zexpGZ = MPC_RGAS_DRY_AIR_R8*zgamma
!C
!C
list_family(1) = 'UA'
list_family(2) = 'SF'
list_family(3) = 'SC'
list_family(4) = 'GP'
FAMILY: do index_family=1,numFamily
call obs_set_current_body_list(lobsSpaceData, list_family(index_family))
BODY: do
index_body = obs_getBodyIndex(lobsSpaceData)
if (index_body < 0) exit BODY
! Process all data within the domain of the model
ityp = obs_bodyElem_i(lobsSpaceData,OBS_VNM,index_body)
if ( ityp.eq.bufr_nezd ) cycle BODY
if( (obs_bodyElem_i(lobsSpaceData,OBS_VCO,index_body).eq.1) &
.and. (obs_bodyElem_i(lobsSpaceData,OBS_ASS,index_body).eq.1) &
.and. (ityp.eq.bufr_nets .or. ityp.eq.bufr_neps &
.or. ityp.eq.bufr_nepn .or. ityp.eq.bufr_ness &
.or. ityp.eq.bufr_neus .or. ityp.eq.bufr_nevs &
.or. obs_bodyElem_i(lobsSpaceData,OBS_XTR,index_body).eq.0) ) then
if( ityp.eq.bufr_neus .or. ityp.eq.bufr_nevs ) then
varType = 'MM'
else
varType = 'TH'
endif
nlev = col_getNumLev(lcolumn,varType)
INDEX_HEADER = obs_bodyElem_i(lobsSpaceData,OBS_HIND,INDEX_BODY)
ITYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY)
IXTR = obs_bodyElem_i(lobsSpaceData,OBS_XTR,INDEX_BODY)
IK = obs_bodyElem_i(lobsSpaceData,OBS_LYR,INDEX_BODY)
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)
ZHHH = ZLEV * GRAV
IPT = nlev - 1 + col_getOffsetFromVarno(lcolumng,ityp)
IPB = IPT+1
IF (ITYP.EQ.BUFR_NETS .OR. ITYP.EQ.BUFR_NESS .OR. &
ITYP.EQ.BUFR_NEUS .OR. ITYP.EQ.BUFR_NEVS) THEN
if(ITYP.eq.BUFR_NESS) THEN
dPdPsfc = col_getPressureDeriv(lcolumng,nlev,index_header,'TH')
columnVarB=lqtoes_tl(col_getElem(lcolumn,nlev,INDEX_HEADER,'HU'), &
col_getElem(lcolumn,nlev,INDEX_HEADER,'TT'), &
col_getElem(lcolumn,1,INDEX_HEADER,'P0'), &
col_getElem(lcolumng,nlev,INDEX_HEADER,'HU'), &
col_getPressure(lcolumng,nlev,INDEX_HEADER,varType), &
dPdPsfc)
else
columnVarB=col_getElem(LCOLUMN,IPB,INDEX_HEADER)
endif
call obs_bodySet_r(lobsSpaceData,OBS_WORK,INDEX_BODY,columnVarB)
ELSEIF (ITYP.EQ.BUFR_NEPS .OR. ITYP.EQ.BUFR_NEPN) THEN
ZLTV = lcolumng%OLTV(1,nlev,INDEX_HEADER)*col_getElem(LCOLUMN,nlev,INDEX_HEADER,'TT') &
+ lcolumng%OLTV(2,nlev,INDEX_HEADER)*col_getElem(LCOLUMN,nlev,INDEX_HEADER,'HU')
ZTVG = lcolumng%OLTV(1,nlev,INDEX_HEADER)*col_getElem(lcolumng,nlev,INDEX_HEADER,'TT')
ZGAMAZ= ZGAMMA*(ZHHH-col_getHeight(lcolumng,nlev,INDEX_HEADER,varType))
ZCON = ((ZTVG-ZGAMAZ)/ZTVG)
ZDELPS= (col_getElem(LCOLUMN,1,INDEX_HEADER,'P0')*ZCON**ZEXP)
ZDELTV= ((col_getElem(lcolumng,1,INDEX_HEADER,'P0')*ZEXP*ZCON**(ZEXP-1)) &
*(ZGAMAZ/(ZTVG*ZTVG)*ZLTV))
call obs_bodySet_r(lobsSpaceData,OBS_WORK,INDEX_BODY, ZDELPS+ZDELTV)
ELSE
IPT = IK + col_getOffsetFromVarno(lcolumng,ityp)
IPB = IPT+1
ZPT = col_getHeight(lcolumng,IK,INDEX_HEADER,varType)
ZPB = col_getHeight(lcolumng,IK+1,INDEX_HEADER,varType)
ZWB = (ZPT-ZHHH)/(ZPT-ZPB)
ZWT = 1.d0 - ZWB
call obs_bodySet_r(lobsSpaceData,OBS_WORK,INDEX_BODY, &
ZWB*col_getElem(LCOLUMN,IPB,INDEX_HEADER) + ZWT*col_getElem(LCOLUMN,IPT,INDEX_HEADER)+ &
(col_getElem(lcolumng,IPB,INDEX_HEADER)-col_getElem(lcolumng,IPT,INDEX_HEADER)))
ENDIF
elseif( (obs_bodyElem_i(lobsSpaceData,OBS_ASS,index_body) .EQ. 1) &
.AND. (obs_bodyElem_i(lobsSpaceData,OBS_XTR,index_body) .EQ. 2) &
.AND. (obs_bodyElem_i(lobsSpaceData,OBS_VNM,index_body) .EQ. BUFR_NEGZ ) &
.AND. (obs_bodyElem_i(lobsSpaceData,OBS_VCO,index_body) .EQ. 1) ) then
nlev = col_getNumLev(lcolumn,'TH')
INDEX_HEADER = obs_bodyElem_i(lobsSpaceData,OBS_HIND,INDEX_BODY)
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)
!C
!C CONTRIBUTION TO Jo
!C
!c TL model for height data below model's orography
!c
ZLTV = lcolumng%OLTV(1,nlev,INDEX_HEADER)*col_getElem(LCOLUMN,nlev,INDEX_HEADER,'TT') &
+ lcolumng%OLTV(2,nlev,INDEX_HEADER)*col_getElem(LCOLUMN,nlev,INDEX_HEADER,'HU')
ZTVG = lcolumng%OLTV(1,nlev,INDEX_HEADER)*col_getElem(lcolumng,nlev,INDEX_HEADER,'TT')
ZCON=(ZLEV/col_getElem(lcolumng,1,INDEX_HEADER,'P0'))**ZEXPGZ
call obs_bodySet_r(lobsSpaceData,OBS_WORK,index_body,(1.d0-zcon)/zgamma*ZLTV &
+ MPC_RGAS_DRY_AIR_R8*ZTVG*zcon*col_getElem(lcolumn,1,index_header,'P0') &
/col_getElem(lcolumng,1,index_header,'P0'))
endif
enddo BODY
enddo FAMILY
END subroutine oda_Hsf
subroutine oda_Hto 1,7
!
! Purpose: Compute simulated radiances observations from profiled model
! increments.
! It returns Hdx in OBS_WORK
!
!author : j. halle *cmda/aes april 8, 2005
!
!revision 001 : a. beaulne *cmda/smc july 2006
! -addition of geopotential field in call to
! tovs_fill_profiles
! S. Pellerin, ARMA, August 2008
! - Avoid multiple (iterative) interpolation to 43 levels
! background variable profiles
! S. Pellerin, ARMA, January 2009
! - call to oda_storeHdx_radiances instead computing Jo
!
implicit none
integer :: datestamp
! 1. Prepare atmospheric profiles for all tovs observation points for use in rttov
! . -----------------------------------------------------------------------------
!
if (min_nsim == 1) then
datestamp = tim_getDatestamp()
call tovs_fill_profiles(lcolumng,lobsSpaceData,datestamp,filt_rlimlvhu,top_bgckIrMode())
endif
! 2. Prepare atmospheric tl profiles for all tovs observation points for use in rttov
! . --------------------------------------------------------------------------------
!
call tovs_fill_profiles_tl(lcolumn,lcolumng,top_bgckIrMode())
! 3. Compute radiance
! . ----------------
!
call tovs_rttov_tl(lobsSpaceData)
call oda_storeHdx_radiances(lobsSpaceData)
return
end subroutine oda_Hto
SUBROUTINE oda_Hro 1,42
!*
!* Purpose: Compute the tangent operator for GPSRO observations.
!*
!*Author : J. M. Aparicio Jan 2004
!*Modified: J. M. Aparicio Dec 2012 adapt to accept bending angle data
!* -------------------
use modgps00base , only : ngpscvmx
use modgps01ctphys , only : p_TC, p_knot
use modgps02wgs84grav , only : gpsgravitysrf
use modgps03diff
use modgps04profile , only : gpsprofile, gpsstruct1sw
use modgps08refop , only : gpsrefopv
use modgps09bend , only : gpsbndopv1
use IndexListDepot_mod, only : struct_index_list
implicit none
REAL*8 zLat, Lat, sLat
REAL*8 zLon, Lon
REAL*8 zAzm, Azm
INTEGER IAZM, ISAT
REAL*8 Rad, Geo, WFGPS
REAL*8, allocatable :: zPP(:)
REAL*8, allocatable :: zDP(:)
REAL*8, allocatable :: zTT(:)
REAL*8, allocatable :: zHU(:)
REAL*8, allocatable :: zUU(:)
REAL*8, allocatable :: zVV(:)
REAL*8 zMT,radw
REAL*8 ZMHXL
REAL*8 DX (ngpscvmx)
INTEGER IDATYP
INTEGER JL, JV, NGPSLEV, NWNDLEV, stat1, JJ
integer :: index_header, index_body, iProfile
type(struct_index_list), pointer :: local_current_list
LOGICAL ASSIM, LFIRST
INTEGER NH, NH1
TYPE(GPSPROFILE) :: PRF
REAL*8 , ALLOCATABLE :: H (:),AZMV(:)
TYPE(GPSDIFF), ALLOCATABLE :: RSTV(:),RSTVP(:),RSTVM(:)
!C WRITE(*,*)'ENTER oda_Hro'
!C
!C * 1. Initializations
!C * ---------------
!C
NGPSLEV=col_getNumLev(lcolumn,'TH')
NWNDLEV=col_getNumLev(lcolumn,'MM')
LFIRST=.FALSE.
if ( .NOT.allocated(vGPSRO_Jacobian) ) then
LFIRST = .TRUE.
allocate(zPP (NGPSLEV))
allocate(zDP (NGPSLEV))
allocate(zTT (NGPSLEV))
allocate(zHU (NGPSLEV))
allocate(zUU (NGPSLEV))
allocate(zVV (NGPSLEV))
allocate(vGPSRO_Jacobian(numGPSROProfiles,GPSRO_MAXPRFSIZE,2*NGPSLEV+1))
allocate(vGPSRO_lJac (numGPSROProfiles))
vGPSRO_lJac=.false.
allocate( H (GPSRO_MAXPRFSIZE) )
allocate( AZMV (GPSRO_MAXPRFSIZE) )
allocate( RSTV (GPSRO_MAXPRFSIZE) )
!C IF (LEVELGPSRO.EQ.1) THEN
!C allocate( RSTVP(GPSRO_MAXPRFSIZE) )
!C allocate( RSTVM(GPSRO_MAXPRFSIZE) )
!C ENDIF
endif
!C
!C Loop over all header indices of the 'RO' family (Radio Occultation)
!C
! Set the header list (start at the beginning of the list)
call obs_set_current_header_list(lobsSpaceData,'RO')
!##$omp parallel default(shared) &
!##$omp private(index_header,idatyp,assim,nh,local_current_list,index_body) &
!##$omp private(iProfile,irad,igeo,iazm,isat,rad,geo,zazm,zmt,wfgps,jj) &
!##$omp private(zlat,zlon,lat,lon,azm,slat) &
!##$omp private(stat1,jl,zpp,zdp,ztt,zhu,zuu,zvv,prf,dx) &
!##$omp private(h,azmv,rstv,rstvp,rstvm,nh1,zmhxl,jv)
nullify(local_current_list)
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)
DATYP: IF ( IDATYP .EQ. 169 ) THEN
!C
!C * Scan for requested data values of the profile, and count them
!C
ASSIM = .FALSE.
NH = 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, &
current_list=local_current_list)
BODY: do
index_body = obs_getBodyIndex(local_current_list)
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
ASSIMILATE: IF (ASSIM) THEN
iProfile=iProfile_from_index(INDEX_HEADER)
!C
!C * Profile at the observation location:
!C
if (.not.vGPSRO_lJac(iProfile)) then
!C
!C * Basic geometric variables of the profile:
!C
zLat = obs_headElem_r(lobsSpaceData,OBS_LAT,INDEX_HEADER)
zLon = obs_headElem_r(lobsSpaceData,OBS_LON,INDEX_HEADER)
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(lcolumng,NGPSLEV,INDEX_HEADER,'TH')/RG
WFGPS= 0.d0
DO JJ=1,NUMGPSSATS
IF (ISAT.EQ.IGPSSAT(JJ)) WFGPS=WGPS(JJ)
ENDDO
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_b
!C
zPP(JL) = col_getPressure(lcolumng,JL,INDEX_HEADER,'TH')
!C * True implementation of zDP (dP/dP0)
zDP(JL) = col_getPressureDeriv(lcolumng,JL,INDEX_HEADER,'TH')
zTT(JL) = col_getElem(lcolumng,JL,INDEX_HEADER,'TT') - p_TC
zHU(JL) = col_getElem(lcolumng,JL,INDEX_HEADER,'HU')
zUU(JL) = 0.d0
zVV(JL) = 0.d0
ENDDO
DO JL = 1, NWNDLEV
zUU(JL) = col_getElem(lcolumng,JL,INDEX_HEADER,'UU') * p_knot
zVV(JL) = col_getElem(lcolumng,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
call obs_set_current_body_list(lobsSpaceData, index_header, &
current_list=local_current_list)
BODY_2: do
INDEX_BODY = obs_getBodyIndex(local_current_list)
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
ENDIF
ENDDO BODY_2
!C
!C * Apply the observation operator:
!C
IF (LEVELGPSRO.EQ.1) THEN
CALL GPSBNDOPV1(H , AZMV, NH, PRF, RSTV)
!C CALL GPSBNDOPV1(H+WFGPS, AZMV, NH, PRF, RSTVP)
!C CALL GPSBNDOPV1(H-WFGPS, AZMV, NH, PRF, RSTVM)
!C do nh1 = 1, nh
!C RSTV(nh1)=(RSTVP(nh1)+RSTV(nh1)+RSTVM(nh1))/3.d0
!C enddo
ELSE
CALL GPSREFOPV (H, NH, PRF, RSTV)
ENDIF
DO NH1=1,NH
vGPSRO_Jacobian(iProfile,NH1,:)= RSTV(NH1)%DVAR(1:2*NGPSLEV+1)
ENDDO
vGPSRO_lJac(iProfile)=.true.
endif
!C
!C * Local vector state
!C
DO JL = 1, NGPSLEV
DX ( JL) = col_getElem(LCOLUMN,JL,index_header,'TT')
DX (NGPSLEV+JL) = col_getElem(LCOLUMN,JL,index_header,'HU')
ENDDO
DX (2*NGPSLEV+1) = col_getElem(LCOLUMN,1 ,index_header,'P0')
!C
!C * Perform the (H(xb)DX-Y') operation
!C * Loop over all body indices for this index_header:
!C
NH1 = 0
call obs_set_current_body_list(lobsSpaceData, index_header, &
current_list=local_current_list)
BODY_3: do
INDEX_BODY = obs_getBodyIndex(local_current_list)
if (INDEX_BODY < 0) exit BODY_3
IF ( obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY).EQ.1 ) THEN
NH1 = NH1 + 1
!C
!C * Evaluate H(xb)DX
!C
ZMHXL = 0.d0
DO JV = 1, 2*NGPSLEV+1
ZMHXL = ZMHXL + vGPSRO_Jacobian(iProfile,NH1,JV) * DX(JV)
ENDDO
!C
!C * Store in CMA
!C
call obs_bodySet_r(lobsSpaceData,OBS_WORK,INDEX_BODY, ZMHXL)
ENDIF
ENDDO BODY_3
ENDIF ASSIMILATE
ENDIF DATYP
ENDDO HEADER
!##$omp end parallel
IF (LFIRST) THEN
!C IF (LEVELGPSRO.EQ.1) THEN
!C deallocate( RSTVM )
!C deallocate( RSTVP )
!C ENDIF
deallocate( RSTV )
deallocate( AZMV )
deallocate( H )
deallocate(zVV)
deallocate(zUU)
deallocate(zHU)
deallocate(zTT)
deallocate(zDP)
deallocate(zPP)
ENDIF
!C WRITE(*,*)'EXIT oda_Hro'
RETURN
END subroutine oda_Hro
SUBROUTINE oda_Hzp 1,20
!*
!* Purpose: Compute simulated profiler observations from profiled model
!* increments.
!* It returns Hdx in OBS_WORK
!* Interpolate vertically the contents of commvo to heights
!* (in meters) of the observations.
!* A linear interpolation in z is performed.
!*
!*Author : J. St-James, CMDA/SMC July 2003
implicit none
INTEGER IPB,IPT
INTEGER INDEX_HEADER,IK
INTEGER J,INDEX_BODY,ITYP
REAL*8 ZVAR,ZDA1,ZDA2
REAL*8 ZWB,ZWT, ZLTV,ZTVG,ZPPOST
REAL*8 ZLEV,ZPT,ZPB,ZLAT,ZLON,ZTORAD,ZDENO
LOGICAL LLOK, LLPRINT, LLUV
character(len=2) :: varType
call obs_set_current_body_list(lobsSpaceData, 'PR')
BODY: do
index_body = obs_getBodyIndex(lobsSpaceData)
if (index_body < 0) exit BODY
IF ( (obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY) .EQ. 1) &
.AND. (obs_bodyElem_i(lobsSpaceData,OBS_XTR,INDEX_BODY) .EQ. 0) &
.AND. (obs_bodyElem_i(lobsSpaceData,OBS_VCO,INDEX_BODY) .EQ. 1) ) THEN
INDEX_HEADER = obs_bodyElem_i(lobsSpaceData,OBS_HIND,INDEX_BODY)
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)
IK = obs_bodyElem_i(lobsSpaceData,OBS_LYR,INDEX_BODY)
ITYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY)
varType = vnl_varTypeFromVarnum(ityp)
IPT = IK + col_getOffsetFromVarno(lcolumng,ityp)
IPB = IPT+1
ZPT = col_getHeight(lcolumng,IK ,INDEX_HEADER,varType)/RG
ZPB = col_getHeight(lcolumng,IK+1,INDEX_HEADER,varType)/RG
ZDENO= ZPT-ZPB
ZWB = (ZPT-ZLEV)/ZDENO
ZWT = 1.0D0 - ZWB
ZDA1= (ZLEV-ZPB)/(ZDENO**2)
ZDA2= (ZPT-ZLEV)/(ZDENO**2)
if(ITYP.eq.BUFR_NEES) then
write(*,*) 'ABORTING IN ODA_HZP: CANNOT ASSIMILATE ES!!!',ityp,obs_getfamily(lobsSpaceData,index_header),index_header,index_body
call abort3d('Aborting in oda_H')
endif
call obs_bodySet_r(lobsSpaceData,OBS_WORK,INDEX_BODY, &
ZWB*col_getElem(LCOLUMN,IPB,INDEX_HEADER) + ZWT*col_getElem(LCOLUMN,IPT,INDEX_HEADER) + &
(col_getElem(lcolumng,IPB,INDEX_HEADER) - col_getElem(lcolumng,IPT,INDEX_HEADER))* &
(ZDA1*col_getHeight(LCOLUMN,IK,INDEX_HEADER,varType)/RG + ZDA2*col_getHeight(LCOLUMN,IK+1,INDEX_HEADER,varType)/RG))
ENDIF
ENDDO BODY
RETURN
END subroutine oda_Hzp
SUBROUTINE oda_Hgp 1,60
!*
!***s/r -oda_Hgp TL of DOBSGPSGB (Jo for GB-GPS ZTD observations)
!*
!*
!*Author : S. Macpherson *ARMA October 2012
!* -------------------
!** Purpose: Compute H'dx for all GPS ZTD observations
!*
use modgps00base , only : ngpscvmx
use modgps01ctphys , only : p_TC
use modgps03diff , only : gpsdiff
use modgps04profilezd , only : gpsprofilezd, gpsstructztd, gpsdpress
use modgps08ztdop , only : gpsZTDopv, gpsPW
implicit none
REAL*8 ZLAT, Lat
REAL*8 ZLON, Lon
REAL*8, allocatable :: ZTTB(:)
REAL*8, allocatable :: ZHUB(:)
REAL*8, allocatable :: ZPPB(:)
REAL*8, allocatable :: ZDP(:)
REAL*8 ZP0B, ZPSMOD, ZPWMOD, ZPWMOD2, dZTD
REAL*8 ZMT
real*8 sfcfield
REAL*8 ZHX, ZLEV, ZDZMIN
REAL*8 JAC(ngpscvmx)
REAL*8 DX (ngpscvmx)
INTEGER INDEX_HEADER, INDEX_BODY
INTEGER JL, NFLEV, status, iztd, icount, NFLEV2, stat, iversion
LOGICAL ASSIM, LSTAG
CHARACTER*2 varType
real*8, dimension(:), pointer :: dpdp0 => null()
TYPE(gpsprofilezd) :: PRF, PRF2
TYPE(gpsdiff) :: ZTDOPV, ZTDOPV2
! WRITE(*,*)'ENTER oda_Hgp'
stat = vgd_get(vco_anl%vgrid,key='ig_1 - vertical coord code',value=iversion)
if (iversion .ne. 5001) then
LSTAG = .TRUE.
varType = 'TH'
else
LSTAG = .FALSE.
varType = 'TH'
endif
ZDZMIN = DZMIN ! from modgpsztd_mod
NFLEV = col_getNumLev(lcolumng,'TH')
NFLEV2 = col_getNumLev(lcolumn,'TH')
!C
!C * 1. Initializations
!C * ---------------
!C
! NOTE: vGPSZTD_Index(numGPSZTD) is initialized in s/r dobsgpsgb
!
if (.not.allocated(vGPSZTD_Index)) then
call abort3d('oda_Hgp: ERROR: vGPSZTD_Index not allocated!')
elseif (.not.allocated(vGPSZTD_Jacobian)) then
write(*,*) ' Allocate vGPSZTD_Jacobian(numGPSZTD,2*NFLEV+1)'
allocate(vGPSZTD_Jacobian(numGPSZTD,2*NFLEV+1))
allocate(vGPSZTD_lJac(numGPSZTD))
vGPSZTD_lJac = .false.
vGPSZTD_Jacobian = 0.0d0
endif
! If first time (iteration), store the Jacobians for all ZTD data to be assimilated
!-----------------------------------------------------------------------------------------
INIT: IF ( .not.vGPSZTD_lJac(1) ) THEN
allocate(ZTTB(NFLEV))
allocate(ZHUB(NFLEV))
allocate(ZPPB(NFLEV))
allocate(ZDP(NFLEV))
write(*,*) 'oda_Hgp: Storing Jacobians for GPS ZTD data ...'
write(*,*) ' INFO: Analysis grid iversion = ', iversion
write(*,*) ' LSTAG = ', LSTAG
write(*,*) ' col_getNumLev(lcolumng,TH) = ', NFLEV
write(*,*) ' col_getNumLev(lcolumn,TH) = ', NFLEV2
write(*,*) ' numGPSZTD = ', numGPSZTD
if ( NFLEV .ne. NFLEV2 ) call abort3d('oda_Hgp: ERROR: NFLEV .ne. NFLEV2!')
icount = 0
! loop over all header indices of the 'GP' family (GPS observations)
call obs_set_current_header_list(lobsSpaceData,'GP')
HEADER_0: do
index_header = obs_getHeaderIndex(lobsSpaceData)
if (index_header < 0) exit HEADER_0
!C
!C * Scan for ZTD assimilation at this location
!C
ASSIM = .FALSE.
! loop over all body indices for this index_header
call obs_set_current_body_list(lobsSpaceData, index_header)
BODY_0: DO
index_body = obs_getBodyIndex(lobsSpaceData)
if (index_body < 0) exit BODY_0
if ( (obs_headElem_i(lobsSpaceData,OBS_ITY,INDEX_HEADER) .eq. 189) &
.and. (obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY) .EQ. BUFR_NEZD) &
.and. (obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY) .EQ. 1) ) then
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)
ASSIM = .TRUE.
endif
ENDDO BODY_0
IF ( ASSIM ) THEN
!C
!C * LR background profile at the observation location x :
!C
icount = icount + 1
Lat = obs_headElem_r(lobsSpaceData,OBS_LAT,INDEX_HEADER)
ZLAT = Lat * MPC_DEGREES_PER_RADIAN_R8
Lon = obs_headElem_r(lobsSpaceData,OBS_LON,INDEX_HEADER)
ZLON = Lon * MPC_DEGREES_PER_RADIAN_R8
ZP0B = col_getElem(lcolumng,1,INDEX_HEADER,'P0')
DO JL = 1, NFLEV
ZTTB(JL) = col_getElem(lcolumng,JL,INDEX_HEADER,'TT') - p_TC
ZHUB(JL) = col_getElem(lcolumng,JL,INDEX_HEADER,'HU')
ZPPB(JL) = col_getPressure(lcolumng,JL,INDEX_HEADER,varType)
!C Get ZDP = dP/dP0
ZDP(JL) = col_getPressureDeriv(lcolumng,JL,INDEX_HEADER,varType)
ENDDO
if ( ZPPB(NFLEV) .ne. ZP0B ) then
write(*,*) ' oda_Hgp: ERROR: ZPPB(NFLEV) .ne. ZP0B'
write(*,*) ' ZPPB(NFLEV), ZP0B =', ZPPB(NFLEV), ZP0B
call abort3d('oda_Hgp:ABORT')
endif
ZMT = col_getHeight(lcolumng,NFLEV,INDEX_HEADER,'TH')/RG
if ( icount .eq. 1 .and. LTESTOP ) write(*,*) 'ZDP (dpdp0) = ', (ZDP(JL),JL= 1,NFLEV)
!c
CALL gpsstructztd(NFLEV,Lat,Lon,ZMT,ZPPB,ZDP,ZTTB,ZHUB,LBEVIS,IREFOPT,PRF)
CALL gpsZTDopv(ZLEV,PRF,LBEVIS,ZDZMIN,ZTDopv,ZPSMOD,IZTDOP)
!C Observation Jacobian H'(xb)
JAC = ZTDopv%DVar
iztd = i_from_index(INDEX_HEADER)
DO JL = 1, 2*NFLEV+1
vGPSZTD_Jacobian(iztd,JL) = JAC(JL)
ENDDO
vGPSZTD_lJac(iztd) = .true.
!
if ( icount .le. 3 .and. LTESTOP ) then
write(*,*) '--------------------------------------------------------- '
write(*,*) iztd, obs_elem_c(lobsSpaceData,'STID',INDEX_HEADER),'ZTDopv (m) = ', ZTDopv%Var
CALL gpsPW(PRF,ZPWMOD)
! sfc pressure dx
ZPPB(NFLEV) = ZPPB(NFLEV) + 50.0d0
nullify(dpdp0)
sfcfield = ZP0B + 50.0d0
status = vgd_dpidpis(vco_anl%vgrid,vco_anl%ip1_T,dpdp0,sfcfield)
ZDP = dpdp0(1:NFLEV)
CALL gpsstructztd(NFLEV,Lat,Lon,ZMT,ZPPB,ZDP,ZTTB,ZHUB,LBEVIS,IREFOPT,PRF2)
CALL gpsZTDopv(ZLEV,PRF2,LBEVIS,ZDZMIN,ZTDopv2,ZPSMOD,IZTDOP)
write(*,*) ' ZTD Operator Test: dP0 = +50 Pa'
write(*,*) ' dZTD NL = ', ZTDopv2%Var - ZTDopv%Var
write(*,*) ' dZTD Linear = ', vGPSZTD_Jacobian(iztd,2*NFLEV+1)*50.0d0
write(*,*) ' '
ZPPB(NFLEV) = ZPPB(NFLEV) - 50.0d0
! log(q) dx
ZHUB(64) = ZHUB(64) - 0.44D-01
ZHUB(65) = ZHUB(65) - 0.44D-01
ZHUB(66) = ZHUB(66) - 0.44D-01
CALL gpsstructztd(NFLEV,Lat,Lon,ZMT,ZPPB,ZDP,ZTTB,ZHUB,LBEVIS,IREFOPT,PRF2)
CALL gpsZTDopv(ZLEV,PRF2,LBEVIS,ZDZMIN,ZTDopv2,ZPSMOD,IZTDOP)
CALL gpsPW(PRF2,ZPWMOD2)
write(*,*) ' ZTD Operator Test: dLQ = -0.44E-01 JL = 64,65,66'
write(*,*) ' dPW (mm) = ', ZPWMOD2 - ZPWMOD
write(*,*) ' dZTD NL = ', ZTDopv2%Var - ZTDopv%Var
dZTD = vGPSZTD_Jacobian(iztd,64+NFLEV)*(-0.44D-01) + vGPSZTD_Jacobian(iztd,65+NFLEV)*(-0.44D-01) + &
vGPSZTD_Jacobian(iztd,66+NFLEV)*(-0.44D-01)
write(*,*) ' dZTD Linear = ', dZTD
write(*,*) ' '
ZHUB(64) = ZHUB(64) + 0.44D-01
ZHUB(65) = ZHUB(65) + 0.44D-01
ZHUB(66) = ZHUB(66) + 0.44D-01
! temperature dx
ZTTB(64) = ZTTB(64) + 2.0d0
ZTTB(65) = ZTTB(65) + 2.0d0
ZTTB(66) = ZTTB(66) + 2.0d0
CALL gpsstructztd(NFLEV,Lat,Lon,ZMT,ZPPB,ZDP,ZTTB,ZHUB,LBEVIS,IREFOPT,PRF2)
CALL gpsZTDopv(ZLEV,PRF2,LBEVIS,ZDZMIN,ZTDopv2,ZPSMOD,IZTDOP)
write(*,*) ' ZTD Operator Test: dTT = +2.0K JL = 64,65,66'
write(*,*) ' dZTD NL = ', ZTDopv2%Var - ZTDopv%Var
dZTD = vGPSZTD_Jacobian(iztd,64)*2.0d0 + vGPSZTD_Jacobian(iztd,65)*2.0d0 + &
vGPSZTD_Jacobian(iztd,66)*2.0d0
write(*,*) ' dZTD Linear = ', dZTD
write(*,*) '--------------------------------------------------------- '
endif
ENDIF
ENDDO HEADER_0
deallocate(ZTTB)
deallocate(ZHUB)
deallocate(ZPPB)
deallocate(ZDP)
write(*,*) 'oda_Hgp: Number of ZTD data (icount) = ', icount
write(*,*) ' Expected number (numGPSZTD) = ', numGPSZTD
write(*,*) ' Last iztd = ', iztd
write(*,*) ' vGPSZTD_Index(1) = ', vGPSZTD_Index(1)
write(*,*) ' vGPSZTD_Index(iztd) = ', vGPSZTD_Index(iztd)
if ( icount .ne. numGPSZTD ) then
call abort3d('oda_Hgp: ERROR: icount .ne. numGPSZTD!')
endif
if ( icount .ne. iztd ) then
call abort3d('oda_Hgp: ERROR: icount .ne. iztd!')
endif
if ( numGPSZTD .ne. iztd ) then
call abort3d('oda_Hgp: ERROR: numGPSZTD .ne. iztd!')
endif
ENDIF INIT
!-----------------------------------------------------------------------------------------
icount = 0
! loop over all header indices of the 'GP' family (GPS observations)
call obs_set_current_header_list(lobsSpaceData,'GP')
HEADER: do
index_header = obs_getHeaderIndex(lobsSpaceData)
if (index_header < 0) exit HEADER
!C
!C * Scan for ZTD assimilation at this location
!C
ASSIM = .FALSE.
! 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
if ( (obs_headElem_i(lobsSpaceData,OBS_ITY,INDEX_HEADER) .eq. 189) &
.and. (obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY) .EQ. BUFR_NEZD) &
.and. (obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY) .EQ. 1) ) then
ASSIM = .TRUE.
ENDIF
ENDDO BODY
!C
!C * If ZTD assimilation, apply the TL observation operator
!C
IF ( ASSIM ) THEN
iztd = i_from_index(INDEX_HEADER)
if ( iztd < 1 .or. iztd > numGPSZTD ) then
call abort3d('oda_Hgp: ERROR: index from i_from_index() is out of range!')
endif
!C
!C * Local vector state (analysis increments)
!C
DO JL = 1, NFLEV
DX (JL) = col_getElem(LCOLUMN,JL,index_header,'TT')
DX (NFLEV+JL) = col_getElem(LCOLUMN,JL,index_header,'HU')
ENDDO
DX (2*NFLEV+1) = col_getElem(LCOLUMN,1 ,index_header,'P0')
!C * Evaluate H'(xb)*dX
!C
ZHX = 0.D0
DO JL = 1, 2*NFLEV+1
ZHX = ZHX + vGPSZTD_Jacobian(iztd,JL)*DX(JL)
ENDDO
!C
!C * Store ZHX = H'dx in OBS_WORK
!C
! loop over all body indices for this index_header
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_headElem_i(lobsSpaceData,OBS_ITY,INDEX_HEADER) .eq. 189) &
.and. (obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY) .EQ. BUFR_NEZD) &
.and. (obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY) .EQ. 1) ) then
call obs_bodySet_r(lobsSpaceData,OBS_WORK,INDEX_BODY, ZHX)
icount = icount + 1
if ( icount .le. 3 .and. LTESTOP ) then
write(*,*) iztd, obs_elem_c(lobsSpaceData,'STID',INDEX_HEADER)
write(*,*) 'JAC(ncv) = ', (vGPSZTD_Jacobian(iztd,JL),JL=1,2*NFLEV+1)
write(*,*) 'DTT(JL) = ', (DX(JL),JL=1,NFLEV)
write(*,*) 'DHU(JL) = ', (DX(JL),JL=NFLEV+1,2*NFLEV)
write(*,*) 'DP0(JL) = ', DX(2*NFLEV+1)
write(*,*) 'ZHX (mm) = ', ZHX*1000.D0
endif
ENDIF
ENDDO BODY_2
ENDIF ! ASSIM
ENDDO HEADER
! WRITE(*,*) 'oda_Hgp: Number of ZTD data locations with obs_bodySet_r(OBS_OMA) = ', icount
! WRITE(*,*)'EXIT oda_Hgp'
RETURN
END subroutine oda_Hgp
end subroutine oda_H