!-------------------------------------- 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 prep_fcst_diff_1(kulstat,kulstdev) 1,32
#if defined (DOC)
*
***s/r prep_fcst_diff_1: Process files of two lagged forecast and generate/write target LAM fcst-error fields.
* Differences are interpolated to target inner-lam4d grid.
*Author: L. Fillion *ARMA/EC 17 Apr 2009
*Revision:
* L. Fillion *ARMA/EC 23 Apr 2009 - Extend to allow interpolation onto target inner-lam4d grid.
* L. Fillion *ARMA/EC 28 Jan 2010 - Introduce ip2min,ip2max to allow various possibilities of NMC-Lagged fcsts.
* L. Fillion *ARMA/EC 28 Jun 2010 - Improve logical to decide on interpolation or not.
*
*Purpose:
*
*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 "comgd1.cdk"
#include "comgdpar.cdk"
#include "comcse1.cdk"
#include "comstdd.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comgrd2.cdk"
#include "comgemla.cdk"
#include "comgemla2.cdk"
#include "comode.cdk"
*
INTEGER KULSTAT,kulstdev
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,icase
INTEGER ILISTE(100),IDATE(100), IDATV(100), IDIMAX, INFON, IFSTRUN, IHH
!
logical llqd,lloutglb,llvfilt,llinterpol
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 itargetid,ezgdef_fmem
integer ip2min,ip2max
!
real*8 zlam_dx
real*8 zmin,zmax
real*8 zwork
real*8 zlq1(ni,nj,nflev)
real*8 zps1(ni,nj)
real*8 ztg1(ni,nj)
!
real*8 zdif_vort(ni,nj,nflev)
real*8 zdif_div(ni,nj,nflev)
real*8 zdif_psi(ni,nj,nflev)
real*8 zdif_chi(ni,nj,nflev)
real*8 zdif_u(ni,nj,nflev)
real*8 zdif_v(ni,nj,nflev)
real*8 zdif_t(ni,nj,nflev)
real*8 zdif_gz(ni,nj,nflev)
real*8 zdif_q(ni,nj,nflev)
real*8 zdif_lq(ni,nj,nflev)
real*8 zdif_ps(ni,nj)
real*8 zdif_tg(ni,nj)
*
real*8 z3d(nila2,njla2,nflev)
real*8 zuulam(nila2,njla2,nflev)
real*8 zvvlam(nila2,njla2,nflev)
real*8 zpslam(nila2,njla2)
real*8 ztglam(nila2,njla2)
real zax2(nila2),zay2(njla2)
!
real*8 zvort(ni,nflev,nj)
real*8 zdiv(ni,nflev,nj)
!
real zax(nila),zay(njla)
!
real*8 zgdpsi(ni,nflev,nj),zgdchi(ni,nflev,nj)
real*8 zwrk3d(ni,nflev,nj)
!
!!
llinterpol = .false.
if(multi_grd.eq.1.and.(.not.lsame_grid12)) llinterpol = .true.
IKULFILE = kulstat
!
NFSTVAR = 0
CFSTVAR(1) = ' '
CFSTVAR(2) = ' '
CFSTVAR(3) = ' '
CFSTVAR(4) = ' '
CFSTVAR(5) = ' '
CFSTVAR(6) = ' '
CFSTVAR(7) = ' '
!
CALL READNML('NAMGDPAR',IFLAG)
!
! 1. Set source and target analysis grid onto which interpolation is done
! --------------------------------------------------------------------
!
do ji=1,nila
zax(ji)=grd_x_8(ji)
enddo
do jj=1,njla
zay(jj)=grd_y_8(jj)
enddo
!
ngid_an= ezgdef_fmem(nila,njla,'Z','E',mig1tic,
& mig2tic,mig3tic,mig4tic,zax,zay) ! mig2tic etc already built by sugrdlam2...
!
do ji=1,nila2
zax2(ji)=grd_x_82(ji)
enddo
do jj=1,njla2
zay2(jj)=grd_y_82(jj)
enddo
!
if(llinterpol) then
itargetid= ezgdef_fmem(nila2,njla2,'Z','E',
& mig1tic2,mig2tic2,mig3tic2,mig4tic2,zax2,zay2) ! tic tac same as extended grid
endif
!
!* 2. Access the increments from a set of files
! . (loop on the files)
!
IDIMAX = 100
DO 201 JFILE = 1, NFLSTAT
!
call openinc(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,'prep_fcst_diff_1: problem with FSTINL')
END IF
IENS = INFON
!
!* . 2.2 Get all the dates at which increments are available
!
ip2min = 9999
ip2max = -9999
!
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)
!
write(nulout,*) 'prep_fcst_diff_1: After FSTPRM: INI,INJ = ',INI,INJ
write(nulout,*) 'prep_fcst_diff_1: After FSTPRM: IP1 = ',ip1
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,IP2
if(ip2.lt.ip2min) ip2min=ip2
if(ip2.gt.ip2max) ip2max=ip2
END DO
9320 FORMAT(5X,"Case No. ",I3,5x,"Date; Time; IP2: ",I10,5x,I8,5x,I8)
!
IF(NENSEMBLE.EQ.0) THEN
NDATESTAT = IDATE(1)
END IF
!
CTYPVARN = ' '
CETIKETN = CLETIKET
!
if(grd_typ.eq.'LU') then
if(mni_in.gt.ini) then
write(nulout,*) 'prep_fcst_diff_1: mni_in, ini = ',mni_in, ini
call abort3d(nulout,'prep_fcst_diff_1: mni_in.gt.INI')
else if(mnj_in.gt.inj) then
write(nulout,*) 'prep_fcst_diff_1: mnj_in, inj = ',mnj_in, inj
call abort3d(nulout,'prep_fcst_diff_1: mnj_in.gt.INJ')
endif
endif
!
! 1st: Fcst with largest IP2
!
call geterr(kulstat,'G','L',ip2max) ! wind images on output
!
call transfer('GD01') ! save first error sample in GD1
!
do jk = 1, nflev
do jj = 1, nj
do ji = 1, ni
zlq1(ji,jj,jk) = dlog(max(q0(ji,jk,jj),1.d-6))
enddo
enddo
enddo
do jj = 1, nj
do ji = 1, ni
zps1(ji,jj) = gps0(ji,1,jj)
ztg1(ji,jj) = gtg0(ji,1,jj)
enddo
enddo
!
! call maxmin(zu1,ni,nflev,nj,zmin,zmax,
! & idum1,idum2,idum3,idum4,'prep_fcst_1 ',
! & 'UU1')
! call maxmin(zps1,ni,1,nj,zmin,zmax,
! & idum1,idum2,idum3,idum4,'prep_fcst_1 ',
! & 'PS1')
! call maxmin(ztg1,ni,1,nj,zmin,zmax,
! & idum1,idum2,idum3,idum4,'prep_fcst_1 ',
! & 'TG1')
!
! 2nd: Fcst with smallest ip2
!
call geterr(kulstat,'G','L',ip2min) ! wind images on output
!
! Create differences: GD1-GD0
!
do jk = 1, nflev
do jj = 1, nj
do ji = 1, ni
zdif_q(ji,jj,jk) = q1(ji,jk,jj) - q0(ji,jk,jj)
enddo
enddo
enddo
!
do jk = 1, nflev
do jj = 1, nj
do ji = 1, ni
ut1(ji,jk,jj) = ut1(ji,jk,jj) - ut0(ji,jk,jj)
vt1(ji,jk,jj) = vt1(ji,jk,jj) - vt0(ji,jk,jj)
tt1(ji,jk,jj) = tt1(ji,jk,jj) - tt0(ji,jk,jj)
gz1(ji,jk,jj) = gz1(ji,jk,jj) - gz0(ji,jk,jj)
q1(ji,jk,jj) = dlog(max(q1(ji,jk,jj),1.d-6)) -
& dlog(max(q0(ji,jk,jj),1.d-6))
enddo
enddo
enddo
!
do jj = 1, nj
do ji = 1, ni
gps1(ji,1,jj) = gps1(ji,1,jj) - gps0(ji,1,jj)
gtg1(ji,1,jj) = gtg1(ji,1,jj) - gtg0(ji,1,jj)
enddo
enddo
!
! Bi-periodic & Construct PSI,CHI differences from U,V wind-images differences
!
call initgdla(zvort,zdiv,zgdpsi,zgdchi,'S',lhelm,.true.) ! WARNING: GD1 used here...
!
! Difference: 12h-6h
! Set fields ready for horizontal interpolation
! and in proper output units onto RPN standard file
!
do jk = 1, nflev
do jj = 1, nj
do ji = 1, ni
zdif_u(ji,jj,jk) = ut1(ji,jk,jj) ! no output
zdif_v(ji,jj,jk) = vt1(ji,jk,jj) ! no output
zdif_t(ji,jj,jk) = tt1(ji,jk,jj)
zdif_gz(ji,jj,jk) = RDECAM*(gz1(ji,jk,jj))
zdif_lq(ji,jj,jk) = q1(ji,jk,jj)
enddo
enddo
enddo
!
do jj = 1, nj
do ji = 1, ni
zdif_ps(ji,jj) = RPATMB*(zps1(ji,jj) - gps0(ji,1,jj))
zdif_tg(ji,jj) = ztg1(ji,jj) - gtg0(ji,1,jj)
enddo
enddo
!
! call maxmin(zdif_u,ni,nflev,nj,zmin,zmax,
! & idum1,idum2,idum3,idum4,'prep_fcst_1 ',
! & 'DU ')
! call maxmin(zdif_ps,ni,1,nj,zmin,zmax,
! & idum1,idum2,idum3,idum4,'prep_fcst_1 ',
! & 'DP0')
! call maxmin(zdif_tg,ni,1,nj,zmin,zmax,
! & idum1,idum2,idum3,idum4,'prep_fcst_1 ',
! & 'DTg')
!
do jk = 1, nflev
do jj = 1, nj
do ji = 1, ni
zdif_vort(ji,jj,jk) = zvort(ji,jk,jj)
zdif_div(ji,jj,jk) = zdiv(ji,jk,jj)
enddo
enddo
enddo
!
if(lhelm) then
do jk = 1, nflev
do jj = 1, nj
do ji = 1, ni
zdif_psi(ji,jj,jk) = zgdpsi(ji,jk,jj)
zdif_chi(ji,jj,jk) = zgdchi(ji,jk,jj)
enddo
enddo
enddo
endif
!
!*3. Interpolate difference fields onto target inner-lam4d grid and write on file
!
cletiket = cetiketerr
write(nulout,*) 'prep_fcst_diff_1: cetiketerr =',cetiketerr
IPAK = -32
iDATYP = 5
ip2 = 0
cldegint = 'CUBIC'
!
! UU,VV
if(llinterpol) then
call hintvec2(zdif_u,zdif_v,ni*nj,ngid_an
& ,zuulam,zvvlam,nila2*njla2,itargetid,nflev,cldegint)
else
zuulam(:,:,:) = zdif_u(:,:,:)
zvvlam(:,:,:) = zdif_v(:,:,:)
endif
!
cldegint = 'CUBIC '
!
! QQ
if(llinterpol) then
call hintscal(zdif_vort,ni*nj,ngid_an,
& z3d,nila2*njla2,itargetid,nflev,cldegint)
else
z3d(:,:,:) = zdif_vort(:,:,:)
endif
do jk = 1, nflev
IP1 = NIP1(jk)
IERR = VFSTECR(z3d(1,1,jk),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila2,njla2,1,IP1,IP2,IP3,'E','QQ',cletiket,
& 'Z',mig1flda2,mig2flda2,mig3flda2,0,IDATYP,.TRUE.)
enddo
! DD
if(llinterpol) then
call hintscal(zdif_div,ni*nj,ngid_an,
& z3d,nila2*njla2,itargetid,nflev,cldegint)
else
z3d(:,:,:) = zdif_div(:,:,:)
endif
do jk = 1, nflev
IP1 = NIP1(jk)
IERR = VFSTECR(z3d(1,1,jk),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila2,njla2,1,IP1,IP2,IP3,'E','DD',cletiket,
& 'Z',mig1flda2,mig2flda2,mig3flda2,0,IDATYP,.TRUE.)
enddo
!
if(lhelm) then
! PP
if(llinterpol) then
call hintscal(zdif_psi,ni*nj,ngid_an,
& z3d,nila2*njla2,itargetid,nflev,cldegint)
else
z3d(:,:,:) = zdif_psi(:,:,:)
endif
do jk = 1, nflev
IP1 = NIP1(jk)
IERR = VFSTECR(z3d(1,1,jk),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila2,njla2,1,IP1,IP2,IP3,'E','PP',cletiket,
& 'Z',mig1flda2,mig2flda2,mig3flda2,0,IDATYP,.TRUE.)
enddo
! CC
if(llinterpol) then
call hintscal(zdif_chi,ni*nj,ngid_an,
& z3d,nila2*njla2,itargetid,nflev,cldegint)
else
z3d(:,:,:) = zdif_chi(:,:,:)
endif
do jk = 1, nflev
IP1 = NIP1(jk)
IERR = VFSTECR(z3d(1,1,jk),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila2,njla2,1,IP1,IP2,IP3,'E','CC',cletiket,
& 'Z',mig1flda2,mig2flda2,mig3flda2,0,IDATYP,.TRUE.)
enddo
endif
! TT
if(llinterpol) then
call hintscal(zdif_t,ni*nj,ngid_an,
& z3d,nila2*njla2,itargetid,nflev,cldegint)
else
z3d(:,:,:) = zdif_t(:,:,:)
endif
do jk = 1, nflev
IP1 = NIP1(jk)
IERR = VFSTECR(z3d(1,1,jk),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila2,njla2,1,IP1,IP2,IP3,'E','TT',cletiket,
& 'Z',mig1flda2,mig2flda2,mig3flda2,0,IDATYP,.TRUE.)
enddo
! GZ
if(llinterpol) then
call hintscal(zdif_gz,ni*nj,ngid_an,
& z3d,nila2*njla2,itargetid,nflev,cldegint)
else
z3d(:,:,:) = zdif_gz(:,:,:)
endif
do jk = 1, nflev
IP1 = NIP1(jk)
IERR = VFSTECR(z3d(1,1,jk),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila2,njla2,1,IP1,IP2,IP3,'E','GZ',cletiket,
& 'Z',mig1flda2,mig2flda2,mig3flda2,0,IDATYP,.TRUE.)
enddo
! HU
if(llinterpol) then
call hintscal(zdif_q,ni*nj,ngid_an,
& z3d,nila2*njla2,itargetid,nflev,cldegint)
else
z3d(:,:,:) = zdif_q(:,:,:)
endif
do jk = 1, nflev
IP1 = NIP1(jk)
IERR = VFSTECR(z3d(1,1,jk),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila2,njla2,1,IP1,IP2,IP3,'E','HU',cletiket,
& 'Z',mig1flda2,mig2flda2,mig3flda2,0,IDATYP,.TRUE.)
enddo
! LQ
if(llinterpol) then
call hintscal(zdif_lq,ni*nj,ngid_an,
& z3d,nila2*njla2,itargetid,nflev,cldegint)
else
z3d(:,:,:) = zdif_lq(:,:,:)
endif
do jk = 1, nflev
IP1 = NIP1(jk)
IERR = VFSTECR(z3d(1,1,jk),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila2,njla2,1,IP1,IP2,IP3,'E','LQ',cletiket,
& 'Z',mig1flda2,mig2flda2,mig3flda2,0,IDATYP,.TRUE.)
enddo
! P0
if(llinterpol) then
call hintscal(zdif_ps,ni*nj,ngid_an,
& zpslam,nila2*njla2,itargetid,1,cldegint)
else
zpslam(:,:) = zdif_ps(:,:)
endif
! TG
if(.not.lsame_grid12) then
call hintscal(zdif_tg,ni*nj,ngid_an,
& ztglam,nila2*njla2,itargetid,1,cldegint)
else
ztglam(:,:) = zdif_tg(:,:)
endif
!
IP1 = NIP1(NFLEV)
IERR = VFSTECR(zpslam(1,1),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila2,njla2,1,IP1,IP2,IP3,'E','P0',cletiket,
& 'Z',mig1flda2,mig2flda2,mig3flda2,0,IDATYP,.TRUE.)
!
IERR = VFSTECR(ztglam(1,1),zwork,IPAK,IKULFILE,NDATESTAT,
& 0,0,nila2,njla2,1,IP1,IP2,IP3,'E','TG',cletiket,
& 'Z',mig1flda2,mig2flda2,mig3flda2,0,IDATYP,.TRUE.)
!
!
! Writing positional parameters
! -----------------------------
!
! Write >>:
cltypvar = 'X'
clnomvar = '>>'
clgrtyp = 'E'
ierr = vfstecr(grd_x_82,zwork,IPAK,IKULFILE,IDATE(1),
& ideet,inpas,nila2,1,1,mig1flda2,mig2flda2,mig3flda2,cltypvar
& ,clnomvar,cetikinc,clgrtyp,mig1tic2,mig2tic2,mig3tic2,mig4tic2
& ,iDATYP,.true.)
!
! Write ^^
cltypvar = 'X'
clnomvar = '^^'
clgrtyp = 'E'
ierr = vfstecr(grd_y_82,zwork,IPAK,IKULFILE,IDATE(1),
& ideet,inpas,1,njla2,1,mig1flda2,mig2flda2,mig3flda2,cltypvar
& ,clnomvar,cetikinc,clgrtyp,mig1tic2,mig2tic2,mig3tic2,mig4tic2
& ,iDATYP,.true.)
!
IERR = FSTFRM (KULSTAT)
IERR = FCLOS (KULSTAT)
201 CONTINUE ! end loop on jfile
!
999 continue
write(nulout,*) 'prep_fcst_diff_1: END'
!
RETURN
END