!-------------------------------------- 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 tt2phi(lcolumnghr) 2,6
#if defined (DOC)
*
***s/r tt2phi - Temperature to geopotential transformation
*
*
*Author : S. Pellerin *ARMA/AES September 1998
*
** Purpose: -Computation of virtual temperature
*
* -call vtap for Tv to phi transformation
*
*
*Arguments
*
#endif
use columnData_mod
IMPLICIT NONE
c
type(struct_columnData) :: lcolumnghr
integer jobs,jlev,nlev_T
real*8 alpha
real*8, allocatable :: vmahr(:)
real*8, allocatable :: vmbhr(:)
real*8, allocatable :: vmchr(:)
real*8, allocatable :: vmdhr(:)
real*8, allocatable :: vmehr(:)
real*8, allocatable :: vmfhr(:)
real*8, allocatable :: pressure(:)
*
nlev_T = col_getNumLev(lcolumnghr,'TH')
allocate(vmahr(nlev_T))
allocate(vmbhr(nlev_T))
allocate(vmchr(nlev_T))
allocate(vmdhr(nlev_T))
allocate(vmehr(nlev_T))
allocate(vmfhr(nlev_T))
allocate(pressure(nlev_T))
*
alpha=-1.0D0
c
!$OMP PARALLEL DO PRIVATE(jobs,jlev,pressure,
!$OMP& vmahr,vmbhr,vmchr,vmdhr,vmehr,vmfhr)
do jobs = 1, col_getNumCol(lcolumnghr)
do jlev = 1, nlev_T
pressure(jlev)=col_getPressure(lcolumnghr,jlev,jobs,'TH')
enddo
call matapatnew(pressure,alpha,nlev_T,vmahr,vmbhr,vmchr,vmdhr,vmehr,vmfhr)
call vtap1dnew(jobs,nlev_T,vmahr,vmbhr,vmchr,vmdhr,vmehr,vmfhr)
enddo
!$OMP END PARALLEL DO
c
deallocate(vmahr)
deallocate(vmbhr)
deallocate(vmchr)
deallocate(vmdhr)
deallocate(vmehr)
deallocate(vmfhr)
deallocate(pressure)
c
return
CONTAINS
SUBROUTINE matapatnew(pvlev,palpha,knlev,vmahr,vmbhr,vmchr,vmdhr,vmehr,vmfhr) 1
C
*S/R MATAPATNEW:
C CALCULE LES ELEMENTS DE LA MATRICE TRIDIAGONALE ASSOCIEE A LA
C SOLUTION PAR UN ALGORITHME DU 4EME ORDRE DE L'EQUATION
C T*S**ALPHA=D(P)/DS OU T ET P SONT DEUX FONCTIONS ECHANTILLONNEES
C AUX N NIVEAUX SIGMA. LES MATRICES GENEREES ICI SERONT UTILISEES
C PAR LES SUBR. VTAP ET VPAT. L'ALGORITHME EST DU A J. COTE.
C NOTE: ON CALCULE IMMEDIATEMENT DANS LE COMMON comode
C LES COEFFICIENTS GENERES PAR LA REDUCTION GAUSSIENNE
C LORS DU CALCUL DE T.
C
C AUTHOR: Michel Beland - RPN AVRIL 1984 - ADAPTE AU MODELE SEF
C
C ARGUMENTS:
C I - PVLEV : PROFILE OF PRESSURE VALUES
C I - PALPHA : EXPOSANT DE SIGMA.
C I - KNLEV : NUMBER OF PRESSURE VALUES
C
C NOTE:
C VMA(I),VMBHR(I),VMCHR(I): DIAG. INF., PRINC., ET SUP. DE LA MAT.
C
C
IMPLICIT NONE
integer knlev
real*8 palpha, pvlev(knlev)
real*8 :: vmahr(:)
real*8 :: vmbhr(:)
real*8 :: vmchr(:)
real*8 :: vmdhr(:)
real*8 :: vmehr(:)
real*8 :: vmfhr(:)
c
logical llprint
INTEGER jl,jlev,im, ilen
REAL*8 ZXM,ZX0,ZXP,ZAA,ZBB,ZEX,ZCC,ZQ(3),ZDD,ZDET
llprint = .false.
c
DO 20 jlev=1,KNLEV
ZX0=PVLEV(jlev)
IF (jlev.EQ.1) THEN
ZXM=PVLEV(1)
ZXP=PVLEV(2)
ZAA=PVLEV(3)-ZX0
ZBB=PVLEV(2)-ZX0
ELSEIF (jlev.EQ.KNLEV) THEN
ZXM=PVLEV(KNLEV-1)
ZXP=PVLEV(KNLEV)
ZAA=PVLEV(KNLEV-1)-ZX0
ZBB=PVLEV(KNLEV-2)-ZX0
ELSE
ZXM=PVLEV(jlev-1)
ZXP=PVLEV(jlev+1)
ZAA=ZXM-ZX0
ZBB=ZXP-ZX0
ENDIF
DO 10 jl=1,3
ZEX=PALPHA+real(jl,8)
IF(ZEX.NE.0.) ZQ(jl)=(ZXP**ZEX-ZXM**ZEX)/ZEX
IF(ZEX.EQ.0.) ZQ(jl)=LOG(ZXP/ZXM)
10 CONTINUE
ZQ(3)=ZQ(3)-ZX0*(2.0D0*ZQ(2)-ZX0*ZQ(1))
ZQ(2)=ZQ(2)-ZX0*ZQ(1)
ZCC=ZAA**2
ZDD=ZBB**2
ZDET=ZAA*ZDD-ZBB*ZCC
VMAHR(jlev)=(ZDD*ZQ(2)-ZBB*ZQ(3))/(2.0D0*ZDET)
VMCHR(jlev)=(ZAA*ZQ(3)-ZCC*ZQ(2))/(2.0D0*ZDET)
VMBHR(jlev)=ZQ(1)/2.0D0-VMAHR(jlev)-VMCHR(jlev)
20 CONTINUE
*
* COEFFICIENTS DE L'OPERATEUR INVERSE
*
DO 30 jlev=1,KNLEV
VMDHR(jlev)=VMAHR(jlev)
VMEHR(jlev)=VMBHR(jlev)
VMFHR(jlev)=VMCHR(jlev)
30 CONTINUE
*
VMDHR(1)=VMDHR(1)/VMFHR(2)
VMEHR(1)=VMEHR(1)-VMDHR(1)*VMDHR(2)
VMFHR(1)=VMFHR(1)-VMDHR(1)*VMEHR(2)
VMFHR(KNLEV)=VMFHR(KNLEV)/VMDHR(KNLEV-1)
VMDHR(KNLEV)=VMDHR(KNLEV)-VMFHR(KNLEV)*VMEHR(KNLEV-1)
VMEHR(KNLEV)=VMEHR(KNLEV)-VMFHR(KNLEV)*VMFHR(KNLEV-1)
*
VMEHR(1)=1.0D0/VMEHR(1)
DO 31 jlev=2,KNLEV
im=jlev-1
VMFHR(im)=VMFHR(im)*VMEHR(im)
31 VMEHR(jlev)=1.0D0/(VMEHR(jlev)-VMDHR(jlev)*VMFHR(im))
*
if(llprint) then
write(*,*)' '
write(*,*)'matapatnew: vmahr = ',vmahr
write(*,*)' '
write(*,*)'matapatnew: vmbhr = ',vmbhr
write(*,*)' '
write(*,*)'matapatnew: vmchr = ',vmchr
write(*,*)' '
write(*,*)'matapatnew: vmdhr = ',vmdhr
write(*,*)' '
write(*,*)'matapatnew: vmehr = ',vmehr
write(*,*)' '
write(*,*)'matapatnew: vmfhr = ',vmfhr
write(*,*)' '
endif
c
RETURN
END SUBROUTINE matapatnew
SUBROUTINE VTAP1DNEW(kobs,nlev,vmahr,vmbhr,vmchr,vmdhr,vmehr,vmfhr) 1,8
C
*S/P VTAP1DNEW:
* AUTHOR: Luc Fillion - ARMA/AES - 10 mar 99
*
use MathPhysConstants_mod
use physicsFunctions_mod
IMPLICIT NONE
INTEGER kobs,nlev
real*8 :: vmahr(:)
real*8 :: vmbhr(:)
real*8 :: vmchr(:)
real*8 :: vmdhr(:)
real*8 :: vmehr(:)
real*8 :: vmfhr(:)
real*8 :: ztv(nlev)
*
INTEGER JLON, IKLEVM2, JK, IK
REAL*8 ZAK, ZBK, ZCK,ZCON,zhu,mountain
real*8, pointer :: gz_column_t(:),gz_column_m(:)
**
do jk = 1, nlev_T
zhu = exp(col_getElem(lcolumnghr,jk,kobs,'HU'))
ztv(jk) = fotvt8(col_getElem(lcolumnghr,jk,kobs,'TT'),zhu)
enddo
c
ZCON = -MPC_RGAS_DRY_AIR_R8
ZAK = -2.0D0*ZCON*VMAHR(nlev_T)
ZBK = -2.0D0*ZCON*VMBHR(nlev_T)
ZCK = -2.0D0*ZCON*VMCHR(nlev_T)
gz_column_t => col_getColumn(lcolumnghr,kobs,'GZ','TH')
mountain = col_getMountain(lcolumnghr,kobs)
gz_column_t(nlev_T) = mountain
gz_column_t(nlev_T-1)=
$ ZAK*ztv(nlev_T-1)+
$ ZBK*ztv(nlev_T)+
& ZCK*ztv(nlev_T-2)+
$ gz_column_t(nlev_T)
IKLEVM2 = nlev_T-2
do JK = 1, IKLEVM2
IK = nlev_T-1-JK
ZAK = -2.0D0*ZCON*VMAHR(IK+1)
ZBK = -2.0D0*ZCON*VMBHR(IK+1)
ZCK = -2.0D0*ZCON*VMCHR(IK+1)
gz_column_t(IK)=ZAK*ztv(IK)+
$ ZBK*ztv(IK+1)+
$ ZCK*ztv(IK+2)+
+ gz_column_t(IK+2)
enddo
gz_column_m => col_getColumn(lcolumnghr,kobs,'GZ','MM')
gz_column_m(:) = gz_column_t(:)
end subroutine vtap1dnew
end