!-------------------------------------- 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 spcorrla(kulstat,koutfile,ldhelm,ldfplane,ldtb_psi, 2,41
& ldcoriol_one,pmfpp,pmfcu,pmftu,pmflq,pmfpsu,pmftg)
#if defined (DOC)
*
***s/r spcorrla - Perform computation of spectral correlations for control vector component fields.
* Limited-Area version of 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 subroutine ptotla.ftn has been called prior to this one here so that
* 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/MSC - Oct 1st 2005.
*Revision:
* L. Fillion - ARMA/EC - 23 Apr 2008 - Implement Spectral representation of PtoT matrix.
! L. Fillion - 29 Apr 2008 - Adjust call before/after initgdla since the latter now uses GD1 array.
! L. Fillion - 29 Oct 2008 - Ensure removal of biais is done properly.
! L. Fillion - 12 Dec 2008 - Get rid of comstdd.cdk and improve ps_u and TG stats.
! L. Fillion - 5 Jan 2009 - Introduce pmfpp,pmfcu,pmftu,pmflq,pmfpsu,pmftg fields in case of MC case.
! L. Fillion - 13 Jan 2009 - Upgrade lam4d to v_10_1_2 of 3dvar: Extra dimension for CORNS.
! L. Fillion - May 2010 - Improved according to preliminary Helmholtz's precomputation error samples in previous steps of
! statistics computations. Clean up of the code. Adjusted withe new initgdla.ftn
*
*
* -------------------
** 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 "comlun.cdk"
#include "comgem.cdk"
#include "comcorr.cdk"
#include "comsp.cdk"
#include "comgd0.cdk"
#include "comgdpar.cdk"
#include "comcse1.cdk"
#include "comfftla.cdk"
#include "comcva.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "namgdpar.cdk"
*
logical ldhelm,ldfplane,ldtb_psi,ldcoriol_one
INTEGER KULSTAT, koutfile
real*8 pmfpp(ni,nflev,nj)
real*8 pmfcu(ni,nflev,nj)
real*8 pmftu(ni,nflev,nj)
real*8 pmflq(ni,nflev,nj)
real*8 pmfpsu(ni,nj)
real*8 pmftg(ni,nj)
!
logical ldopc,llfilt,llvproj,llvfilt
integer vfstlir,inip1,injp1,iensemble
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 zgdpsi(ni,nflev,nj)
real*8 zgdchi(ni,nflev,nj)
real*8 zgdes(ni,nflev,nj)
real*8 zgdgz(ni,nflev,nj)
real*8 ztb(ni,nflev,nj)
real*8 zpb(ni,nflev,nj)
real*8 zvort(ni,nflev,nj)
real*8 zdiv(ni,nflev,nj)
real*8 zpsb(ni,nj)
real*8 z2d(ni,nj)
real*8 z2d_in(mni_in,mnj_in)
!
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
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,' spcorrla- Estimation of Forecast error correlations',//)
!
llfilt = .false.
if(lflt_low) then
llfilt = .true.
clflt = 'L'
else if(lflt_high) then
llfilt = .true.
clflt = 'H'
endif
llvfilt = .false.
llvproj = .false.
!
inip1 = ni+1
injp1 = nj+1
!
!*2. Estimate the mean and st-dev of analysis variables
! --------------------------------------------------
!
idimax = 100
!
! read from file: precomputed mean and stdev of control-variables
!
write(nulout,*) 'spcorrla: nensemble = ',nensemble
! ifile = nulbgst
! if(cstats_step.eq.'ALL ') ifile = koutfile
!
! IERR = FNOM(koutfile,cflstdev,'RND',0)
! IERR = FSTOUV(koutfile,'RND')
!
zmpp(:,:,:) = 0.0
zmcu(:,:,:) = 0.0
zmtu(:,:,:) = 0.0
zmlq(:,:,:) = 0.0
zmtb(:,:,:) = 0.0
zmpsu(:,:) = 0.0
zmpsb(:,:) = 0.0
!
zspp(:,:,:) = 0.0
zscu(:,:,:) = 0.0
zstu(:,:,:) = 0.0
zslq(:,:,:) = 0.0
zstb(:,:,:) = 0.0
zspsu(:,:) = 0.0
zspsb(:,:) = 0.0
!
call getstats_cv(koutfile,zmpp,zmcu,zmtu,zmlq,zmtb,zmpsu,zmpsb,zmtg,
& zspp,zscu,zstu,zslq,zstb,zspsu,zspsb,zstg,nensemble,
& ldhelm)
!
write(nulout,*) 'spcorrla: *************************************'
write(nulout,*) 'spcorrla: max/min of MEAN read from getstats_cv'
write(nulout,*) 'spcorrla: *************************************'
!
if(ldhelm) then
clnomvar = 'PP '
else
clnomvar = 'QQ '
endif
llzdpc = .false.
if(ldhelm.and.cfstvar(1).eq.'UU') llzdpc = .true.
write(nulout,*) 'spcorrla: ldhelm = ',ldhelm
write(nulout,*) 'spcorrla: cfstvar(1) = ',cfstvar(1)
write(nulout,*) 'spcorrla: llzdpc = ',llzdpc
!
call maxmin(zmpp,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& clnomvar)
if(ldhelm) then
clnomvar = 'CU '
else
clnomvar = 'DD '
endif
call maxmin(zmcu,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'CUM')
call maxmin(zmtu,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'TUM')
call maxmin(zmlq,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'LQM')
call maxmin(zmtb,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'TBM')
call maxmin(zmpsb,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'PbM')
call maxmin(zmpsu,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'PuM')
call maxmin(zmtg,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'TgM')
!
write(nulout,*) 'spcorrla: **************************************'
write(nulout,*) 'spcorrla: max/min of STDEV read from getstats_cv'
write(nulout,*) 'spcorrla: **************************************'
!
call maxmin(zspp,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'PPS')
if(zmin.le.0.0) then
CALL ABORT3D(NULOUT,'spcorrla: ST-DEV PP .le. 0.0 !')
endif
call maxmin(zscu,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'CUS')
if(zmin.le.0.0) then
CALL ABORT3D(NULOUT,'spcorrla: ST-DEV CU .le. 0.0 !')
endif
call maxmin(zstu,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'TUS')
if(zmin.le.0.0) then
CALL ABORT3D(NULOUT,'spcorrla: ST-DEV TU .le. 0.0 !')
endif
call maxmin(zslq,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'LQS')
if(zmin.le.0.0) then
CALL ABORT3D(NULOUT,'spcorrla: ST-DEV LQ .le. 0.0 !')
endif
call maxmin(zstb,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'TBS')
if(zmin.le.0.0) then
CALL ABORT3D(NULOUT,'spcorrla: ST-DEV TB .le. 0.0 !')
endif
call maxmin(zspsb,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'PbS')
if(zmin.le.0.0) then
CALL ABORT3D(NULOUT,'spcorrla: ST-DEV Pb .le. 0.0 !')
endif
call maxmin(zspsu,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'PuS')
if(zmin.le.0.0) then
CALL ABORT3D(NULOUT,'spcorrla: ST-DEV PU .le. 0.0 !')
endif
call maxmin(zstg,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'TgS')
if(zmin.le.0.0) then
CALL ABORT3D(NULOUT,'spcorrla: ST-DEV TG .le. 0.0 !')
endif
!
!
!*3. Loop on all error sample files and build spectral correlations
! --------------------------------------------------------------
!
do jfile = 1, nflstat
call openinc(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) ! error sample already treated to be directly used on analysis grid.
!
! Build Balanced variables
! ------------------------
!
if(cfstvar(1).eq.'PP'.or.cfstvar(1).eq.'QQ') then
do jk=1,nflev
do jj=1,nj
do ji=1,ni
zgdpsi(ji,jk,jj) = ut0(ji,jk,jj)
zgdchi(ji,jk,jj) = vt0(ji,jk,jj)
enddo
enddo
enddo
else
write(nulout,*) 'spcorrla: cfstvar(1) = ',cfstvar(1)
CALL ABORT3D(NULOUT,'spcorrla: cfstvar(1) cannot be set to UU ...')
endif
!
call maxmin(zgdpsi,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'PP ')
call maxmin(zgdchi,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'CU ')
!
! Subtract forecast mean if in MC mode
!
if(lmcstats) then
write(nulout,*) 'meancvgd: Subtract fsct ensemble mean from current fcst sample'
do jj=1,nj
do ji=1,ni
do jk=1,nflev
zgdpsi(ji,jk,jj) = zgdpsi(ji,jk,jj) - pmfpp(ji,jk,jj)
zgdchi(ji,jk,jj) = zgdchi(ji,jk,jj) - pmfcu(ji,jk,jj)
tt0(ji,jk,jj) = tt0(ji,jk,jj) - pmftu(ji,jk,jj)
q0(ji,jk,jj) = q0(ji,jk,jj) - pmflq(ji,jk,jj)
enddo
gps0(ji,1,jj) = gps0(ji,1,jj) - pmfpsu(ji,jj)
gtg0(ji,1,jj) = gtg0(ji,1,jj) - pmftg(ji,jj)
enddo
enddo
endif
!
ztb(:,:,:) = 0.0
zpb(:,:,:) = 0.0
zpsb(:,:) = 0.0
!
write(nulout,*) ' '
write(nulout,*) 'spcorrla: ****************************************'
write(nulout,*) 'spcorrla: Uses Balance operators of Order = ',mbal_order
write(nulout,*) 'spcorrla: ldtb_psi = ',ldtb_psi
write(nulout,*) 'spcorrla: ****************************************'
write(nulout,*) ' '
!
if(mbal_order.eq.1) then
!
! Linear-Geostrophic
! ------------------
!
if(ldtb_psi) then
clgrid = 'P'
if(lpsifromglb) clgrid = 'S'
call linbal_la(zpb,zgdpsi,ldfplane,ldcoriol_one,clgrid)
if(llvfilt) call vfilt(zpb,5,'L')
if(llvproj) call vproj(zpb,zpb,nflev) ! Project Pb
call p2tpsb(ztb,zpsb,zpb,cptot,.false.,.true.)
if(llvproj) call viproj(ztb,ztb,nflev) ! Get gridpoint Tb
call maxmin(ztb,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla ',
& 'TB ')
endif
else if(mbal_order.eq.2) then
!
! Tangent-Linear 2nd-Order Balance
! ---------------------------------
!
endif
!
! Build Unbalanced variables
! --------------------------
!
do ji=1,ni
do jj=1,nj
do jk=1,nflev
ut0(ji,jk,jj) = zgdpsi(ji,jk,jj)
vt0(ji,jk,jj) = zgdchi(ji,jk,jj)
tt0(ji,jk,jj) = tt0(ji,jk,jj)-ztb(ji,jk,jj) ! tu
enddo
enddo
enddo
!
do ji=1,ni
do jj=1,nj
gps0(ji,1,jj)=gps0(ji,1,jj)-zpsb(ji,jj) ! psu
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
!
! Computation of forecast error correlations
! ------------------------------------------
!
call transfer('ZSP0')
!
call reespe_la
!
! update the correlation estimate
!
zfact = 2.0d0 ! fact for band zero should be one but this band is not used in actual computations
!$OMP PARALLEL PRIVATE(jband,jm,jk1,jk2,ila,myid,numthd)
myid=omp_get_thread_num()+1
numthd=omp_get_num_threads()
do jband = myid,nband,numthd
do jm = 1, mbandsp(jband)
ila = mila(jm,jband)
do jk2 = 1, nksdim
do jk1 = 1, nksdim
corns(jk1,jk2,jband-1,1) = corns(jk1,jk2,jband-1,1)
& + zfact*(sp(ila,1,jk1)*sp(ila,1,jk2)
& + sp(ila,2,jk1)*sp(ila,2,jk2))
enddo
enddo
enddo
enddo
!$OMP END PARALLEL
331 continue
!
! 3.7 Ending the processing of one file
!
iensemble = iensemble + iens
write(nulout,*) 'spcorrla: 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
!
! Take mbansp factor (see LAM4D documentation, eqn. 3.4.4) into account
!
do jband = 1, nband
do jk1 = 1, nksdim
do jk2 = 1, nksdim
corns(jk1,jk2,jband-1,1) = corns(jk1,jk2,jband-1,1)/rbandtot(jband)
enddo
enddo
enddo
!
!*4. Normalize the result according to the size of the ensemble
! ----------------------------------------------------------
!
call ens2cornsla
!
! write characteristic lengths to std file
!
!*5. Estimate correlation scales
! ---------------------------
!
call corrlengthla(koutfile,.true.,.false.)
!
write(nulout,*) 'spcorrla: END'
!
return
end