!-------------------------------------- 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 ensfcst_mean(pmpp,pmcu,pmtu,pmlq,pmpsu,pmtg, 2,47
& kulstat,koutfile,ldhelm,ldfplane,ldtb_psi)
#if defined (DOC)
*
* * s/r ensfcst_mean: Compute mean and variances of gridpoint
* variables from forecast error samples for the
* LAM4D configuration. Then, store on file.
*
* Author: L. Fillion - ARMA/EC - 17 Dec 2008.
* Revision:
*
* Arguments:
* KULSTAT logical unit number
*
#endif
IMPLICIT NONE
*implicits
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comct0.cdk"
#include "comcst.cdk"
#include "comgem.cdk"
#include "comsp.cdk"
#include "comgd0.cdk"
#include "comgdpar.cdk"
#include "comcse1.cdk"
#include "comgrd.cdk"
#include "comgemla.cdk"
#include "comfftla.cdk"
#include "comcva.cdk"
#include "comgrd_param.cdk"
*
logical ldhelm,ldfplane,ldtb_psi,ldopc
INTEGER KULSTAT,koutfile
!
logical llfiltersdev,llfilt
INTEGER JENS, IENS, jk1, IERR, JFILE, iensemble
integer ji,jj,jk,jvar,inbvar,icase,itrunc,inip1,injp1
parameter(inbvar=5)
character*1 clpart,clflt,clgrid
character*2 clvar(inbvar)
!
CHARACTER*8 cletik
INTEGER FNOM, FSTOUV, FSTFRM, FCLOS, FSTPRM, FSTINF, FSTINL
INTEGER VFSTECR, vfstlir
integer newdate
!
! RPN Standard files parameters
!
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
real*8 HEURES
CHARACTER*1 CLTYPVAR,CLGRTYP
CHARACTER*2 CLNOMVAR
CHARACTER*8 CLETIKET
character (len = 1) :: etk1
character (len = 2) :: etk2
character (len = 2) :: etk
!
integer idum1,idum2,idum3,idum4
real*8 zthreshold,zni
REAL*8 DLA2
REAL*8 ZFACT,zmin,zmax
INTEGER IPAK, IDATEO
CHARACTER*128 CLFLFILE
!
real*8 zx8(nila),zy8(njla)
!
real*8 bufwk3dijk(nila,njla,nflev)
!
real*8 pmpp(nila,nflev,njla)
real*8 pmcu(nila,nflev,njla)
real*8 pmtu(nila,nflev,njla)
real*8 pmlq(nila,nflev,njla)
real*8 pmpsu(nila,njla)
real*8 pmtg(nila,njla)
!
real*8 zspp(nila,nflev,njla)
real*8 zscu(nila,nflev,njla)
real*8 zstu(nila,nflev,njla)
real*8 zslq(nila,nflev,njla)
real*8 zspsu(nila,njla)
real*8 zstg(nila,njla)
!
real*8 zmeanpp(nila,njla,nflev)
real*8 zmeancu(nila,njla,nflev)
real*8 zmeantu(nila,njla,nflev)
real*8 zmeantb(nila,njla,nflev)
real*8 zmeanlq(nila,njla,nflev)
real*8 zmeanpsu(nila,njla)
real*8 zmeantg(nila,njla)
real*8 zmeanpb(nila,njla)
!
real*8 zstdpp(nila,njla,nflev)
real*8 zstdcu(nila,njla,nflev)
real*8 zstdtu(nila,njla,nflev)
real*8 zstdtb(nila,njla,nflev)
real*8 zstdlq(nila,njla,nflev)
real*8 zstdpsu(nila,njla)
real*8 zstdtg(nila,njla)
real*8 zstdpb(nila,njla)
!
real*8 z2d(nila,njla)
real*8 z2d_in(mni_in,mnj_in)
real*8 zwork2d(nila,njla)
real*8 zstdtt(nila,njla,nflev)
real*8 zvaratiob(nila,njla,nflev)
real*8 zvaratiou(nila,njla,nflev)
real*8 zsavet0(nila,njla,nflev)
real*8 zsavetb(nila,njla,nflev)
real*8 zsavepsi(nila,njla,nflev)
real*8 zsavevort(nila,njla,nflev)
!
real*8 zgdpsi(nila,nflev,njla)
real*8 zgdpsis(nila,nflev,njla)
real*8 zgdchi(nila,nflev,njla)
real*8 zvort(nila,nflev,njla)
real*8 zvorts(nila,nflev,njla)
real*8 zdiv(nila,nflev,njla)
real*8 zpb(nila,nflev,njla)
real*8 zt0(nila,nflev,njla)
real*8 ztb(nila,nflev,njla)
real*8 ztu(nila,nflev,njla)
!
real*8 zpsb(nila,njla)
real*8 zpsu(nila,njla)
!
real*8 zxmtb(nila,nflev,njla)
real*8 zstb(nila,nflev,njla)
real*8 zxmpsb(nila,njla)
real*8 zspsb(nila,njla)
!
real*8 zonalpp(njla,nflev)
real*8 zonalcu(njla,nflev)
real*8 zonaltu(njla,nflev)
real*8 zonaltb(njla,nflev)
real*8 zonallq(njla,nflev)
real*8 zonalpsu(njla)
real*8 zonaltg(njla)
real*8 zonalpb(njla)
!
real*8 zwrkflt(nila,nflev,njla)
!
real*8 zwrksp(nla,2,nflev)
real*8 zspmeantt(nband,nflev)
real*8 zspmeantb(nband,nflev)
real*8 zspmeantu(nband,nflev)
real*8 zspsumtt(nband,nflev)
real*8 zspsumtb(nband,nflev)
real*8 zspsumtu(nband,nflev)
real*8 zspsumsqtt(nband,nflev)
real*8 zspsumsqtb(nband,nflev)
real*8 zspsumsqtu(nband,nflev)
real*8 zspvartt(nband,nflev)
real*8 zspvartb(nband,nflev)
real*8 zspvartu(nband,nflev)
real*8 zratiob(nband,nflev)
real*8 zratiou(nband,nflev)
!
!
!!
!
llfiltersdev = .false.
llfilt = .false.
if(lflt_low) then
llfilt = .true.
clflt = 'L'
else if(lflt_high) then
llfilt = .true.
clflt = 'H'
endif
!
clvar(1) = 'PP'
clvar(2) = 'CC'
if(.not.ldhelm) then
clvar(1) = 'QQ'
clvar(2) = 'DD'
endif
clvar(3) = 'TT'
clvar(4) = 'LQ'
clvar(5) = 'P0'
!
inip1 = nila+1
injp1 = njla+1
!
zthreshold = 1.e-15
DLA2 = DBLE(RA) * DBLE(RA)
IDIMAX = 100
write(nulout,*) 'ensfcst_mean: BEGIN '
write(nulout,*) 'ensfcst_mean: NFLSTAT = ',NFLSTAT
! -----------------------
!*1 Initialize accumulators
! -----------------------
pmpp(:,:,:) = 0.0
pmcu(:,:,:) = 0.0
pmtu(:,:,:) = 0.0
pmlq(:,:,:) = 0.0
pmpsu(:,:) = 0.0
pmtg(:,:) = 0.0
!
zspp(:,:,:) = 0.0
zscu(:,:,:) = 0.0
zstu(:,:,:) = 0.0
zslq(:,:,:) = 0.0
zspsu(:,:) = 0.0
zstg(:,:) = 0.0
!
!cluc call getmeangdla(nulbgst) ! read from file: precomputed mean of fields
!
! -------------------------------------------------------------
!*2 Access the increments from a set of files (loop on the files)
! -------------------------------------------------------------
!
iensemble = 0
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 = CFSTVAR(1)
if (CLNOMVAR.eq.'P0') then
IP1 =0
else
IP1 =12000
endif
write(NULOUT,*)
IERR = FSTINL (KULSTAT,INI,INJ,INK
& ,-1,CETIKETERR,IP1,IP2,IP3,' '
& ,CLNOMVAR,ILISTE,INFON,IDIMAX)
!
! Ensure namelist parameters mextendx, mextendy are feasible
! w.r.t. basic-state GEM fields
! ----------------------------------------------------------
!
if(mni_in.gt.ini) then
write(nulout,*) 'ensfcst_mean: mni_in,INI=',mni_in,INI
call abort3d(nulout,'ensfcst_mean: mni_in.gt.INI')
else if(mnj_in.gt.inj) then
write(nulout,*) 'ensfcst_mean: mnj_in,INJ=',mnj_in,INJ
call abort3d(nulout,'ensfcst_mean: mnj_in.gt.INJ')
endif
!
WRITE(NULOUT,9210)INFON
9210 FORMAT(//,4X,"ensfcst_mean: Ensemble of ",I4," increments")
IF(INFON.EQ.0) THEN
WRITE(NULOUT,*)' THIS FILE IS EMPTY.
$ CHECK THE SELECTION CRITERIA'
CALL ABORT3D(NULOUT,'ensfcst_mean: 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)
!
! Ensure namelist parameters mextendx, mextendy are feasible
! w.r.t. basic-state GEM fields
! ----------------------------------------------------------
!
if(grd_typ.eq.'LU') then
if(mni_in.gt.ini) then
write(nulout,*) 'ensfcst_mean: INI, mni_in = ',INI,mni_in
call abort3d(nulout,'ensfcst_mean: mni_in.gt.INI')
else if(mnj_in.gt.inj) then
write(nulout,*) 'ensfcst_mean: INJ, mnj_in = ',INJ,mnj_in
call abort3d(nulout,'ensfcst_mean: mnj_in.gt.INJ')
endif
endif
!
heures = real(INPAS*IDEET/3600)
!
CALL INCDATR(IDATV(JENS),IDATE(JENS),heures)
ierr= 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(iensemble.EQ.0) THEN
NDATESTAT = IDATE(1)
END IF
!
! 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
!
if(lmcstats) then
NSTAMPN = -1
icase=jens ! i.e. will use IP3 as a search parameter and ignore the date in current file since all same
else
NSTAMPN = IDATE(JENS) ! i.e. will use the current date of validity of the current error sample in standard file.
icase = -1 ! ignore IP3 as a search parameter in vfstlir
endif
!
call geterr(kulstat,'G','E',icase)
!
do ji=1,nila
do jj=1,njla
zpsb(ji,jj)=gps0(ji,1,jj)
enddo
enddo
!
call maxmin(zpsb,nila,njla,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'ensfcst_mean',
& 'P0')
!
! Adjusts fields according to B.C.
!
call transfer('GD01')
ldopc = .true.
if(lpsifromglb.or.lpsifromlam) ldopc = .false.
call initgdla(zvort,zdiv,zgdpsi,zgdchi,'U',ldopc)
call transfer('GD10')
!
if(lpsifromlam) then ! get PSI from input file kulstat
do jk=1,nflev
ierr = vfstlir(z2d,kulstat,nila,njla,1,NSTAMPN,
& 'PSI_LAM ',NIP1(JK),-1,-1,'E','PP')
if(ierr.lt.0) then
call abort3d(nulout,'ensfcst_mean: Problem reading PSI field')
endif
do jj=1,njla
do ji=1,nila
zgdpsi(ji,jk,jj) = z2d(ji,jj)
enddo
enddo
ierr = vfstlir(z2d,kulstat,nila,njla,1,NSTAMPN,
& 'CHI_LAM ',NIP1(JK),-1,-1,'E','CC')
if(ierr.lt.0) then
call abort3d(nulout,'ensfcst_mean: Problem reading CHI field')
endif
do jj=1,njla
do ji=1,nila
zgdchi(ji,jk,jj) = z2d(ji,jj)
enddo
enddo
enddo
else if(lpsifromglb) then ! get PSI from input file kulstat
do jk=1,nflev
! ierr = vfstlir(z2d_in,kulstat,mni_in,mnj_in,1,NSTAMPN,
! & 'LAM4D ',NIP1(JK),-1,-1,'E','PP')
! if(ierr.lt.0) then
! call abort3d(nulout,'ensfcst_mean: Problem reading PSI field')
! endif
do jj=1,mnj_in
do ji=1,mni_in
zgdpsi(ji,jk,jj) = ut0(ji,jk,jj)
zgdchi(ji,jk,jj) = vt0(ji,jk,jj)
enddo
enddo
enddo
call mach3(zgdpsi,nila,njla,nflev,inip1,injp1)
call mach3(zgdchi,nila,njla,nflev,inip1,injp1)
! call setmean(zgdchi,0.0,nflev)
endif
!
if(llfilt) then
write(nulout,*) 'ensfcst_mean: **************************************'
write(nulout,*) 'ensfcst_mean: PP error sample is spectrally filtered'
write(nulout,*) 'ensfcst_mean: **************************************'
call gdtruncr(zgdpsi,zwrksp,'T',mflt_trunc,clflt,.false.,nflev)
else
write(nulout,*) 'ensfcst_mean: NO FILTER applied to PP error sample'
endif
!
!
! call vfilt(zt0,1,'L')
!
do ji=1,nila
do jj=1,njla
do jk=1,nflev
if(ldhelm) then
ut0(ji,jk,jj) = zgdpsi(ji,jk,jj)
vt0(ji,jk,jj) = zgdchi(ji,jk,jj)
else
ut0(ji,jk,jj) = zvort(ji,jk,jj)
vt0(ji,jk,jj) = zdiv(ji,jk,jj)
endif
zt0(ji,jk,jj) = tt0(ji,jk,jj)
zsavet0(ji,jj,jk) = zt0(ji,jk,jj)
zsavepsi(ji,jj,jk) = zgdpsi(ji,jk,jj)
zsavevort(ji,jj,jk) = zvort(ji,jk,jj)
enddo
enddo
enddo
!
call maxmin(zt0,nila,njla,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'ensfcst_mean',
& 'T0')
!
! ACCUMULATE SUM OF ELEMENTS AND SUM OF SQUARED ELEMENTS
!
! Loop for Psi, Chi, T, lq, ps, TG
!
do jj = 1, njla
do ji = 1, nila
do jk1 = 1, nflev
pmpp(ji,jk1,jj) = pmpp(ji,jk1,jj) + ut0(ji,jk1,jj)
pmcu(ji,jk1,jj) = pmcu(ji,jk1,jj) + vt0(ji,jk1,jj)
pmtu(ji,jk1,jj) = pmtu(ji,jk1,jj) + zt0(ji,jk1,jj)
pmlq(ji,jk1,jj) = pmlq(ji,jk1,jj) + q0(ji,jk1,jj)
!
zspp(ji,jk1,jj) = zspp(ji,jk1,jj)
& + ut0(ji,jk1,jj)*ut0(ji,jk1,jj)
zscu(ji,jk1,jj) = zscu(ji,jk1,jj)
& + vt0(ji,jk1,jj)*vt0(ji,jk1,jj)
zstu(ji,jk1,jj) = zstu(ji,jk1,jj)
& + zt0(ji,jk1,jj)*zt0(ji,jk1,jj)
zslq(ji,jk1,jj) = zslq(ji,jk1,jj)
& + q0(ji,jk1,jj)*q0(ji,jk1,jj)
enddo
pmpsu(ji,jj) = pmpsu(ji,jj) + gps0(ji,1,jj)
pmtg(ji,jj) = pmtg(ji,jj) + zt0(ji,nflev,jj) ! Use Tu at surface until TG is abord.... cluc
!
zspsu(ji,jj) = zspsu(ji,jj)
& + gps0(ji,1,jj)*gps0(ji,1,jj)
zstg(ji,jj) = zstg(ji,jj)
& + zt0(ji,nflev,jj)*zt0(ji,nflev,jj) ! Use Tu at surface until TG is abord.... cluc
enddo
enddo
231 continue ! end loop on the ensemble within current file
!
iensemble = iensemble + IENS
IERR = FSTFRM (KULSTAT)
IERR = FCLOS (KULSTAT)
201 CONTINUE ! end loop on jfile
write(nulout,*) 'ensfcst_mean: iensemble = ',iensemble
! ----------------------------------------
!*3. COMPUTE VARIANCES OF GD FOR THE ENSEMBLE
! ----------------------------------------
! Loop for Psi, Chi, Tu, Psu, lq
DO jj = 1,njla
DO ji = 1,nila
do jk1 = 1, nflev
zspp(ji,jk1,jj) = ( zspp(ji,jk1,jj) -
+ ((pmpp(ji,jk1,jj)*pmpp(ji,jk1,jj)) / iensemble )) /
+ (iensemble - 1)
if (zspp(ji,jk1,jj).eq.0.0) zspp(ji,jk1,jj)=zthreshold
!
zscu(ji,jk1,jj) = ( zscu(ji,jk1,jj) -
+ ((pmcu(ji,jk1,jj)*pmcu(ji,jk1,jj)) / iensemble )) /
+ (iensemble - 1)
if (zscu(ji,jk1,jj).eq.0.0) zscu(ji,jk1,jj)=zthreshold
!
zstu(ji,jk1,jj) = ( zstu(ji,jk1,jj) -
+ ((pmtu(ji,jk1,jj)*pmtu(ji,jk1,jj)) / iensemble )) /
+ (iensemble - 1)
if (zstu(ji,jk1,jj).eq.0.0) zstu(ji,jk1,jj)=zthreshold
!
zslq(ji,jk1,jj) = ( zslq(ji,jk1,jj) -
+ ((pmlq(ji,jk1,jj)*pmlq(ji,jk1,jj)) / iensemble )) /
+ (iensemble - 1)
if (zslq(ji,jk1,jj).eq.0.0) zslq(ji,jk1,jj)=zthreshold
ENDDO
zspsu(ji,jj) = ( zspsu(ji,jj) -
+ ((pmpsu(ji,jj)*pmpsu(ji,jj)) / iensemble )) /
+ (iensemble - 1)
if (zspsu(ji,jj).eq.0.0) zspsu(ji,jj)=zthreshold
zstg(ji,jj) = ( zstg(ji,jj) -
+ ((pmtg(ji,jj)*pmtg(ji,jj)) / iensemble )) /
+ (iensemble - 1)
if (zstg(ji,jj).eq.0.0) zstg(ji,jj)=zthreshold
ENDDO
ENDDO
!
! ---------------------------------------
!*4. COMPUTE THE MEAN OF GD FOR THE ENSEMBLE
! ---------------------------------------
! Loop for Psi, Chi, T, Ps, lq
!
DO jj = 1,njla
DO ji = 1,nila
do jk1 = 1, nflev
pmpp(ji,jk1,jj) = pmpp(ji,jk1,jj) / iensemble
pmcu(ji,jk1,jj) = pmcu(ji,jk1,jj) / iensemble
pmtu(ji,jk1,jj) = pmtu(ji,jk1,jj) / iensemble
pmlq(ji,jk1,jj) = pmlq(ji,jk1,jj) / iensemble
ENDDO
pmpsu(ji,jj) = pmpsu(ji,jj) / iensemble
pmtg(ji,jj) = pmtg(ji,jj) / iensemble
ENDDO
ENDDO
!
! Transfer data
do jj=1,njla
do ji=1,nila
zmeanpsu(ji,jj) = pmpsu(ji,jj)
zmeantg(ji,jj) = pmtg(ji,jj)
do jk=1,nflev
zmeanpp(ji,jj,jk) = pmpp(ji,jk,jj)
zmeancu(ji,jj,jk) = pmcu(ji,jk,jj)
zmeantu(ji,jj,jk) = pmtu(ji,jk,jj)
zmeanlq(ji,jj,jk) = pmlq(ji,jk,jj)
enddo
enddo
enddo
!
call maxmin(zmeanpsu,nila,njla,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'ensfcst_mean',
& 'P0')
write(nulout,*) 'ensfcst_mean: point 3: zmeanpsu, (min,max)=',zmin,zmax
! -------
!*5 STD DEV
! -------
do jj=1,njla
do ji=1,nila
! Psu
if (zspsu(ji,jj).le.zthreshold) then
write(nulout,*) 'ensfcst_mean: ji,jj,zspsu=',
& ji,jj,zspsu(ji,jj)
zspsu(ji,jj)=zthreshold
! call abort3d(nulout,'ensfcst_mean: ps_u st-dev problem!')
endif
zspsu(ji,jj) = sqrt(zspsu(ji,jj))
zstdpsu(ji,jj) = zspsu(ji,jj)
! TG
if (zstg(ji,jj).le.0.0) then
write(nulout,*) 'ensfcst_mean: ji,jj,zstg=',
& ji,jj,zstg(ji,jj)
! call abort3d(nulout,'ensfcst_mean: TG st-dev problem!')
zstg(ji,jj)=zthreshold
endif
zstg(ji,jj) = sqrt(zstg(ji,jj))
zstdtg(ji,jj) = zstg(ji,jj)
!
do jk=1,nflev
!
if(zspp(ji,jk,jj).le.0.0) then ! Psi
write(nulout,*) 'ensfcst_mean: ji,jk,jj,zspp=',
& ji,jk,jj,zspp(ji,jk,jj)
call abort3d(nulout,'ensfcst_mean: PSI st-dev problem!')
else if(zscu(ji,jk,jj).le.0.0) then ! Chi
write(nulout,*) 'ensfcst_mean: ji,jk,jj,zspp=',
& ji,jk,jj,zspp(ji,jk,jj)
call abort3d(nulout,'ensfcst_mean: CHI_u st-dev problem!')
else if(zstu(ji,jk,jj).le.0.0) then ! Tu
write(nulout,*) 'ensfcst_mean: ji,jk,jj,zstu=',
& ji,jk,jj,zstu(ji,jk,jj)
call abort3d(nulout,'ensfcst_mean: T_u st-dev problem!')
else if(zslq(ji,jk,jj).le.zthreshold) then ! lq
write(nulout,*) 'ensfcst_mean: ji,jk,jj,zslq=',
& ji,jk,jj,zslq(ji,jk,jj)
zslq(ji,jk,jj)=zthreshold
! call abort3d(nulout,'ensfcst_mean: Lnq st-dev problem!')
endif
!
zspp(ji,jk,jj) = sqrt(zspp(ji,jk,jj))
zscu(ji,jk,jj) = sqrt(zscu(ji,jk,jj))
zstu(ji,jk,jj) = sqrt(zstu(ji,jk,jj))
zslq(ji,jk,jj) = sqrt(zslq(ji,jk,jj))
!
zstdpp(ji,jj,jk) = zspp(ji,jk,jj)
zstdcu(ji,jj,jk) = zscu(ji,jk,jj)
zstdtu(ji,jj,jk) = zstu(ji,jk,jj)
zstdlq(ji,jj,jk) = zslq(ji,jk,jj)
enddo
enddo
enddo
!
! ------------------------------------------
! Apply spectral filter to st-dev if desired
! ------------------------------------------
!
if(llfiltersdev) then
!
!* Psi
!
do jj=1,njla
do ji=1,nila
do jk=1,nflev
zwrkflt(ji,jk,jj)=zstdpp(ji,jj,jk)
enddo
enddo
enddo
!
call gdtruncr(zwrkflt,zwrksp,'T',mflt_trunc,clflt,.false.,nflev)
!
do jj=1,njla
do ji=1,nila
do jk=1,nflev
zstdpp(ji,jj,jk) = zwrkflt(ji,jk,jj)
enddo
enddo
enddo
!
!* Chi_u
!
do jj=1,njla
do ji=1,nila
do jk=1,nflev
zwrkflt(ji,jk,jj)=zstdcu(ji,jj,jk)
enddo
enddo
enddo
!
call gdtruncr(zwrkflt,zwrksp,'T',mflt_trunc,clflt,.false.,nflev)
!
do jj=1,njla
do ji=1,nila
do jk=1,nflev
zstdcu(ji,jj,jk) = zwrkflt(ji,jk,jj)
enddo
enddo
enddo
!
!* T_u
!
do jj=1,njla
do ji=1,nila
do jk=1,nflev
zwrkflt(ji,jk,jj)=zstdtu(ji,jj,jk)
enddo
enddo
enddo
!
call gdtruncr(zwrkflt,zwrksp,'T',mflt_trunc,clflt,.false.,nflev)
!
do jj=1,njla
do ji=1,nila
do jk=1,nflev
zstdtu(ji,jj,jk) = zwrkflt(ji,jk,jj)
enddo
enddo
enddo
!
!* lq
!
do jj=1,njla
do ji=1,nila
do jk=1,nflev
zwrkflt(ji,jk,jj)=zstdlq(ji,jj,jk)
enddo
enddo
enddo
!
call gdtruncr(zwrkflt,zwrksp,'T',mflt_trunc,clflt,.false.,nflev)
!
do jj=1,njla
do ji=1,nila
do jk=1,nflev
zstdlq(ji,jj,jk) = zwrkflt(ji,jk,jj)
enddo
enddo
enddo
!
!* ps_u
!
call gdtruncr(zstdpsu,zwrksp,'T',mflt_trunc,clflt,.false.,1)
!
!* TG
!
call gdtruncr(zstdtg,zwrksp,'T',mflt_trunc,clflt,.false.,1)
endif
! -----------------
!*6. OUTPUT Statistics
! -----------------
IPAK = -32
IDATYP = 5
IP1 = 0
IP2 = 0
IP3 = iensemble
IDATEO = NDATESTAT
!
cletik = 'FCSTMEAN'
!
do jvar=1,inbvar
do jk=1,nflev
IP1 = NIP1(jk)
if((clvar(jvar).eq.'PP').or.(clvar(jvar).eq.'QQ')) then
IERR = VFSTECR(zmeanpp(1,1,jk),zmeanpp(1,1,jk),IPAK,koutfile,
$ IDATEO,0,0,nila,njla,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'Z',mig1flda,mig2flda,mig3flda,0,IDATYP,.TRUE.)
IERR = VFSTECR(zsavepsi(1,1,jk),zsavepsi(1,1,jk),IPAK,koutfile,
$ IDATEO,0,0,nila,njla,1,IP1,IP2,IP3,'E','PP',
$ 'ERR-LU ','Z',mig1flda,mig2flda,mig3flda,0,IDATYP,.TRUE.)
IERR = VFSTECR(zsavevort(1,1,jk),zsavevort(1,1,jk),IPAK,koutfile,
$ IDATEO,0,0,nila,njla,1,IP1,IP2,IP3,'E','QQ',
$ 'ERR-LU ','Z',mig1flda,mig2flda,mig3flda,0,IDATYP,.TRUE.)
!
else if((clvar(jvar).eq.'CC').or.(clvar(jvar).eq.'DD')) then
IERR = VFSTECR(zmeancu(1,1,jk),zmeancu(1,1,jk),IPAK,koutfile,
$ IDATEO,0,0,nila,njla,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'Z',mig1flda,mig2flda,mig3flda,0,IDATYP,.TRUE.)
!
else if(clvar(jvar).eq.'TT') then
IERR = VFSTECR(zmeantu(1,1,jk),zmeantu(1,1,jk),IPAK,koutfile,
$ IDATEO,0,0,nila,njla,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'Z',mig1flda,mig2flda,mig3flda,0,IDATYP,.TRUE.)
IERR = VFSTECR(zsavet0(1,1,jk),zsavet0(1,1,jk),IPAK,koutfile,
$ IDATEO,0,0,nila,njla,1,IP1,IP2,IP3,'E',clvar(jvar),
$ 'TTSAMPLE','Z',mig1flda,mig2flda,mig3flda,0,IDATYP,.TRUE.)
!
else if(clvar(jvar).eq.'LQ') then
IERR = VFSTECR(zmeanlq(1,1,jk),zmeanlq(1,1,jk),IPAK,koutfile,
$ IDATEO,0,0,nila,njla,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'Z',mig1flda,mig2flda,mig3flda,0,IDATYP,.TRUE.)
endif
enddo
enddo
! Convert Pa to hPa
do jj=1,njla
do ji=1,nila
zmeanpsu(ji,jj) = zmeanpsu(ji,jj) * 0.01
enddo
enddo
!
IP1=0
IP2=0
!
IERR = VFSTECR(zmeanpsu,zmeanpsu,IPAK,koutfile,IDATEO,0,0,nila,njla,1,
$ IP1,IP2,IP3,'E','P0',cletik,'Z',mig1flda,mig2flda,mig3flda,
$ 0,IDATYP,.TRUE.)
IERR = VFSTECR(zmeantg,zmeantg,IPAK,koutfile,IDATEO,0,0,nila,njla,1,
$ IP1,IP2,IP3,'E','TG',cletik,'Z',mig1flda,mig2flda,mig3flda,
$ 0,IDATYP,.TRUE.)
!
write(nulout,*) 'ensfcst_mean: point 1'
call maxmin(zsavet0,nila,nflev,njla,zmin,zmax,
& idum1,idum2,idum3,idum4,'ensfcst_mean',
& 'T0')
!
! ---------------------------------------------
!*7. OUTPUT STD DEV OF EITHER UU VV TT LQ PP CC P0
! OR UC UT UP
! ---------------------------------------------
IPAK = -32
IDATYP = 5
IP1 = 0
IP2 = 0
IP3 = iensemble
IDATEO = NDATESTAT
!
cletik = 'FCSTSDEV'
!
do jvar=1,inbvar
do jk=1,nflev
IP1 = NIP1(jk)
if((clvar(jvar).eq.'PP').or.(clvar(jvar).eq.'QQ')) then
IERR = VFSTECR(zstdpp(1,1,jk),zstdpp(1,1,jk),IPAK,koutfile,
$ IDATEO,0,0,nila,njla,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'Z',mig1flda,mig2flda,mig3flda,0,IDATYP,.TRUE.)
!
else if((clvar(jvar).eq.'CC').or.(clvar(jvar).eq.'DD')) then
IERR = VFSTECR(zstdcu(1,1,jk),zstdcu(1,1,jk),IPAK,koutfile,
$ IDATEO,0,0,nila,njla,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'Z',mig1flda,mig2flda,mig3flda,0,IDATYP,.TRUE.)
!
else if(clvar(jvar).eq.'TT') then
IERR = VFSTECR(zstdtu(1,1,jk),zstdtu(1,1,jk),IPAK,koutfile,
$ IDATEO,0,0,nila,njla,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'Z',mig1flda,mig2flda,mig3flda,0,IDATYP,.TRUE.)
!
else if(clvar(jvar).eq.'LQ') then
IERR = VFSTECR(zstdlq(1,1,jk),zstdlq(1,1,jk),IPAK,koutfile,
$ IDATEO,0,0,nila,njla,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'Z',mig1flda,mig2flda,mig3flda,0,IDATYP,.TRUE.)
endif
enddo
enddo
! Convert Pa to hPa
do jj=1,njla
do ji=1,nila
zstdpsu(ji,jj) = zstdpsu(ji,jj) * 0.01
enddo
enddo
!
IP1=0
IP2=0
IERR = VFSTECR(zstdpsu,zstdpsu,IPAK,koutfile,IDATEO,0,0,nila,njla,1,
$ IP1,IP2,IP3,'E','P0',cletik,'Z',mig1flda,mig2flda,mig3flda,
$ 0,IDATYP,.TRUE.)
IERR = VFSTECR(zstdtg,zstdtg,IPAK,koutfile,IDATEO,0,0,nila,njla,1,
$ IP1,IP2,IP3,'E','TG',cletik,'Z',mig1flda,mig2flda,mig3flda,
$ 0,IDATYP,.TRUE.)
!
! -----------------------------
! Writing positional parameters
! -----------------------------
cletiket = ' '
cltypvar = ' '
!
do ji=1,nila
zx8(ji)=grd_x_8(ji)
enddo
do jj=1,njla
zy8(jj)=grd_y_8(jj)
enddo
!
ierr = vfstecr(zx8,zx8,ipak,koutfile,idateo,
& 0,0,nila,1,1,mig1flda,mig2flda,mig3flda,cltypvar
& ,'>>',cletiket,'E',mig1tic,mig2tic,mig3tic,mig4tic,idatyp
& ,.true.)
!
ierr = vfstecr(zy8, zy8, ipak, koutfile, idateo,
& 0,0, 1, njla, 1, mig1flda,mig2flda,mig3flda,cltypvar
& ,'^^',cletiket,'E',mig1tic,mig2tic,mig3tic,mig4tic,idatyp
& ,.true.)
!
! IERR = FSTFRM(koutfile)
! IERR = FCLOS(koutfile)
!
write(nulout,*) 'ensfcst_mean: END '
nensemble = iensemble
!
return
end