!-------------------------------------- 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 --------------------------------------
!
*DECK AVTAP
SUBROUTINE AVTAP 1
C
#if defined (DOC)
*S/P AVTAP: Adjoint de VTAP
C
C AUTHOR: Luc Fillion - ARMA/AES CAN, 21 jul, 11 sep 98
C
C REVISION:
* S. Pellerin - Sept 97 - Introduction of site constants
* common (comphy)
* - Introduction of surface pressure
* dependant factor (rtapfac) for eta
* coordinates
* - use of gomt1 for virtual temperature
* revision: Luc Fillion - ARMA/AES CAN, 3 feb 1999
* - Eliminate rtapfac
* C.Charette - ARMA sep 1999
* - Added LLPRINT
* S. Pellerin *ARMA/SMC May 2000
* - Fix for F90 conversion
* C. Charette ARMA/SMC FEV. 2002
* - Commented out the if(llprint...) statements within
* the do loops. They were preventing vectorization.
* Bin He - ARMA June 2005
* - OpenMP optimization.
* C. Charette ARMA/SMC jan. 2005
* - Replaced print statements by write statements
#endif
IMPLICIT NONE
C
INTEGER jobs, IKLEVM2, JK, IK
REAL*8 ZAK, ZBK, ZCK, ZCON
LOGICAL LLPRINT
*implicits
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comode.cdk"
#include "commvo.cdk"
#include "commvo1.cdk"
#include "comphy.cdk"
#include "comlun.cdk"
*
**
integer myid,numthd,omp_get_thread_num,omp_get_num_threads
c
LLPRINT = .FALSE.
ZCON = -RGASD
IKLEVM2 = nflev-2
!$OMP PARALLEL PRIVATE(jobs,jk,myid,numthd,zak,zbk,zck)
myid=omp_get_thread_num()+1
numthd=omp_get_num_threads()
do jobs = myid, nobtot,numthd
do jk=1,nflev
gomt1(jk,jobs) = 0.0
enddo
c
do jk=iklevm2,1,-1
ik = nflev-1-jk
zak = -2.0*ZCON*vma(ik+1)
zbk = -2.0*ZCON*vmb(ik+1)
zck = -2.0*ZCON*vmc(ik+1)
! do jobs = 1, nobtot
gomt1(ik,jobs) = gomt1(ik,jobs)+
& gomgz(ik,jobs)*zak
gomt1(ik+1,jobs) = gomt1(ik+1,jobs)+
& gomgz(ik,jobs)*zbk
gomt1(ik+2,jobs) = gomt1(ik+2,jobs)+
& gomgz(ik,jobs)*zck
gomgz(ik+2,jobs) = gomgz(ik+2,jobs)+gomgz(ik,jobs)
gomgz(ik,jobs) = 0.0
********************************************************
c IF(LLPRINT .AND. JOBS.EQ.1) THEN
c write(nulout,*)'avtap:ik,jobs,zak,zbk,zck= '
c & ,ik,jobs,zak,zbk,zck
c write(nulout,*)
c & 'avtap:ik,jobs,gmt1(ik,),gmt1(ik+1,),gmt1(ik+2,)= '
c & ,ik,jobs,gomt1(IK,jobs),gomt1(IK+1,jobs),gomt1(IK+2,jobs)
c write(nulout,*)'avtap:ik,jobs,gomgz(ik,),gomgz(ik+2,)= '
c & ,ik,jobs,gomgz(ik,jobs),gomgz(ik+2,jobs)
c write(nulout,*)'avtap:ik,jobs= ',ik,jobs
c ENDIF
**********************************************************
enddo
ZAK = -2.0*ZCON*VMA(nflev)
ZBK = -2.0*ZCON*VMB(nflev)
ZCK = -2.0*ZCON*VMC(nflev)
! do jobs = 1, nobtot
gomt1(nflev-1,jobs) = gomt1(nflev-1,jobs)+
& ZAK*gomgz(nflev-1,jobs)
gomt1(nflev,jobs) = gomt1(nflev,jobs)+
& ZBK*gomgz(nflev-1,jobs)
gomt1(nflev-2,jobs) = gomt1(nflev-2,jobs)+
& ZCK*gomgz(nflev-1,jobs)
gomgz(nflev-1,jobs)= 0.0
gomgz(nflev,jobs) = 0.0
********************************************************
c IF(LLPRINT .AND. JOBS.EQ.1) THEN
c write(nulout,*)'avtap:ik,jobs,zak,zbk,zck= ',
c & ik,jobs,zak,zbk,zck
c write(nulout,*)
c & 'avtap:ik,jobs,gomt1(nf,),gomt1(nf-1,),gomt1(nf-2,)= '
c & ,nflev,jobs,gomt1(NFLEV,jobs),gomt1(NFLEV-1,jobs)
c & ,gomt1(NFLEV-2,jobs)
c write(nulout,*)
c & 'avtap:nflev,jobs,gomgz(nflev,),gomgz(nflev-1,)= '
c & ,nflev,jobs,gomgz(nflev,jobs),gomgz(nflev-1,jobs)
c write(nulout,*)'avtap:nflev,jobs= ',nflev,jobs
c ENDIF
**********************************************************
enddo
!$OMP END PARALLEL
C
C
RETURN
END