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

      SUBROUTINE VTAP1DHR(kobs) 1
#if defined (DOC)
C
*S/P VTAP1DHR:
* AUTHOR:  Luc Fillion - ARMA/AES - 10 mar 99
*
* REVISION:
*          S. Pellerin - ARMA/SMC - Sept. 2000
*                      - exclusion of commvo1
*                        and local allocation of working
*                        space for virtual temperature
*                        regional implementation
*
#endif
      IMPLICIT NONE
      INTEGER  kobs
*
      logical llprint
      INTEGER  JLON, IKLEVM2, JK, IK,ier
      REAL*8     ZAK, ZBK, ZCK,ZCON,ztv(1),zhu,fotvv
      pointer (pttv,ztv)
*implicits
#include "comlun.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "commvo.cdk"
#include "commvohr.cdk"
#include "comphy.cdk"
#include "dinternv.cdk"
#include "finternv.cdk"
*modules
*
**
      call hpalloc(pttv,nlevtrl,ier,8)
      do jk = 1, nlevtrl
        zhu = exp(gomqhr(jk,kobs))
        ztv(jk) = fotvv(gomthr(jk,kobs),zhu)
      enddo
      llprint = .false.
c
      ZCON = -RGASD
      ZAK = -2.0*ZCON*VMAHR(nlevtrl)
      ZBK = -2.0*ZCON*VMBHR(nlevtrl)
      ZCK = -2.0*ZCON*VMCHR(nlevtrl)
********************************************************
c       write(nulout,*)'vtaphr:nlevtrl,VMAHR,VMBHR,VMCHR ',
c     &       nlevtrl,VMAHR(nlevtrl),VMBHR(nlevtrl),VMCHR(nlevtrl)
********************************************************
      gomgzhr(nlevtrl,kobs) = RMTMOBS(kobs)
      gomgzhr(nlevtrl-1,kobs)=
     $                   ZAK*ztv(nlevtrl-1)+
     $                   ZBK*ztv(nlevtrl)+
     &                   ZCK*ztv(nlevtrl-2)+
     $                   gomgzhr(nlevtrl,kobs)
********************************************************
c       write(nulout,*)'vtaphr:nlevtrl,kobs,ak,bk,ck,gmgzhr(nlevtrl)',
c     &       nlevtrl,kobs,zak,zbk,zck,gomgzhr(nlevtrl,kobs)
c       write(nulout,*)'vtaphr:nlevtrl-1,kobs,ak,bk,ck,gmgzh(nlevtrl-1)'
c     &       ,nlevtrl-1,kobs,zak,zbk,zck,gomgzhr(nlevtrl-1,kobs)
********************************************************
      IKLEVM2 = nlevtrl-2
      do JK = 1, IKLEVM2
        IK = nlevtrl-1-JK
        ZAK = -2.0*ZCON*VMAHR(IK+1)
        ZBK = -2.0*ZCON*VMBHR(IK+1)
        ZCK = -2.0*ZCON*VMCHR(IK+1)
********************************************************
c       write(nulout,*)'vtaphr:ik+1,VMAHR,VMBHR,VMCHR ',
c     &       ik+1,VMAHR(ik+1),VMBHR(ik+1),VMCHR(ik+1)
********************************************************
        gomgzhr(IK,kobs)=ZAK*ztv(IK)+
     $                  ZBK*ztv(IK+1)+
     $                  ZCK*ztv(IK+2)+
     +                  gomgzhr(IK+2,kobs)
********************************************************
c          write(nulout,*)'vtaphr:ik,kobs,zak,zbk,zck,gomgzg= ',
c     &       ik,kobs,zak,zbk,zck,gomgzhr(ik,kobs)
c          write(nulout,*)'vtaphr:ik,kobs,ztv(ik),ztv(ik+1),ztv(ik+2)= '
c     &       ,ik,kobs,ztv(IK),ztv(IK+1),ztv(IK+2)
**********************************************************
      enddo
c
      if(llprint) then
        do jk=1,nlevtrl
          write(nulout,*)'vtap1dhr: Level, Background GZ,TT,TV = ',jk
     &         ,gomgzhr(jk,1),gomthr(jk,1),ztv(jk)
        enddo
      endif
C
      call hpdeallc(pttv,ier,1)
      RETURN
      END