!-------------------------------------- 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 MEANGD(KULSTAT) 2,13
#if defined (DOC)
*
***s/r MEANGD: calculate mean and variances for stats runs
*
*Author: R. Sarrazin, septembre 1998
*Revision:
* . P. Koclas *CMC/AES June 1999:
* . - Y2K conversion
* JM Belanger CMDA/SMC Jul 2000
* . 32 bits conversion
* . C. Charette *ARMA/SMC Sep 2004
* - Conversion to hybrid vertical coordinate
*
*Arguments KULSTAT logical unit number
*
#endif
IMPLICIT NONE
*implicits
#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 "comstdd.cdk"
*
INTEGER KULSTAT
C
INTEGER JENS, IENS, JK1, IERR, JFILE, JK, JLAT, JLON
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
integer ini, inj,jlev, itrlgid
integer iip1s(jpnflev),iip2,iip3,itrlnlev
integer ipmode,ipkind,ip1_pak_trl,ip1_vco_trl
real zlev(jpnflev)
character*1 clstring
REAL*8 DHEURES
CHARACTER*1 CLTYPVAR,CLGRTYP
CHARACTER*2 CLNOMVAR
CHARACTER*8 CLETIKET
C
REAL*8 DLA2
REAL*8 ZFACT
INTEGER IPAK, IDATEO, IKULFILE
CHARACTER*128 CLFLFILE
C
DLA2 = DBLE(RA) * DBLE(RA)
IKULFILE = 57
C
C INITIALIZE ACCUMULATORS
C
DO JLAT = NJBEG, NJEND
DO JK1 = 1, NKGDIM+2*NFLEV
DO JLON = NIBEG, NIEND
XMGD(JLON,JK1,JLAT) = 0.0
SGD(JLON,JK1,JLAT) = 0.0
ENDDO
ENDDO
ENDDO
C
100 CONTINUE
c*********************************************************************
C* 2. Access the increments of from a set of files
C . (loop on the files)
C
200 CONTINUE
IDIMAX = 100
DO 201 JFILE = 1, NFLSTAT
C
CALL GETINCR(KULSTAT,JFILE)
C
C* . 2.1 Find how many cases there are to be treated
C
210 CONTINUE
C
IP1 = -1
IP2 = -1
IP3 = -1
CLNOMVAR = CFSTVAR(1)
if (CLNOMVAR.eq.'P0') then
IP1 =0
else
call getfldprm(iip1s,iip2,iip3,itrlnlev,CETIKETN,cltypvar
& ,itrlgid,CLNOMVAR,-1,jpnflev,kulstat,nulout
& ,ip1_pak_trl,ip1_vco_trl)
c
c---------Decode and sort the levels
ipmode = -1
do jlev = 1,itrlnlev
call CONVIP(iip1s(jlev),ZLEV(jlev),IPKIND
& ,ipmode,clstring, .false. )
enddo
c
call sort(zlev,itrlnlev)
ipmode = ip1_pak_trl
call CONVIP(IP1,zlev(itrlnlev),ip1_vco_trl
& ,ipmode,clstring, .false. )
endif
c
write(NULOUT,*)
IERR = FSTINL (KULSTAT,INI,INJ,INK
S ,-1,CETIKETN,IP1,IP2,IP3,' '
S ,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,'MEANGD: problem with FSTINL')
END IF
IENS = INFON
C
C* . 2.2 Get all the dates at which increments are available
C
220 CONTINUE
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)
C
DHEURES = DBLE(INPAS*IDEET/3600)
cjmb
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)
C
IF(NENSEMBLE.EQ.0) THEN
NDATESTAT = IDATE(1)
END IF
C
CTYPVARN = ' '
CETIKETN = CLETIKET
C
C 3. Loop on the ensemble
C
300 CONTINUE
DO 321 JENS = 1, IENS
C
C 3.1 Get the increment in grid-point form
C
310 CONTINUE
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)
CALL GETFST(KULSTAT,'G','N')
C
C ACCUMULATE SUM OF ELEMENTS AND SUM OF SQUARED ELEMENTS
C
DO JLAT = NJBEG, NJEND
DO JK1 = 1, NKGDIM
DO JLON = NIBEG, NIEND
XMGD(JLON,JK1,JLAT) = XMGD(JLON,JK1,JLAT) +
+ GD(JLON,JK1,JLAT)
SGD(JLON,JK1,JLAT) = SGD(JLON,JK1,JLAT) +
+ GD(JLON,JK1,JLAT) * GD(JLON,JK1,JLAT)
ENDDO
ENDDO
ENDDO
C
C COMPUTE PSI AND CHI
C
IF (NCONF .EQ. 500) THEN
C
CALL GDSP
C
C CONVERT FROM VORT/DIV TO PSI/CHI
C
DO JK = 1, NFLEV
DO JLAT = 1, NLA
SPVOR(JLAT,1,JK) = SPVOR(JLAT,1,JK) * DLA2*R1SNP1(JLAT)
SPVOR(JLAT,2,JK) = SPVOR(JLAT,2,JK) * DLA2*R1SNP1(JLAT)
SPDIV(JLAT,1,JK) = SPDIV(JLAT,1,JK) * DLA2*R1SNP1(JLAT)
SPDIV(JLAT,2,JK) = SPDIV(JLAT,2,JK) * DLA2*R1SNP1(JLAT)
ENDDO
ENDDO
C
CALL SPEREE(NKSDIM,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
C
C ACCUMULATE SUMS AND SUMS OF SQUARED VALUES
C
DO JLAT = NJBEG, NJEND
DO JK1 = 1, NFLEV
DO JLON = NIBEG, NIEND
XMPP(JLON,JK1,JLAT) = XMPP(JLON,JK1,JLAT) +
+ UT0(JLON,JK1,JLAT)
XMCC(JLON,JK1,JLAT) = XMCC(JLON,JK1,JLAT) +
+ VT0(JLON,JK1,JLAT)
SPP(JLON,JK1,JLAT) = SPP(JLON,JK1,JLAT) +
+ UT0(JLON,JK1,JLAT)*UT0(JLON,JK1,JLAT)
SCC(JLON,JK1,JLAT) = SCC(JLON,JK1,JLAT) +
+ VT0(JLON,JK1,JLAT)*VT0(JLON,JK1,JLAT)
ENDDO
ENDDO
ENDDO
C
ENDIF
C
321 CONTINUE
C
C* . 3.7 Ending the processing of one file
C
370 CONTINUE
NENSEMBLE = NENSEMBLE + IENS
C
IERR = FSTFRM (KULSTAT)
IERR = FCLOS (KULSTAT)
C
C* ---- Ending the loop on files -----
C
201 CONTINUE
C
C COMPUTE VARIANCES OF GD FOR THE ENSEMBLE
C
DO JLAT = NJBEG, NJEND
DO JK1 = 1, NKGDIM+2*NFLEV
DO JLON = NIBEG, NIEND
SGD(JLON,JK1,JLAT) = ( SGD(JLON,JK1,JLAT) -
+ ((XMGD(JLON,JK1,JLAT)*XMGD(JLON,JK1,JLAT)) / NENSEMBLE )) /
+ (NENSEMBLE - 1)
ENDDO
ENDDO
ENDDO
C
C COMPUTE THE MEAN OF GD FOR THE ENSEMBLE
C
DO JLAT = NJBEG, NJEND
DO JK1 = 1, NKGDIM
DO JLON = NIBEG, NIEND
XMGD(JLON,JK1,JLAT) = XMGD(JLON,JK1,JLAT) / NENSEMBLE
ENDDO
ENDDO
ENDDO
C
C ACCUMULATE ZONAL VALUES OF VARIANCES IN FIRST LON
C
DO JLAT = 1, NJ
DO JK1 = 1, NKGDIM+2*NFLEV
DO JLON = 2, NI
SGD(1,JK1,JLAT) = SGD(1,JK1,JLAT) + SGD(JLON,JK1,JLAT)
ENDDO
ENDDO
ENDDO
C
C STD DEV = SQRT OF ZONAL AVERAGE OF VARIANCES
C
DO JLAT = 1, NJ
IF ( NCONF .EQ. 500 ) THEN
C TO GET TRUE UU VV IN KTS
ZFACT = 1. / (CONIMA(JLAT) * RMSKNT)
ELSE
ZFACT = 1.
ENDIF
DO JK1=1,NFLEV
STDUU(NJ-JLAT+1,JK1) = SQRT(SUU(1,JK1,JLAT)/NILON(JLAT)) * ZFACT
STDVV(NJ-JLAT+1,JK1) = SQRT(SVV(1,JK1,JLAT)/NILON(JLAT)) * ZFACT
STDTT(NJ-JLAT+1,JK1) = SQRT(STT(1,JK1,JLAT)/NILON(JLAT))
STDLQ(NJ-JLAT+1,JK1) = SQRT(SLQ(1,JK1,JLAT)/NILON(JLAT))
c ATTN: Dans les hauts niveaux du modele il est possible
c que les champs de difference de LQ soient 0.0 a
c a chacun des points de grille.
c On remplace 0.0 par une petite valeur pour eviter
c de normaliser par une valeur zero dans cse2.ftn par exemple
if(STDLQ(NJ-JLAT+1,JK1) .eq. 0.0) then
STDLQ(NJ-JLAT+1,JK1) = 1.0E-10
endif
STDPP(NJ-JLAT+1,JK1) = SQRT(SPP(1,JK1,JLAT)/NILON(JLAT))
STDCC(NJ-JLAT+1,JK1) = SQRT(SCC(1,JK1,JLAT)/NILON(JLAT))
ENDDO
STDP0(NJ-JLAT+1) = SQRT(SP0(1,1,JLAT)/NILON(JLAT)) * 0.01
ENDDO
C
C OUTPUT STD DEV OF EITHER UU VV TT LQ PP CC P0
C OR UC UT UP
C
IPAK = -32
IDATYP = 5
IP1 = 0
IP2 = 0
IP3 = NENSEMBLE
IDATEO = NDATESTAT
C
IF (NCONF .EQ. 500) THEN
CLFLFILE = CFLPTOT
ELSE
CLFLFILE = CFLSTDEV
ENDIF
C
IERR = FNOM(IKULFILE,CLFLFILE,'RND',0)
IERR = FSTOUV(IKULFILE,'RND')
C
IF (NCONF .EQ. 500) THEN
IERR = VFSTECR(STDUU,STDUU,IPAK,IKULFILE,IDATEO,0,0,1,NJ,
+ NFLEV,IP1,IP2,IP3,'E',CFSTVAR(1),'STDDEV ',
+ 'X',0,0,0,0,IDATYP,.TRUE.)
ENDIF
C
IERR = VFSTECR(STDVV,STDVV,IPAK,IKULFILE,IDATEO,0,0,1,NJ,
+ NFLEV,IP1,IP2,IP3,'E',CFSTVAR(2),'STDDEV ',
+ 'X',0,0,0,0,IDATYP,.TRUE.)
C
IERR = VFSTECR(STDTT,STDTT,IPAK,IKULFILE,IDATEO,0,0,1,NJ,
+ NFLEV,IP1,IP2,IP3,'E',CFSTVAR(3),'STDDEV ',
+ 'X',0,0,0,0,IDATYP,.TRUE.)
C
IF (NCONF .EQ. 500) THEN
IERR = VFSTECR(STDLQ,STDLQ,IPAK,IKULFILE,IDATEO,0,0,1,NJ,
+ NFLEV,IP1,IP2,IP3,'E',CFSTVAR(4),'STDDEV ',
+ 'X',0,0,0,0,IDATYP,.TRUE.)
IERR = VFSTECR(STDPP,STDPP,IPAK,IKULFILE,IDATEO,0,0,1,NJ,
+ NFLEV,IP1,IP2,IP3,'E','PP','STDDEV ',
+ 'X',0,0,0,0,IDATYP,.TRUE.)
IERR = VFSTECR(STDCC,STDCC,IPAK,IKULFILE,IDATEO,0,0,1,NJ,
+ NFLEV,IP1,IP2,IP3,'E','CC','STDDEV ',
+ 'X',0,0,0,0,IDATYP,.TRUE.)
ENDIF
C
IERR = VFSTECR(STDP0,STDP0,IPAK,IKULFILE,IDATEO,0,0,1,NJ,
+ 1 ,IP1,IP2,IP3,'E',CFSTVAR2D(1),'STDDEV ',
+ 'X',0,0,0,0,IDATYP,.TRUE.)
C
IERR = FSTFRM(IKULFILE)
IERR = FCLOS(IKULFILE)
C
NENSEMBLE=0
C
RETURN
END