!-------------------------------------- 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 glb2glb_1(kulstat,kulstdev) 1,18
#if defined (DOC)
*
***s/r glb2glb_1: Process files of forecast error samples and generate/add target Global interpolated fields.
*
*Author: L. Fillion *ARMA/EC 4 Jun 2009
*Revision:
*
*Arguments KULSTAT logical unit number
*
#endif
IMPLICIT NONE
*
*implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comct0.cdk"
#include "comcva.cdk"
#include "comcst.cdk"
#include "comgem.cdk"
#include "comsp.cdk"
#include "comgd0.cdk"
#include "comgdpar.cdk"
#include "comcse1.cdk"
#include "comstdd.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comgemla.cdk"
#include "comode.cdk"
*
INTEGER KULSTAT,kulstdev
C
CHARACTER*1 clflt
logical llfilt
integer ifois
data ifois/0/
INTEGER JENS, IENS, JK1, IERR, JFILE, ji,jj,JK, jla,JLAT, JLON
integer idum1,idum2,idum3,idum4
C
INTEGER FNOM, FSTOUV, FSTFRM, FCLOS, FSTPRM, FSTINL
INTEGER VFSTECR,ezqkdef
C
C* RPN Standard files parameters
C
INTEGER INI,INJ,INK, INPAS, INBITS, IDATYP, IDEET
+ ,IP1,IP2,IP3,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
+ ,IUBC,IEXTR1,IEXTR2,IEXTR3
INTEGER ILISTE(100),IDATE(100), IDATV(100), IDIMAX, INFON, IFSTRUN, IHH
!
logical llqd,lloutglb,llvfilt
integer jvar,jlev, itrlgid,ind
integer iip1s(jpnflev),iip1,iip2,iip3,itrlnlev
integer ipmode,ipkind,ip1_pak_trl,ip1_vco_trl
integer :: k,koutmpg ! the unit which has the selected records.
real zlev(jpnflev)
character*1 clstring
character*(6) cldegint
REAL*8 DHEURES
CHARACTER*1 CLTYPVAR,CLGRTYP
CHARACTER*2 CLNOMVAR,clmoist
CHARACTER*8 CLETIKET
C
REAL*8 DLA2
REAL*8 ZFACT
INTEGER IPAK, IDATEO, IKULFILE, iflag,ikount
CHARACTER*128 CLFLFILE
!
integer igridid_glb,itargetid,ezgdef_fmem
!
real*8 zglb_dx,zlam_dx
real*8 zmin,zmax
real*8 zwork
real*8 zvortglb(ni,nj,nflev)
real*8 zdivglb(ni,nj,nflev)
real*8 zpsiglb(ni,nj,nflev)
real*8 zchiglb(ni,nj,nflev)
real*8 zttglb(ni,nj,nflev)
real*8 zlqglb(ni,nj,nflev)
real*8 zpsglb(ni,nj)
!
real*8 z3d(ni,nflev,nj)
real*8 z3d2(ni,nflev,nj)
real*8 z2d(ni,nj)
!
real*8 zvortint(nila,njla,nflev)
real*8 zdivint(nila,njla,nflev)
real*8 zpsiint(nila,njla,nflev)
real*8 zchiint(nila,njla,nflev)
real*8 zttint(nila,njla,nflev)
real*8 zlqint(nila,njla,nflev)
real*8 zpsint(nila,njla)
*
real*8 ztg(ni,nflev,nj), zqg(ni,nflev,nj), zesg(ni,nflev,nj)
real*8 zug(ni,nflev,nj), zvg(ni,nflev,nj)
real*8 zpsg(ni,nj)
!
real*8 zwrksp(nla,2,nflev)
!
!!
llfilt = .false.
if(lflt_low) then
llfilt = .true.
clflt = 'L'
else if(lflt_high) then
llfilt = .true.
clflt = 'H'
endif
!
llqd = .true.
lloutglb = .false.
DLA2 = DBLE(RA) * DBLE(RA)
IKULFILE = kulstat
!
! Check which moisture input filed is used
!
NFSTVAR = 0
CFSTVAR(1) = ' '
CFSTVAR(2) = ' '
CFSTVAR(3) = ' '
CFSTVAR(4) = ' '
CFSTVAR(5) = ' '
CFSTVAR(6) = ' '
CFSTVAR(7) = ' '
!
CALL READNML('NAMGDPAR',IFLAG)
! ikount = 0
! do jvar = 1, nfstvar
! if(cfstvar(jvar).eq.'HU'.or.cfstvar(jvar).eq.'LQ') then
! clmoist = cfstvar(jvar)
! ikount = ikount +1
! endif
! enddo
! if(ikount.gt.1) then
! CALL ABORT3D(NULOUT,'glb2glb_1: moisture cfstvar...Only one allowed!')
! else
! write(nulout,*) 'glb2glb_1: clmoist = ',clmoist
! endif
!
! 1. Set target analysis grid onto which interpolation is done
! ---------------------------------------------------------
!
!
write(nulout,*) 'glb2glb_1: nila, njla = ',nila,njla
itargetid = ezqkdef(nila, nila, 'G', 0,0,0,0,0)
!
!* 2. Access the increments from a set of files
! . (loop on the files)
!
IDIMAX = 100
DO 201 JFILE = 1, NFLSTAT
!
CALL GETINCR(KULSTAT,JFILE)
!
!* . 2.1 Find how many cases there are to be treated
!
IP1 = -1
IP2 = -1
IP3 = -1
CLNOMVAR = 'P0'
IP1 =0
!
write(NULOUT,*)
IERR = FSTINL (KULSTAT,INI,INJ,INK
& ,-1,CETIKETN,IP1,IP2,IP3,' '
& ,CLNOMVAR,ILISTE,INFON,IDIMAX)
WRITE(NULOUT,9210)INFON
9210 FORMAT(//,4X,"Ensemble of ",I4," increments")
IF(INFON.EQ.0) THEN
WRITE(NULOUT,*)' THIS FILE IS EMPTY. CHECK THE SELECTION CRITERIA'
CALL ABORT3D(NULOUT,'glb2glb_1: problem with FSTINL')
END IF
IENS = INFON
!
!* . 2.2 Get all the dates at which increments are available
!
DO JENS = 1, IENS
IERR = FSTPRM(ILISTE(JENS),IDATE(JENS),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)
!
DHEURES = DBLE(INPAS*IDEET/3600)
!
CALL INCDATR(IDATV(JENS),IDATE(JENS),SNGL(DHEURES))
CALL NEWDATE(IDATV(JENS),IFSTRUN,IHH,-3)
WRITE(NULOUT,9320)JENS, IFSTRUN,IHH
END DO
9320 FORMAT(5X,"Case No. ",I3,5x,"Date and time: ",I10,5x,I8)
!
IF(NENSEMBLE.EQ.0) THEN
NDATESTAT = IDATE(1)
END IF
!
CTYPVARN = ' '
CETIKETN = CLETIKET
!
write(nulout,*) 'glb2glb_1: INI,INJ = ',INI,INJ
!
igridid_glb = ezqkdef(INI, INJ, 'G', 0,0,0,0,0)
!
! 2.3 Loop on the ensemble contained in the current file of differences
!
DO 231 JENS = 1, IENS
!
! Get the increment in grid-point form
!
CALL NEWDATE(IDATV(JENS),IFSTRUN,IHH,-3)
WRITE(NULOUT,9310)JENS, IFSTRUN,IHH
9310 FORMAT(///,5X,"--- Case No. ",I3,5x,"Date and time: ",I10,5x
& ,I8)
NSTAMPN = IDATE(JENS)
! if(lmcstats) then
! call getens(ztg,zgzg,zqg,zug,zvg,zesg,zpsg,kulstat)
! else
CALL GETFST(KULSTAT,'G','N',IP3)
! endif
!
CALL GDSP
!
if(llqd) then ! will produce both QQ,DD and PP,CC onto target LAM grid
CALL SPEREE(NKSDIM,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
do jk = 1, nflev
do jj = 1, nj
ind = nj-jj+1
do ji = 1, ni
zvortglb(ji,ind,jk) = ut0(ji,jk,jj)
zdivglb(ji,ind,jk) = vt0(ji,jk,jj)
enddo
enddo
enddo
endif
!
! CONVERT FROM VORT/DIV TO PSI/CHI
!
DO JK = 1, NFLEV
DO jla = 1, NLA
SPVOR(jla,1,JK) = SPVOR(jla,1,JK) * DLA2*R1SNP1(jla)
SPVOR(jla,2,JK) = SPVOR(jla,2,JK) * DLA2*R1SNP1(jla)
SPDIV(jla,1,JK) = SPDIV(jla,1,JK) * DLA2*R1SNP1(jla)
SPDIV(jla,2,JK) = SPDIV(jla,2,JK) * DLA2*R1SNP1(jla)
ENDDO
ENDDO
!
CALL SPEREE(NKSDIM,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
!
! Set fields ready for horizontal interpolation
! and in proper output units onto RPN standard file
!
do jk = 1, nflev
do jj = 1, nj
ind = nj-jj+1
do ji = 1, ni
zpsiglb(ji,ind,jk) = ut0(ji,jk,jj)
zchiglb(ji,ind,jk) = vt0(ji,jk,jj)
zttglb(ji,ind,jk) = tt0(ji,jk,jj)
if(clmoist.eq.'LQ') then
zlqglb(ji,ind,jk) = q0(ji,jk,jj)
else if(clmoist.eq.'HU') then
zlqglb(ji,ind,jk) = dlog(max(q0(ji,jk,jj),1.d-6))
endif
enddo
enddo
enddo
!
do jj = 1, nj
ind = nj-jj+1
do ji = 1, ni
zpsglb(ji,ind) = RPATMB*gps0(ji,1,jj)
enddo
enddo
!
! if(ifois.eq.0) then
! if(llqd) then
! call maxmin(zvortglb,ni,nflev,nj,zmin,zmax,
! & idum1,idum2,idum3,idum4,'glb2glb_1 ',
! & 'VOR')
! call maxmin(zdivglb,ni,nflev,nj,zmin,zmax,
! & idum1,idum2,idum3,idum4,'glb2glb_1 ',
! & 'DIV')
! endif
! call maxmin(zpsiglb,ni,nflev,nj,zmin,zmax,
! & idum1,idum2,idum3,idum4,'glb2glb_1 ',
! & 'PSI')
! call maxmin(zchiglb,ni,nflev,nj,zmin,zmax,
! & idum1,idum2,idum3,idum4,'glb2glb_1 ',
! & 'CHI')
! call maxmin(zttglb,ni,nflev,nj,zmin,zmax,
! & idum1,idum2,idum3,idum4,'glb2glb_1 ',
! & 'T0 ')
! call maxmin(zlqglb,ni,nflev,nj,zmin,zmax,
! & idum1,idum2,idum3,idum4,'glb2glb_1 ',
! & 'LQ ')
! call maxmin(zpsglb,ni,nj,1,zmin,zmax,
! & idum1,idum2,idum3,idum4,'glb2glb_1 ',
! & 'P0 ')
! ifois = 1
! endif
!
cldegint = 'CUBIC '
write(nulout,*) 'glb2glb_1: Order of Horizontal Interpolation = ',cldegint
!
! if(llqd) then
! call hintscal(zvortglb,ini*inj,igridid_glb,
! & zvortint,nila*njla,itargetid,nflev,cldegint)
! call hintscal(zdivglb,ini*inj,igridid_glb,
! & zdivint,nila*njla,itargetid,nflev,cldegint)
! endif
! call hintscal(zpsiglb,ini*inj,igridid_glb,
! & zpsiint,nila*njla,itargetid,nflev,cldegint)
! call hintscal(zchiglb,ini*inj,igridid_glb,
! & zchiint,nila*njla,itargetid,nflev,cldegint)
! call hintscal(zttglb,ini*inj,igridid_glb,
! & zttint,nila*njla,itargetid,nflev,cldegint)
! call hintscal(zlqglb,ini*inj,igridid_glb,
! & zlqint,nila*njla,itargetid,nflev,cldegint)
! call hintscal(zpsglb,ini*inj,igridid_glb,
! & zpsint,nila*njla,itargetid,1,cldegint)
!
IPAK = -32
iDATYP = 5
ip2 = 0
ip3 = jfile
!
if(lloutglb) then
do jk = 1, nflev
IP1 = NIP1(jk)
if(llqd) then
IERR = VFSTECR(zvortglb(1,1,jk),zvortglb(1,1,jk),IPAK,
& IKULFILE,NDATESTAT,0,0,ni,nj,1,
& ip1,ip2,ip3,'E','QQ',CETIKETN,
& 'G',0,0,0,0,IDATYP,.TRUE.)
IERR = VFSTECR(zdivglb(1,1,jk),zdivglb(1,1,jk),IPAK,
& IKULFILE,NDATESTAT,0,0,ni,nj,1,
& ip1,ip2,ip3,'E','DD',CETIKETN,
& 'G',0,0,0,0,IDATYP,.TRUE.)
endif
IERR = VFSTECR(zpsiglb(1,1,jk),zwork,IPAK,
& IKULFILE,NDATESTAT,0,0,ni,nj,1,
& ip1,ip2,ip3,'E','PP',CETIKETN,
& 'G',0,0,0,0,IDATYP,.TRUE.)
IERR = VFSTECR(zchiglb(1,1,jk),zwork,IPAK,
& IKULFILE,NDATESTAT,0,0,ni,nj,1,
& ip1,ip2,ip3,'E','CC',CETIKETN,
& 'G',0,0,0,0,IDATYP,.TRUE.)
enddo
endif
!
cletiket = cetiketerr
!
do jk = 1, nflev
IP1 = NIP1(jk)
if(llqd) then
IERR = VFSTECR(zvortint(1,1,jk),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila,njla,1,IP1,IP2,IP3,'E','QQ',cletiket,
& 'G',0,0,0,0,IDATYP,.TRUE.)
!
IERR = VFSTECR(zdivint(1,1,jk),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila,njla,1,IP1,IP2,IP3,'E','DD',cletiket,
& 'G',0,0,0,0,IDATYP,.TRUE.)
endif
IERR = VFSTECR(zpsiint(1,1,jk),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila,njla,1,IP1,IP2,IP3,'E','PP',cletiket,
& 'G',0,0,0,0,IDATYP,.TRUE.)
!
IERR = VFSTECR(zchiint(1,1,jk),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila,njla,1,IP1,IP2,IP3,'E','CC',cletiket,
& 'G',0,0,0,0,IDATYP,.TRUE.)
!
IERR = VFSTECR(zttint(1,1,jk),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila,njla,1,IP1,IP2,IP3,'E','TT',cletiket,
& 'G',0,0,0,0,IDATYP,.TRUE.)
!
IERR = VFSTECR(zlqint(1,1,jk),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila,njla,1,IP1,IP2,IP3,'E','LQ',cletiket,
& 'G',0,0,0,0,IDATYP,.TRUE.)
enddo
IP1 = NIP1(NFLEV)
IERR = VFSTECR(zpsint(1,1),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila,njla,1,IP1,IP2,IP3,'E','P0',cletiket,
& 'G',0,0,0,0,IDATYP,.TRUE.)
!
231 CONTINUE ! end loop on the ensemble within current file
201 CONTINUE ! end loop on jfile
!
write(nulout,*) 'glb2glb_1: END'
999 continue
!
RETURN
END