!-------------------------------------- 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 readcv_gusdev 1,13
!
use mod4dv
, only : l4dvar
*
#if defined (DOC)
*
***s/r readcv_gusdev - In grd_typ = 'LU' mode: read and interpolate global st-dev to LU grid.
*
*Author : L. Fillion *ARMA/EC - 14 Feb 2007.
*Revision:
* L. Fillion *ARMA/EC - 13 Jan 2009 - Upgrade to v_10_1_2 of 3dvar.
* L. Fillion *ARMA/EC - 30 Nov 2009. Correct for latitude inverse ordering from RPN files to 3dvar world.
* - Use total st-dev present on stats file in mbal_order = 0 mode.
*
*Arguments
*
#endif
C
use modfgat, only : nstamplist
IMPLICIT NONE
*implicits
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comcst.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comct0.cdk"
#include "comcva.cdk"
#include "comgem.cdk"
#include "rpnstd.cdk"
#include "cvcord.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comgdpar.cdk"
#include "comrgsigla.cdk"
#include "comgemla.cdk"
*
REAL*8 SFOQST8,SFOEW8
EXTERNAL SFOQST8,SFOEW8
!
logical lldebug
integer ibrpstamp
integer inip1,injp1
!
character*1 clgr, ctyp
character*2 cvar(7)
character*8 cetiket
integer idatet,idt,ibits,idtyp,ilatcst
integer inig1,inig2,inig3,ilng,ix1,ix2,ix3
integer ikey,ji,jj,jk,jlev,invar,jvar,iini,iinj,inlev
integer igdgid,ezqkdef,ezgdef_fmem
integer igridid_glb,itargetid,indjj
integer ip1_pak_trl,ip1_vco_trl,iip1,iip2,iip3
integer iip1s(nflev)
integer idum1,idum2,idum3,idum4
integer :: k,koutmpg ! the unit which has the selected records.
!
real*8 zmin,zmax,zscalepp,zscalecu,zscaletu,zscalelq,zscalepu
real*8 zdel_deg,zfac,zfacsigma,zpc
real ax(mni_in),ay(mnj_in)
real*8 zlamfld(mni_in,mnj_in,nflev)
real*8 zfld2d(nila,njla)
real*8 zfld(nila,nflev,njla)
real*8 zsiglatb(nila,nflev,njla)
real*8 zsiglapsb(njla)
real*8, allocatable, dimension(:,:) :: z2dglb
real*8, allocatable, dimension(:,:,:) :: zglbfld
!
EXTERNAL ABORT3D
!
!!
WRITE(NULOUT,FMT='(/,4X,"Starting readcv_gusdev: Bi-Fourier Mode",//)')
!
lldebug = .false.
invar = 5
cvar(1) = 'PP'
cvar(2) = 'CC'
cvar(3) = 'TT'
cvar(4) = 'HU'
cvar(5) = 'P0'
cvar(6) = 'TT'
cvar(7) = 'P0'
!
! 1. Set global grid identifier and dimensions assumed present in the statistics file
! --------------------------------------------------------------------------------
!
ibrpstamp = -1
cletiket = 'TUGLDEV'
cltypvar = 'S'
!
ikey = fstinf(nulbgst,ini,inj,ink,-1,cletiket,
& -1,-1,-1,' ','TT')
write(nulout,*) 'readcv_gusdev: ini,inj = ',ini,inj
!
! call getfldprm2(IIP1S,IIP2,IIP3,INK,cletiket,cltypvar
! & ,igridid_glb,'TT',-1,nflev,nulbgst
! & ,nulout,ip1_pak_trl,ip1_vco_trl,ntrials,koutmpg)
!
igridid_glb = ezqkdef(INI, INJ, 'G', 0,0,0,0,0)
!
! write(nulout,*) 'readcv_gusdev: Nb of vertical level from global stdev = ',INK
! if(ink.ne.nflev) then
! call abort3d(nulout,'readcv_gusdev: Global st-dev & analysis have diff Nb. Levels')
! endif
!
allocate(z2dglb(ini,inj))
allocate(zglbfld(ini,inj,nflev))
!
! 2. Set target analysis grid onto which interpolation is done
! ---------------------------------------------------------
!
do ji=1,mni_in
ax(ji)=grd_x_8(ji)
enddo
do jj=1,mnj_in
ay(jj)=grd_y_8(jj)
enddo
!
itargetid= ezgdef_fmem(mni_in,mnj_in,'Z','E',mig1tic, mig2tic,mig3tic,mig4tic,
& ax,ay) ! tic tac same as extended grid
!
! 3. Read desired fields and interpolate to analysis grid
! ----------------------------------------------------
!
! ilatcst=-1
zdel_deg = 180./real(inj)*rdeg2rad
ilatcst= (90+55)*inj/180 ! 45 deg North (RPN global grid storage from S --> N)
!
do jvar = 1,invar
!
ibrpstamp = -1
cltypvar = 'S'
!
iini = ini
iinj = inj
inlev = nflev
!
if(cvar(jvar).eq.'PP') then
cletiket = 'PPGLDEV'
else if(cvar(jvar).eq.'CC') then
cletiket = 'CUGLDEV'
else if(cvar(jvar).eq.'TT') then
if(jvar.eq.3) cletiket = 'TUGLDEV'
if(jvar.eq.6) cletiket = 'TBGLDEV'
else if(cvar(jvar).eq.'HU') then
cletiket = 'LQGLDEV'
else if(cvar(jvar).eq.'P0') then
if(jvar.eq.5) cletiket = 'PSGLDEV' ! will be used as containing full st-dev
if(jvar.eq.7) cletiket = 'PSBGLDEV'
inlev = 1
iini = 1
endif
!
do jk = 1,inlev
iip1 = nip1(jk)
if(inlev.eq.1) iip1 = nip1(nflev)
ierr=vfstlir(z2dglb,nulbgst,IINI,IINJ,1,-1
& ,cletiket,iip1,-1,-1,' ',cvar(jvar))
if(ierr.lt.0) then
write(nulout,*) 'readcv_gusdev: On file = ',nulbgst
write(nulout,*) 'readcv_gusdev: Level, Variable = ',jk,cvar(jvar)
write(nulout,*) 'readcv_gusdev: cletiket = ',cletiket
write(nulout,*) 'readcv_gusdev: iip1 = ',iip1
write(nulout,*) 'readcv_gusdev: IINI,IINJ = ',IINI,IINJ
call abort3d(nulout,'readcv_gusdev: Reading problem ')
endif
!
do jj = 1,inj
indjj = inj-jj+1
do ji = 1,ini
if(cvar(jvar).ne.'P0') then
zglbfld(ji,jj,jk) = z2dglb(ji,indjj)
else
zglbfld(ji,jj,jk) = z2dglb(1,indjj)
endif
enddo
enddo
!
if(lldebug) then
if((jk.eq.1).and.(cvar(jvar).eq.'P0')) then
call outhoriz2d(zglbfld,'stdev_glb.od','P0',1,
& 1,ini,1,inj,ini,inj,1)
endif
endif
enddo
!
if(lldebug) then
if(cvar(jvar).eq.'P0') then
call maxmin(zglbfld,ini,inlev,inj,zmin,zmax,
& idum1,idum2,idum3,idum4,'read_gu_sdev',
& cvar(jvar))
endif
endif
!
call hintscal(zglbfld,ini*inj,igridid_glb,
& zlamfld,mni_in*mnj_in,itargetid,inlev,'CUBIC')
if(lldebug) then
if(cvar(jvar).eq.'P0') then
call outhoriz2d(zlamfld(1,1,1),'stdev_lam.od','P0',1,
& 1,mni_in,1,mnj_in,mni_in,mnj_in,1)
endif
endif
!
zfld(:,:,:) = 0.0
!
do jk = 1,inlev
do jj = 1,mnj_in
do ji = 1,mni_in
zfld(ji,jk,jj) = zlamfld(ji,jj,jk)
enddo
enddo
enddo
!
inip1 = nila+1
injp1 = njla+1
if(inlev.eq.1) then
zfld2d(:,:) = 0.0
do jj = 1,mnj_in
do ji = 1,mni_in
zfld2d(ji,jj) = zfld(ji,1,jj)
enddo
enddo
call mach2(zfld2d,nila,njla,inip1,injp1)
else
call mach3(zfld,nila,njla,inlev,inip1,injp1)
endif
!
write(nulout,*) 'readcv_gdsdev: scale according to LINMI =',LINMI
write(nulout,*) 'readcv_gdsdev: inlev = ',inlev
!
zfacsigma = 0.32 ! 0.75
if(lcva_helm) then
zpc = 1.0
else
zpc = 1.e-11
endif
if(lcva_euclid) then
zscalepp = zfacsigma*zpc ! 1.0 pour bgcheck
zscalelq = zfacsigma
else
zscalepp = zfacsigma*zpc ! 1.0 pour bgcheck
zscalelq = zfacsigma
endif
!
if(LINMI) then
zscalecu = 0.2
zscaletu = 0.2
zscalepu = 0.5
else
if(lcva_euclid) then
zscalecu = 0.05
zscaletu = 0.05
zscalepu = 0.05
! zscalecu = 0.32*zpc
! zscaletu = 0.32
! zscalepu = 0.32
else
zscalecu = zfacsigma*zpc
zscaletu = zfacsigma
zscalepu = zfacsigma
endif
endif
!
do jk = 1,nflev
do jj = 1,njla
do ji = 1,nila
if(cvar(jvar).eq.'PP') then
rgsiglapp(ji,jk,jj) = zscalepp*zfld(ji,jk,jj)
else if(cvar(jvar).eq.'CC') then
rgsiglacu(ji,jk,jj) = zscalecu*zfld(ji,jk,jj)
else if(cvar(jvar).eq.'TT') then
if(jvar.eq.3) rgsiglatu(ji,jk,jj) = zscaletu*zfld(ji,jk,jj)
if(jvar.eq.6) zsiglatb(ji,jk,jj) = zscaletu*zfld(ji,jk,jj)
else if(cvar(jvar).eq.'HU') then
rgsiglalq(ji,jk,jj) = zscalelq*zfld(ji,jk,jj)
endif
enddo
enddo
enddo
!
if(cvar(jvar).eq.'P0') then
do jj = 1,njla
do ji = 1,nila
zfld2d(ji,jj) = zscalepu*zfld2d(ji,jj)
if(jvar.eq.5) rgsiglapu(ji,1,jj) = zfld2d(ji,jj)
if(jvar.eq.7) zsiglapsb(jj) = zfld2d(ji,jj)
enddo
if(jvar.eq.7) then
write(nulout,*) 'readcv_gsdev: jj,zsiglapsb(jj)=',jj,zsiglapsb(jj)
endif
enddo
endif
!
!cluc go to 998 ! pour bgcheck
!
if(cvar(jvar).eq.'PP') then
do jk = 1,nflev
do jj = 1,njla
do ji = 1,nila
zfld(ji,jk,jj) = rgsiglapp(ji,jk,jj)
enddo
enddo
enddo
call stdev_low(zfld,1,12) ! reduce st-dev in vertical between level 12 and top
do jk = 1,nflev
do jj = 1,njla
do ji = 1,nila
rgsiglapp(ji,jk,jj)=zfld(ji,jk,jj)
enddo
enddo
enddo
else if(cvar(jvar).eq.'CC') then
do jk = 1,nflev
do jj = 1,njla
do ji = 1,nila
zfld(ji,jk,jj) = rgsiglacu(ji,jk,jj)
enddo
enddo
enddo
call stdev_low(zfld,1,12)
do jk = 1,nflev
do jj = 1,njla
do ji = 1,nila
rgsiglacu(ji,jk,jj)=zfld(ji,jk,jj)
enddo
enddo
enddo
else if(cvar(jvar).eq.'TT') then
do jk = 1,nflev
do jj = 1,njla
do ji = 1,nila
if(jvar.eq.3) zfld(ji,jk,jj) = rgsiglatu(ji,jk,jj)
if(jvar.eq.6) zfld(ji,jk,jj) = zsiglatb(ji,jk,jj)
enddo
enddo
enddo
call stdev_low(zfld,1,12)
do jk = 1,nflev
do jj = 1,njla
do ji = 1,nila
if(jvar.eq.3) rgsiglatu(ji,jk,jj)=zfld(ji,jk,jj)
if(jvar.eq.6) zsiglatb(ji,jk,jj)=zfld(ji,jk,jj)
enddo
enddo
enddo
endif
998 continue
enddo ! jvar
!
if(mbal_order.eq.0) then
do ji = 1,nila
do jj = 1,njla
do jk = 1,nflev
rgsiglatu(ji,jk,jj)= sqrt(zsiglatb(ji,jk,jj)**2+rgsiglatu(ji,jk,jj)**2) ! Tb + TU
enddo
rgsiglapu(ji,1,jj)= sqrt(zsiglapsb(jj)**2+rgsiglapu(ji,1,jj)**2) ! PSB + PSU
enddo
enddo
endif
!
deallocate(z2dglb)
deallocate(zglbfld)
!
return
end