!-------------------------------------- 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 cse1la 1,46
#if defined (DOC)
*
***s/r cse1la - Control of Statistical Estimation at level 1 for Mesovar option.
* The sequence of jobs for complete stats calculations is: nconf = 510,500,300
*
*Author : L. Fillion - ARMA/MSC - 1 Oct 2005.
*Revision: Luc Fillion - 2 Dec 2008 - Clean the code and validate (1) lstatsall option; (2) renaming nconf options
*Revision: Luc Fillion - 11 Dec 2008 - Uniformization with Global version cse1glb.ftn
*Revision: Luc Fillion - 10 Aug 2009 - Introduce cptot.ne.'NO'.
*Revision: Luc Fillion - 21 May 2010 - Clean and standardize steps w.r.t cse1glb. Printout limited to root.
* -------------------
** Purpose: to estimate the forecast error correlation from an
* . ensemble of normalized and unbiased residuals such
* . as differences between 12/24h forecast valid at the
* . same time
*Arguments
* -NONE-
#endif
USE procs_topo
IMPLICIT NONE
*implicits
#include "taglam4d.cdk"
#include "comct0.cdk"
#include "comlun.cdk"
#include "comdim.cdk"
#include "comcse1.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comcva.cdk"
#include "comfftla.cdk"
#include "comcorr.cdk"
#include "comgdpar.cdk"
*
character*8 cletik
logical llfplane,lltb_psi,llcoriol_one
integer ibal_order,jrow,jcol,jband
integer idum1,idum2,idum3,idum4
INTEGER IULSTAT, IULCORNS, IULSTDEV, iultemp, ierr
INTEGER FNOM, FSTOUV, FSTFRM, FCLOS,VFSTECR
!
real*8 zmin,zmax
real*8 zmpp(ni,nflev,nj)
real*8 zmcu(ni,nflev,nj)
real*8 zmtu(ni,nflev,nj)
real*8 zmlq(ni,nflev,nj)
real*8 zmpsu(ni,nj)
real*8 zmtg(ni,nj)
real*8 zeig_vec(nksdim2,nksdim2,nband), zeig_val(nksdim2,nband)
real*8 zcorns(nksdim2,nksdim2,0:nband-1,1)
real*8 zmaxmin(nksdim2,nksdim2)
C
WRITE(NULOUT,FMT=9000)
9000 FORMAT(//,3(" *****************"),/,6X
S ," CSE1LA- Computation of Forecast Error Statistics",/
S ,3(" *****************"))
!
!*1. Preliminary Initializations
!
!
iulstat = 54 ! file unit for forecast error sample
iulcorns = 55 ! file unit to write spectral correlations
iulstdev = 56 ! file unit to write all st-dev fields
!
call su1cse1la(iulstat,iulcorns,iulstdev) ! also reads namelist namcse1
!
llfplane = .true. ! active only in lhelm mode
llcoriol_one = .false. ! active only in lhelm mode
lltb_psi = .true. ! .true. regress Tb with PSI; Regress with VORT otherwise.
!
if(cstats_step.ne.'ALL ') then ! get background error statistics from file
cptot = 'NO' ! to avoir reading ptot matrix
mbal_order = 1 ! to force readcornsla to read CORRNS
call sustatsla
mbal_order = 0 ! reset
endif
!
CALL READNML('NAMGDPAR',IERR)
!
write(nulout,*) 'cse1la: cfstvar(1) = ',cfstvar(1)
if(nanalvar.ne.3.and.(mbal_order.eq.0)) then
write(nulout,*) 'cse1glb: NANALVAR = ',nanalvar
CALL ABORT3D(NULOUT,'cse1glb: mbal_order = 0
& so NANALVAR must be set to 3 ...')
endif
!
IERR = FNOM(iulstdev,cflstdev,'RND',0)
IERR = FSTOUV(iulstdev,'RND')
IERR = FNOM (iulcorns,cflcorns,'RND',0)
IERR = FSTOUV(iulcorns,'RND')
!
! allocate space for accumulators
!
call stddall
!
! Prepare for stats computations
!
if(cstats_step.eq.'ALL ') then ! do all steps to produce background error statistics
!
!*1.1 Compute gridpoint st-dev of U,V,T,HU,GZ,P0 forecast errors
! ----------------------------------------------------------
!
! call stdevla1(iulstat,iulcorns,lhelm,llfplane,lltb_psi)
!
if(lmcstats) then ! prepare error fields from ensemble of forecasts already on LAM4D grid.
call ensfcst_mean(zmpp,zmcu,zmtu,zmlq,zmpsu,zmtg,
& iulstat,iulcorns,lhelm,llfplane,lltb_psi)
endif
!
!*1.2 Balance aspects
! ---------------
!
! call ens_rossby_la
!
if(mbal_order.gt.0) then
if(cptot.eq.'SP') then
call sptotla(iulstat,iulcorns,llfplane,lltb_psi,llcoriol_one,
& zmpp,zmcu,zmtu,zmlq,zmpsu,zmtg) ! compute ptot matrix
call wrt_sptot(iulcorns)
else if(cptot.eq.'GD') then
call ptotla_1(iulstat,iulcorns,lhelm,llfplane,lltb_psi,llcoriol_one) ! compute ptot matrix
call writeptotla(iulcorns) ! uses a local file unit
endif
endif
!
!*1.3 Mean and Standard-deviation of error samples required for correlation computations
! ----------------------------------------------------------------------------------
!
call stdev_cv_la(iulstat,iulcorns,lhelm,llfplane,lltb_psi,
& llcoriol_one,zmpp,zmcu,zmtu,zmlq,zmpsu,zmtg)
!
!*1.4 Compute required background-error correlations to be used by the minimization
! -----------------------------------------------------------------------------
!
! call jm_spcorrla(iulstat,iulcorns,lhelm,llfplane,lltb_psi,llcoriol_one,
! & zmpp,zmcu,zmtu,zmlq,zmpsu,zmtg)
!
if(nanalvar.eq.3) then
call spcorrla(iulstat,iulcorns,lhelm,llfplane,lltb_psi,
& llcoriol_one,zmpp,zmcu,zmtu,zmlq,zmpsu,zmtg)
else if(nanalvar.eq.4) then
call spcorrla2(iulstat,iulcorns,lhelm,llfplane,lltb_psi,
& llcoriol_one,zmpp,zmcu,zmtu,zmlq,zmpsu,zmtg)
endif
!
IF(myid == 0) THEN
!
!*1.5 Output RAW correlations on file
! -------------------------------
!
call movecorns(zcorns,corns)
call writecornsla(zcorns,zeig_vec,zeig_val,iulcorns,cflcorns,
& ndatestat,nensemble,'ORI',.true.)
!
!*1.6 Output RSTTDEV*CORNS
! --------------------------------------------
!
call scalecorns(zcorns,'M')
call vloc_corns(zcorns)
call writecornsla(zcorns,zeig_vec,zeig_val,iulcorns,cflcorns,
& ndatestat,nensemble,'LOC',.false.)
!
!*1.7 Output Preconditioner ready for minimization
! --------------------------------------------
!
if(nanalvar.eq.3) then
call movecorns(corns,zcorns)
call sucorns_3
call movecorns(zcorns,corns)
else
call sucornsla2(zcorns)
endif
call writecornsla(zcorns,zeig_vec,zeig_val,iulcorns,cflcorns,
& ndatestat,nensemble,'MIN',.false.)
endif
!
!
!*2.1 Compute gridpoint st-dev of U,V,T,HU,GZ,P0 forecast errors
! ----------------------------------------------------------
!
else if(cstats_step.eq.'MEANGD ') then
call stdev1(iulstat,iulstdev,lhelm,llfplane,lltb_psi)
!
!*2.2 Balance aspects
! ---------------
!
else if(cstats_step.eq.'BALANCE') then
! call ens_rossby_la
if(cptot.eq.'SP') then
call sptotla(iulstat,iulcorns,llfplane,lltb_psi,
& zmpp,zmcu,zmtu,zmlq,zmpsu,zmtg) ! compute ptot matrix
call wrt_sptot(iulcorns)
else if(cptot.eq.'GD') then
call ptotla_1(iulstat,iulstdev,lhelm,llfplane,lltb_psi) ! compute ptot matrix
call writeptotla(iulcorns) ! uses a local file unit
endif
!
!*2.3 Mean and Standard-deviation of error samples required for correlation computations
! ----------------------------------------------------------------------------------
!
else if(cstats_step.eq.'MEANCV ') then
if(mbal_order.gt.0.and.cptot.eq.'SP') then
call rdsptotla ! read precomputed ptot matrix
else if(mbal_order.gt.0.and.cptot.eq.'GD') then
call rdptotla ! read precomputed ptot matrix
endif
call stdev_cv_la(iulstat,iulstdev,lhelm,llfplane,lltb_psi,
& zmpp,zmcu,zmtu,zmlq,zmpsu,zmtg)
!
!*2.4 Compute required background-error correlations to be used by the minimization
! -----------------------------------------------------------------------------
!
else if(cstats_step.eq.'SPCORR ') then
if(mbal_order.gt.0.and.cptot.eq.'SP') then
call rdsptotla ! read precomputed ptot matrix
else if(mbal_order.gt.0.and.cptot.eq.'GD') then
call rdptotla ! read precomputed ptot matrix
endif
call spcorrla(iulstat,iulcorns,lhelm,llfplane,lltb_psi,
& zmpp,zmcu,zmtu,zmlq,zmpsu,zmtg)
call writecornsla(iulcorns,cflcorns,ndatestat,nensemble)
!
!*2.5 Test Vertical Mode Filtering of error samples
! ---------------------------------------------
!
else if(cstats_step.eq.'T_VFILT') then
call test_vfilt(iulstat,iulcorns,llfplane,lltb_psi,llcoriol_one,
& zmpp,zmcu,zmtu,zmlq,zmpsu,zmtg) ! compute ptot matrix
!
!*2.6 Apply localization to CORNS
! ---------------------------
!
else if(cstats_step.eq.'T_VFILT') then
call test_vfilt(iulstat,iulcorns,llfplane,lltb_psi,llcoriol_one,
& zmpp,zmcu,zmtu,zmlq,zmpsu,zmtg) ! compute ptot matrix
!
else if(cstats_step.eq.'LOCCORR') then
!
call movecorns(zcorns,corns)
!
! do jband = 1, nband
! do jcol = 1,nksdim2
! do jrow = 1,nksdim2
! zmaxmin(jrow,jcol) = zcorns(jrow,jcol,jband-1,1)
! enddo
! enddo
! write(nulout,*) 'cse1la: Point 1, jband = ',jband
! call maxmin(zmaxmin,nksdim2,1,nksdim2,zmin,zmax,
! & idum1,idum2,idum3,idum4,'cse1la ',
! & 'CO')
! enddo
! call writecornsla(zcorns,zeig_vec,zeig_val,iulcorns,cflcorns,
! & ndatestat,nensemble,'ORI',.false.)
!
! call tb_corr(iulcorns) ! from PSI correlations directly
!
! call fltcornsla ! ensuure diagonal bocks are positive-definite
!
if(lvloc) then
call vloc_corns(zcorns)
IF(myid == 0) THEN
call writecornsla(zcorns,zeig_vec,zeig_val,iulcorns,cflcorns,
& ndatestat,nensemble,'LOC',.false.)
endif
endif
!
if(lsqrt_bgstat) then
if(nanalvar.eq.3) then
call movecorns(corns,zcorns)
call sucorns_3
call movecorns(zcorns,corns)
else
call sucornsla2(zcorns)
endif
!
IF(myid == 0) THEN
call writecornsla(zcorns,zeig_vec,zeig_val,iulcorns,cflcorns,
& ndatestat,nensemble,'MIN',.false.)
endif
endif
endif
!
! Close files
! -----------
!
IERR = FSTFRM(iulcorns)
IERR = FSTFRM(iulstdev)
IERR = FCLOS (iulcorns)
IERR = FCLOS (iulstdev)
!
return
end