!-------------------------------------- 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 tsp_hemis(kulstat,kulstdev),15
#if defined (DOC)
*
***s/r tsp_hemis: Test Hemispheric global spectral transform.
*
*Author: L. Fillion *ARMA/EC 17 May 2010
*Revision:
*
*Purpose:
*
*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
LOGICAL llimplemented
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 zwr3d(ni,nj,nflev)
!
!!
if(grd_typ.ne.'GU') then
call abort3d(nulout,'tsp_hemis: 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,'tsp_hemis: 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,*) 'tsp_hemis: INI,INJ = ',INI,INJ
if(ini.ne.ni.or.inj.ne.nj) then
call abort3d(nulout,'tsp_hemis: 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
CALL SPGD
!
IPAK = -32
iDATYP = 5
ip2 = 0
ip3 = jfile
!
if(myid == 0 ) then
if(lloutglb) then
do jk = 1, nflev
IP1 = NIP1(jk)
call gdout2('UU',zwr3d(1,1,jk),ni,nj,jk,llimplemented,IP1)
IERR = VFSTECR(zwr3d(1,1,jk),zwork,IPAK,
& nulinclr,NDATESTAT,0,0,ni,nj,1,
& ip1,ip2,ip3,'E','UU','TESTHEM',
& 'G',0,0,0,0,IDATYP,.TRUE.)
call gdout2('VV',zwr3d(1,1,jk),ni,nj,jk,llimplemented,IP1)
IERR = VFSTECR(zwr3d(1,1,jk),zwork,IPAK,
& nulinclr,NDATESTAT,0,0,ni,nj,1,
& ip1,ip2,ip3,'E','VV','TESTHEM',
& 'G',0,0,0,0,IDATYP,.TRUE.)
call gdout2('TT',zwr3d(1,1,jk),ni,nj,jk,llimplemented,IP1)
IERR = VFSTECR(zwr3d(1,1,jk),zwork,IPAK,
& nulinclr,NDATESTAT,0,0,ni,nj,1,
& ip1,ip2,ip3,'E','TT','TESTHEM',
& '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,*) 'tsp_hemis: END'
!
RETURN
END