!-------------------------------------- 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 SUCHECK(CDCTL,CDFG,CDIMP,LDOK),3
IMPLICIT NONE
#if defined (DOC)
*
*s/r SUCHECK :
* Author P. KOCLAS (CMC) FEBRUARY 1994.
*Revision:
* C. Charette *ARMA/AES Jan 96
* . -Abort if trial fields are missing
* P. Gauthier *ARMA/AES March 96
* . In the incremental case (NINCREM = 1), the resolution ( NI and NJ)
* . of the increments can be different from that of the trial field
* C. Charette *ARMA/AES Dec 96
* . -Error messages when CETIKETT is not in trial field file
* P. KOCLAS CMC/CMSV Jan 97
* . -Add common comvfiles and changed call to fnom
* P. KOCLAS CMC/CMSV June 98
* . - Y2K conversion
* S. Pellerin *ARMA/SMC May 2000
* . - Logical unit cleanup
* C. Charette *ARMA/SMC feb 2002
* - Added NPAKANL
*-----------------------------------------------------------------------
*
* 1. READ DIRECTORY OF RPN STANDARD FILES
* TO VERIFY THAT ALL FIELDS REQUESTED
* VIA INPUT NAMELIST FILE ARE PRESENT.
*
* 2. CROSSCHECK INTERNAL CONSISTENCY BETWEEN STANDARD
* FILES AND DATA STORED INTO CMC ADE BURP FILES.
*
* 3. SET ETIQUETTE AND DATESTAMP OF ANALYSIS FILE.
*
*-----------------------------------------------------------------------
*
* ARGUMENTS:
*
* i CDCTL: CONTROL VARIABLE TO INDICATE TYPE
* . OF STORAGE IN STANDARD FILE
* . 'S' : SPECTRAL 'G' : GRID
* i CDFG : CONTROL VARIABLE FOR FIRST GUESS
* . 'F' : FILE
* i CDIMP: CONTROL VARIABLE FOR INITIAL MINIMISATION POINT
* . 'F' : FILE
* o LDOK: LOGICAL VARIABLE --->
* . .TRUE. : NO PROBLEM DETECTED
* . .FALSE.: PROBLEM DETECTED
*
#endif
*
#include "pardim.cdk"
#include "comct0.cdk"
#include "comdim.cdk"
#include "comgem.cdk"
#include "comlun.cdk"
#include "comgdpar.cdk"
#include "compost.cdk"
#include "comcva.cdk"
*
CHARACTER*1 CDCTL,CDFG,CDIMP
LOGICAL LDOK
*
INTEGER IBRPRUN,IFSTRUN,IHH
REAL*8 DHOURS,DINCHRS
INTEGER IKEY,IERR,IGRCHK,INI, INJ, INK, JI, JJ
*
INTEGER IP2I,IP2T
INTEGER IDTYP, IP1, IP2, IP3, IG1, IG2, IG3, IG4, IDT, IPAS
+ , IBITS,ISWA, ILNG, IDLTF, IUBC, IX1, IX2, IX3
CHARACTER*2 CNOM
CHARACTER*8 CETIKET
CHARACTER*1 CLGR,CTYP
*
INTEGER IDHOURS,INHOURS
INTEGER ISTAMPI,IDATET,IDATEI,IDATDF
INTEGER ITIME,IDATE,IRUNN
LOGICAL LLTRCHK,LLDACHK,LLIACHK,LLADECHK
*
INTEGER FNOM, FSTOUV, FSTFRM, FSTINF, FSTPRM, FCLOS
EXTERNAL FNOM, FSTOUV, FSTFRM, FSTINF, FSTPRM, FCLOS
*
*
* DEFAULT VALUES FOR VARIABLES IN NAMELIST
*---------------------------------------------
*
NFSTVAR = 3
CFSTVAR(1) = 'UU'
CFSTVAR(2) = 'VV'
CFSTVAR(3) = 'TT'
*
CMCRUN='g112'
*
CETIKETA ='3DVARANA'
*
CETIKETT =' '
*
CETIKETI =' '
*
CETIKINC = 'ANALINCR'
*
NITER = -1
NPAKANL = -30
*
*---------------------------------------------
*
* OTHER DEFAULTS
*-------------------------
LLADECHK =.TRUE.
LLTRCHK =.TRUE.
LDOK =.TRUE.
CGRTYP ='G'
IG2 =1
*-------------------------
if (nconf.ne.141.and.NINT(NCONF/100.0).ne.6) then
write(nulout,*) 'SUCHECK: reading from unit ',ninmpg
*
c IF(IERR.GE.0)THEN
c IERR = FSTOUV(NINMPG,'RND')
c ELSE
c CALL ABORT3D(NULOUT,'SUCHECK')
c END IF
*
CALL READNML('NAMGDPAR',IERR)
*
WRITE(NULOUT,*) ' '
WRITE(NULOUT,*) ' REQUESTS FROM NAMELIST FILE'
WRITE(NULOUT,*) ' ---------------------------'
WRITE(NULOUT,*) ' '
WRITE(NULOUT,*) ' ETIQUETTES OF STANDARD FILES'
WRITE(NULOUT,*)
S '=================================================='
WRITE(NULOUT,*) ' ANALYSIS:',CETIKETA
WRITE(NULOUT,*) ' TRIAL FIELD:',CETIKETT
WRITE(NULOUT,*) ' INITIAL MINIMISATION POINT:',CETIKETI
WRITE(NULOUT,*) ' ITERATION NUMBER (IP3):',NITER
WRITE(NULOUT,*)
S '=================================================='
WRITE(NULOUT,*) ' '
WRITE(NULOUT,*) ' '
WRITE(NULOUT,*) ' '
WRITE(NULOUT,*) ' ***************************'
WRITE(NULOUT,*) ' ***************** '
*
WRITE(NULOUT,*) ' '
WRITE(NULOUT,*) ' REQUESTS FROM STANDARD FILES'
WRITE(NULOUT,*) ' ----------------------------'
IF ( CDFG .EQ. 'F') THEN
*
************************************************************************
* TRIAL FIELD
************************************************************************
*
WRITE(NULOUT,*) ' '
WRITE(NULOUT,'(10X,"SUCHECK: LOOKING FOR TRIAL FIELD")')
WRITE(NULOUT,'(10X," CETIKETT= ",A8)')CETIKETT
WRITE(NULOUT,*)' '
*
************************************************************************
* FIND THE KEY OF THE FIRST RECORD WITH PARAMETER
* " CETIKETT "
************************************************************************
IKEY = FSTINF(NINMPG,INI,INJ,INK,-1,CETIKETT,
+ -1,-1,-1,' ',' ')
IF(IKEY .LT.0 ) THEN
IKEY = FSTINF(NINMPG,INI,INJ,INK,-1,' ',
+ -1,-1,-1,' ',' ')
IERR = FSTPRM(IKEY,IDATET,IDT,IPAS,INI,INJ,INK,IBITS,IDTYP,
+ IP1,IP2,IP3,CTYP,CNOM,CETIKET,CLGR,IG1,IG2,IG3,IG4,
+ ISWA,ILNG,IDLTF,IUBC,IX1,IX2,IX3)
WRITE(NULOUT,9600)CETIKETT, CETIKET, INI,INJ
9600 FORMAT(///,4X,'In SUCHECK: label specified '
S ,'for the trial field in the namelist ',A8,/
S ,10X,' IS INCONSISTENT WITH THE LABEL ',A8
S ,' FOUND IN THE TRIAL FIELD FILE.',/
S ,10X,'JOB IS ABORTED',//
S ,' THE DIMENSIONS NI,NJ FOUND'
S ,' ON THE TRIAL FIELD FILE ARE: ',2I6 )
CALL ABORT3D(NULOUT
S ,'SUCHECK: Problem with trial field file')
ENDIF
IERR = FSTPRM(IKEY,IDATET,IDT,IPAS,INI,INJ,INK,IBITS,IDTYP,
+ IP1,IP2,IP3,CTYP,CNOM,CETIKET,CLGR,IG1,IG2,IG3,IG4,
+ ISWA,ILNG,IDLTF,IUBC,IX1,IX2,IX3)
*
*========================
*
* Transfer trial field parameters to COMGDPAR
*
NDEETT = IDT
NPAST = IPAS
NIP2T = IP2
NIG2T = IG2
*
* Transfer analysis field parameters to COMGDPAR
*
NDEETA = 0
NPASA = 0
NIP2 = 0
NIG2A = IG2
*
CTYPVART =CTYP
IP2T =IP2
WRITE(NULOUT,'(10X,"PARAMETERS READ FROM TRIAL FIELD FILE")')
WRITE(NULOUT,'(10X," CTYPVART= ",A1," IDATET= ",I10)')
+ CTYPVART,IDATET
WRITE(NULOUT,'(10X," IP2T= ",I5," CETIKET= ",A8)')
+ IP2T, CETIKET
*========================
*
INHOURS=IDT*IPAS/3600
DINCHRS=DBLE(INHOURS)
CALL INCDATR( NSTAMPA, IDATET,DINCHRS)
NSTAMPT = NSTAMPA
IF (CETIKETT .EQ. ' ') CETIKETT=CETIKET
*
LLTRCHK=LLTRCHK .AND. (CLGR .EQ. CGRTYP) .AND. (IERR .GE. 0)
*
WRITE(NULOUT,*) ' '
WRITE(NULOUT,*)' TRIAL FIELD'
WRITE(NULOUT,9000)'NOMVAR','TYPVAR','ETIKET','DATE','IP1','IP2'
& ,'IP3'
WRITE(NULOUT,*)
S '----------------------------------------------------'
WRITE(NULOUT,*)' '
DO JJ = 1,NFSTVAR
IF ( LLTRCHK) THEN
DO JI = 1,NFLEV
IP1 =NIP1(JI)
*=======================================================================
IKEY= FSTINF(NINMPG,INI,INJ,INK,
+ NSTAMPA,CETIKETT,IP1,IP2T,IP3,CTYP,CFSTVAR(JJ))
*=======================================================================
IGRCHK = IABS(INI-NI) + IABS(INJ-NJ)
IF(NINCREM.EQ.1.AND.IGRCHK.NE.0.OR.
S NINCREM.EQ.2.OR.NINCREM.EQ.3) THEN
WRITE(NULOUT,*)
S ' In SUCHECK,Trial field grid (INI,INJ)'
S ,' = (',INI,',',INJ,')'
S ,' Grid of the increments (NI,NJ) = ('
S ,NI,',',NJ,')'
IGRCHK = 0
END IF
LLTRCHK=(LLTRCHK .AND. (IKEY .GE. 0) .AND. (IGRCHK .EQ.
& 0))
WRITE(NULOUT,9100) CFSTVAR(JJ),CTYP,CETIKETT,NSTAMPA,IP1,IP2
& ,IP3
END DO
ENDIF
END DO
IF ( .NOT. LLTRCHK) THEN
WRITE(NULOUT,*)
& 'SUCHECK: ***>> PROBLEM WITH TRIAL FIELD<<***'
WRITE(NULOUT,'(10X,"Namelist "," NI=",I5," NJ=",I5,/,
+ 10X,"File "," NI=",I5," NJ=",I5," NK=",I5)')
+ NI,NJ,INI,INJ,INK
* CALL ABORT3D (NULOUT,'SUCHECK: Problem with NI, NJ ')
ENDIF
ELSE
NSTAMPA=IDATDF
NSTAMPT=IDATDF
CTYPVART='A'
CETIKETT='FIRSTGSS'
LLADECHK=.FALSE.
ENDIF
*
IF ( CDIMP .EQ. 'F') THEN
LLTRCHK=(LLTRCHK .AND. .TRUE.)
*
************************************************************************
* INITIAL MINIMISATION POINT
************************************************************************
*
WRITE(NULOUT,*) ' '
WRITE(NULOUT,*)' INITIAL MINIMISATION POINT '
WRITE(NULOUT,9000)'NOMVAR','TYPVAR','ETIKET','DATE'
+ ,'IP1','IP2','IP3'
WRITE(NULOUT,*)
S '----------------------------------------------------'
WRITE(NULOUT,*)' '
*
************************************************************************
* FIND THE KEY OF THE FIRST RECORD WITH PARAMETER
* " CETIKETI "
************************************************************************
*
IKEY =FSTINF(NINMPG,
+ INI,INJ,INK,-1,CETIKETI,-1,-1,NITER,' ',' ')
*
************************************************************************
* THEN OBTAIN CTYPVARI AND IP2I
************************************************************************
*
IERR = FSTPRM(IKEY,IDATEI,IDT,IPAS,INI,INJ,INK,IBITS,IDTYP,
+ IP1,IP2,IP3,CTYP,CNOM,CETIKET,CLGR,IG1,IG2,IG3,IG4,
+ ISWA,ILNG,IDLTF,IUBC,IX1,IX2,IX3)
*
*=========================
*
* Transfer Initial minimisation point parameters to COMGDPAR
*
NDEETI = IDT
NPASI = IPAS
NIP2I = IP2
NIG2I = IG2
*
CTYPVARI =CTYP
IP2I =IP2
NITER =IP3
*=========================
*
INHOURS=IDT*IPAS/3600
DINCHRS=DBLE(INHOURS)
CALL INCDATR( NSTAMPI, IDATEI,DINCHRS)
IF (CETIKETI .EQ. ' ') CETIKETI=CETIKET
*
LLTRCHK=LLTRCHK .AND. (CLGR .EQ. CGRTYP) .AND. (IERR .GE. 0)
DO JJ = 1,NFSTVAR
IF ( LLTRCHK) THEN
DO JI = 1,NFLEV
IP1 =NIP1(JI)
*=======================================================================
IKEY= FSTINF(NINMPG,INI,INJ,INK, NSTAMPA,CETIKETI
+ ,IP1,IP2I,NITER,CTYP,CFSTVAR(JJ))
*=======================================================================
IGRCHK = IABS(INI-NI) + IABS(INJ-NJ)
LLTRCHK=(LLTRCHK .AND. (IKEY .GE. 0)
+ .AND. (IGRCHK .EQ. 0))
WRITE(NULOUT,9100) CFSTVAR(JJ),CTYP,CETIKETI
+ ,NSTAMPI,IP1,IP2,IP3
END DO
ENDIF
END DO
IF ( .NOT. LLTRCHK) THEN
WRITE(NULOUT,*)
S '***>> PROBLEM WITH INITIAL MINIMISATION POINT <<***'
LDOK=.FALSE.
ELSE
WRITE(NULOUT,*) ' '
WRITE(NULOUT,*) ' ***************************'
WRITE(NULOUT,*) ' ***************** '
INHOURS=IDT*IPAS/3600
DINCHRS=DBLE(INHOURS)
CALL INCDATR( ISTAMPI, IDATEI,DINCHRS)
CALL DIFDATR(ISTAMPI, NSTAMPA,DHOURS)
IDHOURS=DHOURS
*==========================================
LLIACHK= ( IDHOURS .EQ. 0 )
LDOK = ( LDOK .AND. LLIACHK)
*==========================================
IF ( .NOT. LLIACHK) THEN
WRITE(NULOUT,*)
S '* MINEXP00 AND ANALYSIS STAMPS ARE INCONSISTENT *'
ENDIF
ENDIF
ELSE
NSTAMPI= NSTAMPA
CTYPVARI='A'
CETIKETI='MINEXP00'
NITER=0
ENDIF
endif
*
***********************************************************************
* VERIFY DATA AND ANALYSIS STAMPS
***********************************************************************
*
IF ( LLADECHK.AND.(.NOT.LSIMOB) ) THEN
CALL NEWDATE (NSTAMPA,IFSTRUN,IHH,-3)
IFSTRUN=IFSTRUN*100 + IHH/1000000
CALL BRPCHECK(ITIME,IDATE,IRUNN)
IBRPRUN=IDATE*100 + ITIME/100
IDHOURS=(IHH/1000000 - ITIME/100)/3
IDHOURS=IABS(IDHOURS)
WRITE(NULOUT, *)' BURP FILE STAMP: ',IBRPRUN
WRITE(NULOUT, *)' STANDARD FILE STAMP: ',IFSTRUN
*===========================================
LLDACHK = ( IDHOURS .LE. 1 )
LDOK = ( LDOK .AND. LLDACHK )
*===========================================
IF ( .NOT. LLDACHK) THEN
WRITE(NULOUT,*)
S ' ADE AND ANALYSIS STAMPS ARE INCONSISTENT'
* CALL ABORT3D(NULOUT,'SUCHECK')
ENDIF
ENDIF
*
************************************************************************
* TRANSFER TO COMGDPAR
************************************************************************
*
CTYPVARA='A'
NIG =IG2
*
***********************************************************************
* TRANSFER TO COMPOST
***********************************************************************
*
NIG2 =IG2
NSTAMP =NSTAMPA
*
9000 FORMAT(3(1X,A6),5X,A4,8X,A3,2(3X,A3))
9100 FORMAT(1X,A2,5X,A2,5X,A8,3X,I9,3(1X,I5))
*
* 5. Close the file and release memory
* . ---------------------------------
*
RETURN
END