!-------------------------------------- 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 spcorrglb1(kulstat,koutfile,ldhelm,ldfplane,ldtb_psi, 1,45
& ldcoriol_one)
#if defined (DOC)
*
***s/r spcorrglb - Perform computation of spectral correlations for control vector component fields.
* cse2.ftn plus improvements. The input fields are the
* ensemble of error samples for the regular forecast variables; i.e.
* u,v,T,q,ps. The transformation to analysis variables for which we build
* spectral correlations is done here on the fly. Mean and std-dev of these latter
* fields are computed as a first step by meancvgd.ftn. Second, using these std-dev
* the required normalized error samples of required variables is done and spectral
* correlations built, both within the looping structure over files defined below.
* N.B.: We assume the regression matrix PtoT is available.
* . This subroutine is based on cse2.ftn but beware of input fields difference and methodology...
* Because it was substantially different from cse2.ftn, a new name was used.
*
*Author : L. Fillion - ARMA/EC - 28 May 2009.
*Revision:
* L. Fillion - ARMA/EC - 18 Jun 2010.- Introduce a specific subroutine to perform symmetrization of GD0 about the equator.
*
*
* -------------------
** Purpose: to estimate the forecast error correlation from an
* . ensemble of forecast differences; e.g. 12-24h valid at the same time; i.e. the NMC method.
*Arguments
* kulstat =
* koutfile =
#endif
IMPLICIT NONE
*implicits
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comct0.cdk"
#include "comcst.cdk"
#include "comlun.cdk"
#include "comgem.cdk"
#include "comcorr.cdk"
#include "comsp.cdk"
#include "comleg.cdk"
#include "comgd0.cdk"
#include "comgdpar.cdk"
#include "comcse1.cdk"
#include "comcva.cdk"
#include "namgdpar.cdk"
*
logical ldhelm,ldfplane,ldtb_psi,ldcoriol_one
INTEGER KULSTAT, koutfile
!
logical ldopc,llfilt,llvproj,llvfilt
integer vfstlir,iensemble,ind
integer jband,ji,jj,jk,icase,ik1,ik2
INTEGER jens,iens,jk1,jk2,jla,jn,jm,ila,ierr,jfile
integer idum1,idum2,idum3,idum4
real*8 zmin,zmax
real*8 zcon
!
real*8 zmpp(ni,nflev,nj)
real*8 zmcu(ni,nflev,nj)
real*8 zmtu(ni,nflev,nj)
real*8 zmtb(ni,nflev,nj)
real*8 zmlq(ni,nflev,nj)
real*8 zmpsb(ni,nj)
real*8 zmpsu(ni,nj)
real*8 zmtg(ni,nj)
!
real*8 zspp(ni,nflev,nj)
real*8 zscu(ni,nflev,nj)
real*8 zstu(ni,nflev,nj)
real*8 zstb(ni,nflev,nj)
real*8 zslq(ni,nflev,nj)
real*8 zspsu(ni,nj)
real*8 zspsb(ni,nj)
real*8 zstg(ni,nj)
!
real*8 zt0(ni,nflev,nj)
real*8 ztb(ni,nflev,nj)
real*8 zpb(ni,nflev,nj)
real*8 zpsb(ni,nj)
real*8 z2d(ni,nj)
!
logical llzdpc
INTEGER myid,numthd,omp_get_thread_num,omp_get_num_threads
INTEGER FNOM, FSTOUV, FSTFRM, FCLOS, FSTPRM, FSTINF, FSTINL
!
!* RPN Standard files parameters
!
INTEGER INI,INJ,INK, INPAS, INBITS, IDATYP, IDEET
+ ,IP1,IP2,IP3,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
+ ,IUBC,IEXTR1,IEXTR2,IEXTR3
INTEGER ILISTE(100),IDATE(100), IDATV(100), IDIMAX, INFON, IFSTRUN, IHH
REAL*8 DHEURES
CHARACTER*1 CLTYPVAR,CLGRTYP,clflt,clgrid
CHARACTER*3 CLNOMVAR
CHARACTER*8 CLETIKET
!
REAL*8 ZFACT, ZCORIOLIS, zdla2
REAL*8 DLFACT, DLFACT2
EXTERNAL FNOM, FSTOUV, FSTFRM, FCLOS, FSTPRM, FSTINF, FSTINL
!
INTEGER ICOUNT,ifile
!
!!
WRITE(NULOUT,FMT=9000)
9000 FORMAT(3(/,3x,80('.')),//
S ,4x,' spcorrglb- Estimation of Forecast error correlations',//)
!
write(nulout,*) 'spcorrglb1: lhemis = ',lhemis
write(nulout,*) 'spcorrglb1: lnorth = ',lnorth
write(nulout,*) 'spcorrglb1: ldhelm = ',ldhelm
llfilt = .false.
if(lflt_low) then
llfilt = .true.
clflt = 'L'
else if(lflt_high) then
llfilt = .true.
clflt = 'H'
endif
llvfilt = .false.
llvproj = .false.
!
!*2. Estimate the mean and st-dev of analysis variables
! --------------------------------------------------
!
idimax = 100
!
! read from file: precomputed mean and stdev of control-variables
!
write(nulout,*) 'spcorrglb: nensemble = ',nensemble
! ifile = nulbgst
! if(cstats_step.eq.'ALL ') ifile = koutfile
!
! IERR = FNOM(koutfile,cflstdev,'RND',0)
! IERR = FSTOUV(koutfile,'RND')
!
call getstats_cv(koutfile,zmpp,zmcu,zmtu,zmlq,zmtb,zmpsu,zmpsb,zmtg,
& zspp,zscu,zstu,zslq,zstb,zspsu,zspsb,zstg,nensemble,
& ldhelm)
!
write(nulout,*) 'spcorrglb: *************************************'
write(nulout,*) 'spcorrglb: max/min of MEAN read from getstats_cv'
write(nulout,*) 'spcorrglb: *************************************'
!
if(ldhelm) then
clnomvar = 'PP '
else
clnomvar = 'QQ '
endif
llzdpc = .false.
if(cfstvar(1).eq.'UU') llzdpc = .true.
write(nulout,*) 'spcorrglb1: cfstvar(1) = ',cfstvar(1)
write(nulout,*) 'spcorrglb1: llzdpc = ',llzdpc
!
call maxmin(zmpp,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb ',
& clnomvar)
if(ldhelm) then
clnomvar = 'CU '
else
clnomvar = 'DD '
endif
call maxmin(zmcu,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb ',
& 'CUM')
call maxmin(zmtu,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb ',
& 'TUM')
call maxmin(zmlq,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb ',
& 'LQM')
call maxmin(zmtb,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb ',
& 'TBM')
call maxmin(zmpsb,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb ',
& 'PbM')
call maxmin(zmpsu,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb ',
& 'PuM')
call maxmin(zmtg,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb ',
& 'TgM')
!
write(nulout,*) 'spcorrglb: **************************************'
write(nulout,*) 'spcorrglb: max/min of STDEV read from getstats_cv'
write(nulout,*) 'spcorrglb: **************************************'
!
call maxmin(zspp,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb ',
& 'PPS')
if(zmin.le.0.0) then
CALL ABORT3D(NULOUT,'spcorrglb: ST-DEV PP .le. 0.0 !')
endif
call maxmin(zscu,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb ',
& 'CUS')
if(zmin.le.0.0) then
CALL ABORT3D(NULOUT,'spcorrglb: ST-DEV CU .le. 0.0 !')
endif
call maxmin(zstu,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb ',
& 'TUS')
if(zmin.le.0.0) then
CALL ABORT3D(NULOUT,'spcorrglb: ST-DEV TU .le. 0.0 !')
endif
call maxmin(zslq,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb ',
& 'LQS')
if(zmin.le.0.0) then
CALL ABORT3D(NULOUT,'spcorrglb: ST-DEV LQ .le. 0.0 !')
endif
call maxmin(zstb,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb ',
& 'TBS')
if(zmin.le.0.0) then
CALL ABORT3D(NULOUT,'spcorrglb: ST-DEV TB .le. 0.0 !')
endif
call maxmin(zspsb,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb ',
& 'PbS')
if(zmin.le.0.0) then
CALL ABORT3D(NULOUT,'spcorrglb: ST-DEV Pb .le. 0.0 !')
endif
call maxmin(zspsu,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb ',
& 'PuS')
if(zmin.le.0.0) then
CALL ABORT3D(NULOUT,'spcorrglb: ST-DEV PU .le. 0.0 !')
endif
call maxmin(zstg,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb ',
& 'TgS')
if(zmin.le.0.0) then
CALL ABORT3D(NULOUT,'spcorrglb: ST-DEV TG .le. 0.0 !')
endif
!
!
!*3. Loop on all error sample files and build spectral correlations
! --------------------------------------------------------------
!
do jfile = 1, nflstat
CALL GETINCR(KULSTAT,JFILE)
!
!* 3.1 Find how many cases there are to be treated: set iens
!
IP1 = -1
IP2 = -1
IP3 = -1
CLNOMVAR = 'P0'
IERR = FSTINL (KULSTAT,INI,INJ,INK
S ,-1,CETIKETERR,IP1,IP2,IP3,' '
S ,CLNOMVAR,ILISTE,INFON,IDIMAX)
WRITE(NULOUT,9210)INFON
9210 FORMAT(//,4X,"Ensemble of ",I4," increments")
IF(INFON.EQ.0) THEN
WRITE(NULOUT,*)' THIS FILE IS EMPTY. CHECK THE SELECTION CRITERIA'
CALL ABORT3D(NULOUT,'CSE2: problem with FSTINL')
END IF
IENS = INFON
!
! 3.2 Get all the dates at which increments are available
!
DO JENS = 1, IENS
IERR = FSTPRM(ILISTE(JENS),IDATE(JENS),IDEET,INPAS
& ,INI,INJ,INK, INBITS, IDATYP
& ,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP
& ,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
& ,IUBC,IEXTR1,IEXTR2,IEXTR3)
DHEURES = DBLE(INPAS*IDEET/3600)
CALL INCDATR(IDATV(JENS),IDATE(JENS),SNGL(DHEURES))
CALL NEWDATE(IDATV(JENS),IFSTRUN,IHH,-3)
WRITE(NULOUT,9111)JENS, IFSTRUN,IHH
END DO
9111 FORMAT(5X,"Case No. ",I3,5x,"Date and time: ",I10,5x,I8)
!
iensemble=0
IF(iensemble.EQ.0) THEN
NDATESTAT = IDATE(1)
END IF
!
CTYPVARN = ' '
CETIKETN = CLETIKET
!
! 3.3 Loop on the ensemble
!
do 331 jens = 1, iens
!
! Get the increment in grid-point form
!
if(lmcstats) then
NSTAMPN = -1
icase=jens ! i.e. will use IP3 as a search parameter and ignore the date in current file since all same
else
NSTAMPN = IDATE(JENS) ! i.e. will use the current date of validity of the current error sample in standard file.
icase = -1 ! ignore IP3 as a search parameter in vfstlir
endif
!
call geterr(kulstat,'G','E',icase)
!
do ji=1,ni
do jj=1,nj
zpsb(ji,jj)=gps0(ji,1,jj)
enddo
enddo
!
call maxmin(zpsb,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb1 ',
& 'P0 ')
!
! 2.3.2
!
if(llzdpc) then
call gdsp ! (U,V) --> (spvor,spdiv)
if(ldhelm) then
!
! CONVERT FROM VORT/DIV TO PSI/CHI
!
zdla2 = DBLE(RA)*DBLE(RA)
DO JK = 1, NFLEV
DO jla = 1, NLA
SPVOR(jla,1,JK) = SPVOR(jla,1,JK) * zdla2*R1SNP1(jla)
SPVOR(jla,2,JK) = SPVOR(jla,2,JK) * zdla2*R1SNP1(jla)
SPDIV(jla,1,JK) = SPDIV(jla,1,JK) * zdla2*R1SNP1(jla)
SPDIV(jla,2,JK) = SPDIV(jla,2,JK) * zdla2*R1SNP1(jla)
ENDDO
ENDDO
endif
if(lcva_hsp) then
CALL SPEREE_hem(NKSDIM,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,nksdim)
else
CALL SPEREE(NKSDIM,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,nksdim)
endif
endif
!
if(llfilt) then
write(nulout,*) 'spcorrglb1: **************************************'
write(nulout,*) 'spcorrglb1: PP error sample is spectrally filtered'
write(nulout,*) 'spcorrglb1: **************************************'
else
write(nulout,*) 'spcorrglb1: NO FILTER applied to PP error sample'
endif
!
ztb(:,:,:) = 0.0
zpb(:,:,:) = 0.0
zpsb(:,:) = 0.0
zt0(:,:,:) = 0.0
!
write(nulout,*) ' '
write(nulout,*) 'spcorrglb1: ****************************************'
write(nulout,*) 'spcorrglb1: Uses Balance operators of Order = ',mbal_order
write(nulout,*) 'spcorrglb1: ****************************************'
write(nulout,*) ' '
!
if(mbal_order.eq.1) then
!
! Linear-Geostrophic
! ------------------
!
if(ldtb_psi) then
CALL LINBAL(+1,.FALSE.)
else
endif
if(llvfilt) call vfilt(zpb,5,'L')
if(llvproj) call vproj(zpb,zpb,nflev)
!
! call p2tpsb(zt0,zpsb,zpb,cptot,.false.,.true.) ! build Tb, psb from psi
!
if(llvproj) call viproj(zt0,zt0,nflev)
!
else if(mbal_order.eq.2) then
!
! Tangent-Linear 2nd-Order Balance
! ---------------------------------
!
endif
!
if(llvfilt) call vfilt(zt0,5,'L')
call maxmin(zt0,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrglb1',
& 'T0 ')
!
! Build Unbalanced variables
! --------------------------
!
do ji=1,ni
do jj=1,nj
do jk=1,nflev
tt0(ji,jk,jj) = tt0(ji,jk,jj)-zt0(ji,jk,jj)
enddo
enddo
enddo
!
do ji=1,ni
do jj=1,nj
gps0(ji,1,jj)=gps0(ji,1,jj)-zpsb(ji,jj)
enddo
enddo
!
! Produce unbiaised analysis variables
! ------------------------------------
!
do jj = 1, nj
do ji = 1, ni
do jk1 = 1, nflev
ut0(ji,jk1,jj) = ut0(ji,jk1,jj) - zmpp(ji,jk1,jj)
vt0(ji,jk1,jj) = vt0(ji,jk1,jj) - zmcu(ji,jk1,jj)
tt0(ji,jk1,jj) = tt0(ji,jk1,jj) - zmtu(ji,jk1,jj)
q0(ji,jk1,jj) = q0(ji,jk1,jj) - zmlq(ji,jk1,jj)
enddo
gps0(ji,1,jj) = gps0(ji,1,jj) - zmpsu(ji,jj)
gtg0(ji,1,jj) = gtg0(ji,1,jj) - zmtg(ji,jj)
enddo
enddo
!
! divide by st-dev to get normalized unbiaised error samples
! N.B.: A Check was done in meancvgd.ftn s.t. the st-dev have threshold values enforced
!
do jj = 1, nj
do ji = 1, ni
do jk1 = 1, nflev
if(zspp(ji,jk1,jj).ne.0.0) then
ut0(ji,jk1,jj) = ut0(ji,jk1,jj)/zspp(ji,jk1,jj) ! zspp contains psi st-dev... see meancvgd
endif
if(zscu(ji,jk1,jj).ne.0.0) then
vt0(ji,jk1,jj) = vt0(ji,jk1,jj)/zscu(ji,jk1,jj) ! svv contains chi st-dev... see meancvgd
endif
if(zstu(ji,jk1,jj).ne.0.0) then
tt0(ji,jk1,jj) = tt0(ji,jk1,jj)/zstu(ji,jk1,jj) ! stt contains Tu st-dev... see meancvgd
endif
if(zslq(ji,jk1,jj).ne.0.0) then
q0(ji,jk1,jj) = q0(ji,jk1,jj)/zslq(ji,jk1,jj)
endif
enddo
if(zspsu(ji,jj).ne.0.0) then
gps0(ji,1,jj) = gps0(ji,1,jj)/zspsu(ji,jj)
endif
if(zstg(ji,jj).ne.0.0) then
gtg0(ji,1,jj) = gtg0(ji,1,jj)/zstg(ji,jj)
endif
enddo
enddo
!
if(lhemis) then ! symmetrize fields w.r.t equator
if(lnorth) then
call sym_hemis('NH')
else
call sym_hemis('SH')
endif
endif
!
! Computation of forecast error correlations
! ------------------------------------------
!
call transfer('ZSP0')
if(lcva_hsp) then
CALL REESPE_hem(NKSDIM,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
else
CALL REESPE(NKSDIM,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
endif
write(nulout,*) 'spcorrglb1: apres REESPE'
!
! update the correlation estimate
!
!$OMP PARALLEL PRIVATE(jn,jm,jk1,jk2,ila,myid,numthd)
myid=omp_get_thread_num()
numthd=omp_get_num_threads()
DO JN = myid, NTRUNC, numthd
DO JM = 0, JN
ZFACT = 2.
IF (JM .EQ.0)ZFACT = 1.
ILA = NIND(JM) + JN - JM
DO JK1 = 1, NKSDIM
DO JK2 = 1, NKSDIM
CORNS(JK1,JK2,JN,1) = CORNS(JK1,JK2,JN,1)
& + ZFACT*(SP(ILA,1,JK1)*SP(ILA,1,JK2)
& + SP(ILA,2,JK1)*SP(ILA,2,JK2))
END DO
END DO
END DO
END DO
!$OMP END PARALLEL
write(nulout,*) 'spcorrglb1: apres loop sur CORNS'
331 continue
!
! 3.7 Ending the processing of one file
!
iensemble = iensemble + iens
write(nulout,*) 'spcorrglb: iens, iensemble =',iens, iensemble
write(nulout,9370) iens, iensemble
9370 format(5X,I4," cases have been processed up to now",
& 5x,"Current size of the ensemble: ",I4)
!
ierr = fstfrm(kulstat)
ierr = fclos(kulstat)
!
enddo ! loop on files
!
!*4. Normalize the result according to the size of the ensemble
! ----------------------------------------------------------
!
call ens2corns
!
!*5. Estimate correlation scales
! ---------------------------
!
call corrlengthglb(koutfile,.true.,.false.)
!
write(nulout,*) 'spcorrglb1: END'
!
return
end