!-------------------------------------- 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 att2phi(lcolumn,lcolumng) 1,13
*
***s/r att2phi - adjoint of Temperature to phi transformation
* - input and output are GZ, TT, PS, HU in lcolumn
*
*Author : S. Pellerin *ARMA/AES September 1998
*
use MathPhysConstants_mod
use columnData_mod
IMPLICIT NONE
type(struct_columnData) :: lcolumn,lcolumng
type(struct_vco), pointer :: vco_anl
integer jobs,jlev,nlev_T
real*8 :: zcon, zalpha
real*8, allocatable :: vma(:),vmb(:),vmc(:)
real*8, allocatable :: vmd(:),vme(:),vmf(:)
real*8, allocatable :: tv_tmp(:,:)
real*8, pointer :: tt_column(:),hu_column(:)
real*8, pointer :: gz_column_t(:),gz_column_m(:),ps_column(:)
*
nlev_T = col_getNumLev(lcolumn,'TH')
allocate(vma(nlev_T))
allocate(vmb(nlev_T))
allocate(vmc(nlev_T))
allocate(vmd(nlev_T))
allocate(vme(nlev_T))
allocate(vmf(nlev_T))
allocate(tv_tmp(nlev_T,col_getNumCol(lcolumn)))
vco_anl => col_getVco(lcolumng)
zalpha=0.0D0
call matapat(vco_anl%dhyb_m,zalpha,nlev_T,vma,vmb,vmc,vmd,vme,vmf)
call avtap
c
c* Adjoint of preparation r.h.s. for TL-Hydrostatic equation
c ---------------------------------------------------------
c
!$OMP PARALLEL DO PRIVATE(jobs,jlev,zcon,tt_column,
!$OMP& hu_column,ps_column)
do jobs = 1, col_getNumCol(lcolumn)
tt_column => col_getColumn(lcolumn,jobs,'TT')
hu_column => col_getColumn(lcolumn,jobs,'HU')
ps_column => col_getColumn(lcolumn,jobs,'P0')
do jlev = 1, nlev_T
c
c zcon = d(lcolumng%rtapfac)/d(ps)
c
zcon = (vco_anl%db_dhyb_M(jlev)-
+ vco_anl%db_M(jlev)*lcolumng%rtapfac(jlev,jobs))/
+ col_getPressure(lcolumng,jlev,jobs,'TH')
ps_column(1)=ps_column(1)+
& col_getElem(lcolumng,jlev,jobs,'TT')*zcon * tv_tmp(jlev,jobs)
tv_tmp(jlev,jobs)=lcolumng%rtapfac(jlev,jobs)*tv_tmp(jlev,jobs)
enddo
do jlev = 1, nlev_T
tt_column(jlev) = tt_column(jlev)+
& lcolumng%oltv(1,jlev,jobs)*tv_tmp(jlev,jobs)
hu_column(jlev) = hu_column(jlev)+
& lcolumng%oltv(2,jlev,jobs)*tv_tmp(jlev,jobs)
enddo
enddo
!$OMP END PARALLEL DO
deallocate(vma)
deallocate(vmb)
deallocate(vmc)
deallocate(vmd)
deallocate(vme)
deallocate(vmf)
deallocate(tv_tmp)
return
contains
SUBROUTINE AVTAP 1,4
*S/P AVTAP: Adjoint de VTAP
C
C AUTHOR: Luc Fillion - ARMA/AES CAN, 21 jul, 11 sep 98
C
use MathPhysConstants_mod
IMPLICIT NONE
INTEGER jobs, IKLEVM2, JK, IK
REAL*8 ZAK, ZBK, ZCK, ZCON2
integer mythread,numthd,omp_get_thread_num,omp_get_num_threads
c
ZCON2 = -MPC_RGAS_DRY_AIR_R8
IKLEVM2 = nlev_T-2
!$OMP PARALLEL PRIVATE(jobs,ik,jk,mythread,numthd,zak,zbk,zck,
!$OMP+ gz_column_t,gz_column_m)
mythread=omp_get_thread_num()+1
numthd=omp_get_num_threads()
do jobs = mythread, col_getNumCol(lcolumn),numthd
gz_column_m => col_getColumn(lcolumn,jobs,'GZ','MM')
gz_column_t => col_getColumn(lcolumn,jobs,'GZ','TH')
gz_column_t(:) = gz_column_t(:) + gz_column_m(:)
do jk=1,nlev_T
tv_tmp(jk,jobs) = 0.0d0
enddo
c
do jk=iklevm2,1,-1
ik = nlev_T-1-jk
zak = -2.0D0*ZCON2*vma(ik+1)
zbk = -2.0D0*ZCON2*vmb(ik+1)
zck = -2.0D0*ZCON2*vmc(ik+1)
tv_tmp(ik,jobs) = tv_tmp(ik,jobs)+
& gz_column_t(ik)*zak
tv_tmp(ik+1,jobs) = tv_tmp(ik+1,jobs)+
& gz_column_t(ik)*zbk
tv_tmp(ik+2,jobs) = tv_tmp(ik+2,jobs)+
& gz_column_t(ik)*zck
gz_column_t(ik+2) = gz_column_t(ik+2)+gz_column_t(ik)
gz_column_t(ik) = 0.0D0
enddo
ZAK = -2.0D0*ZCON2*VMA(nlev_T)
ZBK = -2.0D0*ZCON2*VMB(nlev_T)
ZCK = -2.0D0*ZCON2*VMC(nlev_T)
tv_tmp(nlev_T-1,jobs) = tv_tmp(nlev_T-1,jobs)+
& ZAK*gz_column_t(nlev_T-1)
tv_tmp(nlev_T,jobs) = tv_tmp(nlev_T,jobs)+
& ZBK*gz_column_t(nlev_T-1)
tv_tmp(nlev_T-2,jobs) = tv_tmp(nlev_T-2,jobs)+
& ZCK*gz_column_t(nlev_T-1)
gz_column_t(nlev_T-1)= 0.0D0
gz_column_t(nlev_T) = 0.0D0
enddo
!$OMP END PARALLEL
C
return
end subroutine avtap
end subroutine att2phi