!-------------------------------------- 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_helmglb1(kulstat,kulstdev) 1,20
#if defined (DOC)
*
***s/r prep_helmglb1: Process files of forecast error samples and generate/add PP,CC or QQ/DD.
*
*Author: L. Fillion *ARMA/EC 29 May 2009
*Revision:
* L. Fillion - ARMA/EC - 11 Mai 2010 - Introduce MPI based on v_11_01b.
* L. Fillion - ARMA/EC - 18 Jun 2010 - Clean and inprove.
*
*Purpose: To be used by global statistics programs
*
*Arguments KULSTAT logical unit number
*
#endif
USE procs_topo
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
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
!
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 zgzglb(ni,nj,nflev)
real*8 zlqglb(ni,nj,nflev)
real*8 zpsglb(ni,nj)
!
real*8 zsp3d(nla,2,nflev)
real*8 zgd3d(nibeg:niend,nflev,njbeg:njend)
real*8 zwrpp(ni,nj,nflev)
real*8 zwrtt(ni,nj,nflev)
!
!!
if(grd_typ.ne.'GU') then
call abort3d(nulout,'prep_helmglb1: grd_typ not GU')
endif
!
llfilt = .false.
if(lflt_low) then
llfilt = .true.
clflt = 'L'
else if(lflt_high) then
llfilt = .true.
clflt = 'H'
endif
!
llqd = .true.
lloutglb = .true.
DLA2 = DBLE(RA) * DBLE(RA)
IKULFILE = kulstat
!
NFSTVAR = 0
CFSTVAR(1) = ' '
CFSTVAR(2) = ' '
!
CALL READNML('NAMGDPAR',IFLAG)
!
!* 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,'prep_helmglb1: 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,*) 'prep_helmglb1: INI,INJ = ',INI,INJ
if(ini.ne.ni.or.inj.ne.nj) then
call abort3d(nulout,'prep_helmglb1: ini.ne.ni.or.inj.ne.nj')
endif
!
! 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
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
!
if(lcva_hsp) then
CALL SPEREE_hem(nksdim,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,nksdim)
else
CALL SPEREE(nksdim,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,nksdim)
endif
!
! 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)
zwrtt(ji,ind,jk) = tt0(ji,jk,jj)
enddo
enddo
enddo
!
! CALL REESPE_hem(NFLEV,zsp3d,zgd3d
! S ,NLA,nibeg,niend,njbeg,njend,NFLEV)
! CALL SPEREE_hem(nflev,zsp3d,zgd3d
! S ,NLA,nibeg,niend,njbeg,njend,NFLEV)
!
!
if(ifois.eq.0) then
if(llqd) then
call maxmin(zvortglb,ni,nflev,nj,zmin,zmax,
& idum1,idum2,idum3,idum4,'prep_helmglb1 ',
& 'VOR')
call maxmin(zdivglb,ni,nflev,nj,zmin,zmax,
& idum1,idum2,idum3,idum4,'prep_helmglb1 ',
& 'DIV')
endif
call maxmin(zpsiglb,ni,nflev,nj,zmin,zmax,
& idum1,idum2,idum3,idum4,'prep_helmglb1 ',
& 'PSI')
call maxmin(zchiglb,ni,nflev,nj,zmin,zmax,
& idum1,idum2,idum3,idum4,'prep_helmglb1 ',
& 'CHI')
call maxmin(zwrtt,ni,nflev,nj,zmin,zmax,
& idum1,idum2,idum3,idum4,'prep_helmglb1 ',
& 'TT0')
ifois = 1
endif
!
IPAK = -32
iDATYP = 5
ip2 = 0
ip3 = jfile
!
if(myid == 0 ) then
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(zwrtt(1,1,jk),zwork,IPAK,
! & IKULFILE,NDATESTAT,0,0,ni,nj,1,
! & ip1,ip2,ip3,'E','TT','TESTHEM ',
! & 'G',0,0,0,0,IDATYP,.TRUE.)
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
endif ! myid
!
231 CONTINUE ! end loop on the ensemble within current file
!
IERR = FSTFRM (KULSTAT)
IERR = FCLOS (KULSTAT) ! IBM
201 CONTINUE ! end loop on jfile
!
write(nulout,*) 'prep_helmglb1: END'
!
RETURN
END