!-------------------------------------- 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_HT(lcolumn,lcolumng,lobsSpaceData) 1,14
use mpivar_mod
use EarthConstants_mod
use MathPhysConstants_mod
use obsSpaceData_mod
use columnData_mod
use bufr
use modgpsztd_mod
implicit none
!
!Purpose:
!Call the several adjoint of observation operators
!
!Author : S. Pellerin *ARMA/MRB January 2009
!
!Revision:
! S. Macpherson ARMA 21 Dec 2012
! - update from Rev189 to Rev213
! - use new ZTD-specific GPS modules modgps04profilezd, modgps08ztdop
! S. Macpherson ARMA 14 Jan 2013
! - use numGPSZTD (from modgpsztd_mod) to determine if call oda_HTgp needed
! - modified oda_HTgp
! - merged with latest version (oda_HTro) from Josep (Rev.213M)
! - like oda_HTro, use OpenMP and Jacobian storage for GPS ZTD
!
type(struct_columnData) :: lcolumn,lcolumng
type(struct_obs) :: lobsSpaceData
type(struct_vco), pointer :: vco_anl
IF(mpi_myid == 0) THEN
write(*,*)'ODA_HT- Adjoint of linearized observation operators'
endif
vco_anl => col_getVco(lcolumng)
call tmg_start(47,'OBS_GPSGB_TLAD') !
if (numGPSZTD > 0) call oda_HTgp
call tmg_stop (47) !
call tmg_start(46,'OBS_ZZZ_TLAD') !
call oda_HTzp
call tmg_stop (46)
call tmg_start(45,'OBS_GPSRO_TLAD') !
call oda_HTro
call tmg_stop (45) ! !
call tmg_start(44,'OBS_TOV_TLAD') !
call oda_HTto
call tmg_stop (44) !
call tmg_start(43,'OBS_SFC_TLAD')
call oda_HTsf
call tmg_stop (43) !
call tmg_start(42,'OBS_PPP_TLAD') !
call oda_HTpp
call tmg_stop (42)
CONTAINS
SUBROUTINE oda_HTpp 1,46
!
!**s/r - Adjoint of the "vertical" interpolation
! for "UPPER AIR" data files.
!
!
!
!Author : P. Koclas *CMC/AES April 1996
!
! Purpose: based on vint3d to build the adjoint of the
! vertical interpolation for UPPER-AIR data files.
!
implicit none
INTEGER IPB,IPT,ITYP
REAL*8 ZRES
REAL*8 ZWB,ZWT,zcon,zexp,zgamma,ZATV,ZTVG
REAL*8 ZLEV,ZPT,ZPB,ZDADPS,ZPRESBPB,ZPRESBPT
INTEGER INDEX_HEADER,IK,nlev_T
INTEGER INDEX_BODY,INDEX_FAMILY
REAL*8 columngVarT,columngVarB,lqtoes
real*8, pointer :: all_column(:),tt_column(:),hu_column(:),ps_column(:)
REAL*8 :: dPdPsT,dPdPsB
logical :: llassim
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)
! Process all data within the domain of the model
IF (llassim) THEN
index_header = obs_bodyElem_i(lobsSpaceData,OBS_HIND,INDEX_BODY)
ZRES = -obs_bodyElem_r(lobsSpaceData,OBS_WORK,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
all_column => col_getColumn(lcolumn,INDEX_HEADER)
tt_column => col_getColumn(lcolumn,INDEX_HEADER,'TT')
hu_column => col_getColumn(lcolumn,INDEX_HEADER,'HU')
ps_column => col_getColumn(lcolumn,INDEX_HEADER,'P0')
if(ITYP.eq.BUFR_NEES) then
call lqtoes_ad(hu_column(IK+1), &
tt_column(IK+1), &
ps_column(1), &
ZWB*ZRES, &
col_getElem(lcolumng,IK+1,INDEX_HEADER,'HU'), &
col_getPressure(lcolumng,IK+1,INDEX_HEADER,'TH'), &
dPdPsB)
call lqtoes_ad(hu_column(IK ), &
tt_column(IK ), &
ps_column(1), &
ZWT*ZRES, &
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
all_column(IPB) = all_column(IPB) + ZWB*ZRES
all_column(IPT) = all_column(IPT) + ZWT*ZRES
columngVarB=col_getElem(lcolumng,IPB,INDEX_HEADER)
columngVarT=col_getElem(lcolumng,IPT,INDEX_HEADER)
endif
ps_column(1) = ps_column(1) + &
(columngVarB - columngVarT) &
*ZDADPS*ZRES
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)
ZRES = -obs_bodyElem_r(lobsSpaceData,OBS_WORK,INDEX_BODY)
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)
nlev_T = col_getNumLev(lcolumn,'TH')
IPT = nlev_T - 1 + col_getOffsetFromVarno(lcolumng,ityp)
IPB = IPT+1
!
! adjoint of TL of geopotential extrapolation below orography
!
zcon = (zlev/col_getElem(lcolumng,1,index_header,'P0'))**zexp
ZATV = ((1.0d0 - ZCON)/ZGAMMA)*ZRES
ZTVG = lcolumng%OLTV(1,nlev_T,INDEX_HEADER)*col_getElem(lcolumng,nlev_T,INDEX_HEADER,'TT')
ps_column(1) = ps_column(1) &
+ MPC_RGAS_DRY_AIR_R8*ZTVG*zcon*zres &
/ col_getElem(lcolumng,1,index_header,'P0')
tt_column(nlev_T) = tt_column(nlev_T) &
+ lcolumng%OLTV(1,nlev_T,INDEX_HEADER)*ZATV
hu_column(nlev_T) = hu_column(nlev_T) &
+ lcolumng%OLTV(2,nlev_T,INDEX_HEADER)*ZATV
endif
enddo BODY
enddo FAMILY
end subroutine oda_HTpp
SUBROUTINE oda_HTsf 1,39
!*
!***s/r AOBSSFC - Adjoint of the "vertical" interpolation
!* for "SURFACE" data files.
!*
!*Author : P. Koclas *CMC/AES April 1996
!* -------------------
!*
!* Purpose: based on surfc1dz to build the adjoint of the
!* vertical interpolation for SURFACE data files.
!*
implicit none
INTEGER IPB,IPT
REAL*8 ZRES
REAL*8 ZWB,ZWT,zcon,zexp,zexpgz,zgamma,ZATV,ZTVG
REAL*8 ZLEV,ZPT,ZPB,ZDADPS,ZDELPS,ZDELTV,ZGAMAZ,ZHHH
INTEGER INDEX_HEADER,IK,nlev
INTEGER INDEX_BODY,ITYP,INDEX_FAMILY
real*8, pointer :: all_column(:),tt_column(:),hu_column(:),ps_column(:)
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* 1. Fill in COMMVO by using the adjoint of the "vertical" interpolation
!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)
all_column => col_getColumn(lcolumn,INDEX_HEADER)
tt_column => col_getColumn(lcolumn,INDEX_HEADER,'TT')
hu_column => col_getColumn(lcolumn,INDEX_HEADER,'HU')
ps_column => col_getColumn(lcolumn,INDEX_HEADER,'P0')
ITYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,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
ZRES = -obs_bodyElem_r(lobsSpaceData,OBS_WORK,INDEX_BODY)
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')
call lqtoes_ad(hu_column(nlev), &
tt_column(nlev), &
ps_column(1), &
ZRES, &
col_getElem(lcolumng,nlev,INDEX_HEADER,'HU'), &
col_getPressure(lcolumng,nlev,INDEX_HEADER,'TH'), &
dPdPsfc)
else
all_column(IPB) = all_column(IPB) + ZRES
endif
ELSEIF (ITYP.EQ.BUFR_NEPS .OR. ITYP.EQ.BUFR_NEPN) THEN
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)
ZDELTV= (col_getElem(lcolumng,1,INDEX_HEADER,'P0')*ZEXP*ZCON**(ZEXP-1)) &
*(ZGAMAZ/(ZTVG*ZTVG))
ZDELPS= ZCON**ZEXP
ZATV = ZDELTV*ZRES
ps_column(1) = ps_column(1) + ZDELPS*ZRES
tt_column(nlev) = tt_column(nlev) &
+ lcolumng%OLTV(1,nlev,INDEX_HEADER)*ZATV
hu_column(nlev)= hu_column(nlev) &
+ lcolumng%OLTV(2,nlev,INDEX_HEADER)*ZATV
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
!ccc ATTN ATTN ZDADPS EST A DEFINIR POUR UNE COORDONNEE Z
ZDADPS= 0.d0
all_column(IPB) = all_column(IPB) + ZWB*ZRES
all_column(IPT) = all_column(IPT) + ZWT*ZRES
ps_column(1) = ps_column(1) + &
(col_getElem(lcolumng,IPB,INDEX_HEADER) - col_getElem(lcolumng,IPT,INDEX_HEADER)) &
*ZDADPS*ZRES
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)
ZRES = -obs_bodyElem_r(lobsSpaceData,OBS_WORK,INDEX_BODY)
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)
!C
!c adjoint of TL of geopotential extrapolation below orography
!c
zcon = (zlev/col_getElem(lcolumng,1,index_header,'P0'))**zexpgz
ZATV = ((1.0d0 - ZCON)/ZGAMMA)*ZRES
ZTVG = lcolumng%OLTV(1,nlev,INDEX_HEADER)*col_getElem(lcolumng,nlev,INDEX_HEADER,'TT')
ps_column(1) = ps_column(1) &
+ MPC_RGAS_DRY_AIR_R8*ZTVG*zcon*zres &
/ col_getElem(lcolumng,1,index_header,'P0')
tt_column(nlev) = tt_column(nlev) &
+ lcolumng%OLTV(1,nlev,INDEX_HEADER)*ZATV
hu_column(nlev) = hu_column(nlev) &
+ lcolumng%OLTV(2,nlev,INDEX_HEADER)*ZATV
endif
ENDDO BODY
ENDDO FAMILY
RETURN
END subroutine oda_HTsf
subroutine oda_HTto 1,3
!
!**s/r tovs_obs_ad - Adjoint of computation of residuals to the tovs observations
!
!
!author : j. halle *cmda/aes april 19, 2005
!
!revision 001 :
! S. Pellerin - ARMA, jan. 2009
! - call to oda_get_radiance_ad
!
! -------------------
! purpose:
!
implicit none
! 1. Getting the adjoint of the residuals
! . ----------------------------------
!
call oda_get_radiance_ad(lobsSpaceData)
! 2. Adjoint of computing radiance
! . -----------------------------
!
call tovs_rttov_ad(lobsSpaceData)
! 3. Adjoint of preparation of atmospheric profiles
! . ----------------------------------------------
!
call tovs_fill_profiles_ad(lcolumn,lcolumng)
end subroutine oda_HTto
SUBROUTINE oda_HTro 1,24
!*
!* Purpose: Compute the adjoint 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
use modgps03diff , only : gpsdiff
use modgpsro_mod
use IndexListDepot_mod, only : struct_index_list
implicit none
REAL*8 DPJO0(ngpscvmx)
REAL*8 DPJO1(ngpscvmx)
REAL*8 zLat, Lat
REAL*8 zAzm, Azm
INTEGER IAZM, ISAT
REAL*8 Rad, Geo, HNH1
REAL*8 zP0, zMT
REAL*8 ZINC, ZOER
real*8, pointer :: tt_column(:),hu_column(:),ps_column(:)
INTEGER IDATYP
INTEGER JL, NGPSLEV
integer :: index_header, index_body, iProfile
type(struct_index_list), pointer :: local_current_list
LOGICAL ASSIM, LUSE
INTEGER NH, NH1
!C WRITE(*,*)'ENTER oda_HTro'
!C
!C * 1. Initializations
!C * ---------------
!C
NGPSLEV=col_getNumLev(lcolumn,'TH')
!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,dpjo0,idatyp,assim,nh,local_current_list,index_body,luse) &
!##$omp private(iProfile,zlat,irad,igeo,iazm,isat,rad,geo,zazm,zmt,lat) &
!##$omp private(nh1,zinc,zoer,dpjo1) &
!##$omp private(tt_column,hu_column,ps_column)
nullify(local_current_list)
HEADER: do
INDEX_HEADER = obs_getHeaderIndex(lobsSpaceData)
if (INDEX_HEADER < 0) exit HEADER
DPJO0 = 0.d0
!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
LUSE=( obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY).EQ.1 )
IF ( LUSE ) 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 * Basic geometric variables of the profile:
!C
zLat = obs_headElem_r(lobsSpaceData,OBS_LAT,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
Lat = zLat * MPC_DEGREES_PER_RADIAN_R8
!C
!C * Perform the (H(xb)DX-Y')/S operation
!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, &
current_list=local_current_list)
BODY_3: do
index_body = obs_getBodyIndex(local_current_list)
if (index_body < 0) exit BODY_3
LUSE=( obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY).EQ.1 )
IF ( LUSE ) THEN
NH1 = NH1 + 1
!C
!C * Normalized increment
!C
ZINC = -obs_bodyElem_r(lobsSpaceData,OBS_WORK,INDEX_BODY)
! ZOER = obs_bodyElem_r(lobsSpaceData,OBS_OER,INDEX_BODY)
!C
!C * O-F Tested criteria:
!C
DPJO1(1:2*NGPSLEV+1) = ZINC * vGPSRO_Jacobian(iProfile,NH1,:)
!C
!C * Accumulate the gradient of the observation cost function:
!C
DPJO0(1:2*NGPSLEV+1) = DPJO0(1:2*NGPSLEV+1) + DPJO1(1:2*NGPSLEV+1)
ENDIF
ENDDO BODY_3
ENDIF ASSIMILATE
ENDIF DATYP
!C
!C * Store H* (HX - Z)/SIGMA in COMMVO
!C
tt_column => col_getColumn(lcolumn,index_header,'TT')
hu_column => col_getColumn(lcolumn,index_header,'HU')
ps_column => col_getColumn(lcolumn,index_header,'P0')
DO JL = 1, NGPSLEV
tt_column(JL) = DPJO0(JL)
hu_column(JL) = DPJO0(JL+NGPSLEV)
ENDDO
ps_column(1) = DPJO0(1+2*NGPSLEV)
ENDDO HEADER
!##$omp end parallel
!C WRITE(*,*)'EXIT oda_HTro'
RETURN
END subroutine oda_HTro
SUBROUTINE oda_HTzp 1,19
!*
!***s/r AOBSZZZ - Adjoint of the "vertical" interpolation in z
!* for profiler data.
!*
!*Author : J. St-James *CMDA/SMC July 2003
!*Revision :
!* -------------------
!*
!* Purpose: based on vint3d to build the adjoint of the
!* vertical interpolation for profiler data.
!*
implicit none
INTEGER IPB,IPT
REAL*8 ZRES,ZDA1,ZDA2,ZDENO
REAL*8 ZWB,ZWT
REAL*8 ZLEV,ZPT,ZPB
INTEGER INDEX_HEADER,IK,ITYP
INTEGER INDEX_BODY
real*8, pointer :: gz_column(:),all_column(:)
character(len=2) :: varType
!C
!C Process all data within the domain of the model
!C
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)
ITYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY)
varType = vnl_varTypeFromVarnum(ityp)
gz_column => col_getColumn(lcolumn,INDEX_HEADER,'GZ',varType)
all_column => col_getColumn(lcolumn,INDEX_HEADER)
ZRES = -obs_bodyElem_r(lobsSpaceData,OBS_WORK,INDEX_BODY)
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)
IK = obs_bodyElem_i(lobsSpaceData,OBS_LYR,INDEX_BODY)
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)
!C
gz_column(IK+1) = gz_column(IK+1) + &
(col_getElem(lcolumng,IPB,INDEX_HEADER)-col_getElem(lcolumng,IPT,INDEX_HEADER))*ZDA2*ZRES/RG
gz_column(IK) = gz_column(IK) + &
(col_getElem(lcolumng,IPB,INDEX_HEADER)-col_getElem(lcolumng,IPT,INDEX_HEADER))*ZDA1*ZRES/RG
all_column(IPB) = all_column(IPB) + ZWB*ZRES
all_column(IPT) = all_column(IPT) + ZWT*ZRES
ENDIF
ENDDO BODY
RETURN
END subroutine oda_HTzp
SUBROUTINE oda_HTgp 1,21
!*
!***s/r -oda_HTgp Adjoint of TL routine oda_Hgp
!*
!*
!*Author : S. Macpherson *ARMA October 2012
!
!*Revisions:
!
! S. Macpherson ARMA 14 Jan 2013
! - like oda_HTro, use OpenMP and Jacobian storage to speed up
!* -------------------
!** Purpose: Compute Ht*grad(Jo) for all GPS ZTD observations
!
! NOTE: ZTD Jacobians are computed and stored in oda_Hgp (first iter.)
!
!*
use modgps00base , only : ngpscvmx
use modgpsztd_mod
implicit none
REAL*8 DPJO0(ngpscvmx)
REAL*8 JAC(ngpscvmx)
!
REAL*8 ZINC
INTEGER JL, NFLEV, iztd
integer :: index_header, index_body, icount
LOGICAL ASSIM
real*8, pointer :: tt_column(:),hu_column(:),ps_column(:)
! WRITE(*,*)'ENTER oda_HTgp'
NFLEV = col_getNumLev(lcolumng,'TH')
IF ( .not.vGPSZTD_lJac(1) ) THEN
call abort3d('oda_HTgp:ERROR: ZTD Jacobians not stored!')
ENDIF
! loop over all header indices of the 'GP' family (GPS observations)
! Set the header list & start at the beginning of the list
call obs_set_current_header_list(lobsSpaceData,'GP')
icount = 0
HEADER: do
index_header = obs_getHeaderIndex(lobsSpaceData)
if (index_header < 0) exit HEADER
DPJO0(:) = 0.0D0
JAC(:) = 0.0D0
!C
!C Scan for requested ZTD assimilation
!C
ASSIM = .FALSE.
! loop over all body indices (still in the 'GP' family)
! Set the body list & start at the beginning of the list)
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
IF (ASSIM) THEN
icount = icount + 1
iztd = i_from_index(INDEX_HEADER)
if ( iztd < 1 .or. iztd > numGPSZTD ) then
call abort3d('oda_HTgp: ERROR: index from i_from_index() is out of range!')
endif
DO JL = 1, 2*NFLEV+1
JAC(JL) = vGPSZTD_Jacobian(iztd,JL)
ENDDO
!C
!C Get Ht*grad(Index_header) = Ht*(H'dx - d)/sigma_o^2
!C
! loop over all body indices (still in the 'GP' family)
! Start at the beginning of the list)
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
ZINC = -obs_bodyElem_r(lobsSpaceData,OBS_WORK,INDEX_BODY)
!C * Accumulate the gradient of the observation cost function
DPJO0(1:2*NFLEV+1) = ZINC * vGPSZTD_Jacobian(iztd,:)
endif
ENDDO BODY_2
!c
!C * Store Ht*grad(Index_header) in COMMVO
!c
tt_column => col_getColumn(lcolumn,index_header,'TT')
hu_column => col_getColumn(lcolumn,index_header,'HU')
ps_column => col_getColumn(lcolumn,index_header,'P0')
DO JL = 1, NFLEV
tt_column(JL) = DPJO0(JL)
hu_column(JL) = DPJO0(JL+NFLEV)
ENDDO
ps_column(1) = DPJO0(2*NFLEV+1)
ENDIF ! ASSIM
ENDDO HEADER
! WRITE(*,*) 'oda_HTgp: Number of ZTD data locations processed = ', icount
! WRITE(*,*)'EXIT oda_HTgp'
RETURN
END subroutine oda_HTgp
end subroutine oda_HT