!-------------------------------------- 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(KULSTAT,KULCORNS,KULSTDEV) 1,11
#if defined (DOC)
*
***s/r PTOT2 - 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 - ARMA - May 2008
* - Modified call to getfst
*
*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"
*
INTEGER KULSTAT, KULCORNS, KULSTDEV
C
INTEGER JENS, IENS, JK1, JK2, JLA
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(100), IDATE(100), IDATV(100), 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 ZM1(NFLEV+1,NFLEV,JPNLATBND), ZM2(NFLEV,NFLEV,JPNLATBND)
REAL*8 ZTT(NFLEV+1,NFLEV,JPNLATBND)
REAL*8 ZPTOTBND(NFLEV+1,NFLEV,JPNLATBND)
REAL*8 ZM2INV(NFLEV,NFLEV,JPNLATBND), ZWORK(NFLEV*NFLEV), 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(nflev,nflev),zeigenv(nflev)
real*8 zeigmax,zeigenvi(nflev)
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 /
ccc DATA DLLATMIN / -90.0D0, -30.0D0, 30.0D0 /
ccc DATA DLLATMAX / -30.0D0, 30.0D0, 90.0D0 /
ccc 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
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
ZPTOTBND(JK1,JK2,JB) = 0.0
END DO
END DO
END DO
DO JB= 1, JPNLATBND
DO JK1= 1, NFLEV
DO JK2 = 1, NFLEV
ZM2(JK1,JK2,JB) = 0.0
ZTT(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 = 100
C
CALL MEANGD(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,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)
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 . 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
ZFACT = 1.0
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 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
ZFACT = 1.0
else
ZFACT = 0.0
endif
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JK1 = 1, NFLEV
DO JK2 = 1, NFLEV
ZM2(JK1,JK2,JB) = ZM2(JK1,JK2,JB) +
+ ZFACT * GZ1(JLON,JK1,JLAT) * GZ1(JLON,JK2,JLAT)
ZTT(JK1,JK2,JB) = ZTT(JK1,JK2,JB) +
+ ZFACT * TT0(JLON,JK1,JLAT) * TT0(JLON,JK2,JLAT)
ENDDO
ENDDO
ENDDO
ENDDO
END DO ! Loop on JPNLATBND
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
C Filter ZM2 by setting smallest eigenvalues to zero
C
CCC DEBUG IN
write(601,*)zm1
write(602,*)zm2
write(603,*)ztt
LFLTEIG = .FALSE.
IWORK=4*NFLEV
do JB=1,JPNLATBND
DO JK1=1,NFLEV
DO JK2=1,NFLEV
ZEIGEN(JK1,JK2)=ZM2(JK1,JK2,JB)
END DO
END DO
CALL DSYEV('V','U',NFLEV, ZEIGEN,NFLEV, 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,NFLEV)
do JK1=1,NFLEV
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,NFLEV)
DO JK1=1,NFLEV
DO JK2=1,NFLEV
ZM2INV(JK1,JK2,JB)=0.0
ZM2(JK1,JK2,JB)=0.0
DO JK=1,NFLEV
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, NFLEV
DO JK2 = 1, NFLEV
IF(ZM2(JK1,JK2,JB).GT.ZMAXI) ZMAXI = ZM2(JK1,JK2,JB)
ENDDO
ENDDO
C
cbue DO JK1 = 1, NFLEV
cbue DO JK2 = 1, NFLEV
cbue ZM2INV(JK1,JK2,JB) = ZM2(JK1,JK2,JB)/ZMAXI
cbue ENDDO
cbue ENDDO
C
cbue ZEPS = RZERO
cbue CALL MINV(ZM2INV,NFLEV,NFLEV,ZWORK,ZDET,ZEPS,0,1)
DO JK1 = 1, (NFLEV+1)
DO JK2 = 1, NFLEV
DO JK = 1, NFLEV
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
write(701,*)zm1
write(702,*)zm2
write(703,*)zm2inv
C
c Copy BAND #3 into BAND #1
ccc DO JK1 = 1, (NFLEV+1)
ccc DO JK2 = 1, NFLEV
ccc ZPTOTBND(JK1,JK2,1) = ZPTOTBND(JK1,JK2,3)
ccc ENDDO
ccc 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,nflev
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, NFLEV
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, NFLEV
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