SUBROUTINE RDSPPTOT(poper,knstatlev,kulbgsto) 1,13
#if defined (DOC)
*
**s/r rdspptot -Read in balance operator spectral coefficients
* .
* Purpose
* . Read in coefficients for P_to_T operator and also turning angle
* for balanced divergence operator
* . Vertical interpolation of operators
*
*Author : S. Pellerin *ARMA/AES February, 2000
*Revision:
* JM Belanger CMDA/SMC Jul 2000
* . 32 bits conversion
* Y.J Rochon *ARQX, Nov 2008
* . Reading and setting of new balance operators
* (*BAL_*C).
*
#endif
IMPLICIT NONE
*implicits
*
* Global variables
*
#include "comdim.cdk"
#include "comlun.cdk"
#include "comleg.cdk"
#include "comstate.cdk"
#include "comcorr.cdk"
#include "rpnstd.cdk"
#include "comspg.cdk"
#include "cominterp.cdk"
#include "comcva.cdk"
*
* Local variables
*
integer knstatlev,kulbgsto
real*8 poper(nflev,knstatlev)
*
integer jn, jk1, jk2, ikey, ilen,jlat,jcol
real*8 zsptheta, zgrtheta, zleg,zwork
real*8 zptotsrc,zspptot,zgrptot,ztheta,zptotecr
& ,zptotmix
real*8 zrgsigtt,zfact
c
pointer (pxzrgsigtt,zrgsigtt(nj,nflev))
pointer (pxzsptheta,zsptheta(0:ntrunc,nflev)),(pxzgrtheta
& ,zgrtheta(nj,nflev))
pointer (pxzspptot,zspptot(0:ntrunc,nflev+1,nflev))
pointer (pxzgrptot,zgrptot(nj,nflev+1,nflev))
pointer (pxzleg,zleg(0:ntrunc,nj))
pointer (pxzptotecr,zptotecr(nflev+1,nflev,nj))
*
pointer (pxzptotmix,zptotmix(nflev+1,knstatlev))
*
pointer (pxzptotsrc,zptotsrc(knstatlev+1,knstatlev))
pointer (pxztheta,ztheta(knstatlev))
*
**
integer vfstlir,vfstecr
external vfstlir,vfstecr
C ------------------------------------------------------
write(nulout,*) 'RDSPPTOT - Begin'
call vflush(nulout)
*
* Allocating a local array
*
ilen = (ntrunc + 1)*nflev
call hpalloc(pxzsptheta,max(1,ilen),ierr,8)
ilen = nj * nflev
call hpalloc(pxzgrtheta,max(1,ilen),ierr,8)
call hpalloc(pxzrgsigtt,max(1,ilen),ierr,8)
ilen = (ntrunc+1) * (nflev+1) * nflev
call hpalloc(pxzspptot,max(1,ilen),ierr,8)
ilen = nj * (nflev + 1) * nflev
call hpalloc(pxzgrptot,max(1,ilen),ierr,8)
ilen = (ntrunc + 1) * nj
call hpalloc(pxzleg,max(1,ilen),ierr,8)
ilen = nj * (nflev + 1) * nflev
call hpalloc(pxzptotecr,max(1,ilen),ierr,8)
*
ilen = (nflev+1) * knstatlev
call hpalloc(pxzptotmix,max(1,ilen),ierr,8)
*
ilen = (knstatlev + 1) * knstatlev
call hpalloc(pxzptotsrc,max(1,ilen),ierr,8)
ilen = knstatlev
call hpalloc(pxztheta,max(1,ilen),ierr,8)
*
* set up simple spectral transforms
*
write(nulout,*) 'RDSPPTOT: Set up simple spectral transforms'
call vflush(nulout)
call zlegpol(zleg,rmu,nj,ntrunc,ntrunc,nj)
C
C Read and set new balance operators BAL_TBPP_CC and BAL_UTPP_UC
C
C Read TT std dev
C
ip1 = -1
ip2 = -1
ip3 = -1
idateo = -1
cletiket = 'STDDEV'
cltypvar = 'E'
clnomvar = 'TT'
ikey = vfstlir(zrgsigtt,nulbgst,ini,inj,ink
& ,idateo,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
IF(IKEY .LT.0 ) THEN
ibal_tbpp_cc=0
write(NULOUT,*)
& 'RDSPPTOT: TT STDDEV not available.'
go to 150
ENDIF
C****
c ibal_tbpp_cc=0
c go to 150
C****
ip1 = -1
ip3 = -1
idateo = -1
cletiket = 'SP_TBCC'
cltypvar = 'X'
clnomvar = 'ZZ'
C
write(nulout,*) 'RDSPPTOT: Start reading in TBPP_CC from unit:'
& ,nulbgst
call vflush(nulout)
ibal_tbpp_cc=1
do jn = 0,ntrunc
ip2 = jn
ikey = vfstlir(ztheta,nulbgst,ini,inj,ink
& ,idateo,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
c
IF(IKEY .LT.0 ) THEN
ibal_tbpp_cc=0
write(NULOUT,*)
& 'RDSPPTOT: BAL_TBPP_CC not available.'
exit
ENDIF
c
if (ini .ne. knstatlev) then
CALL ABORT3D(NULOUT
& ,'RDSPPTOT: BG stat levels inconsitencies')
endif
c
if(lvintbgstat) then
c
c Vertical interpolation O'm = Vmn On
c
call mxmaop1(poper,1,nflev,ztheta,1,knstatlev,zsptheta(jn,1)
& ,ntrunc+1,1,nflev,knstatlev,1)
else
do jk1 = 1,nflev
zsptheta(jn,jk1) = ztheta(jk1)
enddo
endif
c
enddo
c
c Converting BAL_TBPP_CC in physical space
c
if (ibal_tbpp_cc.eq.1) then
c
write(nulout,*) 'RDSPPTOT: Converting tbpp_cc in physical space'
call vflush(nulout)
call zleginv2(zgrtheta,zsptheta,zleg,ntrunc,nj,nflev,nj,nflev
& ,ntrunc)
c
c write(nulout,*) 'TB_CC ',(zgrtheta(jlat,6),jlat=1,nj)
do jlat = 1, nj
do jk1 = 1, nflev
C
C Set TB std dev
C
zfact=sqrt(max(0.01D0,
& zrgsigtt(jlat,jk1)**2-rgsig(jlat,nsposit(nstt)+jk1-1)**2))
C
C Complete balance operator
C
if (abs(zgrtheta(jlat,jk1)).lt.0.05) zgrtheta(jlat,jk1)=0.0D0
bal_tbpp_cc(jk1,jlat) = zgrtheta(jlat,jk1)*
& rgsig(jlat,nsposit(nsdiv)+jk1-1)/zfact
C
C Correspondingly adjust std. dev. of related analysis increment var.
C
rgsig(jlat,nsposit(nsdiv)+jk1-1)=
& sqrt(max(0.0001*rgsig(jlat,nsposit(nsdiv)+jk1-1)**2,
& rgsig(jlat,nsposit(nsdiv)+jk1-1)**2*
& (1.0-zgrtheta(jlat,jk1)**2)))
end do
end do
c write(nulout,*) 'TB_CC ',(bal_tbpp_cc(6,jlat),jlat=1,nj)
open(unit=668,file='./uc_stddev.asc',status='UNKNOWN')
do jk1=0, nflev-1
write(668,400)(rgsig(jlat,nsposit(nsdiv)+jk1),jlat=nj,1,-1)
enddo
write(668,*)
close (unit=668,status='KEEP')
400 format(2x, 7(g11.5, 3x))
end if
C
150 continue
C
write(nulout,*) 'RDSPPTOT: Start reading in UTPP_CC from unit:'
& ,nulbgst
C
C NOTE: Correl(UT,CC) = correl(UT,UC) given that correl(UT,CCB)=0
C where CCB=part of CC from balance with PSI and thus TB (from region
C away from the surface), i.e.
C
C Balance operator = correl(UT,UC)*sigma(UT)/sigma(UC)
C = correl(UT,CC)*sigma(UT)/sigma(UC)
C
C where sigma^2(UC) = sigma^2(CC)- sigma^2(CCB)
C and sigma(UC)= rgsig part for nsposit(nsdiv) set above
C
ip1 = -1
ip3 = -1
idateo = -1
cletiket = 'SP_UTCC'
cltypvar = 'X'
clnomvar = 'ZZ'
C
call vflush(nulout)
ibal_utpp_uc=1
do jn = 0,ntrunc
ip2 = jn
ikey = vfstlir(ztheta,nulbgst,ini,inj,ink
& ,idateo,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
c
IF(IKEY .LT.0 ) THEN
ibal_utpp_uc=0
write(NULOUT,*)
& 'RDSPPTOT: BAL_UTPP_CC not available.'
exit
ENDIF
c
if (ini .ne. knstatlev) then
CALL ABORT3D(NULOUT
& ,'RDSPPTOT: BG stat levels inconsitencies')
endif
c
if(lvintbgstat) then
c
c Vertical interpolation O'm = Vmn On
c
call mxmaop1(poper,1,nflev,ztheta,1,knstatlev,zsptheta(jn,1)
& ,ntrunc+1,1,nflev,knstatlev,1)
else
do jk1 = 1,nflev
zsptheta(jn,jk1) = ztheta(jk1)
enddo
endif
c
enddo
c
c Converting BAL_UTPP_UC in physical space
c
if (ibal_utpp_uc.eq.1) then
C
write(nulout,*) 'RDSPPTOT: Converting UTPP_UC in physical space'
call vflush(nulout)
call zleginv2(zgrtheta,zsptheta,zleg,ntrunc,nj,nflev,nj,nflev
& ,ntrunc)
c
c write(nulout,*) 'UT_CC ',(zgrtheta(jlat,6),jlat=1,nj)
do jlat = 1, nj
do jk1 = 1, nflev
C
C Complete balance operator
C
if (abs(zgrtheta(jlat,jk1)).lt.0.05) zgrtheta(jlat,jk1)=0.0D0
bal_utpp_uc(jk1,jlat) = zgrtheta(jlat,jk1)*
& rgsig(jlat,nsposit(nstt)+jk1-1)/
& rgsig(jlat,nsposit(nsdiv)+jk1-1)
C
C Correspondingly adjust std. dev. of related analysis increment var.
C
rgsig(jlat,nsposit(nstt)+jk1-1)=
& sqrt(max(0.0001D0,rgsig(jlat,nsposit(nstt)+jk1-1)**2*
& (1.0-zgrtheta(jlat,jk1)**2)))
end do
end do
c write(nulout,*) 'UT_CC ',(bal_utpp_uc(6,jlat),jlat=1,nj)
open(unit=668,file='./ut_stddev.asc',status='UNKNOWN')
do jk1=0, nflev-1
write(668,400)(rgsig(jlat,nsposit(nstt)+jk1),jlat=nj,1,-1)
enddo
write(668,*)
close (unit=668,status='KEEP')
end if
c
if (kulbgsto.gt. 0 ) then
ierr = fstprm(ikey,idateo,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
ini = nflev
inj = nj
ink = 0
ip1 = 0
ip2 = 0
c
if (ibal_tbpp_cc.eq.1) then
cletiket = 'TBPP_CC'
c
ierr = vfstecr(bal_tbpp_cc,zwork,-inbits,kulbgsto,idateo,ideet,
& inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar, clnomvar,
& cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp, .true.)
c
end if
c
if (ibal_tbpp_cc.eq.1) then
cletiket = 'UTPP_UC'
c
ierr = vfstecr(bal_utpp_uc,zwork,-inbits,kulbgsto,idateo,ideet,
& inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar, clnomvar,
& cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp, .true.)
c
end if
endif
C Read of spectral coefficients for theta
*
ip1 = -1
ip3 = -1
idateo = -1
cletiket = 'SP_THETA'
cltypvar = 'X'
clnomvar = 'ZZ'
C
c read of spectral coefficients for theta
c
write(nulout,*) 'RDSPPTOT: Start reading in THETA from unit:'
& ,nulbgst
call vflush(nulout)
do jn = 0,ntrunc
ip2 = jn
ikey = vfstlir(ztheta,nulbgst,ini,inj,ink
& ,idateo,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
c
IF(IKEY .LT.0 ) THEN
CALL ABORT3D(NULOUT
& ,'RDSPPTOT: Problem with background stat file')
ENDIF
c
if (ini .ne. knstatlev) then
CALL ABORT3D(NULOUT
& ,'RDSPPTOT: BG stat levels inconsitencies')
endif
c
if(lvintbgstat) then
c
c Vertical interpolation O'm = Vmn On
c
call mxmaop1(poper,1,nflev,ztheta,1,knstatlev,zsptheta(jn,1)
& ,ntrunc+1,1,nflev,knstatlev,1)
else
do jk1 = 1,nflev
zsptheta(jn,jk1) = ztheta(jk1)
enddo
endif
*
enddo
*
c converting theta in physical space
c
write(nulout,*) 'RDSPPTOT: converting theta in physical space'
call vflush(nulout)
call zleginv2(zgrtheta,zsptheta,zleg,ntrunc,nj,nflev,nj,nflev
& ,ntrunc)
*
do jlat = 1, nj
do jk1 = 1, nflev
theta(jk1,jlat) = zgrtheta(jlat,jk1)
end do
end do
c
if ( kulbgsto .gt. 0 ) then
ierr = fstprm(ikey,idateo,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
ini = nflev
inj = nj
ink = 0
ip1 = 0
ip2 = 0
cletiket = 'THETA'
c
ierr = vfstecr(theta, zwork, -inbits, kulbgsto, idateo, ideet,
& inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar, clnomvar,
& cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp, .true.)
c
endif
write(nulout,*) 'RDSPPTOT: Start Reading in SP_PtoT from unit:'
& ,nulbgst
ip1 = -1
ip2 = -1
ip3 = -1
idateo = -1
cletiket = 'SP_PtoT'
cltypvar = 'X'
clnomvar = 'ZZ'
C
c read of spectral coefficients for P to T operator
c
do jn = 0,ntrunc
ip2 = jn
ikey = vfstlir(zptotsrc,nulbgst,ini,inj,ink
s ,idateo,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
c
IF(IKEY .LT.0 ) THEN
CALL ABORT3D(NULOUT
& ,'RDSPPTOT: Problem with background stat file')
ENDIF
c
if (ini .ne. knstatlev+1 .or. inj .ne. knstatlev) then
call abort3d(nulout
& ,'RDSPPTOT: BG stat levels inconsitencies')
endif
c
if(lvintbgstat) then
c
c Vertical interpolation of P to T
c First Vertical interpolation: P'mn = Vmn Pnn
c
call mxmaop1(poper,1,nflev,zptotsrc,1,knstatlev+1,zptotmix,1
& ,nflev+1,nflev,knstatlev,knstatlev)
c
c Copy of the bottom row (P to Ps) from zptotsrc to zptotmix
c
do jcol = 1, knstatlev
zptotmix(nflev+1,jcol) = zptotsrc(knstatlev+1,jcol)
enddo
c
c Second Vertical interpolation: P''mm = P'mn (Vnm)
c
call mxmaop1(zptotmix,1,nflev+1,poper,knstatlev,1,zspptot(jn,1
& ,1),ntrunc+1,(ntrunc+1)*(nflev+1),nflev+1,knstatlev,nflev
& )
c
else
do jk2 = 1,nflev
do jk1 = 1,nflev+1
zspptot(jn,jk1,jk2) = zptotsrc(jk1,jk2)
enddo
enddo
endif
enddo
c
write(nulout,*) 'RDSPPTOT: converting PtoT in physical space'
call vflush(nulout)
ilen = nflev*(nflev+1)
call zleginv2(zgrptot,zspptot,zleg,ntrunc,nj,ilen,nj,ilen
& ,ntrunc)
c
do jlat = 1, nj
do jk2 = 1,nflev
do jk1 = 1, nflev+1
ptot(jk1,jk2,jlat) = zgrptot(jlat,jk1,jk2)
end do
end do
enddo
c COPY NH PTOT TO SH
if(LCOPYPTOT) then
do jk1=1,nflev+1
do jk2=1,nflev
do jlat=1,nj/2
ptot(jk1,jk2,nj-jlat+1)=ptot(jk1,jk2,jlat)
enddo
enddo
enddo
endif
c SCALE PTOT
do jk1=1,nflev+1
do jk2=1,nflev
do jlat=1,nj
ptot(jk1,jk2,jlat)=ptot(jk1,jk2,jlat)*RSCALEPTOT
enddo
enddo
enddo
c ---------------------------------------------------
if ( kulbgsto .gt. 0 ) then
ierr = fstprm(ikey,idateo,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
do jlat = 1, nj
do jk2 = 1,nflev
do jk1 = 1, nflev + 1
zptotecr(jk1,jk2,jlat) = ptot(jk1,jk2,nj-jlat+1)
end do
end do
enddo
c
ini = nflev + 1
inj = nflev
ink = nj
ip1 = 0
ip2 = 0
cletiket = 'P_to_T'
c
ierr = vfstecr(zptotecr, zwork, -inbits, kulbgsto, idateo,
& ideet, inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar,
& clnomvar, cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp,
& .true.)
c
endif
c
* 9. Deallocate local arrays
*
call hpdeallc(pxzleg,ierr,1)
c
call hpdeallc(pxztheta,ierr,1)
call hpdeallc(pxzsptheta,ierr,1)
call hpdeallc(pxzgrtheta,ierr,1)
call hpdeallc(pxzrgsigtt,ierr,1)
c
call hpdeallc(pxzptotsrc,ierr,1)
call hpdeallc(pxzptotmix,ierr,1)
call hpdeallc(pxzspptot,ierr,1)
call hpdeallc(pxzgrptot,ierr,1)
call hpdeallc(pxzptotecr,ierr,1)
*
write(nulout,*)'DONE in RDSPTOT'
c
return
end