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

       subroutine rdptotla 3,6
#if defined (DOC)
*
**s/r rdptotla -Read in balance operator in gridpoint space.
*     .
* Purpose
*     .  Read in coefficients for P_to_T operator and also turning angle
*        for balanced divergence operator
*
*Author  : L. Fillion *ARMA/MSC  8 Oct, 2005 
*Revision:
*
#endif
      IMPLICIT NONE
*implicits
*
*     Global variables
*
#include "taglam4d.cdk"
#include "comdim.cdk"
#include "comct0.cdk"
#include "comdimo.cdk"
#include "comlun.cdk"
#include "comcva.cdk"
#include "comfftla.cdk"
#include "comcorr.cdk"
#include "rpnstd.cdk"
#include "comoba.cdk"
#include "comoahdr.cdk"
#include "comoabdy.cdk"
*
      character*2 llgrd_typ
      integer jk1, jk2, ikey, ilen,jlat,jcol,ilat,jj,iflag,idum
      integer iy
      real*8 zfac
      real*8 znknk(nflev,nflev)
      real*8 zptotlir(nflev+1,nflev)
      real*8 zptotlirx(nflev+1,nflev,800)
      real*8 zptot(nflev+1,nflev)
!
      integer vfstlir,vfstecr
      external vfstlir,vfstecr
!
!!
      llgrd_typ = 'LU'
      if(llgrd_typ.eq.'LU') write(nulout,*) 'rdptotla: Will use P_to_T from LAM '
      if(llgrd_typ.eq.'GU') write(nulout,*) 'rdptotla: Will use P_to_T from Global '
      write(nulout,*) 'rdptotla: Start Reading in P_TO_T from unit:',nulbgst
!
      if(llgrd_typ.eq.'LU') then
        iy = 1 
        ink = nj
        cletiket = 'P_TO_TNJ'
      else if(llgrd_typ.eq.'GU') then
        iy = 1
        ink = 120
        cletiket = 'P_TO_T1 '
      endif
!
      ini = nflev + 1
      inj = nflev
      ip1 = -1
      ip2 = -1 
      ip3 = -1
      idateo = -1
      cltypvar = 'X'
      clnomvar = 'ZZ'
!
      call zero(ini*inj*800,zptotlirx)
      ierr = vfstlir(zptotlirx,nulbgst,ini,inj,ink,idateo,
     &               cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
      if(ierr.lt.0) then
        call abort3d(nulout,'rdptotla: Problem reading P_TO_T field')
      endif
!
      do jj = 1, nj
!        call zero(ini*inj,zptotlir)
!        ierr = vfstlir(zptotlir,nulbgst,ini,inj,ink,idateo,
!     &                 cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
!
        if(ierr.lt.0) then
          call abort3d(nulout,'rdptotla: Problem reading P_TO_T field')
        endif
!
        iflag=0
        do jk2 = 1,nflev
          do jk1 = 1, nflev + 1
            ptot(jk1,jk2,jj)= zptotlirx(jk1,jk2,jj)
            if(ptot(jk1,jk2,jj).ne.0.0) iflag=iflag+1
          enddo
        enddo
      enddo
!
      if(iflag.eq.0) then
        call abort3d(nulout,'rdptotla: P_TO_T Identically zero')
      endif
!
      do jk2 = 1,nflev
        do jk1 = 1, nflev + 1
          zptot(jk1,jk2)=ptot(jk1,jk2,1)
          if(jk1.le.nflev) znknk(jk1,jk2)=ptot(jk1,jk2,1)
        enddo
      enddo
!
      call zero(nflev*nflev,znknk)
      do jk2 = 1,nflev
        do jk1 = 1, nflev
          znknk(jk1,jk2)=ptot(jk1,jk2,1)
        enddo
      enddo
!
!      do jk2 = 1, nflev
!        znknk(1,jk2)=ptot(2,jk2,1)
!        do jj = 1, nj
!          ptot(1,jk2,jj)=ptot(2,jk2,jj)   ! ignore LAM model top's Level = 1 behaviour... set as Level 2.
!        enddo
!      enddo
!
!      call outhoriz2d(zptot,'ptot.od     ','PT',1,
!     &                1,nflev+1,1,nflev,nflev+1,nflev,1)
!      call outhoriz2d(znknk,'ptot_nknk.od','PT',1,
!     &                1,nflev,1,nflev,nflev,nflev,1)
!
      write(nulout,*)'DONE in rdptotla'
!
      return
      end