!-------------------------------------- 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 readgd_gusdev(pfld,cdnomvar,kni,knj,knk) 7,10
!
use mod4dv
, only : l4dvar
*
#if defined (DOC)
*
***s/r readgd_gusdev - Used by Background check in grd_typ = 'GU' and 'LU' mode:
* Read and interpolate global st-dev to target LU or GU grid.
* N.B.: Target grid dimensions mni_in & mnj_in are set to ni, nj in sudim in 'GU' mode...
* N.B.: On writing to RPN standard file, pfld is stored in 3dvar standard way; i.e. N-->S. IG2 parameter is thus set to 1.
*
*Author : L. Fillion *ARMA/EC - 10 Sept 2007.
*Revision:
* L. Fillion *ARMA/EC - 13 Jan 2009 - Upgrade to v_10_1_2 of 3dvar.
* L. Fillion *ARMA/EC - 2 Jul 2009 - Allow target to be lam or global.
* L. Fillion *ARMA/EC - Sept 2009 - Include more flexibility in etiket and ensure abort when reading problems occur.
*
*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"
*
character*2 cdnomvar
integer kni,knj,knk
real*8 pfld(kni,knk,knj)
!
logical lldebug
integer ibrpstamp
integer inip1,injp1,indjj
!
character*1 clgr, ctyp
character*2 cvar(5)
character*8 cetiket
integer :: k,koutmpg ! the unit which has the selected records.
integer idatet,idt,ibits,idtyp,ilatcst
integer inig1,inig2,inig3,ilng,ix1,ix2,ix3
integer ikey,ji,jj,jk,invar,iini,iinj,iink,inlev
integer iniglb,injglb
integer igdgid,ezqkdef,ezgdef_fmem
integer igridid_glb,itargetid
integer ip1_pak_trl,ip1_vco_trl,iip1,iip2,iip3
integer iip1s(nflev)
integer idum1,idum2,idum3,idum4
!
real*8 zmin,zmax,zscalepp,zscalecu,zscaletu,zscalelq,zscalepu
real*8 zdel_deg
real ax(mni_in),ay(mnj_in)
real*8 ztargetfld(mni_in,mnj_in,nflev)
real*8, allocatable, dimension(:,:,:) :: zinstd
real*8, allocatable, dimension(:,:,:) :: zglbfld
!
EXTERNAL ABORT3D
!
!!
WRITE(NULOUT,FMT='(/,4X,"Starting readgd_gusdev",//)')
write(nulout,*) 'readgd_gdsdev: Variable ',cdnomvar
!
lldebug = .false.
!
! 1. Set global grid identifier and dimensions assumed present in the statistics file
! --------------------------------------------------------------------------------
!
ibrpstamp = -1
cletiket = 'TUGLDEV' ! n.b.: TUGLDEV and STDDEV on stats file must have same nj,nflev dimensions
cltypvar = 'S'
!
ikey = fstinf(nulbgst,iniglb,injglb,ink,-1,cletiket,
& -1,-1,-1,'S','TT')
write(nulout,*) 'readgd_gusdev: fstinf on TUGLDEV to detect non-zonal arrays '
write(nulout,*) 'readgd_gusdev: iniglb, injglb = ',iniglb,injglb
!
igridid_glb = ezqkdef(iniglb, injglb, 'G', 0,0,0,0,0)
! write(nulout,*) 'readgd_gusdev: igridid_glb=',igridid_glb
!
! if(ink.ne.nflev.and.cdnomvar.ne.'P0') then
! call abort3d(nulout,'readgd_gusdev: Global st-dev & analysis have diff Nb. Levels')
! endif
!
allocate(zglbfld(iniglb,injglb,nflev))
!
! 2. Set target analysis grid onto which interpolation is done
! ---------------------------------------------------------
!
! N.B.: Target grid dimensions mni_in & mnj_in are set to ni, nj in sudim in 'GU' mode...
!
if(grd_typ.eq.'GU') then
itargetid = ezqkdef(ni, nj, 'G', 0,0,0,0,0)
else
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
endif
!
! 3dvar storage is N-->S : Get IG2 here to be able to inverse pole orientation from input fields if necessary
! ig2 = 0 means storage from S--> N; ig2=1: N-->S
!
IERR = FSTPRM(ikey,IDATEO,IDEET,INPAS ! all capitals are ouput arguments....
+ ,INI,INJ,INK, INBITS, IDATYP
+ ,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP
+ ,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
+ ,IUBC,IEXTR1,IEXTR2,IEXTR3)
!
! 3. Read desired field and interpolate Horizontally to analysis grid
! ----------------------------------------------------------------
!
ibrpstamp = -1
cletiket = 'STDDEV' ! may have 1 x nj dimension....
cltypvar = ' '
!
ikey = fstinf(nulbgst,iini,iinj,ink,-1,cletiket, ! used here to detect horiz. dimensions
& -1,-1,-1,cltypvar,cdnomvar)
!
if(injglb.ne.iinj) then
write(nulout,*) 'readgd_gusdev: For TUGLDEV: iinj = ',injglb
write(nulout,*) 'readgd_gusdev: For STDDEV: iinj = ',iinj
call abort3d(nulout,'readgd_gusdev: Must be same dimensions')
endif
allocate(zinstd(iini,iinj,ink))
write(nulout,*) 'readgd_gusdev: Reading global st-dev for variable ',cdnomvar
write(nulout,*) 'readgd_gusdev: fstinf on STDDEV to detect zonal or non-zonal arrays '
write(nulout,*) 'readgd_gusdev: iini, iinj, ink = ',iini,iinj,ink
if(iini.eq.1) then
write(nulout,*) 'readgd_gusdev: iini = 1 ... Zonal fields are used'
endif
!
!3.1 Read field
! ----------
!
ibrpstamp = -1
cletiket = 'STDDEV' ! may have 1 x nj dimension....
cltypvar = 'E'
!
if(ink.gt.1) then
if(ink.ne.nflev) then
call abort3d(nulout,'readgd_gusdev: ink .ne. nflev ')
endif
ierr=vfstlir(zinstd,nulbgst,iini,iinj,ink,-1
& ,cletiket,-1,-1,-1,' ',cdnomvar)
if(ierr.lt.0) then
write(nulout,*) 'readgd_gusdev: On file = ',nulbgst
write(nulout,*) 'readgd_gusdev: Level, Variable = ',jk,cdnomvar
write(nulout,*) 'readgd_gusdev: cletiket = ',cletiket
write(nulout,*) 'readgd_gusdev: IINI,IINJ = ',IINI,IINJ
call abort3d(nulout,'readgd_gusdev: Reading problem ')
endif
do jk = 1, ink
do jj = 1,injglb
indjj = injglb-jj+1
do ji = 1,iniglb
if(iini.eq.1) then
zglbfld(ji,indjj,jk) = zinstd(1,jj,jk)
else
zglbfld(ji,indjj,jk) = zinstd(ji,jj,jk)
endif
enddo
enddo
enddo
else
inlev = nflev
if(cdnomvar.eq.'P0') inlev = 1
do jk = 1, inlev
ierr=vfstlir(zinstd,nulbgst,iini,iinj,iink,-1
& ,cletiket,-1,-1,-1,' ',cdnomvar)
if(ierr.lt.0) then
write(nulout,*) 'readgd_gusdev: On file = ',nulbgst
write(nulout,*) 'readgd_gusdev: Level, Variable = ',jk,cdnomvar
write(nulout,*) 'readgd_gusdev: cletiket = ',cletiket
write(nulout,*) 'readgd_gusdev: IINI,IINJ,IINK = ',IINI,IINJ,IINK
call abort3d(nulout,'readgd_gusdev: Reading problem ')
endif
!
if(cdnomvar.eq.'P0') then
do jj = 1,inj
write(nulout,*) 'readgd_gusdev: P0: jj,STDDEV=',jj,zinstd(1,jj,1)
enddo
! call maxmin(zinstd,iini,1,iinj,zmin,zmax,
! & idum1,idum2,idum3,idum4,'readgd_gusdev ',
! & cdnomvar)
endif
!
! Fill all longitudes in case zonal average st-dev are input fields
do jj = 1,injglb
indjj = injglb-jj+1
do ji = 1,iniglb
if(iini.eq.1) then
zglbfld(ji,indjj,jk) = zinstd(1,jj,jk)
else
zglbfld(ji,indjj,jk) = zinstd(ji,jj,jk)
endif
enddo
enddo
enddo
endif
!
!*3.2 Interpolate 3D field horizontally from global grid to target grid
! -----------------------------------------------------------------
!
write(nulout,*) 'readgd_gusdev: avant hintscal'
write(nulout,*) 'readgd_gusdev: iniglb,injglb=',iniglb,injglb
write(nulout,*) 'readgd_gusdev: igridid_glb=',igridid_glb
write(nulout,*) 'readgd_gusdev: mni_in,mnj_in=',mni_in,mnj_in
write(nulout,*) 'readgd_gusdev: itargetid=',itargetid
write(nulout,*) 'readgd_gusdev: ink=',ink
!
call hintscal(zglbfld,iniglb*injglb,igridid_glb,
& ztargetfld,mni_in*mnj_in,itargetid,ink,'CUBIC')
!
if(cdnomvar.eq.'P0') then
do ji = 1,mni_in
write(nulout,*) 'readgd_gusdev: P0: ji,st-dev=',ji,ztargetfld(ji,mnj_in/2,1)
enddo
endif
!
call maxmin(ztargetfld,mni_in,ink,mnj_in,zmin,zmax,
& idum1,idum2,idum3,idum4,'readgd_gusdev ',
& cdnomvar)
!
pfld(:,:,:) = 0.0
!
do jk = 1,ink
do jj = 1,mnj_in
do ji = 1,mni_in
pfld(ji,jk,jj) = ztargetfld(ji,jj,jk)
enddo
enddo
enddo
!
deallocate(zinstd)
deallocate(zglbfld)
!
return
end