!-------------------------------------- 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 GETFST(KULFST,CDCTL,CDTYPDA,KIP3) 16,9
#if defined (DOC)
*
*** s/r GETFST - Initialize the content of the model state by
* . reading within a RPN standard file
*
* Author : P. Gauthier *ARMA/AES June 9, 1992
* Revision:
* . P. Gauthier *ARMA/AES April 19, 1994
* . new option for normalized increments
* . P. Koclas *CMC/CMDA February 1994
* . - control type of data read via argument ctypda
* . - comtrl and namtrl replaced by comgdpar
* . P. Koclas *CMC/CMSV Januaryy 1997
* - common comvfiles (for trial field name)
* . S. Pellerin *ARMA/AES Oct 97
* - Introduction of NIP1s from COMGEM
* . L. Fillion *ARMA/AES 10 nov 1997 NFSTVAR-1 then P0
* . - Read Eta-coordinate constants
* . S. Pellerin *ARMA/SMC May 2000
* - Logical unit cleanup
* JM Belanger CMDA/SMC Jul 2000
* . 32 bits conversion
* . M. Buehner *ARMA/SMC October 2004
* - Added argument to specify IP3 value
* - clean up: remove fstnom,fstouv
* . C. Charette *ARMA/SMC Sep. 2004
* - Adapted for hybrid coordinates. Remove cometa.cdk
* and the initialization of its variables ETAPT and
* ETAE1 because they are not used anymore.
* . L. Fillion ARMA/EC - 9 Jan 2009 - Upgrade lam4d to v_10_1_2 of 3dvar.
*
* Arguments
* i KULFST : unit to be assigned to this file
* i CDCTL : control character for type of file
* . 'G' : the file contains grid point fields
* . to be used to define the model state
* . 'S' : the file contains grid point fields
* . to be used to define the model state
* i CDTYPDA : control character for type of data
* . 'I' : Initial minimization point
* . 'F' : First-Guess
* . 'A' : Analysis
* . 'N' : normalized increment
* i KIP3 : IP3 value of fields to be read
*
#endif
C
IMPLICIT NONE
* implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comgem.cdk"
#include "comgd0.cdk"
#include "comgdpar.cdk"
*
INTEGER KULFST,KIP3
CHARACTER*1 CDCTL, CDTYPDA
C
INTEGER IERR, JLEV, JVAR, INI, INJ, INK
INTEGER FNOM, FSTOUV, VFSTLIR, FSTFRM, FCLOS
CHARACTER*8 CLETIKET
CHARACTER*1 CLTYPV
C
INTEGER ISTAMP
C
REAL*8 ZTRANS(NI,NJ)
POINTER (PXTRANS,ZTRANS)
C
EXTERNAL ABORT3D, FNOM, FSTOUV, VFSTLIR, FSTFRM, FCLOS
C
C * 1. Open the file
C . -------------
C
100 CONTINUE
IF (CDCTL.EQ.'S') RETURN
C
C * . 1.1 Allocate space for the buffer
C . -----------------------------
C
110 CONTINUE
CALL HPALLOC(PXTRANS,MAX(NI*NJ,1),IERR,8)
C
C * 2. Definition of the parameters needed to characterize
C . the record containing the model state
C
IF (CDTYPDA.EQ.'F') THEN
ISTAMP =NSTAMPA
CLETIKET=CETIKETT
CLTYPV =CTYPVART
ELSE IF (CDTYPDA.EQ.'I') THEN
ISTAMP =NSTAMPI
CLETIKET=CETIKETI
CLTYPV =CTYPVARI
ELSE IF (CDTYPDA.EQ.'A') THEN
ccc ISTAMP =NSTAMPA
write(nulout,*)'Reading analysis...'
ISTAMP =-1
CLETIKET=CETIKETA
CLTYPV ='E'
ELSE IF (CDTYPDA.EQ.'N') THEN
ccc ISTAMP =NSTAMPN
ISTAMP =-1
CLETIKET=CETIKETN
CLTYPV =CTYPVARN
ELSE
CALL ABORT3D(NULOUT,'GETFST TYPDA: .NE. F A OR I')
ENDIF
230 CONTINUE
C
C * 3. Read the model state (Grid point)
C . ---------------------------------
C
C
C * . 3.1 Set the model state to zero
C . ---------------------------
C
310 CONTINUE
CALL TRANSFER('ZGD0')
C
C***********************************************************************
C
C * . 3.2 Get the 3D-fields from the file
C . ---------------------------
C
320 CONTINUE
C
C
DO 321 JLEV = 1,NFLEV
C
DO 322 JVAR = 1, NFSTVAR
!
! write(nulout,*) 'GETFST: ',CFSTVAR(JVAR)
! write(nulout,*) 'GETFST: ISTAMP = ',ISTAMP
! write(nulout,*) 'GETFST: CLETIKET = ',CLETIKET
! write(nulout,*) 'GETFST: JLEV, NIP1(JLEV) = ',JLEV, NIP1(JLEV)
! write(nulout,*) 'GETFST: CLTYPV = ',CLTYPV
!
! write(nulout,*) 'getfst: Reading variable ',CFSTVAR(JVAR),' at level ',vlev(jlev)
IERR = VFSTLIR(ZTRANS,KULFST,INI,INJ,INK,istamp,cletiket
& ,NIP1(JLEV),-1,KIP3,cltypv,CFSTVAR(JVAR))
IF(IERR.GE.0) THEN
CALL INITGD0(ZTRANS,JLEV,INI,INJ,NIG,CFSTVAR(JVAR))
ELSE
write(nulout,*) 'COULD NOT FIND RECORD:',
+ istamp,NIP1(JLEV),KIP3,cletiket,
+ CLTYPV,CFSTVAR(JVAR),ierr
CALL ABORT3D(NULOUT,'GETFST')
END IF
322 CONTINUE
321 CONTINUE
C
C * . 3.3 Read the 2D-fields from the file
330 CONTINUE
c
DO JVAR = 1, NFSTVAR2D
IERR = VFSTLIR(ZTRANS,KULFST,INI,INJ,INK,istamp,cletiket
& ,0,-1,KIP3,CLTYPV,CFSTVAR2D(JVAR))
IF(IERR.GE.0) THEN
CALL INITGD0(ZTRANS,JLEV,INI,INJ,NIG,CFSTVAR2D(JVAR))
ELSE
write(nulout,*) 'COULD NOT FIND 2D RECORD:',
+ istamp,0,KIP3,cletiket,CLTYPV,CFSTVAR2D(JVAR),ierr
CALL ABORT3D(NULOUT,'GETFST')
END IF
ENDDO
C
C* 5. Release memory
C . ---------------------------------
C
CALL HPDEALLC(PXTRANS,IERR,1)
IF(IERR.NE.0)THEN
CALL ABORT3D(NULOUT,'GETFST. Problem with ZTRANS.')
END IF
C
RETURN
END