!-------------------------------------- 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 tovs_fill_profiles_ad(lcolumn,lcolumng) 1,33
#if defined (doc)
!
!**s/r tovs_fill_profiles_ad - adjoint of interpolation of obs.space to 43-level rttov space
! (adapted from part of code of avtov)
!
!
!author : j. halle *cmda/aes april 21, 2005
!
!revision 001 : j. halle *cmda/smc march 2007
! -fix zvlev for hybrid coordinate
!revision 002 : s. macpherson nov 2012
! - remove #include "comtovst.cdk"
!
! -------------------
! purpose: fill tangent linear profiles structure with info from obs. space
!
!arguments
!
!
#endif
use MathPhysConstants_mod
use tovs_nl_mod
use tovs_lin_mod
use columnData_mod
use obsSpaceData_mod
use tovs_extrap_mod
use rttov_const ,only : q_mixratio_to_ppmv
implicit none
type(struct_columnData) :: lcolumn,lcolumng
type(struct_vco), pointer :: vco_anl
integer, allocatable :: iptobs (:)
integer, allocatable :: iptobscma (:)
integer :: alloc_status(40)
integer :: omp_get_num_threads, nthreads
integer :: istride, ilen, imodulo
integer :: knlev,nlevels,nobmax
integer :: j, i, krtid, jf, iobs, jj, stat
integer :: ilowlvl_T, ilowlvl_M, knpf, jo
integer :: jk, jn, jl
real*8, allocatable :: to_ad (:,:)
real*8, allocatable :: lqo_ad (:,:)
real*8, allocatable :: toext_ad (:,:)
real*8, allocatable :: qoext_ad (:,:)
real*8, allocatable :: zvlev (:,:)
real*8, allocatable :: dPdPs (:,:)
real*8, allocatable :: zt_ad (:,:)
real*8, allocatable :: zlq_ad (:,:)
real*8, allocatable :: zt (:,:)
real*8, allocatable :: zlq (:,:)
real*8, allocatable :: qoext (:,:)
real*8, allocatable :: zps_ad (:)
real*8, allocatable :: xpres (:)
real*8 :: zptop, zptopmbs
real*8, pointer :: uu_column(:),vv_column(:),tt_column(:),hu_column(:),ps_column(:),tg_column(:)
external intavgad
external aexthum4
if(NOBTOV.eq.0) return ! exit if there are not tovs data
! 1. Set index for model's lowest level and model top
! . ------------------------------------------------
vco_anl => col_getVco(lcolumng)
knlev = col_getNumLev(lcolumng,'TH')
if ( col_getPressure(lcolumng,1,1,'TH') .lt. col_getPressure(lcolumng,knlev,1,'TH') ) then
ilowlvl_M = col_getNumLev(lcolumng,'MM')
ilowlvl_T = col_getNumLev(lcolumng,'TH')
else
ilowlvl_M = 1
ilowlvl_T = 1
endif
nlevels=coefs(1) %coef% nlevels
allocate (xpres(nlevels))
xpres(1:nlevels) = coefs(1)% coef % ref_prfl_p(1:nlevels)
! find model level top, within 0.000001 mbs.
zptop = col_getPressure(lcolumng,1,1,'TH')
zptopmbs = zptop/100.d0
zptopmbs = zptopmbs - 0.000001d0
jpmotop = 1
do jl = 2, nlevels
if ( zptopmbs .ge. xpres(jl-1) .and. &
zptopmbs .lt. xpres(jl) ) then
jpmotop = jl
exit
endif
enddo
jpmolev = (nlevels-jpmotop+1)
! 1.1 Number of threads and memory allocation
! . ---------------------------------------
!$omp parallel
nthreads = omp_get_num_threads()
!$omp end parallel
alloc_status(:) = 0
allocate (iptobs (jppf*nthreads) ,stat= alloc_status(1) )
allocate (iptobscma(jppf*nthreads) ,stat= alloc_status(2) )
allocate (to_ad (jpmolev,jppf*nthreads),stat= alloc_status(3) )
allocate (lqo_ad (jpmolev,jppf*nthreads),stat= alloc_status(4) )
allocate (toext_ad (nlevels,jppf*nthreads),stat= alloc_status(5) )
allocate (qoext_ad (nlevels,jppf*nthreads),stat= alloc_status(6) )
allocate (zvlev (knlev,jppf*nthreads) ,stat= alloc_status(7) )
allocate (dPdPs (knlev,jppf*nthreads) ,stat= alloc_status(8) )
allocate (zt_ad (knlev,jppf*nthreads) ,stat= alloc_status(9) )
allocate (zlq_ad (knlev,jppf*nthreads) ,stat= alloc_status(10) )
allocate (zt (knlev,jppf*nthreads) ,stat= alloc_status(11))
allocate (zlq (knlev,jppf*nthreads) ,stat= alloc_status(12))
allocate (qoext (nlevels,jppf*nthreads),stat= alloc_status(13))
allocate (zps_ad (jppf*nthreads) ,stat= alloc_status(14))
if( any(alloc_status /= 0) ) then
write(*,*) ' tovs_fill_profiles_ad : memory allocation error'
call abort3d('tovs_fill_profiles_ad ')
end if
!
! 2. Adjoint of fill profiles structure
! . ----------------------------------
! loop over all instruments
binst: do krtid = 1, nsensors
xpres(1:nlevels) = coefs(krtid)% coef % ref_prfl_p(1:nlevels)
knpf = 0
bb: do iobs = NOBTOV,1,-1
if (lsensor(iobs)==krtid) then
NOBMAX=iobs
exit bb
endif
enddo bb
! loop over all obs.
bobs: do iobs = 1, NOBTOV
if (lsensor(iobs)/=krtid) cycle bobs
jo = lobsno(iobs)
knpf = knpf + 1
do jl = 1, knlev
zt (jl,knpf) = col_getElem(lcolumng,jl,jo,'TT')
zlq (jl,knpf) = col_getElem(lcolumng,jl,jo,'HU')
zvlev(jl,knpf) = col_getPressure(lcolumng,jl,jo,'TH') *MPC_MBAR_PER_PA_R8
dPdPs(jl,knpf) = col_getPressureDeriv(lcolumng,jl,jo,'TH')
enddo
!!! Fix pour eviter probleme au toit avec GEM 4
!!! (grosse varibilite temperature au dernier niveau thermo due a l'extrapolation utilisee)
zt (1,knpf) = zt (2,knpf) - 8.0d0 ! base sur derniere couche environ 4km, lapse rate 2K/km
zlq (1,knpf) = zlq (2,knpf)
!!!!
iptobs (knpf) = iobs
iptobscma(knpf) = jo
if ( knpf .le. 0 ) cycle bobs
if ( knpf .ne. jppf*nthreads .and. iobs .ne. NOBMAX ) cycle bobs
! . 2.4 Adjoint of filling profiles_ad structure
! . ----------------------------------------
do j = 1, knpf
qoext(:,j) = profiles(iptobs(j)) % q(:) / q_mixratio_to_ppmv
enddo
do j = 1 , knpf
ps_column => col_getColumn(lcolumn,iptobscma(j),'P0')
tg_column => col_getColumn(lcolumn,iptobscma(j),'TG')
tt_column => col_getColumn(lcolumn,iptobscma(j),'TT')
hu_column => col_getColumn(lcolumn,iptobscma(j),'HU')
uu_column => col_getColumn(lcolumn,iptobscma(j),'UU')
vv_column => col_getColumn(lcolumn,iptobscma(j),'VV')
toext_ad(:,j) = profiles_ad(iptobs(j)) % t(:)
qoext_ad(:,j) = profiles_ad(iptobs(j)) % q(:) * q_mixratio_to_ppmv
ps_column(1) = profiles_ad(iptobs(j)) % s2m % p *MPC_MBAR_PER_PA_R8
tg_column(1) = profiles_ad(iptobs(j)) % skin % t
tt_column(ilowlvl_T) = profiles_ad(iptobs(j)) % s2m % t
!!! hu_column(ilowlvl_T) = qoext(ilowlvl_T,j) * profiles_ad(iptobs(j)) % s2m % q * q_mixratio_to_ppmv
!!! hu_column(ilowlvl_T) = qoext(ilowlvl_T,j) * profiles_ad(iptobs(j)) % s2m % q
hu_column(ilowlvl_T) = 0.d0
uu_column(ilowlvl_M) = profiles_ad(iptobs(j)) % s2m % u
vv_column(ilowlvl_M) = profiles_ad(iptobs(j)) % s2m % v
end do
! . 2.3 Adjoint of extrapolation of humidity profile (kg/kg)
! above rlimlvhu (normally 300mbs or 70mbs)
! .
if ( abs( zptopmbs - 10.0d0 ) < .1d0 ) then
if ( ldbgtov ) then
do jn = 1, knpf
write(*,*)'qoext_ad*1000 avant aexthum4 = '
write(*,9263)(qoext_ad(i,jn)*1000.d0,i=1,nlevels)
write(*,*)' '
enddo
endif
call aexthum4 (knpf,nlevels,xpres(1:nlevels),qoext_ad,qoext)
if ( ldbgtov ) then
do jn = 1, knpf
write(*,*)'qoext_ad*1000 apres aexthum4 = '
write(*,9263)(qoext_ad(i,jn)*1000.d0,i=1,nlevels)
write(*,*)' '
enddo
endif
endif
! adjoint of conversion lnq --> q
lqo_ad(:,:) = 0.0d0
do jn = 1, knpf
! do jk = 1, jpmolev
do jk = 2, jpmolev
lqo_ad(jk,jn) = qoext_ad(nlevels-jpmolev+jk,jn) * qoext(nlevels-jpmolev+jk,jn)
enddo
! do jk = 1, jpmotop
! lqo_ad(1,jn) = lqo_ad(1,jn) + qoext_ad(jk,jn) * qoext(jk,jn)
! enddo
enddo
! . 2.2 Adjoint of extrapolation of temperature profile above 10mb
! . ----------------------------------------------------------
to_ad(:,:) = 0.0d0
do jn = 1, knpf
to_ad(2:jpmolev,jn)=to_ad(2:jpmolev,jn)+toext_ad(jpmotop+1:nlevels,jn)
! to_ad(1:jpmolev,jn)=to_ad(1:jpmolev,jn)+toext_ad(jpmotop:nlevels,jn)
! do jk=1,jpmotop-1
! to_ad(1,jn)=to_ad(1,jn)+toext_ad(jk,jn)
! enddo
enddo
if ( abs( zptopmbs - 10.0d0 ) < .1d0 ) then
call aextrap (to_ad,toext_ad,jpmolev,nlevels,knpf)
endif
! . 2.1 Adjoint of vertical interpolation of model temperature and logarithm of
! specific humidity to pressure levels required by tovs rt model
! . -----------------------------------------------------------------------
zt_ad (:,:) = 0.0d0
zlq_ad(:,:) = 0.0d0
zps_ad(:) = 0.0d0
imodulo = mod(knpf,nthreads)
if ( imodulo .eq. 0 ) then
istride = max(1,(knpf/nthreads))
else
istride = max(1,(knpf/nthreads)+1)
endif
!$omp parallel
!$omp do private(jn,ilen)
do jn=1,knpf,istride
ilen = min (knpf-jn+1,istride)
if ( ilen .gt. 0) then
call intavgad(zvlev(:,jn:jn+ilen-1),dPdPs(:,jn:jn+ilen-1),zt_ad(:,jn:jn+ilen-1),zt(:,jn:jn+ilen-1), &
zps_ad(jn:jn+ilen-1),knlev,knlev,ilen, &
jpmolev,xpres(jpmotop:nlevels),to_ad(:,jn:jn+ilen-1))
call intavgad(zvlev(:,jn:jn+ilen-1),dPdPs(:,jn:jn+ilen-1),zlq_ad(:,jn:jn+ilen-1),zlq(:,jn:jn+ilen-1), &
zps_ad(jn:jn+ilen-1),knlev,knlev,ilen, &
jpmolev,xpres(jpmotop:nlevels),lqo_ad(:,jn:jn+ilen-1))
endif
enddo
!$omp end do
!$omp end parallel
! . 2.1 Store adjoints in commvo
! . ------------------------
do jn = 1 , knpf
ps_column => col_getColumn(lcolumn,iptobscma(jn),'P0')
tt_column => col_getColumn(lcolumn,iptobscma(jn),'TT')
hu_column => col_getColumn(lcolumn,iptobscma(jn),'HU')
ps_column(1) = ps_column(1) + zps_ad (jn) * MPC_MBAR_PER_PA_R8
do jl = 2, col_getNumLev(lcolumn,'TH')
tt_column(jl) = tt_column(jl) + zt_ad (jl,jn)
hu_column(jl) = hu_column(jl) + zlq_ad (jl,jn)
enddo
enddo
! next bunch !
knpf = 0
enddo bobs
enddo binst
alloc_status(:) = 0
deallocate (iptobs ,stat= alloc_status(1) )
deallocate (iptobscma,stat= alloc_status(2) )
deallocate (to_ad ,stat= alloc_status(3) )
deallocate (lqo_ad ,stat= alloc_status(4) )
deallocate (toext_ad ,stat= alloc_status(5) )
deallocate (qoext_ad ,stat= alloc_status(6) )
deallocate (zvlev ,stat= alloc_status(7) )
deallocate (dPdPs ,stat= alloc_status(8) )
deallocate (zt_ad ,stat= alloc_status(9) )
deallocate (zlq_ad ,stat= alloc_status(10) )
deallocate (zt ,stat= alloc_status(11))
deallocate (zlq ,stat= alloc_status(12))
deallocate (qoext ,stat= alloc_status(13))
deallocate (zps_ad ,stat= alloc_status(14))
deallocate (xpres ,stat= alloc_status(15))
if( any(alloc_status /= 0) ) then
write(*,*) ' tovs_fill_profiles_ad : memory deallocation error'
call abort3d('tovs_fill_profiles_ad ')
end if
9263 format(1x,10f8.4)
! 3. Close up
! . --------
return
end subroutine tovs_fill_profiles_ad