!-------------------------------------- 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 ptotla_1(kulstat,koutfile,ldhelm,ldfplane,ldtb_psi,ldcoriol_one) 2,18
#if defined (DOC)
*
***s/r ptotla_1 - Statistical Estimation of A where:
* vec(T Ps) = A vec(P_b) + vec(T' Ps')
* Identical setup as correlation calculations
*
*Author : Luc Fillion - ARAM/MSC - 7 Apr 2005 Limited-Area version.
*Revision:
* Luc Fillion - ARAM/EC - Jun 2008 - Adapt with GD1 for initgdla.ftn call.
* Luc Fillion - ARAM/EC - 28 May 2010 - Introduce argument ldfilt into initgdla.ftn
*
*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 "comcorr.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"
*
logical ldhelm,ldfplane,ldtb_psi,ldcoriol_one
INTEGER KULSTAT,koutfile
!
integer ji,jj,ifois,icase
! integer isave_ihh,isave_ifstrun
data ifois/0/
INTEGER JENS, IENS, inbens, JK1, JK2, JLA
INTEGER IERR, JFILE, JK, ILON, ILEN, JB, NLATBAND
!
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
!
INTEGER IBND1,IBND2,JPNLATBND
!
REAL*8 DHEURES
CHARACTER*1 CLTYPVAR, CLGRTYP, clflt,clgrid
CHARACTER*2 CLNOMVAR
CHARACTER*8 CLETIKET
!
logical ldopc,llfilt
REAL*8 ZFACT,ZMAXI,ZWT
real*8 zpb(ni,nflev,nj),zgdpsi(ni,nflev,nj),zgdchi(ni,nflev,nj)
real*8 z2d(ni,nj)
real*8 z2d_in(mni_in,mnj_in)
real*8 zgdes(ni,nflev,nj),zgdgz(ni,nflev,nj)
real*8 zvort(ni,nflev,nj),zdiv(ni,nflev,nj)
REAL*8 ZM1(NFLEV+1,NFLEV,nj), ZM2(NFLEV,NFLEV,nj)
REAL*8 ZPTOT(NFLEV,NFLEV)
REAL*8 ZM2INV(NFLEV,NFLEV), ZWORK(NFLEV*NFLEV), ZDET, ZEPS
REAL*8 ZCHIPSI(NFLEV,NJ), ZPSIPSI(NFLEV,NJ)
!
real*8 zmeangdpsi(ni,nflev,nj)
real*8 zsavut0(ni,nflev,nj)
real*8 zwork2d(ni,nj)
real*8 zwrksp(nla,2,nflev)
integer inip1,injp1
integer vfstlir,vfstecr,IPAK, IDATEO,IULPTOT
real*8 zx8(ni),zy8(nj)
!
EXTERNAL FNOM, FSTOUV, FSTFRM, FCLOS, FSTPRM, FSTINF,FSTINL
!
!!
write(nulout,*) 'ptotla_1: BEGIN'
!
llfilt = .false.
if(lflt_low) then
llfilt = .true.
clflt = 'L'
else if(lflt_high) then
llfilt = .true.
clflt = 'H'
endif
!
WRITE(NULOUT,FMT=9000)
9000 FORMAT(3(/,3x,80('.')),//
S ,4x,' ptotla_1- Estimation of P_to_T Operator for LAM4D',//)
!
! Initialize a few constants
!
inip1 = ni+1
injp1 = nj+1
!
!*1. Initialize Arrays
! -----------------
!
zm1(:,:,:) = 0.0
zm2(:,:,:) = 0.0
zptot(:,:) = 0.0
ZCHIPSI(:,:) = 0.0
ZPSIPSI(:,:) = 0.0
THETA(:,:) = 0.0
!
! allocate space for accumulators
!
! call stddall
!
!*2. Access the increments 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 = CFSTVAR(1)
IF (CLNOMVAR.EQ.'P0') THEN
IP1 =0
ELSE
IP1 =12000
ENDIF
WRITE(NULOUT,*)
IERR = FSTINL (KULSTAT,INI,INJ,INK
S ,-1,CETIKETN,IP1,IP2,IP3,' '
S ,CLNOMVAR,ILISTE,INFON,IDIMAX)
WRITE(NULOUT,9210)INFON
9210 FORMAT(//,4X,"ENSEMBLE OF ",I4," DIFFERENT INCREMENTS TYPES")
IF(INFON.EQ.0) THEN
WRITE(NULOUT,*)' THIS FILE IS EMPTY.
$ CHECK THE SELECTION CRITERIA'
CALL ABORT3D(NULOUT,'ptotla_1: PROBLEM WITH FSTINL')
END IF
IENS = INFON
!
!* 2.2 Get all the dates at which increments are available
!
inbens = 0
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(jens.eq.1) then
! isave_IFSTRUN = IFSTRUN
! isave_IHH = IHH
! end
! if(IFSTRUN.eq.isave_IFSTRUN.and.IHH.eq.isave_IHH) inbens=inbens+1
WRITE(NULOUT,9320)JENS, IFSTRUN,IHH
END DO
9320 FORMAT(5X,"Case No. ",I3,5x,"Date and time: ",I10,5x,I8)
!
! iens = inbens
WRITE(NULOUT,9310)iens
9310 FORMAT(//,4X,"ENSEMBLE OF ",I4," INCREMENTS")
!
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','N',icase)
!
! Estimation of P_to_T matrix (A)
!
call transfer('GD01')
ldopc = .true.
if(lpsifromglb.or.lpsifromlam) ldopc=.false.
call initgdla(zvort,zdiv,zgdpsi,zgdchi,'U',ldopc,.false.)
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,'ptotla_1: 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,'ptotla_1: 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,'ptotla_1: Problem reading PSI field')
endif
do jj=1,mnj_in
do ji=1,mni_in
zgdpsi(ji,jk,jj) = z2d_in(ji,jj)
enddo
enddo
enddo
call mach3(zgdpsi,ni,nj,nflev,inip1,injp1)
call setmean(zgdpsi,0.0,nflev)
endif
!
if(llfilt) then
write(nulout,*) 'ptotla_1: **************************************'
write(nulout,*) 'ptotla_1: PP error sample is spectrally filtered'
write(nulout,*) 'ptotla_1: **************************************'
call gdtruncr(zgdpsi,zwrksp,'T',mflt_trunc,clflt,.false.,nflev)
else
write(nulout,*) 'ptotla_1: NO FILTER applied to PP error sample'
endif
!
if(ldtb_psi) then
clgrid = 'S'
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 jj = 1, nj
ZFACT = 1.0
DO ji = 1, ni
DO JK1 = 1, NFLEV+1
DO JK2 = 1, NFLEV
IF(JK1.LE.NFLEV) THEN
ZM1(JK1,JK2,jj) = ZM1(JK1,JK2,jj) +
& ZFACT * TT0(ji,JK1,jj) * zpb(ji,JK2,jj)
ELSE
ZM1(JK1,JK2,jj) = ZM1(JK1,JK2,jj) +
& ZFACT * GPS0(ji,1,jj) * zpb(ji,JK2,jj)
endif
enddo ! jk2 loop
enddo ! jk1 loop
enddo ! ji loop
enddo ! jj loop
!
! update ZM2 = sum_over_t_x_y[vec(P_b) vec(P_b)^T]
!
DO jj = 1, nj
ZFACT = 1.0
DO ji = 1, ni
DO JK1 = 1, NFLEV
DO JK2 = 1, NFLEV
ZM2(JK1,JK2,jj) = ZM2(JK1,JK2,jj) +
+ ZFACT * zpb(ji,JK1,jj) * zpb(ji,JK2,jj)
enddo ! jk2 loop
enddo ! jk1 loop
enddo ! ji loop
enddo ! jj loop
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)
!
998 continue
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
!
do jj = 1, nj
ZMAXI = 0.0
DO JK1 = 1, NFLEV
DO JK2 = 1, NFLEV
IF(ZM2(JK1,JK2,jj).GT.ZMAXI) ZMAXI = ZM2(JK1,JK2,jj)
ENDDO
ENDDO
!
DO JK1 = 1, NFLEV
DO JK2 = 1, NFLEV
ZM2INV(JK1,JK2) = ZM2(JK1,JK2,jj)/ZMAXI
ENDDO
ENDDO
!
ZEPS = RZERO
CALL MINV(ZM2INV,NFLEV,NFLEV,ZWORK,ZDET,ZEPS,0,1)
!
call zero(nflev*nflev,zptot)
!
DO JK1 = 1, NFLEV+1
DO JK2 = 1, NFLEV
DO JK = 1, NFLEV
PTOT(JK1,JK2,jj) = PTOT(JK1,JK2,jj) +
$ ZM1(JK1,JK,jj) * ZM2INV(JK,JK2) / ZMAXI
IF(JK1.LE.NFLEV) THEN
ZPTOT(JK1,JK2) = ZPTOT(JK1,JK2) +
$ ZM1(JK1,JK,jj) * ZM2INV(JK,JK2) / ZMAXI
endif
ENDDO
ENDDO
ENDDO
enddo ! end loop on jj
!
DO JK2 = 1, NFLEV
write(nulout,*) 'ptotla_1: jk2, PTOT(nflev+1,JK2,1)=',
& jk2, PTOT(nflev+1,JK2,1)
enddo
!
! call outhoriz2d(zptot,'ptot.od ','PT',1,
! & 1,nflev,1,nflev,nflev,nflev,1)
!
write(nulout,*) 'ptotla_1: END'
!
RETURN
END