SUBROUTINE SUCVA(KULOUT) 2,13
#if defined (DOC)
*
***s/r SUCVA : Initialisation of the 3Dvar.and different parameters
* . associated with the minimization algorithm
*
*Author : P. Gauthier *ARMA/AES January 27, 1993
*Revision:
* . P. Gauthier *ARMA/AES November 8, 1993
* . Define several parameters to characterize the forecast
* . error which are read from the NAMELIST file
* . P. Koclas *CMC/CMDA February 94
* . -Add comgdpar
* . -Add call to routine SUCHECK to initialize
* . comgdpar and to verify internal consistency
* . between data and standard files
* .
* . P. Koclas *CMC/CMDA September 94
* . -add call to suprep
* . L. Fillion *ARMA/AES Feb 95.
* . -Transfer to SUCOV the use of operational stat. via SUSTAT
* . C. Charette *ARMA/AES Jan 96
* . -Added RSIGQ and RSIGPS
* . -New logical keys LRSTART, LSTAT
* . -Removed call TO GDOUT for trial fields
* . S. Laroche *ARMA/AES Mar 96
* . -Added incremental approach for sef (NINCREM=0,1)
* . P. Koclas *ARMA/AES April 96
* . -Added sucovo and cmapr
* . S. Laroche *ARMA/AES June 96
* . -Added incremental approach for regional model (NINCREM=2,3)
* . P. Gauthier *ARMA/AES December 1996
* . - Corrections for the option NINCREM = 0. Remove the calls to
* . SORTOBS and LISTEOBS
* . S. Pellerin *ARMA/AES Sept 97.
* - Change from TT to GZ states variable
* - Control of the different model state of the 3Dvar
* through COMSTATE, COMSTATEC and COMSTNUM common
* blocks variables (comstate.cdk).
* . M. Buehner November 97
* . Overwrite CSCAL='I' if NANALVAR=3 - new definition of control vector
* . C. Charette November 98
* . Added CHUM
* . J. Halle *CMDA/AES Oct 99
* . -Added processing of TOVS
* . P. Koclas November 99
* . NINCREM=4 for background check
* . B. Brasnett *CMDA/MSC Jan 2000
* - add calls to suvarqc, suasym
* . S. Pellerin *ARMA/SMC May 2000
* . Introduction of nconf 141
* . Bypass of sucheck for nconf 141
* . Logical unit cleanup
* . J. Halle *CMC/CMDA Dec 2000
* . TOVS level 1B data:
* TOVS level 1B data: read namelist namtov.
* . C. Charette *ARMA/SMC Nov 2001
* . Initialize and set variable LLOK
* . S. Pellerin *ARMA/SMC nov. 2001
* . Initialisation of nsim3d counter for 4Dvar communications
* . C. Charette *ARMA/SMC feb 2002
* . Added NPAKANL
* . N. Wagneur *CMDA/MSC Mai 2002
* - Added processing of RADIANCES with MSCFAST RT model
* . J. Halle *CMDA/MSC June 2005
* - Adapt for RTTOV-8.
* . A. Beaulne *CMDA/MSC Jul 2007
* - Add call to su1chn
* . Y.J. Rochon *ARQX/ASTD March 2009
* . Skipping over calls to SUCOV/SUIMP/SUSCAL during background
* check and monitoring where only SIGMAOP is relevant.
*
* . Y. Yang - Oct. 2004
* - Added include "comnumbr.cdk"
* due to the dependence of the "cvcord.cdk" on JPNBRELEM
* . Y.J. Rochon Feb. 2006
* - Added tests on consistency of JPNVARM and NFSTVAR+NFSTVAR2D
* with JPNVARMAX
* . Y.J. Rochon July 2008
* . Removed IF statement on LSIMOB
*
* -------------------
** Purpose: to initialize * the background state (SUFG and LIRREG for the regional 3Dvar)
* . * the observations (SUOBS, SUPREP and CMAPR)
* . * the background error statistics (SUCOV)
* . * write or read (HXb -Z) for an incremental 3Dvar (ZPRIM and READZP)
* . * the observation error statistics (SUCOVO and SETERR)
* . * check the consistency between the background and the observations
* . * the inner product (SUSCAL)
* . * the starting point of the minimisation (SUIMP)
* . * test the operators of the 3Dvar (TESTSP and TESTCVA)
*
*Arguments
* i : KULOUT : logical unit for output
*
#endif
IMPLICIT NONE
*implicits
#include "comdim.cdk"
#include "comnumbr.cdk"
#include "comlun.cdk"
#include "comct0.cdk"
#include "comcva.cdk"
#include "comgdpar.cdk"
#include "cvcord.cdk"
#include "pardim.cdk"
#include "compstat.cdk"
#include "comstate.cdk"
#include "partov.cdk"
#include "comtov.cdk"
*
INTEGER KULOUT
INTEGER JLEV, ILEV, IERR
INTEGER itime,idate,irunn
integer inewhh,newdate,istampobs
real*8 delhh
LOGICAL LLOK
integer :: fnom
C
EXTERNAL CMAPR, SETERR, SUSCAL, SUIMP, SUFG, SUCOV, SUCOVO,
S SUPREP, TESTSP, TRANSFER, SPGD, SUOBS, POSTPROC, FNOM
C
C * 1. Define the parameters for the minimization experiment
C . -----------------------------------------------------
C
LLOK = .FALSE.
C
100 CONTINUE
C
C * . 1.3 Print the content of this NAMELIST
C
130 CONTINUE
WRITE(KULOUT,FMT=9130)N1GC,NVAMAJ,NIMPRES,NITERMAX,NSIMMAX
S ,REPSG
S , CIMP,CFG,CCOV,CFGERR,CSCAL,CHUM
S ,NCNTVAR,NEVALJ
S ,LTSTSP,LTSTCVA,LSTAT
C
LDOBAL=.TRUE.
WRITE(KULOUT,*) '!!!Setting LDOBAL = ',ldobal
C
C Exclusion of the surface level from the control variable
C
!
IF(LSTAT) THEN
WRITE(KULOUT,FMT=9132)
ELSE
WRITE(KULOUT,FMT=9131)
S RSIGUU,RSIGGZ,RNU2
S ,RPORVO,RPORDI,RPORGZ,RPORQ,RPORPS
& ,RPORTR
END IF
9130 FORMAT(8x,'--Parameters used for the minimization'
S ,' (read in NAMCVA)'
S ,/,4x,'N1GC: ',I3,4X,'NVAMAJ: ',I3
S ,/,4X,'NIMPRES: ',I2,4X,'NITERMAX: ',I4,4X
S ,'NSIMMAX: ',I4,4X,'REPSG: ',G12.6,4X
S ,/,4X,'Initial minimization point : ',2X,A1
S ,/,4X,'First-Guess : ',2X,A1
S ,/,4X,'First-Guess error correlation : ',2X,A1
S ,/,4X,'First-Guess error variance : ',2X,A1
S ,/,4X,'Inner product : ',2X,A1
S ,/,4X,'Control anal variable humidity : ',2X,A2
S ,/,4X,'Type of control variable : ',I3
S ,/,4X,'Functional evaluation type : ',I3
S ,/,4X,'Test of the spectral transforms:',2X,L1
S ,4X,'Test of the canonical transforms:',2X,L1
& ,/,4X,'Reading background error statistics from file:',2X,L1)
C
9131 FORMAT(/,4X,"Forecast error covariances are those specified"
S ," in NAMCVA",20("=")
S ,/,4X,"Standard deviations:",2X,"RSIGUU: ",G12.6,2X
S ,"RSIGGZ: ",G12.6,2X,"RNU2: ",F5.3,/,4X
S ,"Correlations characteristic lengths: "
S ,/,6X,"RPORVO: ",G12.6
S ,/,6X,"RPORDI: ",G12.6
S ,/,6X,"RPORGZ: ",G12.6
S ,/,6X,"RPORQ : ",G12.6
S ,/,6X,"RPORPS: ",G12.6
& ,/,6X,"RPORTR: ",G12.6)
9132 FORMAT(/,4X,"Background error statistics are read from"
S ," a file by SUSTAT",3(/))
C
C * 2. Reading and initialization in preparation of the minimization
C . -------------------------------------------------------------
C
200 CONTINUE
WRITE(KULOUT,FMT=9200)
9200 FORMAT(//,5x,"-Reading and initialization in preparation to the "
S ,"minimization",/,6x,61('-'))
C
IF(NANALVAR.eq.3.or.NANALVAR.eq.4) THEN
CSCAL='I'
WRITE(KULOUT,*) 'SUCVA: Overwriting CSCAL=',CSCAL
ENDIF
C
C
C * . 2.1 Create the first-guess
C . --------------------
C
210 CONTINUE
C
c if(nconf.eq.141 .or. nconf.eq.101 .or. nconf .eq. 121 ) then
CALL BRPCHECK(ITIME,IDATE,IRUNN)
ierr = newdate(istampobs,idate,itime,3)
delhh = 3.0
call INCDATR (nbrpstamp, istampobs, delhh)
ierr = newdate(nbrpstamp,nbrpdate,inewhh,-3)
nbrphh=ITIME/100
if (nbrphh .ge. 21 .or. nbrphh .lt. 3) then
nbrphh = 0
elseif(nbrphh .ge. 3 .and. nbrphh .lt. 9) then
nbrphh = 6
elseif(nbrphh .ge. 9 .and. nbrphh .lt. 15) then
nbrphh = 12
else
nbrphh = 18
endif
ierr = newdate(nbrpstamp,nbrpdate,nbrphh*1000000,3)
WRITE(NULOUT, *)' BURP FILES VALID DATE (YYYYMMDD) : ',nbrpdate
WRITE(NULOUT, *)' BURP FILES VALID TIME (HH) : ',nbrphh
CETIKETA = 'SX5PA806'
CETIKETT = ' '
CETIKETI = 'GVAT108F'
CETIKETN = ' '
CETIKINC='SX5PA806'
NITER = 0
CMCRUN =' '
LLOK = .TRUE.
nsim3d = 0
CFSTVAR(:)=' '
CFSTVAR2D(:)=' '
C
if (JPNVARM.lt.JPNVARMAX) then
WRITE(KULOUT,*) 'SUCVA: Possibility of memory fault.'
end if
C
NFSTVAR=4
CFSTVAR(1)='UU'
CFSTVAR(2)='VV'
CFSTVAR(3)='TT'
CFSTVAR(4)='HU'
NFSTVAR2D = 2
CFSTVAR2D(1)='P0'
CFSTVAR2D(2)='TG'
NPAKANL = -30
NPAKINC = -30
ndtinc = 1
CALL READNML('NAMGDPAR',IERR)
C
if (NFSTVAR+NFSTVAR2D.gt.JPNVARMAX) then
CALL ABORT3D(KULOUT,'SUCVA: JPNVARMAX TOO SMALL.')
end if
c
c else
c CALL SUCHECK('G',CFG,CIMP,LLOK)
c endif
*
WRITE(KULOUT,*) ' '
WRITE(KULOUT,*) '=================================================='
*
IF(LLOK) THEN
WRITE(KULOUT,*) ' SUCVA: DATA AND TRIAL FIELDS ARE CONSISTENT '
ELSE
WRITE(KULOUT,*) ' PROBLEM WITH DATA OR TRIAL FIELDS '
ENDIF
WRITE(KULOUT,*) '=================================================='
WRITE(KULOUT,*) ' '
*
CALL TRANSFER('ZSPG')
C
C * . 2.2 Initialize the first-guess error covariance
C . -------------------------------------------
C
220 CONTINUE
C
IF (NCONF.NE.101.AND.NCONF.NE.121) THEN
C
C * 2.2 Initialize the first-guess error covariance
C . -------------------------------------------
C
CALL SUCOV(CCOV,KULOUT)
C
C * 2.3 Create the starting point of the minimization
C . -------------------------------------------
C
CALL SUIMP(NVADIM,VAZX,CIMP)
C
C * 2.4 Initialize the inner product
C . ----------------------------
C
CALL SUSCAL(CSCAL)
ELSE
DAMPLIBG(:,:,:)=1.0D0
END IF
C
221 CONTINUE
C
C * . 2.21 Initialize the observation error covariance
C . -------------------------------------------
C
C IF(.NOT.LSIMOB) CALL SUCOVO
CALL SUCOVO
C
C * 3. Miscellaneous initializations associated
C . with the observations
C . ----------------------------------------
C
300 CONTINUE
C
LEVEL1B=.FALSE.
CALL READNML('NAMTOV',IERR)
CALL READNML('NAMGOES',IERR)
CALL SUOBS(KULOUT)
C
C Determine if Variational QC is required
C
CALL SUVARQC
C
C* Determine if this is a one channel assimilation
C -----------------------------------------------
C
CALL SU1CHN
C
C* Initialize TOVS processing
C --------------------------
C
CALL TOVS_SETUP(KULOUT)
C
C* Initialize GOES RADIANCES processing
C --------------------------
C*
CALL SUGOES(KULOUT)
C
C Filter out data from CMA
C -------------------------
C
IF (LCHEM) THEN
C
C assimilating chemistry data
CALL CH_SUPREP
ELSE
CALL SUPREP
ENDIF
c
CALL CMAPR
C
C* Memory allocation for TOVS processing
C -------------------------------------
C
CALL TOVS_SETUPALLO(KULOUT)
C
C* Memory allocation for GOES RADIANCES processing
C -------------------------------------
C
CALL SUGOESALO(KULOUT)
C
C SET OBSERVATION ERRORS TO CMA FILE
C ----------------------------------
CALL SETERR
c
call suobsgid
c
if (nconf.ne.141.and.NINT(nconf/100.0).ne.6) then
C
C analysis and first-guess dates
C -----------------------------------------------------------------
C
WRITE(KULOUT,*) ' '
WRITE(KULOUT,*) '=========================================='
WRITE(KULOUT,*) ' TRIAL FIELD VALID: ' ,NSTAMPT
WRITE(KULOUT,*) ' --------------'
WRITE(KULOUT,*) ' ANALYSIS DATE: ' ,NSTAMPA
WRITE(KULOUT,*) ' --------------'
WRITE(KULOUT,*) '=========================================='
WRITE(KULOUT,*) ' '
endif
c
IF(LTSTSP) THEN
write(kulout,*)'Spectral transforms are being tested. Please wait...'
CALL TESTSP(KULOUT)
END IF
C
IF(LTSTCVA)THEN
WRITE(KULOUT,FMT='(6X,"--- Test in SUCVA -----")')
CALL TESTCVA(KULOUT,VATRA,VAZG,NVADIM)
END IF
C
RETURN
END