!-------------------------------------- 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 GETERR(KULFST,CDCTL,CDTYPDA,ICASE) 13,12
#if defined (DOC)
*
*** s/r GETERR - 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
* . 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/MSC - 11 Avril 2005 - This version wasnt the official v3d961:v_9_7_0 version
! C. Charette modified it (see his sept. 2004 docum above).
* Pass ini,inj dimensions from the background to initgd0 rather than ni,nj
* so as to allow adaptation of Mesovar analysis grid ann input trial fields.
* N.B.: The latter doesnt affect the computations in the grd_typ=GU mode.
* . L. Fillion ARMA/EC - 25 Aug 2006 - Adapt reading of current error sample in case Ensemble Fcst error are used.
* Argument ICASE introduced.
* . L. Fillion ARMA/EC - 26 Nov 2008 - Add CDTYPDA = 'E' option
* . L. Fillion ARMA/EC - 23 Apr 2009 - Introduce CDTYPDA='L' for 2 lagged forecasts present in each sample files.
* We use argument ICASE to specify iip2 in that case (suited for LAM-OLYMPIC...)
* . L. Fillion ARMA/EC - 29 Jan 2010 - Improve coding structure.
* . L. Fillion ARMA/EC - 12 May 2010 - Limit printout to root.
*
* 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
* . 'E' : Error sample
* . 'L' : Lag-forecasts
* i ICASE : Value of IP3 in Ensemble forecast error file; -1 otherwise.
*
#endif
C
USE procs_topo
IMPLICIT NONE
* implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comgem.cdk"
#include "comgdpar.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comcse1.cdk"
*
INTEGER KULFST, ICASE
CHARACTER*1 CDCTL, CDTYPDA
CHARACTER*2 clvar
C
integer idum1,idum2,idum3,idum4
real*8 zmin,zmax
INTEGER IERR, JLEV, JVAR, INI, INJ, INK, iip1, iip2, iip3
INTEGER FNOM, FSTOUV, VFSTLIR, FSTFRM, FCLOS
CHARACTER*8 CLETIKET
CHARACTER*1 CLTYPV,CLTYPVAR
integer itrlnlev,ip1_pak_trl,ip1_vco_trl,itrlgid,ibrpstamp
integer iip1s_trl(jpnflev)
integer :: k,koutmpg ! the unit which has the selected records.
C
INTEGER ISTAMP
C
REAL*8 ZTRANS(NI,NJ)
! POINTER (PXTRANS,ZTRANS)
EXTERNAL ABORT3D, FNOM, FSTOUV, VFSTLIR, FSTFRM, FCLOS
!
!!
IF(CDCTL.EQ.'S') return ! This has never been implemented...
!
!*1. Open the file
! -------------
!
IERR = -1
IF (CDCTL.EQ.'S') THEN
IERR = FNOM(KULFST,'FSTSP','RND',0)
ELSE IF(CDCTL.EQ.'G')THEN
IF(CDTYPDA.EQ.'N') THEN
C IERR = FNOM(KULFST,'FSTSTAT','RND',0)
ELSE
write(nulout,*) 'GETERR: reading from unit ',kulfst
END IF
ELSE
CALL ABORT3D(NULOUT,'GETERR')
END IF
C
IF(IERR.GE.0.AND.(CDTYPDA.NE.'N').and.cdctl.ne.'G') THEN
IERR = FSTOUV(KULFST,'RND')
ELSE
C CALL ABORT3D(NULOUT,'GETERR')
END IF
!
!*2. Definition of the parameters needed to characterize
! the record containing the model state
! ---------------------------------------------------
!
iip2 = -1
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
write(nulout,*)'Reading analysis...'
ISTAMP =-1
CLETIKET=CETIKETA
CLTYPV =CTYPVARA
ELSE IF (CDTYPDA.EQ.'N') THEN
ISTAMP =NSTAMPN
CLETIKET=CETIKETN
CLTYPV =CTYPVARN
ELSE IF (CDTYPDA.EQ.'E') THEN
ISTAMP =NSTAMPN
CLETIKET=CETIKETERR
CLTYPV = 'E'
ELSE IF (CDTYPDA.EQ.'L') THEN
ISTAMP =-1
iip2 = ICASE
CLETIKET=' '
CLTYPV = 'P'
ELSE
CALL ABORT3D(NULOUT,'GETERR TYPDA: .NE. F A N E OR I')
ENDIF
230 CONTINUE
!
CALL TRANSFER('ZGD0')
!
!*3. Fill GD0
! --------
!
!*3.1 Read 3D fields and fill 3D arrays of GD0
! ----------------------------------------
!
DO 321 JLEV = 1,NFLEV
DO 322 JVAR = 1, NFSTVAR
!
! IF(myid == 0) THEN
! write(nulout,*) 'GETERR: kulfst = ',kulfst
! write(nulout,*) 'GETERR: istamp = ',istamp
! write(nulout,*) 'GETERR: cletiket = ',cletiket
! write(nulout,*) 'GETERR: jlev, nip1(jlev) = ',jlev, nip1(jlev)
! write(nulout,*) 'GETERR: iip2 = ',iip2
! write(nulout,*) 'GETERR: istamp = ',istamp
! write(nulout,*) 'GETERR: cltypv = ',cltypv
! write(nulout,*) 'GETERR: cfstvar(jvar) = ',cfstvar(jvar)
! endif
!
IERR = VFSTLIR(ZTRANS,kulfst,INI,INJ,INK,istamp,cletiket
& ,nip1(jlev),iip2,-1,cltypv,cfstvar(jvar))
!
if(grd_typ.eq.'LU') then
if(mni_in.gt.ini) then
write(nulout,*) 'geterr: mni_in, ini = ',mni_in, ini
call abort3d(nulout,'geterr: mni_in.gt.INI')
else if(mnj_in.gt.inj) then
write(nulout,*) 'geterr: mnj_in, inj = ',mnj_in, inj
call abort3d(nulout,'geterr: mnj_in.gt.INJ')
endif
endif
!
IF(IERR.GE.0) THEN
CALL INITGD0(ZTRANS,JLEV,INI,INJ,NIG,CFSTVAR(JVAR)) ! wind-images on output....
else
write(nulout,*)'- This field has not been found. IERR = ',ierr
CALL ABORT3D(NULOUT,'GETERR')
END IF
322 CONTINUE
321 CONTINUE
!
!*3.2 Read the 2D-fields
! ------------------
! write(nulout,*) 'geterr: '
! write(nulout,*) 'geterr: NFSTVAR2D = ',NFSTVAR2D
! write(nulout,*) 'geterr: '
! write(nulout,*) 'GETERR: ',CFSTVAR(JVAR)
! write(nulout,*) 'GETERR: ISTAMP = ',ISTAMP
! write(nulout,*) 'GETERR: CLETIKET = ',CLETIKET
! write(nulout,*) 'GETERR: JLEV, NIP1(JLEV) = ',JLEV, NIP1(JLEV)
! write(nulout,*) 'GETERR: CLTYPV = ',CLTYPV
! write(nulout,*) 'GETERR: NSTAMPN = ',NSTAMPN
!
DO JVAR = 1, NFSTVAR2D
ztrans(:,:) = 0.0
iip1 = -1
IF(myid == 0) write(nulout,*) 'geterr: ',CFSTVAR2D(JVAR)
IERR = VFSTLIR(ZTRANS,KULFST,INI,INJ,1,ISTAMP,CLETIKET
& ,iip1,iip2,-1,CLTYPV,CFSTVAR2D(JVAR))
!
IF(myid == 0) THEN
IF(IERR.eq.0) THEN
call maxmin(ZTRANS,ini,inj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'geterr ',
& CFSTVAR2D(JVAR))
endif
endif
!
if(ierr.ge.0) CALL INITGD0(ZTRANS,JLEV,INI,INJ,NIG,CFSTVAR2D(JVAR))
ENDDO
!
!*4. Close the file and release memory
! ---------------------------------
!
IF(CDTYPDA.NE.'E' .and. cdctl.ne.'G') THEN
IERR = FSTFRM(KULFST)
IERR = FCLOS(KULFST)
END IF
!
!
RETURN
END