!-------------------------------------- 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 VTAP

      SUBROUTINE VTAP 1
#if defined (DOC)
C
*S/P VTAP:
*         CALCULE Y A PARTIR DE R PAR SOLUTION DE L'EQUATION R*CON=S**E*D(Y)
*         AVEC UN SCHEME DU 4EME ORDRE DU A J. COTE.
*         NOTE: CET ALGORITHME EST EXACTEMENT REVERSIBLE (VOIR VPAT).
*
*         ON DOIT FOURNIR LA COND
*         A LA LIMITE INF. Y(N). LA MATRICE MATAP A ETE CALCULEE DANS LA
*         SUBR. MATAPAT.
*
*
* AUTHOR: MICHEL BELAND - AVRIL 1984 - ADAPTE AU MODELE SEF, AVRIL 1984.
*
* REVISION: LUC FILLION - AUG 94 - MODIFIED FOR VARIATIONAL ANALYSIS.
*           S. Pellerin - Sept 97 - Use of gomt1 for virtual
*                                   temperatures and gomgzg for
*                                   background state
*                                -  Introduction of boundary conditions
*
#endif
      IMPLICIT NONE
      INTEGER  KILG, KLEV
*
      INTEGER  JLON, IKLEVM2, JK, IK, jobs
      REAL*8     ZAK, ZBK, ZCK,ZCON
*implicits
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comode.cdk"
#include "commvo.cdk"
#include "commvo1.cdk"
#include "commvog.cdk"
#include "comphy.cdk"
*modules
*
**
c
c gomt1 : working vector of virtual temperatures.
c
      ZCON = -RGASD
      ZAK = -2.0*ZCON*VMA(nflev)
      ZBK = -2.0*ZCON*VMB(nflev)
      ZCK = -2.0*ZCON*VMC(nflev)
********************************************************
c       print *,'vtap:nflev,VMA,VMB,VMC ',
c     &       nflev,VMA(nflev),VMB(nflev),VMC(nflev)
********************************************************
      do jobs = 1, nobtot
        gomgzg(nflev,jobs) = RMTMOBS(jobs)
        gomgzg(nflev-1,jobs)=
     $                   rtapfac(nflev-1,jobs)*ZAK*gomt1(nflev-1,jobs)+
     $                   rtapfac(nflev,jobs)*ZBK*gomt1(nflev,jobs)+
     &                   rtapfac(nflev-2,jobs)*ZCK*gomt1(nflev-2,jobs)+
     $                   gomgzg(nflev,jobs)
********************************************************
c       print *,'vtap:nflev,jobs,zak,zbk,zck,gomgzg(nflev,)',
c     &       nflev,jobs,zak,zbk,zck,gomgzg(nflev,jobs)
c       print *,'vtap:nflev-1,jobs,zak,zbk,zck,gomgzg(nflev-1,)',
c     &       nflev-1,jobs,zak,zbk,zck,gomgzg(nflev-1,jobs)
********************************************************
      enddo
      IKLEVM2 = nflev-2
      do JK = 1, IKLEVM2
        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)
********************************************************
c       print *,'vtap:ik+1,VMA,VMB,VMC ',
c     &       ik+1,VMA(ik+1),VMB(ik+1),VMC(ik+1)
********************************************************
        do jobs = 1, nobtot
          gomgzg(IK,jobs)=rtapfac(ik,jobs)*ZAK*gomt1(IK,jobs)+
     $                    rtapfac(ik+1,jobs)*ZBK*gomt1(IK+1,jobs)+
     $                    rtapfac(ik+2,jobs)*ZCK*gomt1(IK+2,jobs)+
     +                    gomgzg(IK+2,jobs)
********************************************************
c          print *,'vtap:ik,jobs,zak,zbk,zck,gomgzg= ',
c     &       ik,jobs,zak,zbk,zck,gomgzg(ik,jobs)
c          print *,'vtap:ik,jobs,gomt1(ik,),gomt1(ik+1,),gomt1(ik+2,)= '
c     &       ,ik,jobs,gomt1(IK,jobs),gomt1(IK+1,jobs),gomt1(IK+2,jobs)
c          print *,'vtap:ik,jobs,rtapfac(ik(ik+1)(ik+2)= '
c     &       ,ik,jobs,rtapfac(ik,jobs),rtapfac(ik+1,jobs),
c     &       rtapfac(ik+2,jobs)
**********************************************************

        enddo
      enddo
C
      RETURN
      END