!-------------------------------------- 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_simul 1,4
#if defined (DOC)
*
**s/r readptot_simul -Read in Ptot
*
*Author  : Luc Fillion - 3 Oct 2008 - For testing 1obs with forced Ptot.
*Revision:
#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,nj_120
      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
      nj_120 = 120
      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_simul:DIMENSION OF PTOT ',INI,INJ,INK
        IF(INK .NE. 1 .AND. INK .NE. nj_120) THEN
          write(NULOUT,*) ' readptot_simul:3RD DIMENSION OF PTOT IS NOT VALID'
          CALL ABORT3D(NULOUT,'readptot_simul: Problem with PTOT.')
        ENDIF
C
        IF ( INK .EQ. 1 ) THEN
          DO JN = 1,nj_120
            DO JK1 = 1,INI
              DO JK2 = 1,INJ
                PtoT(JK1,JK2,JN) = ZBUFFER(JK1,JK2,1)
              ENDDO
            ENDDO
          ENDDO
        ENDIF
!
        if(ink .eq. nj_120) then
          if(IG2 .eq. 0 ) THEN
            write(NULOUT,*) ' readptot_simul:PTOT IS read S-->N, IG2= ',IG2
            write(NULOUT,*) ' readptot_simul: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_120) 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_simul: mlatobs = ',mlatobs
        DO JN = 1,nj
          DO JK1 = 1,INI
            DO JK2 = 1,INJ
              PtoT(JK1,JK2,JN) = PtoT(JK1,JK2,ipt)  ! use for all latitudes
            ENDDO
          ENDDO
        ENDDO
!
        if(lunitptot) then
          write(nulout,*) ' '
          write(nulout,*) '-----------------------------------------'
          write(nulout,*) 'readptot_simul: UNIT MATRIX USED FOR PTOT'
          write(nulout,*) '-----------------------------------------'
          write(nulout,*) ' '
          ptot(:,:,:) = 0.0
          do jj = 1,nj
            do jk1=1,nflev
              ptot(jk1,jk1,jj) = 1.0
            enddo
          enddo
        endif
!
        if(llprint) then
          DO JK1 = 1,INI
            DO JK2 = 1,INJ
              write(nulout,*) 'readptot_simul: 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_simul'
C
      RETURN
      END