!-------------------------------------- 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 PTOT2_2(KULSTAT,KULCORNS,KULSTDEV) 1,17
#if defined (DOC)
*
***s/r PTOT2_2 -Statistical Estimation of A where:
* vec(T Ps) = A vec(P_b) + vec(T' Ps')
* Identical setup as correlation calculations
*
*Author : Mark Buehner *ARMA/AES July, 1998
*Revision: 001 R. Sarrazin oct. 98
* remove mean with call to meangd, add scaling by zfact
* . 002 P. Koclas *CMC/AES June 1999:
* . - Y2K conversion
* . 003 JM Belanger *CMDA/SMC* June 2001
* . - 32 bits conversion.
* . 004 JM Belanger *CMDA/SMC* June 2001
* . - Compute PTOT for three latitude bands.
* . 005 C. Charette *ARMA/SMC Oct 2002
* - Adapted for hybrid coordinates
* . 006 M. Buehner *ARMA/MSC* February 2004
* . - Vertical localization for ZM1,ZM2
* . 007 C. Charette - ARMA/SMC - Sep. 2004
* - Conversion to hybrid vertical coordinate
* 008 M. Buehner May 2008
* - New version of PtoT2 adapted for new PtoT approach
* with localization for Tb correlations
*
*Arguments: KULSTAT logical unit number
* KULCORNS logical unit number
* KULSTDEV logical unit number
*
#endif
IMPLICIT NONE
*implicits
#include "comlun.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comcst.cdk"
#include "comgem.cdk"
#include "comleg.cdk"
#include "comcorr.cdk"
#include "comsp.cdk"
#include "comgd0.cdk"
#include "comsp1.cdk"
#include "comgd1.cdk"
#include "comgdpar.cdk"
#include "comcse1.cdk"
#include "comstdd.cdk"
#include "comcva.cdk"
*
INTEGER KULSTAT, KULCORNS, KULSTDEV
C
INTEGER JENS, IENS, JK1, JK2, JLA, JN, JM, ILA
INTEGER IERR, JFILE, JK, JLAT, ILON, JLON, ILEN, JB, NLATBAND
C
INTEGER FNOM, FSTOUV, FSTFRM, FCLOS, FSTPRM, FSTINF, FSTINL
C
C RPN Standard files parameters
C
INTEGER INI, INJ, INK, INPAS, INBITS, IDATYP, IDEET,
+ IP1, IP2, IP3, IG1, IG2, IG3, IG4, ISWA, ILENGTH, IDLTF,
+ IUBC, IEXTR1, IEXTR2, IEXTR3
INTEGER ILISTE(600), IDATE(600), IDATV(600), IDIMAX, INFON, IFSTRUN, IHH
C
integer iip1s(jpnflev),iip2,iip3,itrlnlev,jlev, itrlgid
integer ipmode,ipkind,ip1_pak_trl,ip1_vco_trl
real zlev(jpnflev)
character*1 clstring
INTEGER IBND1,IBND2,JPNLATBND,ILAT
PARAMETER (JPNLATBND = 3)
C
REAL*8 DHEURES
CHARACTER*1 CLTYPVAR, CLGRTYP
CHARACTER*2 CLNOMVAR
CHARACTER*8 CLETIKET
C
REAL*8 ZFACT,ZMAXI,ZWT,ZPROF(JPNFLEV),ZPS
REAL*8 ZFACT2,ZFACTTOT
REAL*8 ZM1(NFLEV+1,NFLEV,JPNLATBND), ZM2(NFLEVPTOT,NFLEVPTOT,JPNLATBND)
REAL*8 ZM1PSI(NFLEV+1,NFLEV,JPNLATBND)
REAL*8 ZM1SP(NFLEV+1,NFLEV,NTRUNC+1),ZM2SP(NFLEVPTOT,NFLEVPTOT,NTRUNC+1)
REAL*8 ZTPSISP(NFLEV+1,NFLEVPTOT,NTRUNC+1)
REAL*8 ZPSIPSI2SP(NFLEVPTOT,NFLEVPTOT,NTRUNC+1)
REAL*8 ZTT(NFLEV,NFLEV,JPNLATBND)
REAL*8 ZTPSI(NFLEV+1,NFLEVPTOT,JPNLATBND)
REAL*8 ZPSIPSI2(NFLEVPTOT,NFLEVPTOT,JPNLATBND)
REAL*8 ZTTSP(NFLEV,NFLEV,NTRUNC+1)
REAL*8 ZPTOTBND(NFLEV+1,NFLEV,JPNLATBND)
REAL*8 ZM2INV(NFLEVPTOT,NFLEVPTOT,JPNLATBND),ZWORK(NFLEVPTOT*NFLEVPTOT),ZDET,ZEPS
REAL*8 ZCHIPSI(NFLEV,NJ), ZPSIPSI(NFLEV,NJ)
INTEGER INDXMID(JPNLATBND)
REAL*8 DLA2, DL1SA2
REAL*8 DLLATMIN(JPNLATBND), DLLATMAX(JPNLATBND)
REAL*8 DLLATMID(JPNLATBND)
REAL*8 ZLC,ZTLEN,ZR,ZCORR,ZPRES1,ZPRES2
ccc debug in
real*8 zeigwrk(4*nflev),zeigen(nflevptot,nflevptot),zeigenv(nflevptot)
real*8 zeigmax,zeigenvi(nflevptot)
real zfix
integer iwork,info
LOGICAL LFLTEIG
CCC DEBUG out
C
DATA DLLATMIN / -60.0D0, -30.0D0, 30.0D0 /
DATA DLLATMAX / -30.0D0, 30.0D0, 60.0D0 /
DATA DLLATMID / -45.0D0, 00.0D0, 45.0D0 /
c DATA DLLATMIN / -91.0D0, -30.0D0, 30.0D0 /
c DATA DLLATMAX / -30.0D0, 30.0D0, 91.0D0 /
c DATA DLLATMID / -45.0D0, 00.0D0, 45.0D0 /
C
EXTERNAL FNOM, FSTOUV, FSTFRM, FCLOS, FSTPRM, FSTINF,FSTINL
C---------------------------------------------------------------------
C
WRITE(NULOUT,FMT=9000)
9000 FORMAT(3(/,3x,80('.')),//
S ,4x,' PTOT2- Estimation of P_to_T Operator',//)
C
C Initialize a few constants
C
DLA2 = DBLE(RA)*DBLE(RA)
DL1SA2 = 1.D0/DLA2
C
C 1. Initialize P_to_T, ZM1, ZM2
C
100 CONTINUE
ZFACTTOT = 0.0
DO JLAT = 1, NJ
ZFACTTOT = ZFACTTOT + cos(RLATI(JLAT))
ENDDO
ZFACTTOT = NJ/ZFACTTOT
DO JK1= 1, (NFLEV+1)
DO JK2 = 1, NFLEV
DO JLAT = 1, NJ
PTOT(JK1,JK2,JLAT) = 0.0
END DO
END DO
END DO
DO JB= 1, JPNLATBND
DO JK1= 1, (NFLEV+1)
DO JK2 = 1, NFLEV
ZM1(JK1,JK2,JB) = 0.0
ZM1PSI(JK1,JK2,JB) = 0.0
ZPTOTBND(JK1,JK2,JB) = 0.0
END DO
END DO
END DO
DO JB= 1, JPNLATBND
DO JK1= 1, NFLEVPTOT
DO JK2 = 1, NFLEVPTOT
ZM2(JK1,JK2,JB) = 0.0
END DO
END DO
END DO
DO JB= 1, JPNLATBND
DO JK1= 1, (NFLEV+1)
DO JK2 = 1, NFLEVPTOT
ZTPSI(JK1,JK2,JB) = 0.0
END DO
END DO
END DO
DO JB= 1, JPNLATBND
DO JK1= 1, NFLEVPTOT
DO JK2 = 1, NFLEVPTOT
ZPSIPSI2(JK1,JK2,JB) = 0.0
END DO
END DO
END DO
DO JB= 1, JPNLATBND
DO JK1= 1, NFLEV
DO JK2 = 1, NFLEV
ZTT(JK1,JK2,JB) = 0.0
END DO
END DO
END DO
DO JB= 1, NTRUNC+1
DO JK1= 1, NFLEV
DO JK2 = 1, NFLEV
ZTTSP(JK1,JK2,JB) = 0.0
END DO
END DO
END DO
DO JB= 1, NTRUNC+1
DO JK1= 1, (NFLEV+1)
DO JK2 = 1, NFLEV
ZM1SP(JK1,JK2,JB) = 0.0
END DO
END DO
END DO
DO JB= 1, NTRUNC+1
DO JK1= 1, NFLEVPTOT
DO JK2 = 1, NFLEVPTOT
ZM2SP(JK1,JK2,JB) = 0.0
END DO
END DO
END DO
DO JB= 1, NTRUNC+1
DO JK1= 1, (NFLEV+1)
DO JK2 = 1, NFLEVPTOT
ZTPSISP(JK1,JK2,JB) = 0.0
END DO
END DO
END DO
DO JB= 1, NTRUNC+1
DO JK1= 1, NFLEVPTOT
DO JK2 = 1, NFLEVPTOT
ZPSIPSI2SP(JK1,JK2,JB) = 0.0
END DO
END DO
END DO
C
C Initialize covariances for THETA estimation
C
DO JK1=1,NFLEV
DO JLAT=1,NJ
ZCHIPSI(JK1,JLAT) = 0.0
ZPSIPSI(JK1,JLAT) = 0.0
THETA(JK1,JLAT) = 0.0
ENDDO
ENDDO
C Calculate indexes
C NOTE: The latitudes in vector RLATI are stored from North to South
DO JB = 1, JPNLATBND
DO JLAT = 2, NJ
ILAT = NJ - JLAT + 1
IF ( 2.*RPI*DLLATMID(JB)/360. .LT. RLATI(JLAT-1)
& .AND. 2.*RPI*DLLATMID(JB)/360. .GE. RLATI(JLAT)) THEN
INDXMID(JB) = JLAT
ENDIF
ENDDO
ENDDO
C
C allocate space for accumulators
C
CALL STDDALL
C
C*********************************************************************
C* 2. Access the increments of PSI and (T,lnPs) from a set of files
C . (loop on the files)
C
200 CONTINUE
IDIMAX = 600
C
CALL MEANGD_2(KULSTAT)
DO 201 JFILE = 1, NFLSTAT
C
CALL GETINCR(KULSTAT,JFILE)
C
C* . 2.1 Find how many cases there are to be treated
C
210 CONTINUE
C
IP1 = -1
IP2 = -1
IP3 = -1
CLNOMVAR = CFSTVAR(1)
IF (CLNOMVAR.EQ.'P0') THEN
IP1 =0
ELSE
call getfldprm(iip1s,iip2,iip3,itrlnlev,CETIKETN,cltypvar
& ,itrlgid,CLNOMVAR,-1,jpnflev,kulstat,nulout
& ,ip1_pak_trl,ip1_vco_trl)
c
c---------Decode and sort the levels
ipmode = -1
do jlev = 1,itrlnlev
call CONVIP(iip1s(jlev),ZLEV(jlev),IPKIND
& ,ipmode,clstring, .false. )
enddo
c
call sort(zlev,itrlnlev)
c---------Read in nomvar at the surface (at zlev(itrlnlev)
ipmode = ip1_pak_trl
call CONVIP(IP1,zlev(itrlnlev),ip1_vco_trl
& ,ipmode,clstring, .false. )
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," INCREMENTS")
IF(INFON.EQ.0) THEN
WRITE(NULOUT,*)' THIS FILE IS EMPTY. CHECK THE SELECTION CRITERIA'
CALL ABORT3D(NULOUT,'PTOT2: PROBLEM WITH FSTINL')
END IF
IENS = INFON
C
C* . 2.2 Get all the dates at which increments are available
C
220 CONTINUE
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)
C
DHEURES = DBLE(INPAS*IDEET/3600)
CALL INCDATR(IDATV(JENS),IDATE(JENS),SNGL(DHEURES))
CALL NEWDATE(IDATV(JENS),IFSTRUN,IHH,-3)
write(nulout,*) ' DATES=',IDATE(JENS),SNGL(DHEURES),IDATV(JENS)
WRITE(NULOUT,9320)JENS, IFSTRUN,IHH
END DO
9320 FORMAT(5X,"Case No. ",I3,5x,"Date and time: ",I10,5x,I8)
C
IF(NENSEMBLE.EQ.0) THEN
NDATESTAT = IDATE(1)
END IF
C
CTYPVARN = ' '
CETIKETN = CLETIKET
C
C* 3. Loop on the ensemble
C
300 CONTINUE
DO 321 JENS = 1, IENS
C
C* 3.1 Get the increment in grid-point form
C
310 CONTINUE
CALL NEWDATE(IDATV(JENS),IFSTRUN,IHH,-3)
WRITE(NULOUT,9310)JENS, IFSTRUN,IHH
9310 FORMAT(3(/),5X,"--- Case No. ",I3,5x,"Date and time: ",I10
& ,5x,I8)
NSTAMPN = IDATE(JENS)
CALL GETFST(KULSTAT,'G','N',-1)
CALL REESPE(NKSDIM,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
c apply spectral filter
c DO JN = (NTRUNC-10),NTRUNC
c DO JM = 0, JN
c ILA = NIND(JM) + JN - JM
c DO JK = 1, NKSDIM
c SP(ILA,1,JK)=0.0
c SP(ILA,2,JK)=0.0
c ENDDO
c ENDDO
c ENDDO
CALL SPEREE(NKSDIM,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
C
C remove ensemble mean from fields in gd
C
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JK1 = 1, NKGDIM
GD(JLON,JK1,JLAT) = GD(JLON,JK1,JLAT) -
+ XMGD(JLON,JK1,JLAT)
ENDDO
ENDDO
ENDDO
c
c Normalize by local stddev
c
if(.true.) then
c transform u,v to psi,chi
CALL GDSP
DO JK = 1, NFLEV
DO JLA = 1, NLA
SPVOR(JLA,1,JK) = SPVOR(JLA,1,JK) * DLA2*R1SNP1(JLA)
SPVOR(JLA,2,JK) = SPVOR(JLA,2,JK) * DLA2*R1SNP1(JLA)
SPDIV(JLA,1,JK) = SPDIV(JLA,1,JK) * DLA2*R1SNP1(JLA)
SPDIV(JLA,2,JK) = SPDIV(JLA,2,JK) * DLA2*R1SNP1(JLA)
END DO
END DO
CALL SPEREE(NKSDIM,SP,GD
S ,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JK1 = 1, NFLEV
IF(SPP(JLON,JK1,JLAT).gt.0) THEN
UT0(JLON,JK1,JLAT) = UT0(JLON,JK1,JLAT) /
+ SPP(JLON,JK1,JLAT)
ELSE
UT0(JLON,JK1,JLAT) = 0.0
WRITE(NULOUT,*) "SPP NON-POSITIVE:",
+ SPP(JLON,JK1,JLAT)
ENDIF
IF(SCC(JLON,JK1,JLAT).gt.0) THEN
VT0(JLON,JK1,JLAT) = VT0(JLON,JK1,JLAT) /
+ SCC(JLON,JK1,JLAT)
ELSE
VT0(JLON,JK1,JLAT) = 0.0
WRITE(NULOUT,*) "SCC NON-POSITIVE:",
+ SCC(JLON,JK1,JLAT)
ENDIF
IF(STT(JLON,JK1,JLAT).gt.0) THEN
TT0(JLON,JK1,JLAT) = TT0(JLON,JK1,JLAT) /
+ STT(JLON,JK1,JLAT)
ELSE
TT0(JLON,JK1,JLAT) = 0.0
WRITE(NULOUT,*) "STT NON-POSITIVE:",
+ STT(JLON,JK1,JLAT)
ENDIF
ENDDO
IF(SP0(JLON,1,JLAT).gt.0) THEN
GPS0(JLON,1,JLAT) = GPS0(JLON,1,JLAT) /
+ SP0(JLON,1,JLAT)
ELSE
GPS0(JLON,1,JLAT) = 0.0
WRITE(NULOUT,*) "SP0 NON-POSITIVE:",
+ SP0(JLON,1,JLAT)
ENDIF
ENDDO
ENDDO
c convert back to u,v
CALL REESPE(NKSDIM,SP,GD,NLA
S ,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
DO JLEV = 1, NFLEV
DO JLA = 1, NLA
SPVOR(JLA,1,JLEV) = SPVOR(JLA,1,JLEV)*DL1SA2*RNNP1(JLA)
SPVOR(JLA,2,JLEV) = SPVOR(JLA,2,JLEV)*DL1SA2*RNNP1(JLA)
SPDIV(JLA,1,JLEV) = SPDIV(JLA,1,JLEV)*DL1SA2*RNNP1(JLA)
SPDIV(JLA,2,JLEV) = SPDIV(JLA,2,JLEV)*DL1SA2*RNNP1(JLA)
ENDDO
ENDDO
CALL SPGD
endif
C
C . Estimation of P_to_T matrix (A)
C
C CALCULATE PB FROM WIND FIELD
C USE THE LINEAR BALANCE: INPUT=SPVOR1 OUTPUT=SPGZ
CALL GDSP
DO JK = 1, NFLEV
DO JLA = 1, NLA
SPVOR1(JLA,1,JK) = SPVOR(JLA,1,JK)
SPVOR1(JLA,2,JK) = SPVOR(JLA,2,JK)
END DO
END DO
CALL LINBAL(+1,.FALSE.)
C
C . CONVERT VOR/DIV TO PSI/CHI
C
DO JK = 1, NFLEV
DO JLA = 1, NLA
SPVOR(JLA,1,JK) = SPVOR(JLA,1,JK) * DLA2*R1SNP1(JLA)
SPVOR(JLA,2,JK) = SPVOR(JLA,2,JK) * DLA2*R1SNP1(JLA)
SPDIV(JLA,1,JK) = SPDIV(JLA,1,JK) * DLA2*R1SNP1(JLA)
SPDIV(JLA,2,JK) = SPDIV(JLA,2,JK) * DLA2*R1SNP1(JLA)
END DO
END DO
C
C . Transform to physical space
C P_b in gz1, and PSI, CHI in ut1,vt1
C tt,ps already in physical space (GD0)
CALL SPEREE(NKSDIM,SP,GD1
S ,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
DO JB=1,JPNLATBND
C
C update ZM1 = sum_over_t_x_y[vec(T lnPs) vec(P_b)^T]
C
DO JLAT = 1, NJ
if ((RLATI(JLAT) .gt. 2.*RPI*DLLATMIN(JB)/360.)
+ .and. (RLATI(JLAT) .le. 2.*RPI*DLLATMAX(JB)/360.)) then
cbue ZFACT = 1.0
ZFACT = cos(RLATI(JLAT))*ZFACTTOT*MASKLAT(JLAT)
else
ZFACT = 0.0
endif
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JK1 = 1, (NFLEV+1)
DO JK2 = 1, NFLEV
IF(JK1.LE.NFLEV) THEN
ZM1(JK1,JK2,JB) = ZM1(JK1,JK2,JB) +
+ ZFACT * TT0(JLON,JK1,JLAT) * GZ1(JLON,JK2,JLAT)
ELSE
ZM1(JK1,JK2,JB) = ZM1(JK1,JK2,JB) +
+ ZFACT * GPS0(JLON,1,JLAT) * GZ1(JLON,JK2,JLAT)
ENDIF
ENDDO
ENDDO
ENDDO
ENDDO
C
C update ZM1PSI = sum_over_t_x_y[vec(T lnPs) vec(PSI)^T]
C
DO JLAT = 1, NJ
if ((RLATI(JLAT) .gt. 2.*RPI*DLLATMIN(JB)/360.)
+ .and. (RLATI(JLAT) .le. 2.*RPI*DLLATMAX(JB)/360.)) then
cbue ZFACT = 1.0
ZFACT = cos(RLATI(JLAT))*ZFACTTOT*MASKLAT(JLAT)
if(RLATI(JLAT).lt.0.0) ZFACT = -1.0*ZFACT
else
ZFACT = 0.0
endif
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JK1 = 1, (NFLEV+1)
DO JK2 = 1, NFLEV
IF(JK1.LE.NFLEV) THEN
ZM1PSI(JK1,JK2,JB) = ZM1PSI(JK1,JK2,JB) +
+ ZFACT * TT0(JLON,JK1,JLAT) * UT1(JLON,JK2,JLAT)
ELSE
ZM1PSI(JK1,JK2,JB) = ZM1PSI(JK1,JK2,JB) +
+ ZFACT * GPS0(JLON,1,JLAT) * UT1(JLON,JK2,JLAT)
ENDIF
ENDDO
ENDDO
ENDDO
ENDDO
C
C update ZM2 = sum_over_t_x_y[vec(P_b) vec(P_b)^T]
C
DO JLAT = 1, NJ
if ((RLATI(JLAT) .gt. 2.*RPI*DLLATMIN(JB)/360.)
+ .and. (RLATI(JLAT) .le. 2.*RPI*DLLATMAX(JB)/360.)) then
cbue ZFACT = 1.0
ZFACT = cos(RLATI(JLAT))*ZFACTTOT*MASKLAT(JLAT)
else
ZFACT = 0.0
endif
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JK1 = 1, NFLEVPTOT
DO JK2 = 1, NFLEVPTOT
ZM2(JK1,JK2,JB) = ZM2(JK1,JK2,JB) +
+ ZFACT * GZ1(JLON,JK1,JLAT) * GZ1(JLON,JK2,JLAT)
ENDDO
ENDDO
DO JK1 = 1, NFLEV
DO JK2 = 1, NFLEV
ZTT(JK1,JK2,JB) = ZTT(JK1,JK2,JB) +
+ ZFACT * TT0(JLON,JK1,JLAT) * TT0(JLON,JK2,JLAT)
ENDDO
ENDDO
ENDDO
ENDDO
C
C update ZTPSI = sum_over_t_x_y[vec(T lnPs) vec(PSI)^T]
C
DO JLAT = 1, NJ
if ((RLATI(JLAT) .gt. 2.*RPI*DLLATMIN(JB)/360.)
+ .and. (RLATI(JLAT) .le. 2.*RPI*DLLATMAX(JB)/360.)) then
cbue ZFACT = 1.0
ZFACT = cos(RLATI(JLAT))*ZFACTTOT*MASKLAT(JLAT)
else
ZFACT = 0.0
endif
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JK1 = 1, (NFLEV+1)
DO JK2 = 1, NFLEVPTOT
IF(JK1.LE.NFLEV) THEN
ZTPSI(JK1,JK2,JB) = ZTPSI(JK1,JK2,JB) +
+ ZFACT * TT0(JLON,JK1,JLAT) * UT1(JLON,JK2,JLAT)
ELSE
ZTPSI(JK1,JK2,JB) = ZTPSI(JK1,JK2,JB) +
+ ZFACT * GPS0(JLON,1,JLAT) * UT1(JLON,JK2,JLAT)
ENDIF
ENDDO
ENDDO
ENDDO
ENDDO
C
C update ZPSIPSI2 = sum_over_t_x_y[vec(PSI) vec(PSI)^T]
C
DO JLAT = 1, NJ
if ((RLATI(JLAT) .gt. 2.*RPI*DLLATMIN(JB)/360.)
+ .and. (RLATI(JLAT) .le. 2.*RPI*DLLATMAX(JB)/360.)) then
cbue ZFACT = 1.0
ZFACT = cos(RLATI(JLAT))*ZFACTTOT*MASKLAT(JLAT)
else
ZFACT = 0.0
endif
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JK1 = 1, NFLEVPTOT
DO JK2 = 1, NFLEVPTOT
ZPSIPSI2(JK1,JK2,JB) = ZPSIPSI2(JK1,JK2,JB) +
+ ZFACT * UT1(JLON,JK1,JLAT) * UT1(JLON,JK2,JLAT)
ENDDO
ENDDO
ENDDO
ENDDO
C
END DO ! Loop on JPNLATBND
DO JN=0,NTRUNC
JB=JN+1
C
C update ZM1SP = sum_over_t_x_y[vec(T lnPs) vec(P_b)^T]
C
DO JM = 0, JN
ZFACT2=1.0
IF (JM .NE.0)ZFACT2 = ZFACT2*2.
ILA = NIND(JM) + JN - JM
DO JK1 = 1, (NFLEV+1)
DO JK2 = 1, NFLEV
IF(JK1.LE.NFLEV) THEN
ZM1SP(JK1,JK2,JB) = ZM1SP(JK1,JK2,JB) +
+ ZFACT2 * (SPTT(ILA,1,JK1) * SPGZ(ILA,1,JK2) +
+ SPTT(ILA,2,JK1) * SPGZ(ILA,2,JK2))
ELSE
ZM1SP(JK1,JK2,JB) = ZM1SP(JK1,JK2,JB) +
+ ZFACT2 * (SPPS(ILA,1,1) * SPGZ(ILA,1,JK2) +
+ SPPS(ILA,2,1) * SPGZ(ILA,2,JK2))
ENDIF
ENDDO
ENDDO
ENDDO
C
C update ZM2SP = sum_over_t_x_y[vec(P_b) vec(P_b)^T]
C
DO JM = 0, JN
ZFACT2=1.0
IF (JM .NE.0)ZFACT2 = ZFACT2*2.
ILA = NIND(JM) + JN - JM
DO JK1 = 1, NFLEVPTOT
DO JK2 = 1, NFLEVPTOT
ZM2SP(JK1,JK2,JB) = ZM2SP(JK1,JK2,JB) +
+ ZFACT2 * (SPGZ(ILA,1,JK1) * SPGZ(ILA,1,JK2) +
+ SPGZ(ILA,2,JK1) * SPGZ(ILA,2,JK2))
ENDDO
ENDDO
ENDDO
C
C update ZTPSISP = sum_over_t_x_y[vec(T lnPs) vec(PSI)^T]
C
DO JM = 0, JN
ZFACT2=1.0
IF (JM .NE.0)ZFACT2 = ZFACT2*2.
ILA = NIND(JM) + JN - JM
DO JK1 = 1, (NFLEV+1)
DO JK2 = 1, NFLEVPTOT
IF(JK1.LE.NFLEV) THEN
ZTPSISP(JK1,JK2,JB) = ZTPSISP(JK1,JK2,JB) +
+ ZFACT2 * (SPTT(ILA,1,JK1) * SPVOR(ILA,1,JK2) +
+ SPTT(ILA,2,JK1) * SPVOR(ILA,2,JK2))
ELSE
ZTPSISP(JK1,JK2,JB) = ZTPSISP(JK1,JK2,JB) +
+ ZFACT2 * (SPPS(ILA,1,1) * SPVOR(ILA,1,JK2) +
+ SPPS(ILA,2,1) * SPVOR(ILA,2,JK2))
ENDIF
ENDDO
ENDDO
ENDDO
C
C update ZPSIPSI2SP = sum_over_t_x_y[vec(PSI) vec(PSI)^T]
C
DO JM = 0, JN
ZFACT2=1.0
IF (JM .NE.0)ZFACT2 = ZFACT2*2.
ILA = NIND(JM) + JN - JM
DO JK1 = 1, NFLEVPTOT
DO JK2 = 1, NFLEVPTOT
ZPSIPSI2SP(JK1,JK2,JB) = ZPSIPSI2SP(JK1,JK2,JB) +
+ ZFACT2 * (SPVOR(ILA,1,JK1) * SPVOR(ILA,1,JK2) +
+ SPVOR(ILA,2,JK1) * SPVOR(ILA,2,JK2))
ENDDO
ENDDO
ENDDO
C
C update ZTTSP = sum_over_t_x_y[vec(TT) vec(TT)^T]
C
DO JM = 0, JN
ZFACT2=1.0
IF (JM .NE.0)ZFACT2 = ZFACT2*2.
ILA = NIND(JM) + JN - JM
DO JK1 = 1, NFLEV
DO JK2 = 1, NFLEV
ZTTSP(JK1,JK2,JB) = ZTTSP(JK1,JK2,JB) +
+ ZFACT2 * (SPTT(ILA,1,JK1) * SPTT(ILA,1,JK2) +
+ SPTT(ILA,2,JK1) * SPTT(ILA,2,JK2))
ENDDO
ENDDO
ENDDO
ENDDO ! JN LOOP
C
C
C update ZCHIPSI and ZPSIPSI covariances
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JK1 = 1, NFLEV
ZPSIPSI(JK1,JLAT) = ZPSIPSI(JK1,JLAT) +
+ UT1(JLON,JK1,JLAT) * UT1(JLON,JK1,JLAT)
ZCHIPSI(JK1,JLAT) = ZCHIPSI(JK1,JLAT) +
+ VT1(JLON,JK1,JLAT) * UT1(JLON,JK1,JLAT)
ENDDO
ENDDO
ENDDO
c
321 CONTINUE
C
C* . 3.7 Ending the processing of one file
C
370 CONTINUE
NENSEMBLE = NENSEMBLE + IENS
WRITE(NULOUT,9370) IENS, NENSEMBLE
9370 FORMAT(5X,I4," cases have been processed",
S 5x,"Current size of the ensemble: ",I4)
C
IERR = FSTFRM (KULSTAT)
IERR = FCLOS (KULSTAT)
C
C* ---- Ending the loop on files -----
C
201 CONTINUE
C
C Filter ZM2 by setting smallest eigenvalues to zero
C
CCC DEBUG IN
write(601,*)zm1
write(602,*)zm2
write(603,*)ztt
write(604,*)zm1sp
write(605,*)zm2sp
write(606,*)zttsp
write(607,*)ztpsi
write(608,*)ztpsisp
write(609,*)zpsipsi2
write(610,*)zpsipsi2sp
write(611,*)zm1psi
LFLTEIG = .FALSE.
cbue SET ZM1,ZM2 EQUAL FOR ALL THREE REGIONS
DO JK1 = 1, NFLEVPTOT
DO JK2 = 1, NFLEVPTOT
c ZM2(JK1,JK2,1)=ZM2(JK1,JK2,1)+ZM2(JK1,JK2,2)+ZM2(JK1,JK2,3)
ZM2(JK1,JK2,1)=ZM2(JK1,JK2,1)+ZM2(JK1,JK2,3)
ZM2(JK1,JK2,2)=ZM2(JK1,JK2,1)
ZM2(JK1,JK2,3)=ZM2(JK1,JK2,1)
ENDDO
ENDDO
DO JK1 = 1, (NFLEV+1)
DO JK2 = 1, NFLEVPTOT
c ZM1(JK1,JK2,1)=ZM1(JK1,JK2,1)+ZM1(JK1,JK2,2)+ZM1(JK1,JK2,3)
ZM1(JK1,JK2,1)=ZM1(JK1,JK2,1)+ZM1(JK1,JK2,3)
ZM1(JK1,JK2,2)=ZM1(JK1,JK2,1)
ZM1(JK1,JK2,3)=ZM1(JK1,JK2,1)
ENDDO
ENDDO
IWORK=4*NFLEV
do JB=1,JPNLATBND
DO JK1=1,NFLEVPTOT
DO JK2=1,NFLEVPTOT
ZEIGEN(JK1,JK2)=ZM2(JK1,JK2,JB)
END DO
END DO
CALL DSYEV('V','U',NFLEVPTOT, ZEIGEN,NFLEVPTOT, ZEIGENV,ZEIGWRK, IWORK
& ,INFO )
*
zeigmax=maxval(ZEIGENV)
write(nulout,*)'zm2 eigmax= ',jb,zeigmax
WRITE(NULOUT,'(1x,"ZM2 ORIGINAL EIGEN VALUES BAND= ",I3)') JB
WRITE(NULOUT,'(1x,5e15.8)') (ZEIGENV(JK1),JK1=1,NFLEVPTOT)
do JK1=1,NFLEVPTOT
if(LFLTEIG .and. (ZEIGENV(JK1).lt. (1.0e-4*zeigmax))) then
ZEIGENV(JK1)=0.0
ZEIGENVI(JK1)=0.0
else
ZEIGENVI(JK1)=1.0/ZEIGENV(JK1)
endif
enddo
WRITE(NULOUT,'(1x,"ZM2 FILTERED EIGEN VALUES BAND= ",I3)') JB
WRITE(NULOUT,'(1x,5e15.8)') (ZEIGENV(JK1),JK1=1,NFLEVPTOT)
DO JK1=1,NFLEVPTOT
DO JK2=1,NFLEVPTOT
ZM2INV(JK1,JK2,JB)=0.0
ZM2(JK1,JK2,JB)=0.0
DO JK=1,NFLEVPTOT
ZM2INV(JK1,JK2,JB)=ZM2INV(JK1,JK2,JB)+ZEIGEN(JK1,JK)
& *ZEIGENVI(JK)*ZEIGEN(JK2,JK)
ZM2(JK1,JK2,JB) =ZM2(JK1,JK2,JB) +ZEIGEN(JK1,JK)
& *ZEIGENV(JK) *ZEIGEN(JK2,JK)
END DO
END DO
END DO
enddo
C
C* . Calculate A = ZM1*inv(ZM2)
C . ----------------------------------------------------------
C
*
C seem to need to scale ZM2 before calling MINV (otherwise overflow error)
C scale by maximum value (zmaxi) - rescale in final calculation
DO JB=1,JPNLATBND
ZMAXI = 0.0
DO JK1 = 1, NFLEVPTOT
DO JK2 = 1, NFLEVPTOT
IF(ZM2(JK1,JK2,JB).GT.ZMAXI) ZMAXI = ZM2(JK1,JK2,JB)
ENDDO
ENDDO
C
cbue DO JK1 = 1, NFLEVPTOT
cbue DO JK2 = 1, NFLEVPTOT
cbue ZM2INV(JK1,JK2,JB) = ZM2(JK1,JK2,JB)/ZMAXI
cbue ENDDO
cbue ENDDO
C
cbue ZEPS = RZERO
cbue CALL MINV(ZM2INV,NFLEVPTOT,NFLEVPTOT,ZWORK,ZDET,ZEPS,0,1)
DO JK1 = 1, (NFLEV+1)
DO JK2 = 1, NFLEVPTOT
DO JK = 1, NFLEVPTOT
ZPTOTBND(JK1,JK2,JB) = ZPTOTBND(JK1,JK2,JB) +
$ ZM1(JK1,JK,JB) * ZM2INV(JK,JK2,JB)
ENDDO
ENDDO
ENDDO
END DO ! Loop on JPNLATBND
CCC DEBUG
c write(701,*)zm1
c write(702,*)zm2
c write(703,*)zm2inv
c
c Use mean of BAND 1 and 3 for all (globally constant)
c
c DO JK1 = 1, (NFLEV+1)
c DO JK2 = 1, NFLEVPTOT
c ZPTOTBND(JK1,JK2,1) = (ZPTOTBND(JK1,JK2,1)+ZPTOTBND(JK1,JK2,2)+ZPTOTBND(JK1,JK2,3))/3.0
c ZPTOTBND(JK1,JK2,3) = ZPTOTBND(JK1,JK2,1)
c ZPTOTBND(JK1,JK2,2) = ZPTOTBND(JK1,JK2,1)
c ENDDO
c ENDDO
C
C Apply vertical localization to both covariance matrices: ZM1,ZM2
C ----------------------------------------------------------------
ccc ztlen= 2.5 ! specify length scale (in units of ln(Pressure))
ccc ztlen= 3.0 ! specify length scale (in units of ln(Pressure))
ccc ztlen= 4.0 ! specify length scale (in units of ln(Pressure))
CCC ztlen= 2.0 ! specify length scale (in units of ln(Pressure))
ztlen= -1.0 ! specify length scale (in units of ln(Pressure))
C
C Calculate typical vertical profile of the pressure
C ----------------------------------------------------------------
zps = 101000. 0
call calcpres(ZPROF,vhybinc,nflev,ZPS,rptopinc
& ,rprefinc,rcoefinc,1)
C
do jk1=1,nflev
write(nulout,*)'ptot2:lev,hyb,zprof,log= ',jk1,vhybinc(jk1)
& ,zprof(jk1),log(zprof(jk1))
enddo
write(nulout,*)'ptot2:ztlen= ',ztlen
c
if(ZTLEN.gt.0.0) then
c calculate 5'th order function (from Gaspari and Cohn)
ZLC=ZTLEN/2.0
do jk1=1,nflev+1
if(jk1.gt.nflev) then
zpres1=log(ZPROF(nflev))
else
zpres1=log(ZPROF(jk1))
endif
do jk2=1,nflevptot
zpres2=log(ZPROF(jk2))
ZR = abs(zpres2 - zpres1)
if(ZR.le.ZLC) then
zcorr=-0.250*(ZR/ZLC)**5+0.5*(ZR/ZLC)**4
+ +0.625*(ZR/ZLC)**3-(5.0/3.0)*(ZR/ZLC)**2+1.0
elseif(ZR.le.(2.0*ZLC)) then
zcorr=(1.0/12.0)*(ZR/ZLC)**5-0.5*(ZR/ZLC)**4
+ +0.625*(ZR/ZLC)**3+(5.0/3.0)*(ZR/ZLC)**2
+ -5.0*(ZR/ZLC)+4.0-(2.0/3.0)*(ZLC/ZR)
else
zcorr= 0.0
endif
if(zcorr.lt.0.0) zcorr=0.0
write(NULOUT,*) 'VERT LOCALIZATION=',
+ jk1,jk2,zpres1,zpres2,zr,zlc,zcorr
c apply to ZPTOTBND for all latitude bands
do JB=1,JPNLATBND
ZPTOTBND(jk1,jk2,jb)=ZPTOTBND(jk1,jk2,jb)*zcorr
enddo
enddo
enddo
endif
C
C Apply smoothing over latitude on operator PTOT(nflev+1,nflev,nj).
C NOTE: The latitudes in PTOT are stored from South to North
C
C PP_Tb (NFLEV,NFLEV,120) STORED in PTOT(1:NFLEV,1:NFLEV,1:NJ)
C
DO JK1 = 1, NFLEV
DO JK2 = 1, NFLEVPTOT
DO JLAT = 1,NJ
ILAT = NJ -JLAT + 1
if (RLATI(JLAT) .ge.RLATI(INDXMID(3))) THEN
IBND1 = 3
PTOT(JK1,JK2,ILAT) = ZPTOTBND(JK1,JK2,IBND1)
ELSEIF (RLATI(JLAT) .LE. RLATI(INDXMID(1))) THEN
IBND1 = 1
PTOT(JK1,JK2,ILAT) = ZPTOTBND(JK1,JK2,IBND1)
ELSEIF ((RLATI(JLAT) .GT. RLATI(INDXMID(1)))
+ .and. (RLATI(JLAT) .LE. RLATI(INDXMID(2)))) then
IBND1 = 1
IBND2 = 2
ZWT = (RLATI(JLAT) - RLATI(INDXMID(2)))/
+ (RLATI(INDXMID(1)) - RLATI(INDXMID(2)))
PTOT(JK1,JK2,ILAT) = ZWT * ZPTOTBND(JK1,JK2,IBND1) +
+ (1.0 - ZWT) * ZPTOTBND(JK1,JK2,IBND2)
ELSEIF ((RLATI(JLAT) .GT. RLATI(INDXMID(2)))
+ .and. (RLATI(JLAT) .LE. RLATI(INDXMID(3)))) then
IBND1 = 3
IBND2 = 2
ZWT = (RLATI(JLAT) - RLATI(INDXMID(2)))/
+ (RLATI(INDXMID(3)) - RLATI(INDXMID(2)))
PTOT(JK1,JK2,ILAT) = ZWT * ZPTOTBND(JK1,JK2,IBND1) +
+ (1.0 - ZWT) * ZPTOTBND(JK1,JK2,IBND2)
ENDIF
ENDDO
ENDDO
ENDDO
C
C PP_Ps (1,NFLEV,NJ) STORED in PTOT(NFLEV+1,1:NFLEV,1:NJ)
C
DO JK2 = 1, NFLEVPTOT
DO JLAT = 1,NJ
ILAT = NJ -JLAT + 1
if (RLATI(JLAT) .ge.RLATI(INDXMID(3))) THEN
IBND1 = 3
PTOT(NFLEV+1,JK2,ILAT) = ZPTOTBND(NFLEV+1,JK2,IBND1)
ELSEIF (RLATI(JLAT) .LE. RLATI(INDXMID(1))) THEN
IBND1 = 1
PTOT(NFLEV+1,JK2,ILAT) = ZPTOTBND(NFLEV+1,JK2,IBND1)
ELSEIF ((RLATI(JLAT) .GT. RLATI(INDXMID(1)))
+ .and. (RLATI(JLAT) .LE. RLATI(INDXMID(2)))) then
IBND1 = 1
IBND2 = 2
ZWT = (RLATI(JLAT) - RLATI(INDXMID(2)))/
+ (RLATI(INDXMID(1)) - RLATI(INDXMID(2)))
PTOT(NFLEV+1,JK2,ILAT) = ZWT * ZPTOTBND(NFLEV+1,JK2,IBND1) +
+ (1.0 - ZWT) * ZPTOTBND(NFLEV+1,JK2,IBND2)
ELSEIF ((RLATI(JLAT) .GT. RLATI(INDXMID(2)))
+ .and. (RLATI(JLAT) .LE. RLATI(INDXMID(3)))) then
IBND1 = 3
IBND2 = 2
ZWT = (RLATI(JLAT) - RLATI(INDXMID(2)))/
+ (RLATI(INDXMID(3)) - RLATI(INDXMID(2)))
PTOT(NFLEV+1,JK2,ILAT) = ZWT * ZPTOTBND(NFLEV+1,JK2,IBND1) +
+ (1.0 - ZWT) * ZPTOTBND(NFLEV+1,JK2,IBND2)
ENDIF
ENDDO
ENDDO
C
C calculate THETA
C
DO JLAT = 1, NJ
DO JK1 = 1, NFLEV
THETA(JK1,JLAT) =
+ ATAN(-ZCHIPSI(JK1,JLAT) / ZPSIPSI(JK1,JLAT))
ENDDO
ENDDO
C deallcate space
C
CALL STDDDAL
C
C
C TEMPORARALLY SET TO ZERO FOR TESTS
ccc DO JK1 = 1, (NFLEV+1)
ccc DO JK2 = 1, NFLEV
ccc DO JLAT = 1,NJ
ccc PTOT(JK1,JK2,JLAT)=0.0
ccc ENDDO
ccc ENDDO
ccc ENDDO
RETURN
END