!-------------------------------------- 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 --------------------------------------
!
PROGRAM CNT0
#if defined (DOC)
*
*** s/r CNT0 - Routine controlling the job at its highest level
*
* Author : P. Gauthier *ARMA/AES June 9, 1992
* Revision:
* P. Koclas CMC/CMSV January 1997
* . added calls to EXDB and SUFILNAM
* M. Buehner October 1998
* configs for stats computation
*
* M. Buehner january 1999
* Added options for hbht and 1obs experiments
* S. Pellerin *ARMA/SMC April 2000
* .Clean up
* .Introduction of NCONF 141:
* -> Horizontal and Vertical interpolations
* of trial to Obs location and analysis
* levels
* -> Horizontal and vertical interpolations
* of increments to model grid points and levels
* -> Truncation and vertical interpolation of
* Background statistics
*
* C. Charette M.Buehner *ARMA/SMC Jun 2002
* .To calculate variance of observed variables with v9.2.0(CALL HBHT)
* .TO do single obs experiment with direct calculation
* for observed variables with v9.2.0(CALL ONEOBS)
* Note: These 2 options were no longer working with version
* 9 of the 3dvar
*
* M. Buehner August 2002
* .Added options related to HEV's (preconditioning) and SV's
* C. Charette M.Buehner *ARMA/SMC Nov 2004
* .Remove temporary reset of nconf to 141 for case(901)
*
* M. Buehner May 2008
* .Added option 801 - version of genincr when using new approach
* for PtoT with localized Tb correlations (NANALVAR=4)
*
* S. Pellerin August 2008
* .Added calls to 'tmg_*' subroutines
*
* L. Fillion - ARMA/MSC - 7 Apr 2005 - Limited Area LAM4D option via grd_typ parameter.
* L. Fillion - ARMA/EC - Aug 2007 - Update lam4d to v_10_0_3.
* L. Fillion - ARMA/EC - Mar 2008 - Introduce 1 obs simulation for LAM4D and Global: via l1obs in namcva.
* L. Fillion - ARMA/EC - 03 Apr 2008: Rename su1obs (old 'GU' option) by suoneobs.
* L. Fillion - ARMA/EC - Upgrade to v_10_1_2 of 3dvar.
* C. Charette - ARMA/EC - Mar 2010 - Add case NCONF=201 for ENFK perturbations.
*
* Bin He . Jan. 2010
* . MPI Parallelization for 3dvar
**
* Bin He . Mar. 2013
* . change subroutine cnt0 to Main Progarm.
* . bug fix in tmg_init.
* Arguments
* -NONE-
*
#endif
USE procs_topo
,only : myid
IMPLICIT NONE
* implicits
#include "comct0.cdk"
#include "comlun.cdk"
#include "comgrd_param.cdk"
*
INTEGER ICONFI,ISTAMP,EXDB,EXFIN
character(len=9) :: clmsg
INTEGER :: root,IERR
! 0.1 MPI initilization .
CALL init_mpi
root = 0
call tmg_init(myid, 'TMG_3D-VAR' )
IF(myid == root) THEN
clmsg = 'VAR3D_BEG'
call wrstatus(clmsg)
ISTAMP=EXDB('3DVAR','DEBUT','NON')
ENDIF
C
C
C * 1. Initialize level 0 commons.
C ---------------------------
C
100 CONTINUE
CALL SU0YOMA
C
C
IF(myid == root) call printrev("START OF MAIN PROGRAM CNT0",26)
C
C
CALL SU0YOMB
C ------------------------------------------------------------------
C
C * 2. Decide on configuration of job.
C -------------------------------
C
200 CONTINUE
ICONFI=IABS(NCONF)/100
C
C * 2.0 INTEGRATION JOB: barotropic model configuration.
C
201 CONTINUE
select case (nconf)
case(101)
IF(myid == root) WRITE(NULOUT,FMT=9203)ICONFI,NCONF
9203 FORMAT(" CNT0- NCONF = ",1X,I4," CALLING BGCHECK")
call tmg_start(11,'PREMIN')
call preproc
call tmg_stop(11)
call tmg_start(12,'BGCHECK')
CALL BGCHECK
call tmg_stop(12)
case(121)
WRITE(NULOUT,FMT=9204)ICONFI,NCONF
9204 FORMAT(" CNT0- ICONFI NCONF = ",1X,I4,1X,I4," CALLING RESIDUAL
& S")
call tmg_start(11,'PREMIN')
call preproc
call tmg_stop(11)
call tmg_start(12,'RESIDUALS')
CALL RESIDUALS
call tmg_stop (12)
case(131)
WRITE(NULOUT,FMT=9900)NCONF
call suoneobs
call hbht
9900 FORMAT(//,40(" *"),/,4X,"NCONF =",1X,I3,4X
S ," -HBHT- computation of effective standard deviations "
S ," for observed variables -",/,40(" *"),/)
case(141)
WRITE(NULOUT,FMT=9401)NCONF
9401 FORMAT(" CNT0- NCONF = ",1X,I4," CALLING PREPROC")
call tmg_start(11,'PREMIN')
call preproc
call tmg_stop (11)
call tmg_start(12,'MIN')
call minimize
call tmg_stop (12)
call tmg_start(13,'POSMIN')
call postmin
call tmg_stop (13)
c
case(201)
WRITE(NULOUT,FMT=9295)NCONF
9295 FORMAT(//,40(" *"),/,4X,"NCONF =",1X,I3,4X
S ,"- RANDOM NUMBER PETURBATIONS"
S ," BASED ON MATRIX B -",/,40(" *"),/)
c
CALL ENKF_PTURB(nulout)
case(300)
WRITE(NULOUT,FMT=9300)NCONF
9300 FORMAT(//,40(" *"),/,4X,"NCONF =",1X,I3,4X
S ,"- STATISTICAL ESTIMATION OF THE FORECAST ERROR"
S ," CORRELATIONS -",/,40(" *"),/)
!
if(grd_typ.eq.'LU') then
call cse1la
else
call cse1glb
! call cse1
endif
!
case(400)
CALL CSIMOBS1
!
case(480)
!
WRITE(NULOUT,*) '--------------------------------------------------------------'
WRITE(NULOUT,*) 'PREPARATION OF ERROR SAMPLES FROM FILES CONTAINING 2 FORECASTS'
WRITE(NULOUT,*) '--------------------------------------------------------------'
!
call prep_fcst_diff
!
case(485)
!
WRITE(NULOUT,*) '-----------------------------------------------------'
WRITE(NULOUT,*) ' PREPARE HELMHOLTZ FIELDS READY FOR GLOBAL STATISTICS'
WRITE(NULOUT,*) '-----------------------------------------------------'
!
call prep_helmglb
!
case(486)
!
WRITE(NULOUT,*) '-------------------------------------------------'
WRITE(NULOUT,*) 'CONVERSION OF ERROR SAMPLES from GLOBAL to GLOBAL'
WRITE(NULOUT,*) '-------------------------------------------------'
!
call glb2glb
!
!
case(490)
!
WRITE(NULOUT,*) '-------------------------------------------------'
WRITE(NULOUT,*) 'CONVERSION OF ERROR SAMPLES from GLOBAL to LAM4D'
WRITE(NULOUT,*) '-------------------------------------------------'
!
call glb2lam
!
case(500)
c
WRITE(NULOUT,*) '-----------------------------'
WRITE(NULOUT,*) 'ESTIMATION OF P_TO_T OPERATOR'
WRITE(NULOUT,*) '-----------------------------'
CALL PTOT1
case(600)
WRITE(NULOUT,FMT=9402)NCONF
9402 FORMAT(" CNT0- NCONF = ",1X,I4," CALCULATING HEVs")
call tmg_start(11,'PREMIN')
call preproc
call tmg_stop(11)
call calchev
case(601)
WRITE(NULOUT,FMT=9403)NCONF
9403 FORMAT(" CNT0- NCONF = ",1X,I4," CALCULATING SVs")
call tmg_start(11,'PREMIN')
call preproc
call tmg_stop(11)
call calcsv
case(605)
WRITE(NULOUT,FMT=9404)NCONF
9404 FORMAT(" CNT0- NCONF = ",1X,I4," PARTIALLY EVOLVE SVs")
call tmg_start(11,'PREMIN')
call preproc
call tmg_stop(11)
call propsv
case(610)
WRITE(NULOUT,FMT=9405)NCONF
9405 FORMAT(" CNT0- NCONF = ",1X,I4," 1OBS WITH SVs")
call suoneobs
call susvbg
call oneobs
c
case(611)
WRITE(NULOUT,FMT=9406)NCONF
9406 FORMAT(" CNT0- NCONF = ",1X,I4," MINIMIZE WITH SVs")
call susvbg
call tmg_start(11,'PREMIN')
call preproc
call tmg_stop(11)
call tmg_start(12,'MIN')
call minimize
call tmg_stop (12)
call tmg_start(13,'POSMIN')
call postmin
call tmg_stop (13)
c
case(800)
WRITE(NULOUT,FMT=9800)NCONF
CALL GENINCR
9800 FORMAT(//,40(" *"),/,4X,"NCONF =",1X,I3,4X
S ," -GENINCR- COMPUTATION OF FORECAST DIFFERENCES FOR THE"
S ," ANALYSIS VARIABLES -",/,40(" *"),/)
case(801)
WRITE(NULOUT,FMT=9801)NCONF
CALL GENINCR_2
9801 FORMAT(//,40(" *"),/,4X,"NCONF =",1X,I3,4X
S ," -GENINCR- COMPUTATION OF FORECAST DIFFERENCES FOR THE"
S ," ANALYSIS VARIABLES (NEW PTOT APPROACH) -",/,40(" *"),/)
C
case(901)
WRITE(NULOUT,FMT=9990)NCONF
call su1obs
call oneobs
9990 FORMAT(//,40(" *"),/,4X,"NCONF =",1X,I3,4X
S ," -ONEOBS- single obs experiment with direct calculation
& "," for observed variables -",/,40(" *"),/)
c
case(3211)
write(nulout,fmt='(//,4x,A,1x,i4)')'Testing spectral transforms...NCONF =',nconf
call teststagwinds
case default
WRITE(UNIT=NULOUT,FMT='('' ERROR CNT0 JOB'',2I6)')ICONFI,NCONF
END select
C
C * 3. Job termination
C
300 CONTINUE
C
CALL SUTERM(NULOUT)
C
IF(myid == root) THEN
clmsg = 'VAR3D_END'
call wrstatus(clmsg)
ENDIF
call tmg_terminate (myid, 'TMG_3D-VAR' )
CALL RPN_COMM_FINALIZE(ierr)
END PROGRAM CNT0