!-------------------------------------- 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 READPTOT 2,4
#if defined (DOC)
*
**s/r readptot -Read in balance operator coefficients
*     .
* Purpose
*     .  Read in coefficients for P_to_T operator and also turning angle
*        for balanced divergence operator
*
*Author  : Mark Buehner *ARMA/AES  August, 1998
*Revision:
*          C. Charette *ARMA/AES Nov 1998
*          - Changed LDIVBAL to LBALDIV
*
*          C. Charette *ARMA/AES SEP 1999
*          - Operator PTOT as a function of latitude
*          C. Charette *ARMA/AES Jan 2000
*          - Remove fnom. Assume stats file is  already open
*          S. Pellerin *ARMA/SMC May 2000
*          - Logical unit cleanup
*          JM Belanger CMDA/SMC  Jul 2000
*                   . 32 bits conversion
*           C. Charette - ARMA/SMC - Sep. 2004
*            - Support etikets 'P_TO_T' or 'P_to_T'
*           L. Fillion - ARMA/EC - 3 Sep. 2008
*            - Used to read the gridpoint P_TO_T array on the global stats file in simulated analysis mode.
#endif
      IMPLICIT NONE
*implicits
*
*     Global variables
*
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcorr.cdk"
#include "comcse1.cdk"
#include "comcva.cdk"
#include "comsim.cdk"
*
*     Local variables
*
      INTEGER KDATESTAMP, KENSEMBLE
      INTEGER JN, JK1, JK2, IKEY, ILEN
      REAL*8 ZBUFFER(NFLEV+1,NFLEV,NJ)
      POINTER (PXZBUFFER,ZBUFFER)

      logical llprint
      integer ipt,jj
      external vfstlir

#include "rpnstd.cdk"
*
**
*-----------------------------------------------------------------
!
      llprint = .true.
*     0. Allocating a local array
*
      ILEN = NJ*NFLEV*(NFLEV+1)
      CALL HPALLOC(PXZBUFFER,MAX(1,ILEN),IERR,8)
C
      IP1 = -1
      IP2 = -1
      IP3 = -1
      IDATEO = -1
C
c Check if balanced divergence is activated
      if(LBALDIV) then
        IKEY = VFSTLIR(THETA(1,1),nulbgst,INI,INJ,INK
     S      ,IDATEO,'THETA   ',IP1,IP2,IP3,'X','ZZ')
      endif
C
      IKEY = VFSTLIR(ZBUFFER,nulbgst,INI,INJ,INK
     S      ,IDATEO,'P_to_T  ',IP1,IP2,IP3,'X','ZZ')
      IF(IKEY .LT. 0) THEN
        IKEY = VFSTLIR(ZBUFFER,nulbgst,INI,INJ,INK
     S       ,IDATEO,'P_TO_T  ',IP1,IP2,IP3,'X','ZZ')
      ENDIF
C
      IF(IKEY .GE. 0) THEN
        write(NULOUT,*) ' PTOT IS AVAILABLE'
        IERR = FSTPRM(IKEY,IDATEO,IDEET,INPAS
     +       ,INI,INJ,INK, INBITS, IDATYP
     +       ,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP
     +       ,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
     +       ,IUBC,IEXTR1,IEXTR2,IEXTR3)
C
        write(NULOUT,*) ' readptot:DIMENSION OF PTOT ',INI,INJ,INK
        IF(INK .NE. 1 .AND. INK .NE. NJ) THEN
          write(NULOUT,*) ' readptot:3RD DIMENSION OF PTOT IS NOT VALID'
          CALL ABORT3D(NULOUT,'readptot: Problem with PTOT.')
        ENDIF
C
        IF ( INK .EQ. 1 ) THEN
          DO JN = 1,NJ
            DO JK1 = 1,INI
              DO JK2 = 1,INJ
                PtoT(JK1,JK2,JN) = ZBUFFER(JK1,JK2,1)
              ENDDO
            ENDDO
          ENDDO
        ENDIF

        if(ink .eq. nj) then
          if(IG2 .eq. 0 ) THEN
            write(NULOUT,*) ' readptot:PTOT IS read S-->N, IG2= ',IG2
            write(NULOUT,*) ' readptot:PTOT IS stored N-->S '
            DO JN = 1,INK
              DO JK1 = 1,INI
                DO JK2 = 1,INJ
                  PtoT(JK1,JK2,INK-JN+1) = ZBUFFER(JK1,JK2,JN)
                ENDDO
              ENDDO
            ENDDO
          ELSE
            DO JN = 1,INK
              DO JK1 = 1,INI
                DO JK2 = 1,INJ
                  PtoT(JK1,JK2,JN) = ZBUFFER(JK1,JK2,JN)
                ENDDO
              ENDDO
            ENDDO
          ENDIF
        ENDIF
      ELSE
        write(NULOUT,*) ' PTOT NOT AVAILABLE'
      ENDIF
      IERR = FSTPRM(IKEY,IDATEO,IDEET,INPAS
     +     ,INI,INJ,INK, INBITS, IDATYP
     +     ,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP
     +     ,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
     +     ,IUBC,IEXTR1,IEXTR2,IEXTR3)
C
      KENSEMBLE  = IP3
      KDATESTAMP = IDATEO
*
      write(NULOUT,*) 'Size of ensemble used to est. P_to_T=',
     +                KENSEMBLE
*
      if(l1obs) then ! will force a unique regression valid at the location of the simulated obs
        if(mlatobs.lt.0.or.mlatobs.gt.nj) mlatobs = 1  ! case where suobs_sim.ftn hasnt been called yet...
        if(mlatobs.eq.0) mlatobs = 1  ! case where obs. is at the Pole...
        ipt = mlatobs
        write(nulout,*) 'readptot: mlatobs = ',mlatobs
        DO JN = 1,INK
          DO JK1 = 1,INI
            DO JK2 = 1,INJ
              PtoT(JK1,JK2,JN) = PtoT(JK1,JK2,ipt)  ! use for all latitudes
            ENDDO
          ENDDO
        ENDDO
!
        if(llprint) then
          DO JK1 = 1,INI
            DO JK2 = 1,INJ
              write(nulout,*) 'readptot: jk1,jk2,ptot(jk1,jk2,1)=',
     &           jk1,jk2,ptot(jk1,jk2,1)
            enddo
          enddo
        endif
      endif
*
*     9. Deallocate local arrays
*
      CALL HPDEALLC(PXZBUFFER,IERR,1)
*
      write(NULOUT,*)'DONE in READPTOT'
C
      RETURN
      END