!-------------------------------------- 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 readcvsdev 2,13
#if defined (DOC)
*
***s/r readcvsdev - In grdtyp = 'LU mode: Read the gridpoint standard deviation of (psi,chi_u,t_u,lnq,ps_u)
*
*Author : Luc Fillion - ARMA/MSC - 7 Oct 2005.
*Revision: Luc Fillion - ARMA/EC - 4 Apr 2006 - Validate Barotropic option.
* N.B.: A check should be added in case the bg stats file is used with wrong grid size...
*Revision: Luc Fillion - ARMA/EC - 13 May 2010 - Adjust magnitude of simulated st-dev in 'LU' mode
* and simulated context.
*
* Arguments:
* input:
*
#endif
implicit none
*implicits
*
* Global variables
*
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "rpnstd.cdk"
#include "comgem.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comcva.cdk"
#include "comrgsigla.cdk"
#include "comstate.cdk"
*
logical llfilt,llam,lglb,llbuffer
integer inbrvar3d,inbrvar2d,ilevcst
parameter(inbrvar3d=4,inbrvar2d=1)
integer jvar,jn,jlev
integer ikey,ji,jj,jk,ilen,jlat
real*8 zwork,zlevmin,zdiff,zscale
real*8 zgr,zgsig,zpc
character*2 clvar3d(inbrvar3d),clvar2d(inbrvar2d)
real*8 zstd2d(ni,nj)
real*8 zstd3d(ni,nflev,nj)
real*8 zwrksp(nla,2,nflev)
!---------------------------------------------------------------------
!
if(lcva_helm) then
clvar3d(1) = 'PP'
clvar3d(2) = 'CC'
else
clvar3d(1) = 'QQ'
clvar3d(2) = 'DD'
endif
clvar3d(3) = 'TT'
clvar3d(4) = 'LQ'
!
clvar2d(1) = 'P0'
!
llam = .false.
lglb = .true.
llfilt = .false.
llbuffer = .not.lpilot
!
write(nulout,*) 'readcvsdev:****************************'
write(nulout,*) 'readcvsdev: lsdevsim = ',lsdevsim
write(nulout,*) 'readcvsdev: llam = ',llam
write(nulout,*) 'readcvsdev: llfilt = ',llfilt
write(nulout,*) 'readcvsdev: lglb = ',lglb
write(nulout,*) 'readcvsdev: lpilot = ',lpilot
write(nulout,*) 'readcvsdev: llbuffer = ',llbuffer
write(nulout,*) 'readcvsdev:****************************'
!
zlevmin = 0.9000
ilevcst = nflev
zdiff = 1.e35
!
do jlev = 1,nflev
if(abs(vlev(jlev)-zlevmin).lt.zdiff) then
ilevcst = jlev
zdiff = abs(vlev(jlev)-zlevmin)
endif
enddo
write(nulout,*) 'readcvsdev: Level below which TT-sdev is kept cst=',ilevcst
write(nulout,*) 'readcvsdev: vlev(ilevcst) = ',vlev(ilevcst)
!
ilen = ni*nj*nflev
call zero(ilen,rgsigla)
!
if(lglb) then
!
!*2. Use global background error st-dev
! ----------------------------------
!
call readcv_gusdev
!
else if(llam) then
!
!*3. Use LAM background error st-dev
! -------------------------------
*
*3.1 Read gridpoint analysis-type variables background error st-dev
*
ini=ni
inj=nj
ink=1
idate(1) = -1
ip1 = -1
ip2 = -1
ip3 = -1
*
cletiket = 'CVGDSDEV'
cltypvar ='E'
!
write(nulout,*) 'Reading 3D variables'
!
do jvar = 1, inbrvar3d
clnomvar = clvar3d(jvar)
write(nulout,*)'Reading ',clnomvar
do jk=1,nflev
ip1 = nip1(jk)
ikey = vfstlir(zstd2d,nulbgst,ini,inj,ink,idate(1)
& ,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
!
if(ikey .lt.0 ) then
call abort3d(nulout
& ,'readcvsdev: Problem with background stat file')
endif
!
zscale = 0.5
if(clnomvar .eq. 'QQ'.or.clnomvar .eq. 'PP') then
do ji = 1, ni
do jj = 1, nj
rgsiglapp(ji,jk,jj) = zscale*zstd2d(ji,jj)
enddo
enddo
elseif(clnomvar .eq. 'DD'.or.clnomvar .eq. 'CC') then
do ji = 1, ni
do jj = 1, nj
rgsiglacu(ji,jk,jj) = zscale*zstd2d(ji,jj)
enddo
enddo
elseif(clnomvar .eq. 'TT') then
do ji = 1, ni
do jj = 1, nj
if(vlev(jk).le.vlev(ilevcst)) then
rgsiglatu(ji,jk,jj) = zscale*zstd2d(ji,jj)
else
rgsiglatu(ji,jk,jj) = rgsiglatu(ji,ilevcst,jj)
endif
enddo
enddo
elseif(clnomvar .eq. 'LQ') then
do ji = 1, ni
do jj = 1, nj
rgsiglalq(ji,jk,jj) = zstd2d(ji,jj)
enddo
enddo
endif
enddo
enddo
!
! Filter sdev
!
if(llfilt) then
do jk=1,nflev
do ji=1,ni
do jj=1,nj
zstd3d(ji,jk,jj) = rgsiglapp(ji,jk,jj)
enddo
enddo
enddo
!
call gdtruncr(zstd3d,zwrksp,'T',ntrunc,'H',.false.,nflev)
!
do jk=1,nflev
do ji=1,ni
do jj=1,nj
rgsiglapp(ji,jk,jj) = zstd3d(ji,jk,jj)
enddo
enddo
enddo
endif
call outhoriz2d(zstd3d,'sdevpp500.od','PP',nflev/2,
& 1,ni,1,nj,ni,nj,nflev)
!
write(nulout,*) 'Reading 2D variables'
!
do jvar = 1, inbrvar2d
clnomvar = clvar2d(jvar)
write(nulout,*)'Reading ',clnomvar
ip1 = 0
ip2 = 0
ikey = vfstlir(zstd2d,nulbgst,ini,inj,ink,idate(1)
& ,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
!
if(clnomvar .eq. 'P0') then
do ji = 1, ni
do jj = 1, nj
rgsiglapu(ji,1,jj) = zstd2d(ji,jj)*100.0
enddo
enddo
endif
enddo
endif
!
if(llbuffer) then
!PP
do jk=1,nflev
do ji=1,ni
do jj=1,nj
zstd3d(ji,jk,jj)=rgsiglapp(ji,jk,jj)
enddo
enddo
enddo
call gdmaskh(zstd3d,nflev)
do jk=1,nflev
do ji=1,ni
do jj=1,nj
rgsiglapp(ji,jk,jj)=zstd3d(ji,jk,jj)
enddo
enddo
enddo
!Cu
do jk=1,nflev
do ji=1,ni
do jj=1,nj
zstd3d(ji,jk,jj)=rgsiglacu(ji,jk,jj)
enddo
enddo
enddo
call gdmaskh(zstd3d,nflev)
do jk=1,nflev
do ji=1,ni
do jj=1,nj
rgsiglacu(ji,jk,jj)=zstd3d(ji,jk,jj)
enddo
enddo
enddo
!Tu
do jk=1,nflev
do ji=1,ni
do jj=1,nj
zstd3d(ji,jk,jj)=rgsiglatu(ji,jk,jj)
enddo
enddo
enddo
call gdmaskh(zstd3d,nflev)
do jk=1,nflev
do ji=1,ni
do jj=1,nj
rgsiglatu(ji,jk,jj)=zstd3d(ji,jk,jj)
enddo
enddo
enddo
!Lq
do jk=1,nflev
do ji=1,ni
do jj=1,nj
zstd3d(ji,jk,jj)=rgsiglalq(ji,jk,jj)
enddo
enddo
enddo
call gdmaskh(zstd3d,nflev)
do jk=1,nflev
do ji=1,ni
do jj=1,nj
rgsiglalq(ji,jk,jj)=zstd3d(ji,jk,jj)
enddo
enddo
enddo
!Psu
do ji=1,ni
do jj=1,nj
zstd2d(ji,jj)=rgsiglapu(ji,1,jj)
enddo
enddo
call gdmaskh(zstd2d,1)
do ji=1,ni
do jj=1,nj
rgsiglapu(ji,1,jj)=zstd2d(ji,jj)
enddo
enddo
endif
!
! Initialize TG st-dev
! --------------------
!
if(NSEXIST(nstg).eq.1) call sutg_sdev(nulbgst)
!
WRITE(nulout,*)'DONE in READCVSDEV'
!
return
end