subroutine ch_rdspstd(poper,knstatlev,kulbgsto) 1,8
#if defined (DOC)
*
***s/r CH_RDSPSTD - Read the spectral coefficients of standard deviations
* from a RPN standard file and perform vertical
* interpolation.
*
*Author : RDSPSTD by S.Pellerin *ARMA/AES November, 2000
* Extended to CH_RDSPSTD by Y. Yang, ARQI 2005
*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
* . Added reading std dev for species.
* . clvar3d and clvar2d can now be read from namelist
* to make it easier for future expansion
* Y. Yang Oct. 2004
* . Added logical LCHEM for reading NAMVARSTD only when needed.
* ie. when assimilating species. Otherwise use default.
* Y. Yang Feb. 2005
* . Removed 'OZ' as now part of 'TR'
* Y.J. Rochon *ARQX/MSC May 2005, Feb 2006, April 2007
* . Unit for reading species background stats now
* NULBGSTR. Correspondingly added if statement for
* call to vstlir.
* . Added *sigscl2d and *sigscl3d for scaling of std. dev.
* Non-default scaling factors provided by NAMVARSTD.
* . Reading of NAMVARSTD when available and not just when
* LCHEM is true. This allows optional scaling
* of dynamics related std. dev. for either state of LCHEM.
* . Changed CGCMT/NGCMT to CSCMT/NSCMT
* Y.J. Rochon *ARQX Aug 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 "comct0.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comchem.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,indyn
parameter (jptrunc=200)
character*4 cvar3d(inbrvar3d),cvar2d(inbrvar2d)
integer jvar,jn,jlevi
integer ikey, jlevo, ilen, jlat
integer jtr
integer iflag
real*8 zsp,zspbuf,zwork,zsigscl3d(inbrvar3d),zsigscl2d(inbrvar2d)
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 vfstlir,vfstecr
external vfstlir,vfstecr
c
c data clvar3d/'PP','UC','UT','LQ','CC','ES','GZ','TT','UU','VV'/
c data clvar2d/'UP','P0'/
*---------------------------------------------------------------------
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'
indyn=4
C
clvar2d(1) ='UP'
C
if (nanalvar.eq.4) then
clvar3d(5)='TB'
indyn=5
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
c
c Check that inbrvar3d >= ncmtmax+10
c
if (inbrvar3d .lt. ncmtmax+10) then
call abort3d(nulout, 'CH_RDSPSTD: inbrvar3d less than ncmtmax+10 !')
endif
CALL READNML('NAMVARSTD',IFLAG)
if (.NOT.LCHEM.AND.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(:)
C
else if (LCHEM) then
C
C Assumes that all default dynamics variables are included
C in the final list of variables!!
C
zsigscl2d(:)=sigscl2d(:)
zsigscl3d(:)=sigscl3d(:)
C
end if
C
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
if (jvar.le.indyn) then
ikey = vfstlir(zspbuf,nulbgst,ini,inj,ink,idate(1)
s ,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
else
ikey = vfstlir(zspbuf,nulbgstr,ini,inj,ink,idate(1)
s ,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
end if
*
if(ikey .lt.0 ) then
call abort3d(nulout
& ,'CH_RDSPSTD: Could not find std. dev.')
endif
c
if (ini .ne. knstatlev) then
call abort3d(nulout
& ,'CH_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
else
C
C* For chemical species. Find the position of the tracer
C
do jtr =1,NSCMT
if(clnomvar .eq. CSCMT(jtr)) then
do jlat = 1, nj
do jlevo = 1, nflev
rgsigtr(jlat,jlevo+nflev*(jtr-1)) = zgr(jlat,jlevo)
enddo
enddo
go to 999
endif
enddo
if (jtr .gt. nscmt) then
write(nulout, *) 'Skipped background std for variable', clnomvar
endif
endif
c
999 continue
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
if (clvar2d(jvar) .eq. ' ') go to 777
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
C Apply scaling of std. dev. (optional scaling factors from NAMVARSTD
C namelist; default value is 1.0)
C
zgr(:,:)=zgr(:,:)*zsigscl2d(jvar)
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 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
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
777 continue
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 CH_RDSPSTD'
*
RETURN
END