!-------------------------------------- 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 --------------------------------------
***s/r vte_vrtical -  Vertical interpolation from pressure to hyb levels
*
#include "model_macros_f.h"
*

      subroutine vte_vrtical ( F_f, F_ps, np, nk, F_lna, lv, F_lapse_L ) 4,1
      implicit none
*
      logical F_lapse_L 
      integer lv, nk , np
      real    F_f(np,*), F_lna(lv), F_ps(np)
*
*AUTHOR
*     M. Valin DRPN SEPT 2000
*
*REVISION
* v2_30   Valin M.            - Initial version
*
*OBJECT
*     see above id
*
*ARGUMENTS
*  Name        I/O                 Description
*----------------------------------------------------------------
* F_f          I/O          field to interpolate going in        
*                           vertically interpolated field going out
* F_ps          I      LOG of PS                           
* F_topp        I      LOG of pressure at the TOP          
* F_pia, F_pib  I      Hybrid coordinate definition          
* F_lna         I      LOG of analysis levels              
* F_lapse       I      .false. for ZERO lapse rate         
*----------------------------------------------------------------------
*
#include "glb_ld.cdk"
#include "geomg.cdk"
**
      integer i,l
      real target(np,nk), xlapse, fdcol(np,lv), flapse(np), 
     $     source(np,lv), d(np,nk), expps(np)
      real*8 hr_8(lv), hrd_8(lv), hrsq_8(lv), conv_8, x_8, xp1_8, xm1_8
*
*     ---------------------------------------------------------------
*
      xlapse = 0.0
      if ( F_lapse_L ) xlapse = 1.0
      conv_8 = 100.
      conv_8 = dlog(conv_8)
*
      do l=1,lv-1                       ! interval between source levels
           hr_8(l) = 1.0/(F_lna(l+1)-F_lna(l))
         hrsq_8(l) = hr_8(l)*hr_8(l)
      enddo
      do l=2,lv-1                       ! scaling term
         hrd_8(l) = 1.0/(hr_8(l)+hr_8(l-1))
      enddo
*  
      do l=2,lv-1      ! fdcol will contain vertical derivative of f
         do i=1,np
            x_8   =F_f(i,l)
            xm1_8 =F_f(i,l-1)
            xp1_8 =F_f(i,l+1)
            fdcol(i,l) = (hrsq_8(l  )*(xp1_8-x_8) 
     $                  + hrsq_8(l-1)*(x_8-xm1_8)) * hrd_8(l)
         end do
      end do
*
      do i=1,np        ! adjust first and last level
         fdcol(i,1) = 0
         fdcol(i,lv)= hr_8(lv-1)*(F_f(i,lv)-F_f(i,lv-1))
         flapse(i)  = (fdcol(i,lv)-fdcol(i,lv-1))*hr_8(lv-1)*xlapse
      end do           ! flapse is column lapse rate for extrapolation
*
      do i=1,np        ! precompute exponentials (large savings)
         expps  (i) = exp(F_ps  (i))
      end do
*
      do l=1,nk      ! compute vertical coordinate of each target point
      do i=1,np
         target(i,l) =  log( Geomg_pia(l)+ Geomg_pibb(l) *expps(i) )
     $                - conv_8
      end do
      end do
*
      do l=1,lv       ! compute vertical coordinate of each source point
      do i=1,np
         source(i,l) = F_lna(l)
      end do
      end do
*
      call vterp2 (d,target,target,F_f,fdcol,source,np,np,lv,nk,flapse)
*
      do l=1,nk       ! copy result from temporary location into array F
      do i=1,np
         F_f(i,l) = d(i,l)
      end do
      end do
*
*     ---------------------------------------------------------------
*
      return
      end