!-------------------------------------- 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 SUCVA(KULOUT) 3,33
#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.
* . L. Fillion/C. Page MSC/UQAM June 20, 2003: Upgrade to v10_0_0 Apr 2006
* - Limited-Area variational analysis option: LAM4D.
* . L. Fillion - ARMA/MSC - Oct04, Feb05: Upgrade to v10_0_0 Apr 2006
* add sufftla,sugemla,suroto,sugetgd
* . L. Fillion - ARMA/EC - 15 Aug 2007 - Update lam4d to v_10_0_3.
* . L. Fillion - ARMA/EC - 25 Mar 2008 - Shallow-water option included. Add comment on sudim.ftn below...
* . A. Beaulne *CMDA/MSC Jul 2007
* - Add call to su1chn
* . L. Fillion - ARMA/EC - 24 Apr 2008 - Update lam4d to v_10_1_3.
* . S. Macpherson - ARMA/MRD - Aug 2008 - Added initialization of GB-GPS observations
* . L. Fillion - ARMA/EC - 3 Nov 2008 - Introduce mbal_order.
* . Bin He *ARMA/MRB Feb. 2009
* - MPI Parallelization
* . L. Fillion - ARMA/EC - 9 Oct 2009 - Introduce rotated Gaussian grid in grd_typ='GU' mode.
* - Validate 1obs option on v_10.3.3
* . L. Fillion - ARMA/EC - 13 Oct 2009 - Remove call to readptot_simul.ftn
* . L. Fillion - ARMA/EC - 12 Nov 2009 - Add option for INMI.
* . L. Fillion - ARMA/EC - 4 May 2010 - Relocate 1obs code to adapt to MPI version (Obs).
*
* -------------------
** 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
USE mod4dv
,only : l4dvar
IMPLICIT NONE
*implicits
#include "comdim.cdk"
#include "namcva.cdk"
#include "comct0.cdk"
#include "comlun.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comcva.cdk"
#include "comgdpar.cdk"
#include "cvcord.cdk"
#include "comgpsgb.cdk"
#include "comspg.cdk"
#include "comsim.cdk"
#include "comcorr.cdk"
*
INTEGER KULOUT
INTEGER JLEV, ILEV, IERR
INTEGER itime,idate,irunn
integer inewhh,newdate,istampobs,jj
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.
!
! N.B.: The content of the namelist namcva.cdk was read previously by sudim.ftn
!
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
if(mbal_order.gt.0.or.LINMI) LDOBAL=.TRUE.
WRITE(KULOUT,*) 'sucva: LINMI = ',LINMI
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
& ,RPOROZ,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,"RPOROZ: ",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
WRITE(KULOUT,*) 'SUCVA: grd_typ = ',grd_typ
WRITE(KULOUT,*) 'SUCVA: namelist CSCAL=',CSCAL
!
if(grd_typ.eq.'LU') then
CSCAL='I'
else
IF(NANALVAR.eq.3.or.NANALVAR.eq.4) THEN
CSCAL='I'
ENDIF
endif
WRITE(KULOUT,*) 'SUCVA: Enforcing CSCAL=',CSCAL
C
C
C * . 2.1 Create the first-guess ! this section needs documentation updating!!: Luc Oct 04: Aug 07.
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(KULOUT, *)' BURP FILES VALID DATE (YYYYMMDD) : ',nbrpdate
WRITE(KULOUT, *)' BURP FILES VALID TIME (HH) : ',nbrphh
CETIKETA = 'SX5PA806'
CETIKETT = ' '
CETIKETI = 'GVAT108F'
CETIKETN = ' '
CETIKINC='SX5PA806'
NITER = 0
CMCRUN =' '
LLOK = .TRUE.
nsim3d = 0
do jlev = 1,7
CFSTVAR(jlev) = ' '
CFSTVAR2D(jlev) = ' '
enddo
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 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
CALL SUCOV(CCOV,KULOUT)
C
C * . 2.21 Initialize the observation error covariance
C . -------------------------------------------
C
221 CONTINUE
IF(.NOT.LSIMOB) CALL SUCOVO
C
C * . 2.3 Create the starting point of the minimization
C . -------------------------------------------
C
230 CONTINUE
C
CALL SUIMP(NVADIM,VAZX,CIMP)
C
C
C * . 2.4 Initialize the inner product
C . ----------------------------
C
240 CONTINUE
C
C
CALL SUSCAL(CSCAL)
C
C * 3. Miscellaneous initializations associated
C . with the observations
C . ----------------------------------------
C
300 CONTINUE
C
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* Initialize GB-GPS processing (read NAMGPSGB in namelist file)
C --------------------------
C*
CALL SUGPSGB(KULOUT)
C
C Filter out data from CMA
C -------------------------
CALL SUPREP
C
C If single GB-GPS observation assimilation, select the observation
IF ( L1GPSOBS ) CALL FILT_GPSGB
C
CALL CMAPR
C
if(l1obs) then
call suobs_sim ! initializes simulated observations
call suobsgid_1obs
call sualobsb(KULOUT) !
else
call suobsgid
!
CALL getobstag
call rebuildCMA ()
call rebldnotag () !! bhe
call sualobsb(KULOUT) !
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
!
endif
!
! SET FAST WIND ROTATION OBS COEFFICIENTS
! ---------------------------------------
!
if (grd_roule) then
call suroto
endif
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
RETURN
END