!-------------------------------------- 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 rdspstd(poper,knstatlev,kulbgsto) 1,10
#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
*
* 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 "comcorr.cdk"
#include "comcst.cdk"
#include "comcva.cdk"
*
* Arguments
*
integer knstatlev,kulbgsto
real*8 poper(nflev,knstatlev)
*
* local variables
*
integer jptrunc,inbrvar3d,inbrvar2d,inbrvar3dmax,inbrvar2dmax
parameter(jptrunc=200,inbrvar3dmax=5,inbrvar2dmax=2)
integer jvar,jn,jlevi,inix,injx,inkx
integer ikey, jlevo, ilen, jlat
real*8 zsp,zspbuf,zwork,zcoriolis
real*8 zleg,zgr,zgsig,zstddev(nksdim2,nj)
character*2 clvar3d(inbrvar3dmax),clvar2d(inbrvar2dmax)
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
data clvar3d/'PP','UC','UT','LQ','TB'/
data clvar2d/'UP','PB'/
*---------------------------------------------------------------------
*
if(nanalvar.eq.4) then
inbrvar3d=inbrvar3dmax
inbrvar2d=inbrvar2dmax
else
inbrvar3d=inbrvar3dmax-1
inbrvar2d=inbrvar2dmax-1
endif
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
clnomvar = clvar3d(jvar)
write(nulout,*)'Reading ',clnomvar
do jn = 0,ntrunc
ip2 = jn
ikey = fstinf(nulbgst,inix,injx,inkx,idate(1)
s ,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
if(ikey .ge.0 ) then
ikey = vfstlir(zspbuf,nulbgst,ini,inj,ink,idate(1)
s ,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
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)
endif
else
c call abort3d(nulout
c & ,'RDSPSTD: Problem with background stat file')
write(nulout,*) 'WARNING: CANNOT FIND SPSTD FOR ',clnomvar,jn
write(nulout,*) 'WARNING: SETTING TO ZERO!!!'
zspbuf(:)=0.0
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)
*
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
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
enddo
*
write(nulout,*) 'Reading 2D variables'
do jvar = 1, inbrvar2d
clnomvar = clvar2d(jvar)
write(nulout,*)'Reading ',clnomvar
do jn = 0,ntrunc
ip2 = jn
ikey = fstinf(nulbgst,inix,injx,inkx,idate(1)
s ,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
if(ikey .ge.0 ) then
ikey = vfstlir(zspbuf,nulbgst,ini,inj,ink,idate(1)
s ,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
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)
endif
c
else
c call abort3d(nulout
c & ,'RDSPSTD: Problem with background stat file')
write(nulout,*) 'WARNING: CANNOT FIND SPSTD FOR ',clnomvar,jn
write(nulout,*) 'WARNING: SETTING TO ZERO!!!'
zspbuf(:)=0.0
endif
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
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