!-------------------------------------- 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 sptotla(kulstat,koutfile,ldfplane,ldtb_psi,ldcoriol_one, 2,38
& pmpp,pmcu,pmtu,pmlq,pmpsu,pmtg)
#if defined (DOC)
*
***s/r sptotla - Statistical Estimation of A where:
* vec(T Ps) = A vec(P_b) + vec(T' Ps')
* Identical setup as correlation calculations
*
*Author : Luc Fillion - ARMA/EC - 18 Apr 2008
*Revision:
! L. Fillion - 29 Apr 2008 - Adjust call before/after initgdla since the latter now uses GD1 array.
! L. Fillion - 17 Nov 2008 - Introduce pmpp,pmcu,pmtu,pmlq,pmpsu,pmtg fields in case of MC case.
! Revision: Luc Fillion - EC/CAN - 25 Feb 2009. - Allo low and high wvnb filtering at the same time.
*
*Arguments: KULSTAT logical unit number for error sample forecast files.
*
#endif
IMPLICIT NONE
*implicits
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comgem.cdk"
#include "comgemla.cdk"
#include "comsp.cdk"
#include "comgd0.cdk"
#include "comsp1.cdk"
#include "comgd1.cdk"
#include "comgdpar.cdk"
#include "comcse1.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comfftla.cdk"
#include "comcva.cdk"
#include "comcorr.cdk"
*
real*8 pmpp(ni,nflev,nj)
real*8 pmcu(ni,nflev,nj)
real*8 pmtu(ni,nflev,nj)
real*8 pmlq(ni,nflev,nj)
real*8 pmpsu(ni,nj)
real*8 pmtg(ni,nj)
*
logical ldfplane,ldtb_psi,llvfilt,llvproj,ldcoriol_one
INTEGER KULSTAT,koutfile
!
logical llfilt,llwrite
logical ldopc
integer ji,jj,ifois,isave,icase,jlev
data ifois,isave/0,0/
INTEGER JENS, IENS, JK1, JK2, JLA
INTEGER IERR, JFILE, JK, ILON, ILEN, JB, NLATBAND
!
INTEGER FNOM, FSTOUV, FSTFRM, FCLOS, FSTPRM, FSTINF, FSTINL
integer vfstlir
!
! RPN Standard files parameters
!
INTEGER vfstecr
INTEGER IPAK, IDATEO
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
!
INTEGER IBND1,IBND2
!
REAL*8 DHEURES
CHARACTER*1 CLTYPVAR, CLGRTYP, clgrid
CHARACTER*2 CLNOMVAR
CHARACTER*8 CLETIKET
!
character*1 clpart,clflt
integer jband,ila,ioutband,jm,inip1,injp1
integer idum1,idum2,idum3,idum4
real*8 zmin,zmax
REAL*8 ZFACT,ZMAXI,ZWT
real*8 zgdpsi(ni,nflev,nj),zgdchi(ni,nflev,nj)
real*8 zgdes(ni,nflev,nj),zgdgz(ni,nflev,nj)
real*8 zvort(ni,nflev,nj),zdiv(ni,nflev,nj)
real*8 zpb(ni,nflev,nj)
real*8 z3d(ni,nflev,nj)
!
real*8 zx8(ni),zy8(nj)
real*8 z2d(ni,nj)
real*8 zpsb(ni,nj)
real*8 z2d_in(mni_in,mnj_in)
!
real*8 zwrksp(nla,2,nflev)
!
real*8 ztb(ni,nflev,nj)
real*8 zsavepsi(ni,nj,nflev)
real*8 zsavepb(ni,nj,nflev)
real*8 zsavett(ni,nj,nflev)
real*8 zorig_pp(ni,nj,nflev)
real*8 zorig_tt(ni,nj,nflev)
real*8 zsptt(nla,2,nflev)
real*8 zsppb(nla,2,nflev)
real*8 zspps(nla,2)
REAL*8 ZM1(NFLEV+1,NFLEV,nband), ZM2(NFLEV,NFLEV,nband)
REAL*8 ZPTOT(NFLEV,NFLEV)
REAL*8 ZM2INV(NFLEV,NFLEV), ZWORK(NFLEV*NFLEV), ZDET, ZEPS
!
EXTERNAL FNOM, FSTOUV, FSTFRM, FCLOS, FSTPRM, FSTINF,FSTINL
!
!!
write(nulout,*) 'sptotla: BEGIN'
!
WRITE(NULOUT,FMT=9000)
9000 FORMAT(3(/,3x,80('.')),//
S ,4x,' sptotla- Spectral Estimation of P_to_T Operator',//)
!
ioutband = 5
inip1 = ni+1
injp1 = nj+1
llwrite = .false.
llvfilt = .false.
llfilt = .false.
llvproj = .false.
!
if(lflt_low) then
llfilt = .true.
clflt = 'L'
else if(lflt_high) then
llfilt = .true.
clflt = 'H'
else if(lflt_high.and.lflt_low) then
llfilt = .true.
clflt = '2'
endif
if(llvfilt) then
write(nulout,*) 'sptotla: Vertical mode filtering applied'
else
write(nulout,*) 'sptotla: NO Vertical mode filtering applied'
endif
if(llvproj) then
write(nulout,*) 'sptotla: Vertical mode Projection applied'
else
write(nulout,*) 'sptotla: NO Vertical mode Projection applied'
endif
!
!*1. Initialize P_to_T, ZM1, ZM2
! ---------------------------
!
zm1(:,:,:) = 0.0
zm2(:,:,:) = 0.0
zptot(:,:) = 0.0
!
!*2. Access the errors sample of PSI and (T,lnPs) from a set of files
! (loop on the files)
! -------------------------------------------------------------
!
IDIMAX = 100
!
! call getmeangdla(nulbgst) ! read from file: precomputed mean of fields
DO 201 JFILE = 1, NFLSTAT
!
call openinc(kulstat,jfile)
!
!* 2.1 Find how many cases there are to be treated
!
IP1 = -1
IP2 = -1
IP3 = -1
CLNOMVAR = 'P0'
! write(nulout,*) 'sptotla: CLNOMVAR=',CLNOMVAR
! write(nulout,*) 'sptotla: CETIKETERR=',CETIKETERR
! write(nulout,*) 'sptotla: KULSTAT=',KULSTAT
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,'sptotla: PROBLEM WITH FSTINL')
END IF
IENS = INFON
write(nulout,*) 'sptotla: IENS = ',IENS
if(iens.gt.1) CALL ABORT3D(NULOUT,'sptotla: IENS > 1 .... stop ')
!
!* 2.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)
if(llwrite) WRITE(NULOUT,9320)JENS, IFSTRUN,IHH
END DO
9320 FORMAT(5X,"Case No. ",I3,5x,"Date and time: ",I10,5x,I8)
!
NENSEMBLE=0
IF(NENSEMBLE.EQ.0) THEN
NDATESTAT = IDATE(1)
END IF
!
CTYPVARN = ' '
CETIKETN = CLETIKET
!
!* 2.3 Loop on the ensemble
!
DO 231 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)
!
! Estimation of P_to_T matrix (A)
!
call transfer('GD01')
ldopc = .true.
if(lpsifromglb.or.lpsifromlam) ldopc = .false.
write(nulout,*) 'sptotla: call to initgdla with ldopc=',ldopc
call initgdla(zvort,zdiv,zgdpsi,zgdchi,'U',ldopc)
call transfer('GD10')
!
if(lpsifromlam) then ! get PSI from input file kulstat
do jk=1,nflev
ierr = vfstlir(z2d,kulstat,ini,inj,1,NSTAMPN,
& 'PSI_LAM ',NIP1(JK),-1,-1,'E','PP')
if(ierr.lt.0) then
call abort3d(nulout,'sptotla: 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,ini,inj,1,NSTAMPN,
& 'CHI_LAM ',NIP1(JK),-1,-1,'E','CC')
if(ierr.lt.0) then
call abort3d(nulout,'sptotla: 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,ini,inj,1,NSTAMPN,
! & CETIKETERR,NIP1(JK),-1,-1,'E','PP')
! write(nulout,*) 'sptotla: ini,inj dimensions of PP,CC from GLB=',ini,inj
! if(ierr.lt.0) then
! call abort3d(nulout,'sptotla: 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 sample form forecast mean if in MC mode
!
if(lmcstats) then
do jj=1,nj
do ji = 1,ni
do jlev = 1,nflev
zgdpsi(ji,jlev,jj) = zgdpsi(ji,jlev,jj) - pmpp(ji,jlev,jj)
zgdchi(ji,jlev,jj) = zgdchi(ji,jlev,jj) - pmcu(ji,jlev,jj)
tt0(ji,jlev,jj) = tt0(ji,jlev,jj) - pmtu(ji,jlev,jj)
q0(ji,jlev,jj) = q0(ji,jlev,jj) - pmlq(ji,jlev,jj)
enddo
gps0(ji,1,jj) = gps0(ji,1,jj) - pmpsu(ji,jj)
gtg0(ji,1,jj) = gtg0(ji,1,jj) - pmtg(ji,jj)
enddo
enddo
endif
!
zpb(:,:,:) = 0.0
zsavepb(:,:,:) = 0.0
zsavepsi(:,:,:) = 0.0
zpsb(:,:) = 0.0
!
write(nulout,*) ' '
write(nulout,*) 'sptotla: ****************************************'
write(nulout,*) 'sptotla: Uses Balance operators of Order = ',mbal_order
write(nulout,*) 'sptotla: ****************************************'
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)
else
do jk=1,nflev
do jj=1,nj
do ji=1,ni
zpb(ji,jk,jj)=zvort(ji,jk,jj)
enddo
enddo
enddo
endif
!
do jk=1,nflev
do jj=1,nj
do ji=1,ni
zsavepb(ji,jj,jk)=zpb(ji,jk,jj)
zorig_pp(ji,jj,jk)=zgdpsi(ji,jk,jj)
zsavepsi(ji,jj,jk)=zgdpsi(ji,jk,jj)
enddo
enddo
enddo
!
! Build spectral fields
! ---------------------
!
zsppb(:,:,:) = 0.0
if(llvfilt) call vfilt(zpb,5,'L') ! vertical normal mode filtering of P
if(llvproj) call vproj(zpb,zpb,nflev) ! Project PB
call re2spla(zsppb,zpb,nflev)
if(llfilt) then
write(nulout,*) 'sptotla: **************************************'
write(nulout,*) 'sptotla: GP error sample is spectrally filtered'
write(nulout,*) 'sptotla: **************************************'
call gdtruncr(z3d,zsppb,'T',mflt_trunc,clflt,.true.,nflev) ! filters directly in spectral space the input array zsptt
else
write(nulout,*) 'sptotla: NO FILTER applied to TT error sample'
endif
!
do jk=1,nflev
do jj=1,nj
do ji=1,ni
z3d(ji,jk,jj)=tt0(ji,jk,jj)
zorig_tt(ji,jj,jk)=tt0(ji,jk,jj)
enddo
enddo
enddo
!
if(llvproj) call vproj(z3d,z3d,nflev) ! Project TT0
!
if(isave.eq.0) then
isave = 1
call gdtruncr(zgdpsi,zwrksp,'T',mflt_trunc,clflt,.false.,nflev) ! just to see with rec if filtering is OK
call gdtruncr(z3d,zwrksp,'T',mflt_trunc,clflt,.false.,nflev) ! just to see with rec if filtering is OK
!
do jk=1,nflev
do jj=1,nj
do ji=1,ni
zsavepsi(ji,jj,jk)=zgdpsi(ji,jk,jj)
zsavett(ji,jj,jk)=z3d(ji,jk,jj)
enddo
enddo
enddo
endif
!
do jj=1,nj
do ji=1,ni
z2d(ji,jj)=gps0(ji,1,jj)
enddo
enddo
!
zspps(:,:) = 0.0
call re2spla(zsptt,z3d,nflev)
call re2spla(zspps,z2d,1)
if(llfilt) then
write(nulout,*) 'sptotla: **************************************'
write(nulout,*) 'sptotla: TT P0 error samples spectrally filtered'
write(nulout,*) 'sptotla: **************************************'
call gdtruncr(z3d,zsptt,'T',mflt_trunc,clflt,.true.,nflev) ! filters directly in spectral space the input array zsptt
call gdtruncr(z2d,zspps,'T',mflt_trunc,clflt,.true.,1) ! filters directly in spectral space the input array zsptt
else
write(nulout,*) 'sptotla: NO FILTER applied to TT P0 error samples'
endif
!
if(ifois.eq.0) then ! we output some fields on file for ensuring all is OK...
ifois = 1
call maxmin(zgdpsi,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'sptotla ',
& 'PP')
call maxmin(zpb,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'sptotla ',
& 'PB')
call maxmin(z3d,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'sptotla ',
& 'T0')
call maxmin(z2d,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'sptotla ',
& 'P0')
! call outhoriz2d(zgdpsi,'psi.od ','PP',nflev/2,
! & 1,ni,1,nj,ni,nj,nflev)
! call outhoriz2d(zpb,'pb.od ','PB',nflev/2,
! & 1,ni,1,nj,ni,nj,nflev)
!
IPAK = -32
IDATYP = 5
IP1 = 0
IP2 = 0
IP3 = jfile
IDATEO = NDATESTAT
!
do jk=1,nflev
!
IP1 = NIP1(jk)
!
IERR = VFSTECR(zsavepb(1,1,jk),zsavepb(1,1,jk),IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E','GZ',
& 'PB ','Z',mig1flda,mig2flda,mig3flda,0,IDATYP,.TRUE.)
!
IERR = VFSTECR(zorig_pp(1,1,jk),zorig_pp(1,1,jk),IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E','PP',
& 'ZORIG_PP','Z',mig1flda,mig2flda,mig3flda,0,IDATYP,.TRUE.)
!
IERR = VFSTECR(zsavepsi(1,1,jk),zsavepsi(1,1,jk),IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E','PP',
& 'ZSAVEPSI','Z',mig1flda,mig2flda,mig3flda,0,IDATYP,.TRUE.)
!
IERR = VFSTECR(zorig_tt(1,1,jk),zorig_tt(1,1,jk),IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E','TT',
& 'ZORIG_TT','Z',mig1flda,mig2flda,mig3flda,0,IDATYP,.TRUE.)
!
IERR = VFSTECR(zsavett(1,1,jk),zsavett(1,1,jk),IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E','TT',
& 'ZSAVETT','Z',mig1flda,mig2flda,mig3flda,0,IDATYP,.TRUE.)
enddo
! -----------------------------
! Writing positional parameters
! -----------------------------
cletiket = ' '
cltypvar = ' '
!
do ji=1,ni
zx8(ji)=grd_x_8(ji)
enddo
do jj=1,nj
zy8(jj)=grd_y_8(jj)
enddo
!
ierr = vfstecr(zx8,zx8,ipak,koutfile,idateo,
& 0,0,ni,1,1,mig1flda,mig2flda,mig3flda,cltypvar
& ,'>>',cletiket,'E',mig1tic,mig2tic,mig3tic,mig4tic,idatyp
& ,.true.)
!
ierr = vfstecr(zy8, zy8, ipak, koutfile, idateo,
& 0,0, 1, nj, 1, mig1flda,mig2flda,mig3flda,cltypvar
& ,'^^',cletiket,'E',mig1tic,mig2tic,mig3tic,mig4tic,idatyp
& ,.true.)
endif
!
write(nulout,*) 'sptotla: mextendx,mextendy = ',mextendx,mextendy
!
! update ZM1 = sum_over_t_x_y[vec(T lnPs) vec(P_b)^T]
! ---------------------------------------------------
!
ZFACT = 1.0
!
do jband = 2, nband
do jm = 1, mbandsp(jband)
ila=mila(jm,jband)
DO JK1 = 1, NFLEV+1
DO JK2 = 1, NFLEV
IF(JK1.LE.NFLEV) THEN
ZM1(JK1,JK2,jband) = ZM1(JK1,JK2,jband) +
& ZFACT * zsptt(ila,1,jk1) * zsppb(ila,1,jk2)
ELSE
ZM1(JK1,JK2,jband) = ZM1(JK1,JK2,jband) +
& ZFACT * zspps(ila,1) * zsppb(ila,1,jk2)
endif
enddo ! jk2 loop
enddo ! jk1 loop
!
! update ZM2 = sum_over_t_x_y[vec(P_b) vec(P_b)^T]
!
ZFACT = 1.0
DO JK1 = 1, NFLEV
DO JK2 = 1, NFLEV
ZM2(JK1,JK2,jband) = ZM2(JK1,JK2,jband) +
+ ZFACT * zsppb(ila,1,JK1) * zsppb(ila,1,JK2)
enddo ! jk2 loop
enddo ! jk1 loop
enddo ! jm loop
enddo ! jband loop
endif
231 continue ! loop on jens
!
NENSEMBLE = NENSEMBLE + IENS
WRITE(NULOUT,9370) IENS, NENSEMBLE
9370 FORMAT(5X,I4," cases have been processed",
S 5x,"Current size of the ensemble: ",I4)
!
IERR = FSTFRM (KULSTAT)
IERR = FCLOS (KULSTAT)
!
201 continue ! loop on jfile
!
!*3. Compute A = ZM1*inv(ZM2)
! ------------------------
!
! seem to need to scale ZM2 before calling MINV (otherwise overflow error)
! scale by maximum value (zmaxi) - rescale in final calculation
!
sptot(:,:,:) = 0.0
!
do jband = 2, min(nband,mflt_trunc+5)
ZMAXI = 0.0
DO JK1 = 1, NFLEV
DO JK2 = 1, NFLEV
IF(abs(ZM2(JK1,JK2,jband)).GT.ZMAXI) ZMAXI = ZM2(JK1,JK2,jband)
ENDDO
ENDDO
if(zmaxi.eq.0.) then
write(nulout,*) 'sptotla: jband, ZMAXI = ',jband, zmaxi
CALL ABORT3D(NULOUT,'sptotla: zmaxi = 0.')
endif
!
DO JK1 = 1, NFLEV
DO JK2 = 1, NFLEV
ZM2INV(JK1,JK2) = ZM2(JK1,JK2,jband)/ZMAXI
ENDDO
ENDDO
!
ZEPS = RZERO
write(nulout,*) 'sptotla: Inverting ZM1 matrix for band nb. = ',jband
CALL MINV(ZM2INV,NFLEV,NFLEV,ZWORK,ZDET,ZEPS,0,1)
!
DO JK1 = 1, NFLEV+1
DO JK2 = 1, NFLEV
DO JK = 1, NFLEV
SPTOT(JK1,JK2,jband) = SPTOT(JK1,JK2,jband) +
$ ZM1(JK1,JK,jband) * ZM2INV(JK,JK2) / ZMAXI
ENDDO
ENDDO
ENDDO
enddo ! end loop on jband
!
write(nulout,*) 'sptotla: ioutband = ',ioutband
DO JK2 = 1, NFLEV
write(nulout,*) 'sptotla: jk2, SPTOT(nflev+1,JK2,ioutband)=',
& jk2, SPTOT(nflev+1,JK2,ioutband)
enddo
!
! call outhoriz2d(zptot,'sptot.od ','PT',1,
! & 1,nflev,1,nflev,nflev,nflev,1)
write(nulout,*) 'sptotla: END'
!
RETURN
END