!-------------------------------------- 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_gl 1,8
!
use mod4dv
, only : l4dvar
*
#if defined (DOC)
*
***s/r readcv_gusdev_gl - In grd_typ = 'GU' and lcva_hemis mode: read and interpolate global st-dev to GU grid
* at another resolution.
*
*Author : L. Fillion *ARMA/EC - 4 Jun 2009.
*Revision:
* L. Fillion *ARMA/EC - Sept 2009. Improve security check after reading on file.
* L. Fillion *ARMA/EC - Sept 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.
* L. Fillion *ARMA/EC - 27 oct 2009 - Include rotated global analysis grid option.
* L. Fillion *ARMA/EC - 12 Jul 2010 - Initialize TG st-dev.
*
*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 "comgdpar.cdk"
#include "comspg.cdk"
#include "comgrd_param.cdk"
#include "comgemla.cdk"
#include "comstate.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.
integer ig1tic,ig2tic,ig3tic,ig4tic
integer ig1in,ig2in,ig3in
!
real*8 zmin,zmax,zscalepp,zscalecu,zscaletu,zscalelq,zscalepu
real*8 zdel_deg,zfac,zfacsigma,zpc
real*8 zglfld(ni,nj,nflev)
real*8 zfld2d(ni,nj)
real*8 zfld(ni,nflev,nj)
real*8, allocatable, dimension(:,:) :: z2dglb
real*8, allocatable, dimension(:,:,:) :: zglbfld
!
real zptop4, zpref4,zrcoef4,zdummy
real ax(ni),ay(nj)
real zxlon1_4,zxlat1_4,zxlon2_4,zxlat2_4
!
EXTERNAL ABORT3D
!
!!
WRITE(NULOUT,FMT='(/,4X,"Starting readcv_gusdev_gl",//)')
!
lldebug = .false.
invar = 7
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_gl: 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_gl: Nb of vertical level from global stdev = ',INK
! if(ink.ne.nflev) then
! call abort3d(nulout,'readcv_gusdev_gl: 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
! ---------------------------------------------------------
!
if(grd_roule) then
zxlon1_4 = grd_xlon1
zxlat1_4 = grd_xlat1
zxlon2_4 = grd_xlon2
zxlat2_4 = grd_xlat2
!
do ji=1,ni
ax(ji) = grd_x_8(ji)
enddo
do jj=1,nj
ay(jj) = grd_y_8(jj)
enddo
!
call cxgaig('E',ig1tic,ig2tic,ig3tic,ig4tic,
& zxlat1_4,zxlon1_4,zxlat2_4,zxlon2_4)
!
call cigaxg('E', zxlat1_4, zxlon1_4, zxlat2_4, zxlon2_4,
& ig1tic,ig2tic,ig3tic,ig4tic)
!
itargetid = ezgdef_fmem(ni,nj,'Z','E',ig1tic, ig2tic,ig3tic,ig4tic,
& ax,ay)
else
itargetid = ezqkdef(ni, nj, 'G', 0,0,0,0,0)
endif
!
! 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 = 'PSUGLDEV'
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_gl: On file = ',nulbgst
write(nulout,*) 'readcv_gusdev_gl: Level, Variable = ',jk,cvar(jvar)
write(nulout,*) 'readcv_gusdev_gl: cletiket = ',cletiket
write(nulout,*) 'readcv_gusdev_gl: iip1 = ',iip1
write(nulout,*) 'readcv_gusdev_gl: IINI,IINJ = ',IINI,IINJ
call abort3d(nulout,'readcv_gusdev_gl: Reading problem ')
endif
!
do jj = 1,inj
indjj = inj-jj+1
if(ig2.eq.0) indjj = inj-jj+1
do ji = 1,ini
zglbfld(ji,jj,jk) = z2dglb(ji,indjj)
enddo
enddo
!
if(cvar(jvar).eq.'P0') then
write(nulout,*) 'readcv_gusdev_gl: cletiket= ',cletiket
do jj = 1,inj
write(nulout,*) 'readcv_gusdev_gl: jj,zglbfld(1,jj,1)=',jj,zglbfld(1,jj,1)
enddo
endif
enddo
!
call hintscal(zglbfld,ini*inj,igridid_glb,
& zglfld,ni*nj,itargetid,inlev,'CUBIC')
!
zfld(:,:,:) = 0.0
!
do jk = 1,inlev
do jj = 1,nj
do ji = 1,ni
zfld(ji,jk,jj) = zglfld(ji,jj,jk)
enddo
enddo
enddo
!
if(inlev.eq.1) then
zfld2d(:,:) = 0.0
do jj = 1,nj
do ji = 1,ni
zfld2d(ji,jj) = zfld(ji,1,jj)
enddo
write(nulout,*) 'readcv_gusdev_gl: jj,zfld2d(1,jj)=',jj,zfld2d(1,jj)
enddo
endif
!
if(ntrunc.ge.300) then
zfacsigma = 0.98
else if(ntrunc.ge.200) then
zfacsigma = 0.75
else if(ntrunc.ge.100) then
zfacsigma = 1.0
endif
!
if(nconf.ne.141) zfacsigma = 1.0 ! bgcheck & reglam4d !cluc
!
if(lcva_helm) then
zpc = 1.0
else
zpc = 1.e-11
endif
zscalepp = zfacsigma*zpc ! 1.0 pour bgcheck
zscalelq = zfacsigma
!
if(LINMI) then
zscalecu = 0.2
zscaletu = 0.2
zscalepu = 0.5
else
zscalecu = zfacsigma*zpc
zscaletu = zfacsigma
zscalepu = zfacsigma
endif
!
do jk = 1,nflev
do jj = 1,nj
if(cvar(jvar).eq.'PP') then
rgsiguu(jj,jk) = zscalepp*zfld(1,jk,jj)
else if(cvar(jvar).eq.'CC') then
rgsigvv(jj,jk) = zscalecu*zfld(1,jk,jj)
else if(cvar(jvar).eq.'TT') then
if(jvar.eq.3) rgsigtt(jj,jk) = zscaletu*zfld(1,jk,jj)
if(jvar.eq.6) rgsigtb(jj,jk) = zscaletu*zfld(1,jk,jj)
else if(cvar(jvar).eq.'HU') then
rgsigq(jj,jk) = zscalelq*zfld(1,jk,jj)
endif
enddo
enddo
!
if(cvar(jvar).eq.'P0') then
do jj = 1,nj
do ji = 1,ni
zfld2d(ji,jj) = zscalepu*zfld2d(ji,jj)
if(jvar.eq.5) rgsigps(jj,1) = zfld2d(ji,jj)
if(jvar.eq.7) rgsigpsb(jj) = zfld2d(ji,jj)
enddo
if(jvar.eq.7) then
write(nulout,*) 'readcv_gusdev_gl: jj,rgsigpsb(jj)=',jj,rgsigpsb(jj)
endif
enddo
endif
!
! go to 998 ! pour bgcheck
!
if(cvar(jvar).eq.'PP') then
do jk = 1,nflev
do jj = 1,nj
do ji = 1,ni
zfld(ji,jk,jj) = rgsiguu(jj,jk)
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,nj
do ji = 1,ni
rgsiguu(jj,jk)=zfld(ji,jk,jj)
enddo
enddo
enddo
else if(cvar(jvar).eq.'CC') then
do jk = 1,nflev
do jj = 1,nj
do ji = 1,ni
zfld(ji,jk,jj) = rgsigvv(jj,jk)
enddo
enddo
enddo
call stdev_low(zfld,1,12)
do jk = 1,nflev
do jj = 1,nj
do ji = 1,ni
rgsigvv(jj,jk)=zfld(ji,jk,jj)
enddo
enddo
enddo
else if(cvar(jvar).eq.'TT') then
do jk = 1,nflev
do jj = 1,nj
do ji = 1,ni
if(jvar.eq.3) zfld(ji,jk,jj) = rgsigtt(jj,jk)
if(jvar.eq.6) zfld(ji,jk,jj) = rgsigtb(jj,jk)
enddo
enddo
enddo
call stdev_low(zfld,1,12)
do jk = 1,nflev
do jj = 1,nj
do ji = 1,ni
if(jvar.eq.3) rgsigtt(jj,jk)=zfld(ji,jk,jj)
if(jvar.eq.6) rgsigtb(jj,jk)=zfld(ji,jk,jj)
enddo
enddo
enddo
endif
998 continue
enddo ! jvar
!
if(mbal_order.eq.0) then
do jj = 1,nj
do jk = 1,nflev
rgsigtt(jj,jk)= sqrt(rgsigtb(jj,jk)**2+rgsigtt(jj,jk)**2) ! Tb + TU
enddo
rgsigps(jj,1)= sqrt(rgsigpsb(jj)**2+rgsigps(jj,1)**2) ! PSB + PSU
enddo
endif
!
! Initialize TG st-dev
! --------------------
!
!cluc if(NSEXIST(nstg).eq.1) call sutg_sdev(nulbgst) ! activate only when stats program properly generate corns for tg ....
!
deallocate(z2dglb)
deallocate(zglbfld)
!
return
end