!-------------------------------------- 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 1,3
#if defined (DOC)
*
***s/r att2phi - adjoint of Temperature to phi transformation
*
*
*Author : S. Pellerin *ARMA/AES September 1998
*
*Revision: L. Fillion *ARMA/AES - 24 nov 98
* - Include ES option
*Revision: L. Charette *ARMA/AES - 08 dec 98
* - Added llprint for diagnostics
*Revision: L. Fillion *ARMA/AES - 3 feb 1999
* - Introduce adjoint of ps dependence of TLM
*Revision: C. Charette *ARMA/AES - 8 feb 1999
* - Replaced zptop by rppobs(1,jobs)
* and zpscon by gompsg(1,jobs)
*
* JM Belanger CMDA/SMC Dec 2000
* . 32 bits conversion
* (replace real constant by REAL*8 alpha in
* call to MATAPAT).
* C. Charette ARMA/SMC FEV. 2002
* - Commented out the if(llprint...) statements within
* the do loops. They were preventing vectorization.
* P. Koclas P. Koclas
* -changed nesting of loops ( conversion to IBM)
* C. Charette - ARMA/SMC - Jun. 2003
* - Conversion to hybrid vertical coordinate
*
* Purpose: -call avtap for computation of adjoint of phi to adjoint
* of tv transformation
** -Computation of adjoint temperature variable and
* adjoint of logarith of specific humidity due to virtual
* temperature increments
*
*
*
*
*Arguments
*
#endif
IMPLICIT NONE
*implicits
*------------------------------------------------------------------------
#include "comlun.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comcva.cdk"
#include "comdimo.cdk"
#include "commvo.cdk"
#include "commvo1.cdk"
#include "commvog.cdk"
#include "comgem.cdk"
#include "comcst.cdk"
*
integer jobs,jlev
logical llprint
real*8 zcon, zalpha, psurf
real*8 zpresb,zpresbd,zterm
*
**
C
llprint = .false.
c llprint = .true.
c
zalpha=0.0D0
call matapat(vhybinc,zalpha,nflev)
call avtap
c
c* Adjoint of preparation r.h.s. for TL-Hydrostatic equation
c ---------------------------------------------------------
c
!$OMP PARALLEL DO PRIVATE(jobs,jlev,zpresb,zterm,zpresbd,zcon)
do jobs = 1, nobtot
do jlev = 1, nflev
c
c zcon = d(rtapfac)/d(ps)
c
zpresb = ((vhybinc(jlev) - rptopinc/rprefinc)
& /(1.0D0-rptopinc/rprefinc))**rcoefinc
if((rcoefinc-1.0) .lt. RPRECIS) then
zterm = 1.0
else
zterm = ((vhybinc(jlev) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**(rcoefinc-1.0)
endif
zpresbd= rcoefinc * zterm
zcon = (zpresbd-zpresb*rtapfac(jlev,jobs))/rppobs(jlev,jobs)
gomps(1,jobs)=gomps(1,jobs)+
& gomtg(jlev,jobs)*zcon * gomt1(jlev,jobs)
gomt1(jlev,jobs)=rtapfac(jlev,jobs)*gomt1(jlev,jobs)
enddo
enddo
!$OMP END PARALLEL DO
c
if(chum.eq.'LQ') then
c
!$OMP PARALLEL DO PRIVATE(jobs,jlev)
do jobs = 1, nobtot
do jlev = 1, nflev
gomt(jlev,jobs) = gomt(jlev,jobs)+
& oltv(1,jlev,jobs)*gomt1(jlev,jobs)
gomq(jlev,jobs) = gomq(jlev,jobs)+
& oltv(2,jlev,jobs)*gomt1(jlev,jobs)
***************************************************************
c if(llprint .and. jobs.le.15) then
c write(nulout,*)'att2phi: jobs,jlev,OLTV(1,,),OLTV(2,,)'
c & , jobs,jlev,OLTV(1,jlev,jobs),OLTV(2,jlev,jobs)
c write(nulout,*)'att2phi:gmt1,GMQ(lev,obs),GMT(lev,obs) '
c & ,gomt1(jlev,jobs),gomq(jlev,jobs),gomt(jlev,jobs)
c call vflush(nulout)
c endif
***************************************************************
enddo
enddo
!$OMP END PARALLEL DO
else if(chum.eq.'ES') then
!$OMP PARALLEL DO PRIVATE(jobs,jlev)
do jobs = 1, nobtot
do jlev = 1, nflev
gomt(jlev,jobs) = gomt(jlev,jobs)+
& oltv(1,jlev,jobs)*gomt1(jlev,jobs)
gomq1(jlev,jobs) = oltv(2,jlev,jobs)*gomt1(jlev,jobs)
***************************************************************
c if(llprint .and. jobs.le.15) then
c write(nulout,*)'att2phi: jobs,jlev,OLTV(1,,),OLTV(2,,)'
c & , jobs,jlev,OLTV(1,jlev,jobs),OLTV(2,jlev,jobs)
C write(nulout,*)'att2phi:gmt1,GMQ1(lev,obs),GMT(lev,obs) '
c & ,gomt1(jlev,jobs),gomq1(jlev,jobs),gomt(jlev,jobs)
c call vflush(nulout)
c endif
***************************************************************
enddo
enddo
!$OMP END PARALLEL DO
c
c compute (adelt, adel(T-Td)) from adelq
c
call aesahuo
***************************************************************
c if(llprint .and. jobs.le.15) then
c write(nulout,*)'att2phi: AFTER CALL AESAHUO '
c do jlev = 1, nflev
c do jobs = 1, nobtot
c write(nulout,*)'att2phi: jobs,jlev,GOMT1,GOMQ,GOMT '
c & ,gomt1(jlev,jobs),gomq(jlev,jobs),gomt(jlev,jobs)
c enddo
c enddo
c call vflush(nulout)
c endif
***************************************************************
endif
c
return
end