!-------------------------------------- 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_tl(lcolumn,lcolumng) 1,31
#if defined (doc)
!
!**s/r tovs_fill_profiles_tl - tangent linear of interpolation of obs.space to rttov space
! (adapted from part of code of lvtov)
!
!
!author : j. halle *cmda/aes april 12, 2005
!
!revision 001 : a. beaulne *cmda/smc june 2006
! -add ozone from climatology to all sensors
!
!revision 002 : j. halle *cmda/smc march 2007
! -fix zvlev for hybrid coordinate
!revision 003 : S. Heilliette septembre 2011
! -adapt to rttv-10
!revision 004 : 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 obsSpaceData_mod
use columnData_mod
use tovs_extrap_mod
use rttov_const ,only : q_mixratio_to_ppmv
Use parkind1, Only : jpim ,jprb
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 :: nlevels,knlev,nobmax
integer :: j, i, krtid, jf, iobs, jj, stat
integer :: ilowlvl_M,ilowlvl_T, knpf, jo
integer :: jk, jn, jl
real*8, allocatable :: to_tl (:,:)
real*8, allocatable :: lqo_tl (:,:)
real*8, allocatable :: toext_tl (:,:)
real*8, allocatable :: qoext_tl (:,:)
real*8, allocatable :: zvlev (:,:)
real*8, allocatable :: dPdPs (:,:)
real*8, allocatable :: zt_tl (:,:)
real*8, allocatable :: zlq_tl (:,:)
real*8, allocatable :: zt (:,:)
real*8, allocatable :: zlq (:,:)
real*8, allocatable :: qoext (:,:)
real*8, allocatable :: zps_tl (:)
real*8, allocatable :: xpres (:)
real*8 :: zptop, zptopmbs
external intavg
external exthum4
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_tl (jpmolev,jppf*nthreads) ,stat= alloc_status(3) )
allocate (lqo_tl (jpmolev,jppf*nthreads) ,stat= alloc_status(4) )
allocate (toext_tl (nlevels ,jppf*nthreads),stat= alloc_status(5) )
allocate (qoext_tl (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_tl (knlev,jppf*nthreads) ,stat= alloc_status(9) )
allocate (zlq_tl (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_tl (jppf*nthreads) ,stat= alloc_status(14))
if( any(alloc_status /= 0) ) then
write(*,*) ' tovs_fill_profiles_tl : memory allocation error'
call abort3d('tovs_fill_profiles_tl ')
end if
iptobs (:) = 0
iptobscma(:) = 0
toext_tl (:,:) = 0.0d0
zvlev (:,:) = 0.0d0
dPdPs (:,:) = 0.0d0
zt_tl (:,:) = 0.0d0
zlq_tl (:,:) = 0.0d0
zt (:,:) = 0.0d0
zlq (:,:) = 0.0d0
qoext (:,:) = 0.0d0
zps_tl (:) = 0.0d0
to_tl (:,:) = 0.0d0
lqo_tl (:,:) = 0.0d0
!
! 2. Fill profiles structure
! . -----------------------
! loop over all instruments
binst: do krtid=1,nsensors
! loop over all obs.
knpf = 0
xpres(1:nlevels) = coefs(krtid)% coef % ref_prfl_p(1:nlevels)
bb: do iobs = NOBTOV,1,-1
if (lsensor(iobs)==krtid) then
NOBMAX=iobs
exit bb
endif
enddo bb
bobs: do iobs = 1, NOBTOV
if (lsensor(iobs)/=krtid) cycle bobs
jo = lobsno(iobs)
knpf = knpf + 1
zps_tl (knpf) = col_getElem(lcolumn,1,jo,'P0')*MPC_MBAR_PER_PA_R8
do jl = 1, knlev
zt_tl (jl,knpf) = col_getElem(lcolumn,jl,jo,'TT')
zlq_tl (jl,knpf) = col_getElem(lcolumn,jl,jo,'HU')
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_tl (1,knpf) = 0.d0
zlq_tl (1,knpf) = 0.d0
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.1 Vertical interpolation of model temperature and logarithm of
! specific humidity to pressure levels required by tovs rt model
! . --------------------------------------------------------------
do jn = 1, knpf
qoext(1:nlevels,jn) = profiles(iptobs(jn)) % q(1:nlevels) / q_mixratio_to_ppmv
enddo
to_tl (:,:) = 0.0d0
lqo_tl(:,:) = 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 intavgtl(zvlev(:,jn:jn+ilen-1),dPdPs(:,jn:jn+ilen-1),zt_tl(:,jn:jn+ilen-1),zt(:,jn:jn+ilen-1), &
zps_tl(jn:jn+ilen-1),knlev,knlev,ilen, &
jpmolev,xpres(jpmotop:nlevels),to_tl(:,jn:jn+ilen-1))
call intavgtl(zvlev(:,jn:jn+ilen-1),dPdPs(:,jn:jn+ilen-1),zlq_tl(:,jn:jn+ilen-1),zlq(:,jn:jn+ilen-1), &
zps_tl(jn:jn+ilen-1),knlev,knlev,ilen, &
jpmolev,xpres(jpmotop:nlevels),lqo_tl(:,jn:jn+ilen-1))
endif
enddo
!$omp end do
!$omp end parallel
! . 2.2 Extrapolation of temperature profile above 10mb
! . -----------------------------------------------
toext_tl(:,:) = 0.0d0
if ( abs( zptopmbs - 10.0d0 ) > .1d0 ) then
do jn = 1, knpf
toext_tl(jpmotop:nlevels,jn)=to_tl(1:jpmolev,jn)
toext_tl(1:jpmotop-1,jn)=0.d0
enddo
else
call lextrap (to_tl,toext_tl,jpmolev,nlevels,knpf)
endif
! . 2.3 Extrapolation of humidity profile (kg/kg)
! above rlimlvhu (normally 300mbs or 70mbs)
! . -----------------------------------------
qoext_tl(:,:) = 0.0d0
do jn = 1, knpf
do jk = 1, jpmotop-1
qoext_tl(jk,jn) = 0.d0
enddo
do jk = 1, jpmolev
qoext_tl(nlevels-jpmolev+jk,jn) = qoext(nlevels-jpmolev+jk,jn)*lqo_tl(jk,jn)
enddo
enddo
if ( abs( zptopmbs - 10.0d0 ) < .1d0 ) then
if ( ldbgtov ) then
do jn = 1, knpf
write(*,*)'qoext_tl*1000 avant exthum4 = '
write(*,9263)(qoext_tl(i,jn)*1000.d0,i=1,nlevels)
write(*,*)' '
enddo
endif
call lexthum4 (knpf,nlevels,xpres(1:nlevels),qoext_tl,qoext)
if ( ldbgtov ) then
do jn = 1, knpf
write(*,*)'qoext_tl*1000 apres exthum4 = '
write(*,9263)(qoext_tl(i,jn)*1000.d0,i=1,nlevels)
write(*,*)' '
enddo
endif
endif
! . 2.4 Fill profiles_tl structure
! . --------------------------
do j = 1 , knpf
jj=iptobs(j)
profiles_tl(jj) % nlevels = nlevels
profiles_tl(jj) % nlayers = nlevels - 1
profiles_tl(jj) % o3(:) = 0.0d0
if(coefs(krtid)%coef%nco2 > 0) then
profiles_tl(jj) % co2(:) = 0.d0
endif
if(coefs(krtid)%coef%nn2o > 0) then
profiles_tl(jj) % n2o(:) = 0.d0
endif
if(coefs(krtid)%coef%nco > 0) then
profiles_tl(jj) % co(:) = 0.d0
endif
if(coefs(krtid)%coef%nch4 > 0) then
profiles_tl(jj) % ch4(:) = 0.d0
endif
profiles_tl(jj) % ctp = 0.0d0
profiles_tl(jj) % cfraction = 0.0d0
profiles_tl(jj) % zenangle = 0.0d0
profiles_tl(jj) % azangle = 0.0d0
profiles_tl(jj) % skin % surftype = 0
profiles_tl(jj) % skin % t = col_getElem(lcolumn,1,iptobscma(j),'TG')
profiles_tl(jj) % skin % fastem(:)= 0.0d0
profiles_tl(jj) % skin % salinity = 0.0d0
profiles_tl(jj) % s2m % t = col_getElem(lcolumn,ilowlvl_T,iptobscma(j),'TT')
!! The following line has been commented out because qoext(ilowlvl_T,j) may be out of bound
!!! profiles_tl(jj) % s2m % q = qoext(ilowlvl_T,j) * col_getElem(lcolumn,ilowlvl_T,iptobscma(j),'HU') * q_mixratio_to_ppmv
!! The right code should be
!!profiles_tl(jj) % s2m % q = exp(gomq1(ilowlvl_T,iptobscma(j))) * pgomq_tl(ilowlvl_T,iptobscma(j)) * q_mixratio_to_ppmv
!! but since the logical flag 'use_q2m' is set to .false. in rttov_const.F90 (in RTTOV code)
!! this variable profiles_tl(jj) % s2m % q is not used so it can be set to 0
profiles_tl(jj) % s2m % q = 0.d0
profiles_tl(jj) % s2m % p = col_getElem(lcolumn,1,iptobscma(j),'P0')*MPC_MBAR_PER_PA_R8
profiles_tl(jj) % s2m % u = col_getElem(lcolumn,ilowlvl_M,iptobscma(j),'UU')
profiles_tl(jj) % s2m % v = col_getElem(lcolumn,ilowlvl_M,iptobscma(j),'VV')
profiles_tl(jj) % p(1:nlevels) = 0.d0
profiles_tl(jj) % t(1:nlevels) = toext_tl(1:nlevels,j)
profiles_tl(jj) % q(1:nlevels) = qoext_tl(1:nlevels,j) * q_mixratio_to_ppmv
end do
! 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_tl ,stat= alloc_status(3) )
deallocate (lqo_tl ,stat= alloc_status(4) )
deallocate (toext_tl ,stat= alloc_status(5) )
deallocate (qoext_tl ,stat= alloc_status(6) )
deallocate (zvlev ,stat= alloc_status(7) )
deallocate (dPdPs ,stat= alloc_status(8) )
deallocate (zt_tl ,stat= alloc_status(9) )
deallocate (zlq_tl ,stat= alloc_status(10))
deallocate (zt ,stat= alloc_status(11))
deallocate (zlq ,stat= alloc_status(12))
deallocate (qoext ,stat= alloc_status(13))
deallocate (zps_tl ,stat= alloc_status(14))
deallocate (xpres ,stat= alloc_status(15))
if( any(alloc_status /= 0) ) then
write(*,*) ' tovs_fill_profiles_tl : memory deallocation error'
call abort3d('tovs_fill_profiles_tl ')
end if
9263 format(1x,10f8.4)
! 3. Close up
! . --------
return
end subroutine tovs_fill_profiles_tl