!-------------------------------------- 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,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
*          Bin He   - ARMA/MRB   - Oct. 2011,
*                   - 4Dvar optimization.

#endif
       USE modfgat,only : istepobs,nobs,notag
      IMPLICIT NONE
C
      INTEGER  jobs,iobs, 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,iobs,jk,myid,numthd,zak,zbk,zck)
      myid=omp_get_thread_num()+1
      numthd=omp_get_num_threads()
      do iobs = myid, nobs(istepobs) ,numthd
        jobs = notag(iobs,istepobs) 
         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