subroutine rdspstd(poper,knstatlev,kulbgsto) 1,7
#if defined (DOC)
*
***s/r RSPSTD - Read the spectral coefficients of standard deviations
* from a RPN standard file and perform vertical
* interpolation.
*
*Author : S.Pellerin *ARMA/AES November, 2000
*Revision:/
* JM Belanger CMDA/SMC Jul 2000
* . 32 bits conversion
*
* J. Halle CMDA/SMC April 2003
* . Added RFACTHUM, which multiplies background
* error std for LQ. Default = 1.0
* Y. Yang Oct. 2003
* . clvar3d and clvar2d can be read from namelist
* NAMVARSTD
* Y.J. Rochon *ARQX/MSC Feb 2006
* . Added *sigscl2d and *sigscl3d for scaling of std. dev.
* . Reading non-default scaling factors via NAMVARSTD
* namelist.
* Y.J. Rochon *ARQX Jan 2010
* . Added TB and PB as posssible default parameters following
* V10.2.2 rdspstd.ftn
*
* Arguments:
* input:
* POPER(nflev,knstatlev): explicit vertical interpolation operator
* KNSTATLEV : Number of level of the original statistics
* kulbgsto : Logical unit for backgroud stat output
*
#endif
implicit none
*implicits
*
* Global variables
*
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comspg.cdk"
#include "rpnstd.cdk"
#include "comleg.cdk"
#include "cominterp.cdk"
#include "compstat.cdk"
#include "comvarstd.cdk"
#include "comcorr.cdk"
#include "comcst.cdk"
#include "comcva.cdk"
*
*
* Arguments
*
integer knstatlev,kulbgsto
real*8 poper(nflev,knstatlev)
*
* local variables
*
integer jptrunc
parameter(jptrunc=200)
integer jvar,jn,jlevi
integer ikey, jlevo, ilen, jlat
real*8 zsp,zspbuf,zwork
real*8 zleg,zgr,zgsig
pointer (pxzspbuf,zspbuf(knstatlev))
c
pointer (pxzsp,zsp(0:ntrunc,nflev))
pointer (pxzgr,zgr(nj,nflev))
pointer (pxzleg,zleg(0:ntrunc,nj))
pointer (pxzgsig,zgsig(1,nj,nflev))
c
integer iflag
character*4 cvar3d(inbrvar3d),cvar2d(inbrvar2d)
real*8 zsigscl3d(inbrvar3d),zsigscl2d(inbrvar2d)
c
C---------------------------------------------------------------------
C
C* Defaults values for clvar*d, sigscl*d
C
sigscl3d(:)=1.0
sigscl2d(:)=1.0
zsigscl3d(:)=1.0
zsigscl2d(:)=1.0
clvar3d(:) = ' '
clvar2d(:) = ' '
clvar3d(1) ='PP'
clvar3d(2) ='UC'
clvar3d(3) ='UT'
clvar3d(4) ='LQ'
C
clvar2d(1) ='UP'
C
if (nanalvar.eq.4) then
clvar3d(5)='TB'
clvar2d(2) ='PB'
end if
C
cvar2d(:)=clvar2d(:)
cvar3d(:)=clvar3d(:)
C
C* Read clvar3d and clvar2d from namelist
C
C Also read std. dev. scaling factors zsigscl*d
C
IFLAG=1
CALL READNML('NAMVARSTD',IFLAG)
if (IFLAG.EQ.0) then
C
C Restrict list to default dynamical variables.
C
do jn=1,inbrvar3d
do jvar=1,inbrvar3d
if (cvar3d(jn).eq.clvar3d(jvar)) then
zsigscl3d(jn)=sigscl3d(jvar)
exit
end if
end do
end do
do jn=1,inbrvar2d
do jvar=1,inbrvar2d
if (cvar2d(jn).eq.clvar2d(jvar)) then
zsigscl2d(jn)=sigscl2d(jvar)
exit
end if
end do
end do
clvar3d(:)=cvar3d(:)
clvar2d(:)=cvar2d(:)
end if
*
ilen = knstatlev
call hpalloc(pxzspbuf,max(1,ilen),ierr,8)
ilen = (ntrunc+1)*nflev
call hpalloc(pxzsp,max(1,ilen),ierr,8)
ilen = nj*nflev
call hpalloc(pxzgr,max(1,ilen),ierr,8)
ilen = nj*(ntrunc+1)
call hpalloc(pxzleg,max(1,ilen),ierr,8)
ilen = nj*nflev
call hpalloc(pxzgsig,max(1,ilen),ierr,8)
**
* ----- Reading variances in spectral space -----
*
* 0. Set up simple spectral transforms
*
call zlegpol(zleg,rmu,nj,ntrunc,ntrunc,nj)
*
ilen = (njend -njbeg +1)*nkgdim
*
* Initializing all the variances fields to zero
*
write(nulout,*)'Zeroing RGSIG'
call zero(ilen,rgsig)
*
* 2. Reading the data
*
* . 2.1 Background error standard deviations
*
idate(1) = -1
ip1 = -1
ip2 = -1
ip3 = -1
*
cletiket = 'SPSTDDEV'
cltypvar ='X'
***********************************************************************
write(nulout,*) 'Reading 3D variables'
do jvar = 1, inbrvar3d
if (clvar3d(jvar) .eq. ' ') go to 888
clnomvar = clvar3d(jvar)
write(nulout,*)'Reading ',clnomvar
do jn = 0,ntrunc
ip2 = jn
ikey = vfstlir(zspbuf,nulbgst,ini,inj,ink,idate(1)
s ,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
*
if(ikey .lt.0 ) then
call abort3d(nulout
& ,'RDSPSTD: Problem with background stat file')
endif
c
if (ini .ne. knstatlev) then
call abort3d(nulout
& ,'RDSPSTD: BG stat levels inconsitencies')
endif
c
if(lvintbgstat) then
c
c Vertical interpolation O'm = Vmn On
c
call mxmaop1(poper,1,nflev,zspbuf,1,knstatlev,zsp(jn,1)
& ,ntrunc+1,(ntrunc+1)*nflev,nflev,knstatlev,1)
else
do jlevo = 1, nflev
zsp(jn,jlevo) = zspbuf(jlevo)
enddo
endif
enddo
c
c Transform to physical space.
c N.B.: LQ values are mutiplied by RFACTHUM
*
call zleginv2(zgr,zsp,zleg,ntrunc,nj,nflev,nj,nflev,ntrunc)
*
C Apply scaling of std. dev. (optional scaling factors from NAMVARSTD
C namelist; default value is 1.0)
C
zgr(:,:)=zgr(:,:)*zsigscl3d(jvar)
C
if(clnomvar .eq. 'PP') then
do jlat = 1, nj
do jlevo = 1, nflev
rgsiguu(jlat,jlevo) = zgr(jlat,jlevo)
enddo
enddo
elseif(clnomvar .eq. 'UC' .or. clnomvar .eq. 'CC') then
do jlat = 1, nj
do jlevo = 1, nflev
rgsigvv(jlat,jlevo) = zgr(jlat,jlevo)
enddo
enddo
elseif(clnomvar .eq. 'UT') then
do jlat = 1, nj
do jlevo = 1, nflev
rgsigtt(jlat,jlevo) = zgr(jlat,jlevo)
enddo
enddo
elseif(clnomvar .eq. 'TB') then
do jlat = 1, nj
do jlevo = 1, nflev
rgsigtb(jlat,jlevo) = zgr(jlat,jlevo)
enddo
enddo
elseif(clnomvar .eq. 'LQ') then
do jlat = 1, nj
do jlevo = 1, nflev
rgsigq(jlat,jlevo) = zgr(jlat,jlevo)*rfacthum
enddo
enddo
endif
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 jlevo = 1,nflev
zgsig(1,jlat,jlevo) = zgr(nj-jlat+1,jlevo)
enddo
enddo
c
ierr = vfstecr(zgsig, zwork, -inbits, kulbgsto, idateo, ideet,
& inpas, 1, nj, nflev, 0, 0, ip3, 'E', clnomvar,
& 'STDDEV',clgrtyp,ig1, ig2, ig3, ig4, idatyp, .true.)
c
endif
888 continue
enddo
*
write(nulout,*) 'Reading 2D variables'
do jvar = 1, inbrvar2d
clnomvar = clvar2d(jvar)
write(nulout,*)'Reading ',clnomvar
do jn = 0,ntrunc
ip2 = jn
ikey = vfstlir(zspbuf,nulbgst,ini,inj,ink,idate(1)
s ,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
c
zsp(jn,1) = zspbuf(1)
c
enddo
c
c Transform to physical space
c
call zleginv2(zgr,zsp,zleg,ntrunc,nj,1,nj,nflev,ntrunc)
c
if(clnomvar .eq. 'UP') then
do jlat = 1, nj
rgsigps(jlat,1) = zgr(jlat,1)*100.0
c rgsigps(jlat,1) = 0.0
enddo
endif
if(clnomvar .eq. 'PB') then
do jlat = 1, nj
rgsigpsb(jlat) = zgr(jlat,1)*100.0
c rgsigpsb(jlat) = 0.0
enddo
endif
c
c
c compute stddev for all variables (including balanced temperature)
c
c DO jlevi = 1, NKGDIM
c DO jlat=1,NJ
c ZSTDDEV(jlevi,jlat)=CORVERT(jlevi,jlevi)*RGSIG(jlat,jlevi)
c ENDDO
c ENDDO
c DO jlevi = NKGDIM+1, NKGDIM+NFLEV
c DO jlat=1,NJ
c ZCORIOLIS = 2.*ROMEGA*RMU(jlat)
c ZSTDDEV(jlevi,jlat)=CORVERT(jlevi,jlevi)*ZCORIOLIS*RGSIGTB(jlat,jlevi)
c ENDDO
c ENDDO
c write(702,*) zstddev
c
c
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
zgsig(1,jlat,1) = zgr(nj-jlat+1,1)
enddo
c
ierr = vfstecr(zgsig, zwork, -inbits, kulbgsto, idateo, ideet,
& inpas, 1, nj, 1, 0, 0, ip3, 'E', clnomvar,
& 'STDDEV',clgrtyp,ig1, ig2, ig3, ig4, idatyp, .true.)
c
endif
enddo
*
* 9. Deallocate local arrays
*
call hpdeallc(pxzspbuf,ierr,1)
c
call hpdeallc(pxzsp,ierr,1)
call hpdeallc(pxzgr,ierr,1)
call hpdeallc(pxzleg,ierr,1)
call hpdeallc(pxzgsig,ierr,1)
*
WRITE(nulout,*)'DONE in RDSPSTD'
*
RETURN
END