!-------------------------------------- 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 spcorrla2(kulstat,koutfile,ldhelm,ldfplane,ldtb_psi, 2,55
& ldcoriol_one,pmfpp,pmfcu,pmftu,pmflq,
& pmfpsu,pmftg)
#if defined (DOC)
*
***s/r spcorrla2 - An extension of spcorrla.ftn where TbTb correlations and Tb-Psi correlations are
* introduced as part of CORNS matrix (first introduced in the Global code by Mark Buehner 2008).
*
*Author : L. Fillion - ARMA/EC - 4 Mar 2009
*Revision:
*
* -------------------
** Purpose: to estimate the forecast error correlation from an
* . ensemble of forecast error samples.
*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"
*
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,llvfilt,llfilt,llvproj
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 zt0(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 zsavet0(ni,nj,nflev)
real*8 zsavetb(ni,nj,nflev)
real*8 zpsb(ni,nj)
real*8 z2d(ni,nj)
real*8 z2d_in(mni_in,mnj_in)
!
real*8 zsptb(nla,2,nflev)
real*8 zwrksp(nla,2,nflev)
!
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*2 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,' spcorrla2- Estimation of Forecast error correlations',//)
!
if(nanalvar.ne.4) then
write(nulout,*) 'spcorrla2: nanalvar = ',nanalvar
CALL ABORT3D(NULOUT,'spcorrla2: nanalvar must be 4 here...')
endif
!
llvfilt = .false.
llvproj = .true.
llfilt = .false.
! if(lflt_low) then
! llfilt = .true.
! clflt = 'L'
! else if(lflt_high) then
! llfilt = .true.
! clflt = 'H'
! endif
!
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,*) 'spcorrla2: nensemble = ',nensemble
!
call getstats_cv(koutfile,zmpp,zmcu,zmtu,zmlq,zmtb,zmpsu,zmpsb,zmtg,
& zspp,zscu,zstu,zslq,zstb,zspsu,zspsb,zstg,nensemble)
!
write(nulout,*) 'spcorrla2: *************************************'
write(nulout,*) 'spcorrla2: max/min of MEAN read from getstats_cv'
write(nulout,*) 'spcorrla2: *************************************'
!
call maxmin(zmpp,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla2 ',
& 'PP')
call maxmin(zmcu,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla2 ',
& 'CU')
call maxmin(zmtu,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla2 ',
& 'TU')
call maxmin(zmlq,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla2 ',
& 'LQ')
call maxmin(zmtb,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla2 ',
& 'TB')
call maxmin(zmpsb,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla2 ',
& 'Pb')
call maxmin(zmpsu,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla2 ',
& 'Pu')
call maxmin(zmtg,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla2 ',
& 'Tg')
!
write(nulout,*) 'spcorrla2: **************************************'
write(nulout,*) 'spcorrla2: max/min of STDEV read from getstats_cv'
write(nulout,*) 'spcorrla2: **************************************'
!
call maxmin(zspp,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla2 ',
& 'PP')
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,'spcorrla2 ',
& 'CU')
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,'spcorrla2 ',
& 'TU')
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,'spcorrla2 ',
& 'LQ')
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,'spcorrla2 ',
& 'TB')
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,'spcorrla2 ',
& 'Pb')
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,'spcorrla2 ',
& 'Pu')
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,'spcorrla2 ',
& 'Tg')
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)
!
! Build Balanced variables
! ------------------------
!
call transfer('GD01')
ldopc = .true.
if(lpsifromglb.or.lpsifromlam) ldopc = .false.
call initgdla(zvort,zdiv,zgdpsi,zgdchi,'U',ldopc) ! adjusts fields according to B.C.
call transfer('GD10')
!
if(lpsifromlam) then ! get PSI from input file kulstat
do jk=1,nflev
ierr = vfstlir(z2d,kulstat,ni,nj,1,NSTAMPN,
& 'PSI_LAM ',NIP1(JK),-1,-1,'E','PP')
if(ierr.lt.0) then
call abort3d(nulout,'spcorrla2: Problem reading PSI field')
endif
do jj=1,nj
do ji=1,ni
zgdpsi(ji,jk,jj) = z2d(ji,jj)
enddo
enddo
ierr = vfstlir(z2d,kulstat,ni,nj,1,NSTAMPN,
& 'CHI_LAM ',NIP1(JK),-1,-1,'E','CC')
if(ierr.lt.0) then
call abort3d(nulout,'spcorrla2: Problem reading CHI field')
endif
do jj=1,nj
do ji=1,ni
zgdchi(ji,jk,jj) = z2d(ji,jj)
enddo
enddo
enddo
else if(lpsifromglb) then ! get PSI from input file kulstat
do jk=1,nflev
! ierr = vfstlir(z2d_in,kulstat,mni_in,mnj_in,1,NSTAMPN,
! & 'LAM4D ',NIP1(JK),-1,-1,'E','PP')
! if(ierr.lt.0) then
! call abort3d(nulout,'spcorrla2: Problem reading PSI field')
! endif
do jj=1,mnj_in
do ji=1,mni_in
zgdpsi(ji,jk,jj) = ut0(ji,jk,jj)
zgdchi(ji,jk,jj) = vt0(ji,jk,jj)
enddo
enddo
enddo
call mach3(zgdpsi,ni,nj,nflev,inip1,injp1)
call mach3(zgdchi,ni,nj,nflev,inip1,injp1)
endif
!
! 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
!
if(llfilt) then
write(nulout,*) 'spcorrla2: **************************************'
write(nulout,*) 'spcorrla2: PP error sample is spectrally filtered'
write(nulout,*) 'spcorrla2: **************************************'
call gdtruncr(zgdpsi,zwrksp,'T',mflt_trunc,clflt,.false.,nflev)
else
write(nulout,*) 'spcorrla2: NO FILTER applied to PP error sample'
endif
!
ztb(:,:,:) = 0.0
zpb(:,:,:) = 0.0
zpsb(:,:) = 0.0
!
write(nulout,*) ' '
write(nulout,*) 'spcorrla2: ****************************************'
write(nulout,*) 'spcorrla2: Uses Balance operators of Order = ',mbal_order
write(nulout,*) 'spcorrla2: ldtb_psi = ',ldtb_psi
write(nulout,*) 'spcorrla2: ****************************************'
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(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,'spcorrla2 ',
& '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
if(ldhelm) then
ut0(ji,jk,jj) = zgdpsi(ji,jk,jj)
vt0(ji,jk,jj) = zgdchi(ji,jk,jj)
else
ut0(ji,jk,jj) = zvort(ji,jk,jj)
vt0(ji,jk,jj) = zdiv(ji,jk,jj)
endif
zsavet0(ji,jj,jk) = tt0(ji,jk,jj)
zsavetb(ji,jj,jk) = ztb(ji,jk,jj)
zt0(ji,jk,jj) = tt0(ji,jk,jj)-ztb(ji,jk,jj) ! tu
enddo
enddo
enddo
!
! Filter stratospheric vertical modes from T_u
!
if(llvfilt) call vfilt(zt0,5,'L')
!
do ji=1,ni
do jj=1,nj
do jk=1,nflev
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) ! psu
enddo
enddo
!
! Produce unbiaised analysis variables
! ------------------------------------
!
!ok
write(nulout,*) 'spcorrla2: avant d enlever la moyenne sur TB'
call maxmin(ztb,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla2 ',
& 'TB')
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)
ztb(ji,jk1,jj) = ztb(ji,jk1,jj) - zmtb(ji,jk1,jj)
enddo
zpsb(ji,jj) = zpsb(ji,jj) - zmpsb(ji,jj)
gps0(ji,1,jj) = gps0(ji,1,jj) - zmpsu(ji,jj)
gtg0(ji,1,jj) = gtg0(ji,1,jj) - zmtg(ji,jj)
enddo
enddo
write(nulout,*) 'spcorrla2: apres avoir enleve la moyenne sur TB'
call maxmin(ztb,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla2 ',
& 'TB')
!
! 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
!ok
if(zstb(ji,jk1,jj).ne.0.0) then
ztb(ji,jk1,jj) = ztb(ji,jk1,jj)/zstb(ji,jk1,jj) ! stb contains Tb st-dev... see meancvgd
endif
!ok
enddo
!ok
if(zspsb(ji,jj).ne.0.0) then
zpsb(ji,jj) = zpsb(ji,jj)/zspsb(ji,jj)
endif
!ok
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
write(nulout,*) 'print ici'
call maxmin(ztb,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla2 ',
& 'TB')
!
! 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
!
! update the Tb_Tb and PSI_Tb correlation estimates
!
write(nulout,*) 'print ici'
call maxmin(ztb,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla2 ',
& 'TB')
call re2spla(zsptb,ztb,nflev)
call maxmin(zsptb,nla,nflev,2,zmin,zmax,
& idum1,idum2,idum3,idum4,'spcorrla2 ',
& 'SP')
!
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, nflev
do jk1 = 1, nflev
corns(nksdim+jk1,nksdim+jk2,jband-1,1) = ! Tb_Tb
& corns(nksdim+jk1,nksdim+jk2,jband-1,1)
& + zfact*(zsptb(ila,1,jk1)*zsptb(ila,1,jk2)
& + zsptb(ila,2,jk1)*zsptb(ila,2,jk2))
corns(jk1,nksdim+jk2,jband-1,1) = ! PSI_Tb
& corns(jk1,nksdim+jk2,jband-1,1)
& + zfact*(sp(ila,1,jk1)*zsptb(ila,1,jk2)
& + sp(ila,2,jk1)*zsptb(ila,2,jk2))
corns(nksdim+jk1,jk2,jband-1,1) =
& corns(jk1,nksdim+jk2,jband-1,1)
enddo
enddo
enddo
enddo
!$OMP END PARALLEL
331 continue
!
! 3.7 Ending the processing of one file
!
iensemble = iensemble + iens
write(nulout,*) 'spcorrla2: 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, nksdim2
do jk2 = 1, nksdim2
corns(jk1,jk2,jband-1,1) = corns(jk1,jk2,jband-1,1)/rbandtot(jband)
enddo
enddo
enddo
!
!*4. Ensure symmetric corns
! ----------------------
!
do jk2=1,nksdim2
do jk1=jk2,nksdim2
do jband=1,nband
corns(jk2,jk1,jband-1,1) = corns(jk1,jk2,jband-1,1)
enddo
enddo
enddo
!
!*5. Normalize the result according to the size of the ensemble
! ----------------------------------------------------------
!
call ens2cornsla2
!
!*7. Estimate correlation scales
! ---------------------------
!
call corrlengthla2(koutfile,.true.,.false.)
!
write(nulout,*) 'spcorrla2: END'
!
return
end