!-------------------------------------- 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_rttov_tl(lobsSpaceData) 1,28
#if defined (doc)
!**s/r tovs_rttov_tl - Tangent linear of computation of radiance with rttov_tl
! (adapted from part of code of lvtov)
!
!
!author : j. halle *cmda/aes april 19, 2005
!
!revision 001 : a. beaulne *cmda/msc june 2006
! - addition of ozone and IR surface emissivities
!revision 002 : r. sarrazin cmda april 2008
! - adapt to CSR
!revision 003 : s. heilliette
! - adapt to IASI
! S. heilliette:
! - adaptation to rttov 10.0 (october 2010)
!revision 004 : s. macpherson nov 2012
! - remove #include "comtovst.cdk"
! -------------------
! purpose:
!
!arguments
!
#endif
use MathPhysConstants_mod
use tovs_nl_mod
use tovs_lin_mod
use obsSpaceData_mod
use columnData_mod
Use rttov_const, only : sensor_id_mw,gas_id_watervapour
implicit none
!implicits
#include "rttov_tl2.interface"
#include "rttov_alloc_prof.interface"
#include "rttov_alloc_rad.interface"
#include "rttov_alloc_transmission.interface"
type(struct_obs) :: lobsSpaceData
real*8 :: ctpmin, ctpmax
integer :: joff,ilev
integer :: isurface
integer :: nlevels
integer :: nchannels
integer :: len_nchannels
integer :: nchannels_max
integer :: alloc_status(60)
integer :: rttov_err_stat ! rttov error return code
integer :: omp_get_num_threads
integer :: nthreads, max_nthreads
integer :: j, i, krtid, io, jf, iobs, iobs1, jch
integer :: ibegin, ibeginob, ilast, ilastob, jj
integer :: ival, iplatform, isat, knpf
integer :: jo, jdata, idata, idatend, idatyp
integer :: jk, jn, jl, ig
integer :: instrum, ilen, istride, ith
integer :: sensor_type ! sensor type (1=infrared; 2=microwave; 3=high resolution, 4=polarimetric)
integer :: knpf_tot, ioffset, nrank, ichn
integer, allocatable :: ncan (:) ! number of channels for each profile
integer, allocatable :: knpf_th (:)
integer, allocatable :: iptobs (:)
integer, allocatable :: nchannels_th (:)
integer, allocatable :: errorstatus_th (:)
integer, allocatable :: iptobs_th (:,:)
real*8, allocatable :: surfem1_th (:,:)
real*8, allocatable :: emissivity_th (:,:)
real*8, allocatable :: emissivity_tl_th (:,:)
real*8, allocatable :: emissivity_out_th (:,:)
real*8, allocatable :: emissivity_out_tl_th (:,:)
real*8, allocatable :: cloudemissivity_th (:,:)
real*8, allocatable :: cloudemissivity_tl_th (:,:)
type(radiance_type) , allocatable :: radiancedata_d_th (:) ! radiances full structure buffer used in rttov calls
type(radiance_type) , allocatable :: radiancedata_tl_th (:) ! tl radiances full structure buffer used in rttov calls
type(transmission_type), allocatable :: transmission_th (:) ! transmission
type(transmission_type), allocatable :: transmission_tl_th (:) ! transmission tl
type( profile_type ) , allocatable :: profilesdata_th (:,:) ! profiles buffer used in rttov calls
type( profile_type ) , allocatable :: profilesdata_tl_th (:,:) ! tl profiles buffer used in rttov calls
type( rttov_chanprof ) , allocatable :: chanprof_th (:,:)
logical ,save :: first=.true.
logical :: init
logical, allocatable :: calcemis_th (:,:)
real*8, allocatable :: surfem1 (:)
integer :: indobs,istep
integer :: omp_get_thread_num, ithread,asw
if(NOBTOV.eq.0) return ! exit if there are not tovs data
! 1. Get number of threads available and allocate memory for some variables
! . ----------------------------------------------------------------------
!
!$omp parallel
max_nthreads = omp_get_num_threads()
!$omp end parallel
alloc_status(:) = 0
allocate ( knpf_th (max_nthreads) ,stat=alloc_status(1))
allocate ( iptobs_th (jppf,max_nthreads) ,stat=alloc_status(2))
allocate ( errorstatus_th (max_nthreads) ,stat=alloc_status(3))
allocate ( nchannels_th (max_nthreads) ,stat=alloc_status(4))
allocate ( iptobs (jppf*max_nthreads) ,stat=alloc_status(5))
if( any(alloc_status /= 0) ) then
write(*,*) ' tovs_rttov_tl: alloc_status = ', alloc_status(:)
write(*,'(" tovs_rttov_tl: arrays #1 memory allocation error")')
call abort3d('tovs_rttov_tl ')
end if
!
! 2. Computation of hx for tovs data only
! . ------------------------------------
! Loop over all sensors specified by user
do krtid = 1, nsensors
nlevels=coefs(krtid)%coef % nlevels
sensor_type = coefs(krtid) % coef % id_sensor
iplatform = coefs(krtid) % coef % id_platform
isat = coefs(krtid) % coef % id_sat
instrum = coefs(krtid) % coef % id_inst
! loop over all obs.
knpf = 0
bobs: do iobs = 1, NOBTOV
jo = lobsno(iobs)
! Currently processed sensor?
if ( lsensor(iobs) .eq. krtid ) then
knpf = knpf + 1
iptobs(knpf) = iobs
endif
if ( knpf .le. 0 ) cycle bobs
if ( knpf .ne. jppf*max_nthreads .and. iobs .ne. NOBTOV ) cycle bobs
! . 2.1 Separate profiles according to the number of threads and
! . calculate the actual number of threads which will be used.
! . ----------------------------------------------------------
ith = 0
knpf_th (:) = 0
iptobs_th(:,:) = 0
istride = min(knpf,jppf)
do jn = 1, knpf,istride
ilen = min (knpf-jn+1,istride)
ith = ith + 1
knpf_th(ith) = ilen
do i = 1, ilen
iptobs_th(i,ith) = iptobs(jn+i-1)
enddo
enddo
! set nthreads to actual number of threads which will be used.
nthreads = min(max_nthreads,ith)
! . 2.2 Prepare all input variables required by rttov.
! for the purposes of using openmp; an additional dimension
! is added to most input variables, corresponding
! to the number of threads.
! . ---------------------------------------------------------
alloc_status(:)=0
allocate (ncan(knpf),stat= alloc_status(1))
ncan(:) = nchan(krtid)
! compute max possible values for nchannels using knpf, i.e. maximum number of profiles.
nchannels_max=SUM(ncan(1:knpf))
allocate ( surfem1_th (nchannels_max,nthreads) ,stat=alloc_status(2))
allocate ( chanprof_th (nchannels_max,nthreads) ,stat=alloc_status(3))
allocate ( emissivity_th (nchannels_max,nthreads) ,stat=alloc_status(4))
allocate ( emissivity_tl_th(nchannels_max,nthreads) ,stat=alloc_status(5))
allocate ( emissivity_out_th (nchannels_max,nthreads) ,stat=alloc_status(6))
allocate ( emissivity_out_tl_th(nchannels_max,nthreads),stat=alloc_status(7))
allocate ( calcemis_th (nchannels_max,nthreads) ,stat=alloc_status(8))
allocate ( surfem1 (nchannels_max) ,stat=alloc_status(9))
allocate ( cloudemissivity_th (nchannels_max,nthreads) ,stat=alloc_status(10))
allocate ( cloudemissivity_tl_th(nchannels_max,nthreads),stat=alloc_status(11))
! get AIRS & IASI ir emissivities
if (instrum.eq.11 .or. instrum.eq.16 .or. instrum.eq.27) then
surfem1(:) = 0.98d0
do jn = 1, knpf
iobs1 = iptobs(jn)
jo = lobsno(iobs1)
idata = obs_headElem_i(lobsSpaceData,OBS_RLN,jo)
idatend = obs_headElem_i(lobsSpaceData,OBS_NLV,jo) + idata - 1
do jdata = idata, idatend
if(obs_bodyElem_i(lobsSpaceData,OBS_ASS,jdata).eq.1) then
ichn = nint(obs_bodyElem_r(lobsSpaceData,OBS_PPP,jdata))
ichn = max(0,min(ichn,jpchmax+1))
do nrank = 1, nchan(krtid)
if ( ichn == ichan(nrank,krtid) ) exit
end do
surfem1 ( nrank + (jn-1)*nchan(krtid) ) = obs_bodyElem_r(lobsSpaceData,OBS_SEM,jdata)
end if
end do
end do
end if
allocate ( radiancedata_d_th(nthreads) ,stat=alloc_status(12)) ! radiances full structure buffer used in rttov calls
allocate ( radiancedata_tl_th(nthreads) ,stat=alloc_status(13)) ! tl radiances full structure buffer used in rttov calls
allocate ( transmission_th (nthreads) ,stat=alloc_status(14)) ! transmission
allocate ( transmission_tl_th (nthreads) ,stat=alloc_status(15)) ! transmission tl
allocate ( profilesdata_th(istride,nthreads) ,stat=alloc_status(16)) ! profilesdata
allocate ( profilesdata_tl_th(istride,nthreads),stat=alloc_status(17)) ! profilesdata tl
if( any(alloc_status /= 0) ) then
write(*,*) ' tovs_rttov_tl: alloc_status = ', alloc_status(:)
write(*,'(" tovs_rttov_tl: arrays #2 memory allocation error")')
call abort3d('tovs_rttov_tl ')
end if
!loop on threads
knpf_tot = 0
do ith = 1, nthreads
ichn = 0
Do j = 1 , knpf_th(ith)
DO jch = 1,ncan(j)
ichn = ichn +1
chanprof_th(ichn,ith)%prof=j
chanprof_th(ichn,ith)%chan=jch
End Do
End Do
nchannels_th(ith)=SUM(ncan(1:knpf_th(ith)))
init=.true.
asw=1 ! 1 to allocate,0 to deallocate
! allocate transmitance structure
call rttov_alloc_transmission(rttov_err_stat,transmission_th(ith),nlayers=nlevels-1, &
nchannels=nchannels_th(ith),asw=asw,init=init )
if (rttov_err_stat/=0) THEN
Write(*,*) "Error in transmittance allocation",rttov_err_stat
call abort3d('tovs_rttov ')
endif
call rttov_alloc_transmission(rttov_err_stat,transmission_tl_th(ith),nlayers=nlevels-1, &
nchannels=nchannels_th(ith),asw=asw,init=init )
if (rttov_err_stat/=0) THEN
Write(*,*) "Error in transmittance tl allocation",rttov_err_stat
call abort3d('tovs_rttov ')
endif
! allocate radiance structures
call rttov_alloc_rad ( rttov_err_stat, nchannels_th(ith), radiancedata_d_th(ith),nlevels-1,asw,init=init)
if (rttov_err_stat/=0) THEN
Write(*,*) "Error in radiance allocation",rttov_err_stat
call abort3d('tovs_rttov_tl ')
endif
call rttov_alloc_rad ( rttov_err_stat,nchannels_th(ith),radiancedata_tl_th(ith),nlevels-1,asw,init=init)
if (rttov_err_stat/=0) THEN
Write(*,*) "Error in radiance tl allocation",rttov_err_stat
call abort3d('tovs_rttov_tl ')
endif
knpf_tot = knpf_tot + knpf_th(ith)
surfem1_th (:,ith) = 0.d0
len_nchannels = nchannels_th(ith)/knpf_th(ith)
ioffset=len_nchannels*(knpf_tot-knpf_th(ith))
do j = 1 , knpf_th(ith)
joff=len_nchannels*(j-1)
isurface = profiles(iptobs_th(j,ith)) % skin % surftype
if (sensor_type .eq. sensor_id_mw ) then
if ( isurface .eq. 0 .or. &
isurface .eq. 2 ) then
calcemis_th(joff+1:joff+len_nchannels ,ith) = .false.
surfem1_th (joff+1:joff+len_nchannels ,ith) = 0.75d0
else
calcemis_th(joff+1:joff+len_nchannels ,ith) = .true.
surfem1_th (joff+1:joff+len_nchannels ,ith) = 0.d0
endif
elseif ((instrum .eq. 11) .or. (instrum .eq. 16) .or. (instrum .eq. 27)) then
calcemis_th(joff+1:joff+len_nchannels ,ith) = .false.
surfem1_th (joff+1:joff+len_nchannels,ith) = &
surfem1(joff+1+ioffset:joff+len_nchannels+ioffset)
elseif ((instrum .eq. 20) .or. (instrum .eq. 21) .or. &
(instrum .eq. 22) .or. (instrum .eq. 24) ) then
calcemis_th(joff+1:joff+len_nchannels ,ith) = .true.
surfem1_th (joff+1:joff+len_nchannels,ith) = 0.d0
else
call abort3d('tovs_rttov_tl. invalid sensor type')
endif
enddo
! Build the list of channels/profiles indices
emissivity_th(:,ith) = surfem1_th(:,ith)
cloudemissivity_th(:,ith)=0.0d0
cloudemissivity_tl_th(:,ith)=0.0d0
enddo
do ith = 1, nthreads
! allocate profile structures
init=.true.
asw=1
call rttov_alloc_prof (rttov_err_stat,knpf_th(ith),profilesdata_th(:,ith),nlevels, &
opts(krtid),asw=asw,init=init)
if (rttov_err_stat/=0) THEN
Write(*,*) "Error in profiles allocation",rttov_err_stat
call abort3d('tovs_rttov_tl ')
endif
call rttov_alloc_prof (rttov_err_stat,knpf_th(ith),profilesdata_tl_th(:,ith),nlevels, &
opts(krtid),asw=asw,init=init)
if (rttov_err_stat/=0) THEN
Write(*,*) "Error in profiles tl allocation",rttov_err_stat
call abort3d('tovs_rttov_tl ')
endif
!.. fill profilesdata arrays
do j = 1 , knpf_th(ith)
jj=iptobs_th(j,ith)
profilesdata_th(j,ith) % nlevels = profiles(jj) % nlevels
profilesdata_th(j,ith) % nlayers = profiles(jj) % nlayers
profilesdata_th(j,ith) % id = profiles(jj) % id
profilesdata_th(j,ith) % date = profiles(jj) % date
profilesdata_th(j,ith) % time = profiles(jj) % time
profilesdata_th(j,ith) % p(:) = profiles(jj) % p(:)
profilesdata_th(j,ith) % t(:) = profiles(jj) % t(:)
profilesdata_th(j,ith) % q(:) = profiles(jj) % q(:)
profilesdata_th(j,ith) % o3(:) = profiles(jj) % o3(:)
if(coefs(krtid)%coef%nco2 > 0) then
profilesdata_th(j,ith) % co2(:) = profiles(jj) % co2(:)
endif
if(coefs(krtid)%coef%nn2o > 0) then
profilesdata_th(j,ith) % n2o(:) = profiles(jj) % n2o(:)
endif
if(coefs(krtid)%coef%nco > 0) then
profilesdata_th(j,ith) % co(:) = profiles(jj) % co(:)
endif
if(coefs(krtid)%coef%nch4 > 0) then
profilesdata_th(j,ith) % ch4(:) = profiles(jj) % ch4(:)
endif
profilesdata_th(j,ith) % ctp = profiles(jj) % ctp
profilesdata_th(j,ith) % cfraction = profiles(jj) % cfraction
profilesdata_th(j,ith) % zenangle = profiles(jj) % zenangle
profilesdata_th(j,ith) % azangle = profiles(jj) % azangle
profilesdata_th(j,ith) % sunzenangle = profiles(jj) % sunzenangle!
profilesdata_th(j,ith) % sunazangle = profiles(jj) % sunazangle!
profilesdata_th(j,ith) % latitude = profiles(jj) % latitude!
profilesdata_th(j,ith) % longitude = profiles(jj) % longitude!
profilesdata_th(j,ith) % elevation = profiles(jj) % elevation!
profilesdata_th(j,ith) % skin % surftype = profiles(jj) % skin % surftype
profilesdata_th(j,ith) % skin % watertype = profiles(jj) % skin % watertype !
profilesdata_th(j,ith) % skin % t = profiles(jj) % skin % t
profilesdata_th(j,ith) % skin % salinity = profiles(jj) % skin % salinity
profilesdata_th(j,ith) % skin % fastem(:) = profiles(jj) % skin % fastem(:)
profilesdata_th(j,ith) % s2m % t = profiles(jj) % s2m % t
profilesdata_th(j,ith) % s2m % q = profiles(jj) % s2m % q
profilesdata_th(j,ith) % s2m % p = profiles(jj) % s2m % p
profilesdata_th(j,ith) % s2m % u = profiles(jj) % s2m % u
profilesdata_th(j,ith) % s2m % v = profiles(jj) % s2m % v
! profilesdata_th(j,ith) % s2m % o = profiles(jj) % s2m % o !surface ozone not used
profilesdata_th(j,ith) % s2m % wfetc = profiles(jj) % s2m % wfetc!
! profilesdata_th(j,ith) % clw(:) = profiles(jj) % clw(:)
profilesdata_th(j,ith) % idg = profiles(jj) % idg
profilesdata_th(j,ith) % ish = profiles(jj) % ish
profilesdata_th(j,ith) % snow_frac = profiles(jj)% snow_frac
profilesdata_th(j,ith) % soil_moisture = profiles(jj)% soil_moisture
profilesdata_th(j,ith) % Be = profiles(jj)% Be
profilesdata_th(j,ith) % cosbk = profiles(jj)% cosbk
end do
!.. fill profilesdata_tl arrays
do j = 1 , knpf_th(ith)
jj=iptobs_th(j,ith)
profilesdata_tl_th(j,ith) % nlevels = profiles_tl(jj) % nlevels
profilesdata_tl_th(j,ith) % nlayers = profiles_tl(jj) % nlayers
profilesdata_tl_th(j,ith) % p(:) = profiles_tl(jj) % p(:)
profilesdata_tl_th(j,ith) % t(:) = profiles_tl(jj) % t(:)
profilesdata_tl_th(j,ith) % q(:) = profiles_tl(jj) % q(:)
profilesdata_tl_th(j,ith) % o3(:) = profiles_tl(jj) % o3(:)
if(coefs(krtid)%coef%nco2 > 0) then
profilesdata_tl_th(j,ith) % co2(:) = profiles_tl(jj) % co2(:)
endif
if(coefs(krtid)%coef%nn2o > 0) then
profilesdata_tl_th(j,ith) % n2o(:) = profiles_tl(jj) % n2o(:)
endif
if(coefs(krtid)%coef%nco > 0) then
profilesdata_tl_th(j,ith) % co(:) = profiles_tl(jj) % co(:)
endif
if(coefs(krtid)%coef%nch4 > 0) then
profilesdata_tl_th(j,ith) % ch4(:) = profiles_tl(jj) % ch4(:)
endif
profilesdata_tl_th(j,ith) % ctp = profiles_tl(jj) % ctp
profilesdata_tl_th(j,ith) % cfraction = profiles_tl(jj) % cfraction
profilesdata_tl_th(j,ith) % zenangle = profiles_tl(jj) % zenangle
profilesdata_tl_th(j,ith) % azangle = profiles_tl(jj) % azangle
profilesdata_tl_th(j,ith) % sunzenangle = profiles_tl(jj) % sunzenangle!
profilesdata_tl_th(j,ith) % sunazangle = profiles_tl(jj) % sunazangle!
profilesdata_tl_th(j,ith) % latitude = profiles_tl(jj) % latitude!
profilesdata_tl_th(j,ith) % longitude = profiles_tl(jj) % longitude!
profilesdata_tl_th(j,ith) % elevation = profiles_tl(jj) % elevation!
profilesdata_tl_th(j,ith) % skin % surftype = profiles_tl(jj) % skin % surftype
profilesdata_tl_th(j,ith) % skin % watertype = profiles_tl(jj) % skin % watertype !
profilesdata_tl_th(j,ith) % skin % t = profiles_tl(jj) % skin % t
profilesdata_tl_th(j,ith) % skin % fastem(:) = profiles_tl(jj) % skin % fastem(:)
profilesdata_tl_th(j,ith) % skin % salinity = profiles_tl(jj) % skin % salinity
profilesdata_tl_th(j,ith) % s2m % t = profiles_tl(jj) % s2m % t
profilesdata_tl_th(j,ith) % s2m % q = profiles_tl(jj) % s2m % q
profilesdata_tl_th(j,ith) % s2m % p = profiles_tl(jj) % s2m % p
profilesdata_tl_th(j,ith) % s2m % u = profiles_tl(jj) % s2m % u
profilesdata_tl_th(j,ith) % s2m % v = profiles_tl(jj) % s2m % v
profilesdata_tl_th(j,ith) % s2m % wfetc = profiles_tl(jj) % s2m % wfetc!
profilesdata_tl_th(j,ith) % idg = profiles_tl(jj) % idg
profilesdata_tl_th(j,ith) % ish = profiles_tl(jj) % ish
profilesdata_tl_th(j,ith) % snow_frac = profiles_tl(jj) % snow_frac
! profilesdata_tl_th(j,ith) % soil_moisture = profiles_tl(jj) % soil_moisture
profilesdata_tl_th(j,ith) % Be = profiles_tl(jj) % Be
profilesdata_tl_th(j,ith) % cosbk = profiles_tl(jj) % cosbk
end do
!.. climatological moisture clip for profilesdata and profilesdata_tl arrays
! Modifie par S.Heilliette
! pour utiliser le bon profil min ou max pour chaque instrument
! au lieu du premier (AIRS) habituellement en mode analyse
! ne doit rien changer en mode background check
ig=coefs(krtid)%coef%fmv_gas_pos(gas_id_watervapour)
do j = 1 , knpf_th(ith)
do jl = 1 , coefs(krtid) %coef% nlevels
if ( profiles(iptobs_th(j,ith)) % q(jl) &
.le. coefs(krtid)%coef%lim_prfl_gmin(jl,ig) ) then
profilesdata_th(j,ith) % q(jl) = coefs(krtid)%coef%lim_prfl_gmin(jl,ig)
profilesdata_tl_th(j,ith) % q(jl) = 0.0d0
elseif ( profiles(iptobs_th(j,ith)) % q(jl) &
.ge. coefs(krtid)%coef%lim_prfl_gmax(jl,ig) ) then
profilesdata_th(j,ith) % q(jl) = coefs(krtid)%coef%lim_prfl_gmax(jl,ig)
profilesdata_tl_th(j,ith) % q(jl) = 0.0d0
endif
enddo
end do
enddo
! . 2.3 Compute tl radiance with rttov_tl
! . ---------------------------------
errorstatus_th(:) = 0
emissivity_tl_th(:,:) = 0.0d0
cloudemissivity_tl_th(:,:) = 0.0d0
!$omp parallel
!$omp do private(ith)
do ith = 1, nthreads
call rttov_tl2( &
errorstatus_th(ith), & ! out
chanprof_th(1:nchannels_th(ith),ith), & ! in
opts(krtid), & ! in
profilesdata_th(1:knpf_th(ith),ith), & ! in
profilesdata_tl_th(1:knpf_th(ith),ith), & ! inout
coefs(krtid), & ! in
calcemis_th(1:nchannels_th(ith),ith), & ! in
emissivity_th(1:nchannels_th(ith),ith), & ! in
emissivity_tl_th(1:nchannels_th(ith),ith), & ! in
emissivity_out_th(1:nchannels_th(ith),ith), & ! out
emissivity_out_tl_th(1:nchannels_th(ith),ith), & ! out
cloudemissivity_th(1:nchannels_th(ith),ith), & ! in
cloudemissivity_tl_th(1:nchannels_th(ith),ith),& ! in
transmission_th(ith), & ! inout
transmission_tl_th(ith), & ! inout
radiancedata_d_th(ith), & ! inout
radiancedata_tl_th(ith) ) ! inout
if (errorstatus_th(ith)/=0) then
Write(*,*) "Error in rttov_tl2",ith,errorstatus_th(ith)
call abort3d('tovs_rttov_tl ')
endif
enddo
!$omp end do
!$omp end parallel
! . 2.4 Store hx in the structure radiance_tl
! . ------------------------------------
do ith = 1, nthreads
do jn = 1, knpf_th(ith)
io = iptobs_th(jn,ith)
joff=nchannels_th(ith)/knpf_th(ith)*(jn-1)
radiance_tl(io) % bt(:) = radiancedata_tl_th(ith) % bt(joff+1:joff+nchannels_th(ith)/knpf_th(ith))
! rttov_errorstatus(io) = errorstatus_th(ith)
enddo
enddo
! de-allocate memory
do ith = 1, nthreads
asw=0 ! 1 to allocate,0 to deallocate
! deallocate transmitance structures
call rttov_alloc_transmission(rttov_err_stat,transmission_th(ith),nlayers=nlevels-1, &
nchannels=nchannels_th(ith),asw=asw )
if (rttov_err_stat/=0) THEN
Write(*,*) "Error in transmittance deallocation",rttov_err_stat
call abort3d('tovs_rttov ')
endif
call rttov_alloc_transmission(rttov_err_stat,transmission_tl_th(ith),nlayers=nlevels-1, &
nchannels=nchannels_th(ith),asw=asw )
if (rttov_err_stat/=0) THEN
Write(*,*) "Error in transmittance tl deallocation",rttov_err_stat
call abort3d('tovs_rttov ')
endif
! deallocate radiance structures
call rttov_alloc_rad (rttov_err_stat,nchannels_th(ith),radiancedata_d_th(ith),nlevels-1,asw)
if (rttov_err_stat/=0) THEN
Write(*,*) "Error in radiance deallocation",rttov_err_stat
call abort3d('tovs_rttov_tl ')
endif
call rttov_alloc_rad (rttov_err_stat,nchannels_th(ith),radiancedata_tl_th(ith),nlevels-1,asw)
if (rttov_err_stat/=0) THEN
Write(*,*) "Error in radiance tl deallocation",rttov_err_stat
call abort3d('tovs_rttov_tl ')
endif
! deallocate profile structures
call rttov_alloc_prof (rttov_err_stat,knpf_th(ith),profilesdata_th(:,ith),nlevels, &
opts(krtid),asw=asw)
if (rttov_err_stat/=0) THEN
Write(*,*) "Error in profiles deallocation",rttov_err_stat
call abort3d('tovs_rttov_tl ')
endif
call rttov_alloc_prof (rttov_err_stat,knpf_th(ith),profilesdata_tl_th(:,ith),nlevels, &
opts(krtid),asw=asw)
if (rttov_err_stat/=0) THEN
Write(*,*) "Error in profiles tl deallocation",rttov_err_stat
call abort3d('tovs_rttov_tl ')
endif
enddo
alloc_status(:) = 0
deallocate ( profilesdata_th ,stat=alloc_status(1) )
deallocate ( profilesdata_tl_th,stat=alloc_status(2) )
deallocate ( radiancedata_d_th ,stat=alloc_status(3) ) ! radiances full structure buffer used in rttov calls
deallocate ( radiancedata_tl_th,stat=alloc_status(4) ) ! tl radiances full structure buffer used in rttov calls
deallocate ( transmission_th ,stat=alloc_status(5) ) ! transmission
deallocate ( transmission_tl_th,stat=alloc_status(6) ) ! transmission tl
deallocate ( ncan ,stat=alloc_status(7) )
deallocate ( surfem1_th ,stat=alloc_status(8) )
deallocate ( chanprof_th ,stat=alloc_status(9) )
deallocate ( emissivity_th ,stat=alloc_status(10))
deallocate ( emissivity_tl_th ,stat=alloc_status(11))
deallocate ( emissivity_out_th ,stat=alloc_status(12))
deallocate ( emissivity_out_tl_th,stat=alloc_status(13))
deallocate ( calcemis_th ,stat=alloc_status(14))
deallocate ( surfem1 ,stat=alloc_status(15))
deallocate ( cloudemissivity_th ,stat=alloc_status(16))
deallocate ( cloudemissivity_tl_th,stat=alloc_status(17))
if( any(alloc_status /= 0) ) then
write(*,*) ' tovs_rttov_tl: alloc_status = ', alloc_status(:)
write(*,'(" tovs_rttov_tl: arrays #2 memory deallocation error")')
call abort3d('tovs_rttov_tl ')
end if
! next bunch !
knpf = 0
enddo bobs
end do
! 3. Close up
! . --------
! deallocate memory
alloc_status(:) = 0
deallocate ( knpf_th ,stat=alloc_status(1))
deallocate ( iptobs_th ,stat=alloc_status(2))
deallocate ( errorstatus_th ,stat=alloc_status(3))
deallocate ( nchannels_th ,stat=alloc_status(4))
deallocate ( iptobs ,stat=alloc_status(5))
if( any(alloc_status /= 0) ) then
write(*,*) ' tovs_rttov_tl: alloc_status = ', alloc_status(:)
write(*,'(" tovs_rttov_tl: arrays #1 memory deallocation error")')
call abort3d('tovs_rttov_tl ')
end if
return
end subroutine tovs_rttov_tl