!-------------------------------------- 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(lcolumnghr,lobsSpaceData,datestamp,LIMLVHU,bgckMode) 2,39
!
!**s/r tovs_fill_profiles - interpolation of obs. space to rttov space
! (adapted from part of code of dobstovs)
!
!
!author : j. halle *cmda/aes december 13, 2004
!
!revision 001 : a. beaulne *cmda/smc june 2006
! -add ozone from climatology to all sensors
! -modifications for AIRS :
! + addition of geopotential field to subr argument
! + addition of latitude, longitude, height field,
! sun zenith angle and cloud fraction
! to personnalized profile structure
!
!revision 002 : j. halle *cmda/smc march 2007
! -fix zvlev for hybrid coordinate
!revision 003 : C. Charette - ARMA et N.Wagneur - CMDA - Juillet 2011
! . Ajout de la capacite de lire le champ d'essai de GEM Version 4
! . ayant une grille verticale decalee dite "STAGGERED"
!revision 004 : s. macpherson nov 2012
! - remove #include "comtovst.cdk"
!revision 005 : S. Heilliette october 2010
! -adapt to rttov10
!
! -------------------
! purpose: fill profiles structure with info from obs. space
!
!arguments
!
use EarthConstants_mod
use MathPhysConstants_mod
use tovs_nl_mod
use multi_ir_bgck_mod
use ozoneclim
use obsSpaceData_mod
use columnData_mod
use tovs_extrap_mod
Use rttov_const, only : q_mixratio_to_ppmv, &
gas_id_co2, &
gas_id_n2o, &
gas_id_co , &
gas_id_ch4, &
gas_id_ozone, &
gas_id_mixed, &
gas_id_watervapour, &
gas_id_wvcont, &
zenmax
implicit none
type(struct_obs) :: lobsSpaceData
type(struct_columnData) :: lcolumnghr
integer :: datestamp
real*8 :: LIMLVHU
logical :: bgckMode
integer, allocatable :: ksurf (:)
integer, allocatable :: iptobs (:)
integer, allocatable :: iptobscma (:)
integer, allocatable :: isatzen (:)
integer, allocatable :: isatazim (:)
integer, allocatable :: isunza (:)
real*8, allocatable :: zlat (:)
real*8, allocatable :: zlon (:)
real*8, allocatable :: ozo (:,:)
integer :: alloc_status(40)
integer :: omp_get_num_threads, nthreads
integer :: istride, ilen, imodulo
integer :: nlevels,nobmax
integer :: j, i, krtid, jf, iobs, jj
integer :: knpf, jo
integer :: jk, jn, jl
integer :: ilansea,ilowlvl_M,ilowlvl_T, ig
integer :: knlev
real*8, allocatable :: to (:,:)
real*8, allocatable :: lqo (:,:)
real*8, allocatable :: zho (:,:)
real*8, allocatable :: toext (:,:)
real*8, allocatable :: qoext (:,:)
real*8, allocatable :: zhoext(:,:)
real*8, allocatable :: zvlev (:,:)
real*8, allocatable :: zt (:,:)
real*8, allocatable :: zlq (:,:)
real*8, allocatable :: zht (:,:)
real*8, allocatable :: xpres (:)
real*8 :: zptop, zptopmbs
real*8, allocatable :: toto3obs(:),PP(:,:)
external intavg
external lintv2
external exthum4
write(*,*) "Entering tovs_fill_profiles subroutine"
if(NOBTOV.eq.0) return ! exit if there are no tovs data
knlev = col_getNumLev(lcolumnghr,'TH')
!
! 1. Set index for model's lowest level and model top
! . ------------------------------------------------
100 continue
if ( col_getPressure(lcolumnghr,1,1,'TH') .lt. col_getPressure(lcolumnghr,knlev,1,'TH') ) then
ilowlvl_M = col_getNumLev(lcolumnghr,'MM')
ilowlvl_T = col_getNumLev(lcolumnghr,'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(lcolumnghr,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 (ksurf (jppf*nthreads) ,stat= alloc_status(1) )
allocate (iptobs (jppf*nthreads) ,stat= alloc_status(2) )
allocate (iptobscma (jppf*nthreads) ,stat= alloc_status(3) )
allocate (isatzen (jppf*nthreads) ,stat= alloc_status(4) )
allocate (isatazim (jppf*nthreads) ,stat= alloc_status(5) )
allocate (isunza (jppf*nthreads) ,stat= alloc_status(6) )
allocate (zlat (jppf*nthreads) ,stat= alloc_status(8) )
allocate (zlon (jppf*nthreads) ,stat= alloc_status(9) )
allocate (ozo (nlevels,jppf*nthreads),stat= alloc_status(10))
allocate (to (jpmolev,jppf*nthreads),stat= alloc_status(11))
allocate (lqo (jpmolev,jppf*nthreads),stat= alloc_status(12))
allocate (zho (jpmolev,jppf*nthreads),stat= alloc_status(13))
allocate (toext (nlevels ,jppf*nthreads),stat= alloc_status(14))
allocate (qoext (nlevels ,jppf*nthreads),stat= alloc_status(15))
allocate (zhoext (nlevels ,jppf*nthreads),stat= alloc_status(16))
allocate (zvlev (knlev,jppf*nthreads),stat= alloc_status(17))
allocate (zt (knlev,jppf*nthreads),stat= alloc_status(18))
allocate (zlq (knlev,jppf*nthreads),stat= alloc_status(19))
allocate (zht (knlev,jppf*nthreads),stat= alloc_status(20))
if( any(alloc_status /= 0) ) then
write(*,*) ' tovs_fill_profiles : memory allocation error'
call abort3d('tovs_fill_profiles ')
end if
! 1.2 Read ozone climatology
! . ----------------------
call ozo_read_climatology(datestamp)
!
! 2. 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
jo = lobsno(iobs)
if (lsensor(iobs)/=krtid) cycle bobs
knpf = knpf + 1
! extract land/sea/sea-ice flag (0=land, 1=sea, 2=sea-ice)
ilansea = obs_headElem_i(lobsSpaceData,OBS_OFL,jo)
ksurf(knpf) = ilansea
! extract satellite zenith and azimuth angle,
! sun zenith angle, cloud fraction, latitude and longitude
isatzen(knpf) = obs_headElem_i(lobsSpaceData,OBS_SZA,jo)
isatazim(knpf) = obs_headElem_i(lobsSpaceData,OBS_AZA,jo)
isunza(knpf) = obs_headElem_i(lobsSpaceData,OBS_SUN,jo)
zlat(knpf) = obs_headElem_r(lobsSpaceData,OBS_LAT,jo) *MPC_DEGREES_PER_RADIAN_R8
zlon(knpf) = obs_headElem_r(lobsSpaceData,OBS_LON,jo) *MPC_DEGREES_PER_RADIAN_R8
do jl = 1, knlev
zt (jl,knpf) = col_getElem(lcolumnghr,jl,jo,'TT')
zlq (jl,knpf) = col_getElem(lcolumnghr,jl,jo,'HU')
zvlev(jl,knpf) = col_getPressure(lcolumnghr,jl,jo,'TH') * MPC_MBAR_PER_PA_R8
zht (jl,knpf) = col_getHeight(lcolumnghr,jl,jo,'TH') / rg
enddo
!!! Fix temporaire (?) pour eviter probleme au toit avec GEM 4: on ne veut pas utiliser
!!! le premier niveau de GEM qui est disgnostique (extrapole a partir des deux niveaux plus bas)
!!! (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) ! extrapolation valeur constante pour H2O peu important a cette hauteur
!!!!
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, logarithm of
! specific humidity and height levels to pressure levels
! required by tovs rt model
! . ------------------------------------------
!$omp parallel private(istride)
imodulo = mod(knpf,nthreads)
if ( imodulo .eq. 0 ) then
istride = max(1,(knpf/nthreads))
else
istride = max(1,(knpf/nthreads)+1)
endif
!$omp do private(jn,ilen)
do jn=1,knpf,istride
ilen = min (knpf-jn+1,istride)
if ( ilen .gt. 0) then
call intavg (zvlev(:,jn:jn+ilen-1),zt(:,jn:jn+ilen-1),knlev,knlev,ilen, &
jpmolev,xpres(jpmotop:nlevels),to(:,jn:jn+ilen-1))
call intavg (zvlev(:,jn:jn+ilen-1),zlq(:,jn:jn+ilen-1),knlev,knlev,ilen, &
jpmolev,xpres(jpmotop:nlevels),lqo(:,jn:jn+ilen-1))
call lintv2 (zvlev(:,jn:jn+ilen-1),zht(:,jn:jn+ilen-1),knlev,knlev,ilen, &
jpmolev,xpres(jpmotop:nlevels),zho(:,jn:jn+ilen-1))
endif
enddo
!$omp end do
!$omp end parallel
! . 2.2 Extrapolation of temperature profile above model top
! . ----------------------------------------------------
toext(:,:) = 0.0d0
if ( abs( zptopmbs - 10.0d0 ) > .1d0 ) then ! si le toit n'est pas a 10. hPa
!constant value extrapolation for now modified with a bias....
do jn=1,knpf
toext(nlevels-jpmolev+1:nlevels,jn) = to(1:jpmolev,jn)
if (nlevels==51) then
! si coefficients sur 51 niveaux 2 niveaux au dessus de 0.1 hPa
toext(1,jn) = to(1,jn) - 33.77d0
toext(2,jn) = to(1,jn) - 22.33d0
else
! si coefficients sur 44 niveaux 1 niveau au dessus de 0.1 hPa
toext(1,jn) = to(1,jn) - 33.77d0
endif
enddo
else
! vieux code pour extrapolation du profil de temperature
call extrap (to,toext,jpmolev,nlevels,knpf)
endif
! . 2.3 Extrapolation of height profile above model top
! . -----------------------------------------------
zhoext(:,:) = 0.0d0
call htextrap (zhoext,zho,xpres(1:nlevels),nlevels,jpmolev,jpmotop,knpf)
! . 2.4 Extrapolation of humidity profile (kg/kg)
! above rlimlvhu (normally 300mbs or 70mbs)
! . -----------------------------------------
qoext(:,:) = 0.0d0
do jn = 1, knpf
do jk = 1, jpmolev
qoext(nlevels-jpmolev+jk,jn) = exp(lqo(jk,jn))
enddo
enddo
if ( abs( zptopmbs - 10.0d0 ) > .1d0 ) then ! si le toit n'est pas a 10. hPa
qoext(1:jpmotop,1:knpf) = MPC_MINIMUM_HU_R8
else
if ( ldbgtov ) then
do jn = 1, knpf
write(*,*)'qoext*1000 avant exthum4 = '
write(*,9263)(qoext(i,jn)*1000.d0,i=1,nlevels)
write(*,*)' '
enddo
endif
call exthum4 (knpf,nlevels,xpres(1:nlevels),qoext,LIMLVHU)
if ( ldbgtov ) then
do jn = 1, knpf
write(*,*)'qoext*1000 apres exthum4 = '
write(*,9263)(qoext(i,jn)*1000.d0,i=1,nlevels)
write(*,*)' '
enddo
endif
endif
! . 2.5 Get ozone profiles (ppmv)
! . -------------------------
allocate ( toto3obs(knpf) )
toto3obs(:) = 0.d0
allocate( PP(nlevels,knpf) )
DO J=1,knpf
PP(1:nlevels,J)=xpres(1:nlevels)
ENDDO
call ozo_get_profile (ozo,toto3obs,zlat, &
pp,nlevels,knpf,datestamp)
deallocate( PP )
deallocate ( toto3obs )
! . 2.6 Fill profiles structure
! . -----------------------
do j = 1 , knpf
jj=iptobs(j)
profiles(jj) % id = "" ! profile id, up to 128 characters, to consider for use
profiles(jj) % nlevels = nlevels
profiles(jj) % nlayers = nlevels - 1
profiles(jj) % zenangle = (isatzen(j)-9000)/100.0
!pour ne pas faire planter RTTOV dans le cas (rare) ou isatzen n'est pas defini ou invalide
if (profiles(jj) % zenangle .lt.0.0d0 .or. &
profiles(jj) % zenangle .gt. zenmax ) then
write(*,*) "!!! WARNING !!!"
write(*,*) "INVALID ZENITH ANGLE"
write(*,*) "angle, profile number, sensor", profiles(jj) % zenangle, jj, krtid
write(*,*) "replaced by 0.0 !!!"
profiles(jj) % zenangle=0.d0
endif
!**********************************************************
profiles(jj) % azangle = (isatazim(j))/100.0d0
profiles(jj) % sunzenangle = (isunza(j)-9000)/100.0d0
profiles(jj) % sunazangle = 0.d0 ! necessaire pour radiation solaire a changer plus tard
profiles(jj) % latitude = zlat(j)
profiles(jj) % longitude = zlon(j)
profiles(jj) % elevation = 0.001d0*zht(ilowlvl_T,j) ! unite km
profiles(jj) % skin % surftype = ksurf(j)
profiles(jj) % skin % watertype= 1 !utilise pour calcul rayonnement solaire reflechi seulement
profiles(jj) % skin % t = col_getElem(lcolumnghr,1,iptobscma(j),'TG')
profiles(jj) % skin % salinity = 35.d0 ! for FASTEM-4 only to revise (practical salinity units)
profiles(jj) % skin % fastem(:)= 0.0d0
!
profiles(jj) % s2m % t = col_getElem(lcolumnghr,ilowlvl_T,iptobscma(j),'TT')
!!! profiles(jj) % s2m % q = exp(col_getElem(lcolumnghr,ilowlvl_T,iptobscma(j),'HU')) * q_mixratio_to_ppmv
profiles(jj) % s2m % q = 0.3D6 !! new a value between 0 and 0.6d6 so that RTTOV will not complain
profiles(jj) % s2m % p = col_getElem(lcolumnghr,1 ,iptobscma(j),'P0')*MPC_MBAR_PER_PA_R8
profiles(jj) % s2m % u = col_getElem(lcolumnghr,ilowlvl_M,iptobscma(j),'UU')
profiles(jj) % s2m % v = col_getElem(lcolumnghr,ilowlvl_M,iptobscma(j),'VV')
profiles(jj) % s2m % o = 0.0d0 !surface ozone never used
profiles(jj) % s2m % wfetc = 100000.0d0 ! Wind fetch (in meter for rttov10 ?) used to calculate reflection of solar radiation by sea surface
!
profiles(jj) % idg = 0
profiles(jj) % ish = 0
profiles(jj) % snow_frac = 0.d0 ! Surface coverage snow fraction(0-1), used only by IR emissivity atlas
profiles(jj) % soil_moisture = 0.d0 ! soil moisure (m**3/m**3) not yet used
profiles(jj) % Be = 0.4d0 ! earth magnetic field strength (gauss) (must be non zero)
profiles(jj) % cosbk = 0.0d0 ! cosine of the angle between the earth magnetic field and wave propagation direction
if ( bgckMode ) then
profiles_qc(jj) % lat = zlat(j)
profiles_qc(jj) % lon = zlon(j)
profiles_qc(jj) % sunza = profiles(jj) % sunzenangle
endif
if(coefs(krtid)%coef%nco2 > 0) then
ig= coefs(krtid)%coef%fmv_gas_pos(gas_id_co2)
profiles(jj) % co2(:) = coefs(krtid)%coef%ref_prfl_mr(:,ig)
endif
if(coefs(krtid)%coef%nn2o > 0) then
ig = coefs(krtid)%coef%fmv_gas_pos(gas_id_n2o)
profiles(jj) % n2o(:) = coefs(krtid)%coef%ref_prfl_mr(:,ig)
endif
if(coefs(krtid)%coef%nco > 0) then
ig = coefs(krtid)%coef%fmv_gas_pos(gas_id_co)
profiles(jj) % co(:) = coefs(krtid)%coef%ref_prfl_mr(:,ig)
endif
if(coefs(krtid)%coef%nch4 > 0) then
ig = coefs(krtid)%coef%fmv_gas_pos(gas_id_ch4)
profiles(jj) % ch4(:) = coefs(krtid)%coef%ref_prfl_mr(:,ig)
endif
profiles(jj) % p(:) = coefs(krtid) %coef% ref_prfl_p(:)
profiles(jj) % t(:) = toext(:,j)
profiles(jj) % q(:) = qoext(:,j) * q_mixratio_to_ppmv
profiles(jj) % o3(:) = ozo(:,j)
if ( bgckMode ) profiles_qc(jj) % z(:) = zhoext(:,j)
profiles(jj) % ctp = 1013.25d0
profiles(jj) % cfraction = 0.d0
end do
! next bunch !
knpf = 0
enddo bobs
enddo binst
alloc_status(:) = 0
deallocate (ksurf ,stat= alloc_status(1) )
deallocate (iptobs ,stat= alloc_status(2) )
deallocate (iptobscma ,stat= alloc_status(3) )
deallocate (isatzen ,stat= alloc_status(4) )
deallocate (isatazim ,stat= alloc_status(5) )
deallocate (isunza ,stat= alloc_status(6) )
deallocate (zlat ,stat= alloc_status(8) )
deallocate (zlon ,stat= alloc_status(9) )
deallocate (ozo ,stat= alloc_status(10))
deallocate (to ,stat= alloc_status(11))
deallocate (lqo ,stat= alloc_status(12))
deallocate (zho ,stat= alloc_status(13))
deallocate (toext ,stat= alloc_status(14))
deallocate (qoext ,stat= alloc_status(15))
deallocate (zhoext ,stat= alloc_status(16))
deallocate (zvlev ,stat= alloc_status(17))
deallocate (zt ,stat= alloc_status(18))
deallocate (zlq ,stat= alloc_status(19))
deallocate (zht ,stat= alloc_status(20))
deallocate (xpres ,stat= alloc_status(21))
if( any(alloc_status /= 0) ) then
write(*,*) ' tovs_fill_profiles : memory deallocation error'
call abort3d('tovs_fill_profiles ')
end if
9263 format(1x,10f8.4)
! 3. Close up
! . --------
return
end subroutine tovs_fill_profiles