!-------------------------------------- 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_2(KULSTAT) 2,32
#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
* M. Buehner ARMA May 2008
* . Version of MEANGD for new PtoT approach
* with localized Tb correlations (NANALVAR=4)
*
*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 "comleg.cdk"
#include "comgd0.cdk"
#include "comgdpar.cdk"
#include "comcse1.cdk"
#include "comstdd.cdk"
#include "comstate.cdk"
*
INTEGER KULSTAT
C
INTEGER JENS, IENS, JK1, IERR, JFILE, JK, JLAT, JLON
integer ila,jn,jm
C
integer ipkind,jlev,iip3,itrnlnlev,iip1s,iip2
integer iip1s(jpnflev),iip2,iip3,itrlnlev,jlev, itrlgid
integer ipmode,ipkind,ip1_pak_trl,ip1_vco_trl
real zlev(jpnflev)
character*1 clstring
C
INTEGER FNOM, FSTOUV, FSTFRM, FCLOS, FSTPRM, FSTINF, 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, IP3LIST(600)
INTEGER ILISTE(600),IDATE(600), IDATV(600), IDIMAX, INFON, IFSTRUN, IHH
REAL*8 DHEURES,ZBUF(NI,NJ),ZBUFYZ(NJ,NFLEV),ZBUFY(NJ)
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
write(nulout,*) 'START OF MEANGD'
call flush(nulout)
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 = 600
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
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,IP3LIST(JENS),CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP
+ ,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
+ ,IUBC,IEXTR1,IEXTR2,IEXTR3)
C
DHEURES = DBLE(INPAS*IDEET)/3600.0
cbue
c DHEURES = 0.0d0
cjmb
CALL INCDATR(IDATV(JENS),IDATE(JENS),(DHEURES))
CALL NEWDATE(IDATV(JENS),IFSTRUN,IHH,-3)
WRITE(NULOUT,9320)JENS, IFSTRUN,IHH,IP3LIST(JENS)
END DO
9320 FORMAT(5X,"Case No. ",I3,5x,"Date and time: ",I10,5x,I8," and IP3=",I8)
C
IF(NENSEMBLE.EQ.0) THEN
NDATESTAT = IDATE(1)
END IF
C
CTYPVARN = CLTYPVAR
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,IP3LIST(JENS)
9310 FORMAT(///,5X,"--- Case No. ",I3,5x,"Date and time: ",I10,5x,I8,
+ " and IP3=",I8)
NSTAMPN = IDATV(JENS)
CALL GETFST(KULSTAT,'G','N',IP3LIST(JENS))
CALL REESPE(NKSDIM,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
c apply spectral filter
c DO JN = (NTRUNC-10),NTRUNC
c DO JM = 0, JN
c ILA = NIND(JM) + JN - JM
c DO JK = 1, NKSDIM
c SP(ILA,1,JK)=0.0
c SP(ILA,2,JK)=0.0
c ENDDO
c ENDDO
c ENDDO
CALL SPEREE(NKSDIM,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
c
c apply spectral filter
c
c CALL GDSP
c DO JN = 0, 4
c DO JM = 0, JN
c ILA = NIND(JM) + JN - JM
c DO JK = 1, NKSDIM
c SP(ILA,1,JK)=0.0
c SP(ILA,2,JK)=0.0
c ENDDO
c ENDDO
c ENDDO
c CALL SPGD
C
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 ! FOR PTOT CALCULATION
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 STD DEV 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)
IF(SGD(JLON,JK1,JLAT).gt.0.0) THEN
SGD(JLON,JK1,JLAT) = SQRT(SGD(JLON,JK1,JLAT))
ELSE
SGD(JLON,JK1,JLAT) = 0.0d0
ENDIF
ENDDO
ENDDO
ENDDO
C
C COMPUTE THE MEAN OF GD FOR THE ENSEMBLE
C
DO JLAT = NJBEG, NJEND
DO JK1 = 1, NKGDIM+2*NFLEV
DO JLON = NIBEG, NIEND
XMGD(JLON,JK1,JLAT) = XMGD(JLON,JK1,JLAT) / NENSEMBLE
ENDDO
ENDDO
ENDDO
c ********************************************************************
c WRITE OUT 3D STD DEV FIELDS
c
IPAK = -32
IDATYP = 5
IP1 = 0
IP2 = 0
IP3 = NENSEMBLE
IDATEO = NDATESTAT
C
IERR = FNOM(IKULFILE,'std_3d.fst','RND',0)
IERR = FSTOUV(IKULFILE,'RND')
C
IF (NCONF .EQ. 500) THEN ! FOR PTOT CALCULATION (UU is UU)
DO JK1=1,NFLEV
DO JLAT=1,NJ
ZFACT = 1. / (CONIMA(JLAT) * RMSKNT) ! TO GET TRUE UU VV IN KTS
DO JLON=1,NI
ZBUF(JLON,JLAT)=SUU(JLON,JK1,NJ+1-JLAT)*ZFACT
ENDDO
ENDDO
IERR = VFSTECR(ZBUF,ZBUF,IPAK,IKULFILE,IDATEO,0,0,NI,NJ,
+ 1,NIP1(jk1),IP2,IP3,'E',CFSTVAR(1),'STDDEV3D',
+ 'G',0,0,0,0,IDATYP,.TRUE.)
ENDDO
ENDIF
C
DO JK1=1,NFLEV
DO JLAT=1,NJ
IF ( NCONF .EQ. 500 ) THEN ! FOR PTOT CALCULATION
C TO GET TRUE UU VV IN KTS
ZFACT = 1. / (CONIMA(JLAT) * RMSKNT)
ELSE
ZFACT = 1.
ENDIF
DO JLON=1,NI
ZBUF(JLON,JLAT)=SVV(JLON,JK1,NJ+1-JLAT)*ZFACT
ENDDO
ENDDO
IERR = VFSTECR(ZBUF,ZBUF,IPAK,IKULFILE,IDATEO,0,0,NI,NJ,
+ 1,NIP1(JK1),IP2,IP3,'E',CFSTVAR(2),'STDDEV3D',
+ 'G',0,0,0,0,IDATYP,.TRUE.)
ENDDO
C
DO JK1=1,NFLEV
DO JLAT=1,NJ
DO JLON=1,NI
ZBUF(JLON,JLAT)=STT(JLON,JK1,NJ+1-JLAT)
ENDDO
ENDDO
IERR = VFSTECR(ZBUF,ZBUF,IPAK,IKULFILE,IDATEO,0,0,NI,NJ,
+ 1,NIP1(JK1),IP2,IP3,'E',CFSTVAR(3),'STDDEV3D',
+ 'G',0,0,0,0,IDATYP,.TRUE.)
ENDDO
C
IF (NCONF .EQ. 500) THEN ! FOR PTOT CALCULATION
DO JK1=1,NFLEV
DO JLAT=1,NJ
DO JLON=1,NI
ZBUF(JLON,JLAT)=SLQ(JLON,JK1,NJ+1-JLAT)
ENDDO
ENDDO
if(nfstvar.ge.4) then
IERR = VFSTECR(ZBUF,ZBUF,IPAK,IKULFILE,IDATEO,0,0,NI,NJ,
+ 1,NIP1(JK1),IP2,IP3,'E',CFSTVAR(4),'STDDEV3D',
+ 'G',0,0,0,0,IDATYP,.TRUE.)
endif
ENDDO
DO JK1=1,NFLEV
DO JLAT=1,NJ
DO JLON=1,NI
ZBUF(JLON,JLAT)=SPP(JLON,JK1,NJ+1-JLAT)
ENDDO
ENDDO
IERR = VFSTECR(ZBUF,ZBUF,IPAK,IKULFILE,IDATEO,0,0,NI,NJ,
+ 1,NIP1(JK1),IP2,IP3,'E','PP','STDDEV3D',
+ 'G',0,0,0,0,IDATYP,.TRUE.)
ENDDO
DO JK1=1,NFLEV
DO JLAT=1,NJ
DO JLON=1,NI
ZBUF(JLON,JLAT)=SCC(JLON,JK1,NJ+1-JLAT)
ENDDO
ENDDO
IERR = VFSTECR(ZBUF,ZBUF,IPAK,IKULFILE,IDATEO,0,0,NI,NJ,
+ 1,NIP1(JK1),IP2,IP3,'E','CC','STDDEV3D',
+ 'G',0,0,0,0,IDATYP,.TRUE.)
ENDDO
ENDIF
C
DO JLAT=1,NJ
DO JLON=1,NI
ZBUF(JLON,JLAT)=SP0(JLON,1,NJ+1-JLAT)*0.01
ENDDO
ENDDO
IERR = VFSTECR(ZBUF,ZBUF,IPAK,IKULFILE,IDATEO,0,0,NI,NJ,
+ 1 ,0,IP2,IP3,'E',CFSTVAR2D(1),'STDDEV3D',
+ 'G',0,0,0,0,IDATYP,.TRUE.)
C
IF (NCONF .EQ. 500 .AND. NGEXIST(NGTG).eq.1) THEN ! FOR PTOT CALCULATION
DO JLAT=1,NJ
DO JLON=1,NI
ZBUF(JLON,JLAT)=STG(JLON,1,NJ+1-JLAT)
ENDDO
ENDDO
IERR = VFSTECR(ZBUF,ZBUF,IPAK,IKULFILE,IDATEO,0,0,NI,NJ,
+ 1 ,0,IP2,IP3,'E','TG','STDDEV3D',
+ 'G',0,0,0,0,IDATYP,.TRUE.)
ENDIF
C
IERR = FSTFRM(IKULFILE)
IERR = FCLOS(IKULFILE)
c ********************************************************************
c WRITE OUT 3D MEAN FIELDS
c
IPAK = -32
IDATYP = 5
IP1 = 0
IP2 = 0
IP3 = NENSEMBLE
IDATEO = NDATESTAT
C
IERR = FNOM(IKULFILE,'mean_3d.fst','RND',0)
IERR = FSTOUV(IKULFILE,'RND')
C
IF (NCONF .EQ. 500) THEN ! FOR PTOT CALCULATION
DO JK1=1,NFLEV
DO JLAT=1,NJ
IF ( NCONF .EQ. 500 ) THEN ! FOR PTOT CALCULATION
C TO GET TRUE UU VV IN KTS
ZFACT = 1. / (CONIMA(JLAT) * RMSKNT)
ELSE
ZFACT = 1.
ENDIF
DO JLON=1,NI
ZBUF(JLON,JLAT)=XMUU(JLON,JK1,NJ+1-JLAT)*ZFACT
ENDDO
ENDDO
IERR = VFSTECR(ZBUF,ZBUF,IPAK,IKULFILE,IDATEO,0,0,NI,NJ,
+ 1,NIP1(jk1),IP2,IP3,'E',CFSTVAR(1),'MEAN3D ',
+ 'G',0,0,0,0,IDATYP,.TRUE.)
ENDDO
ENDIF
C
DO JK1=1,NFLEV
DO JLAT=1,NJ
IF ( NCONF .EQ. 500 ) THEN ! FOR PTOT CALCULATION
C TO GET TRUE UU VV IN KTS
ZFACT = 1. / (CONIMA(JLAT) * RMSKNT)
ELSE
ZFACT = 1.
ENDIF
DO JLON=1,NI
ZBUF(JLON,JLAT)=XMVV(JLON,JK1,NJ+1-JLAT)*ZFACT
ENDDO
ENDDO
IERR = VFSTECR(ZBUF,ZBUF,IPAK,IKULFILE,IDATEO,0,0,NI,NJ,
+ 1,NIP1(JK1),IP2,IP3,'E',CFSTVAR(2),'MEAN3D ',
+ 'G',0,0,0,0,IDATYP,.TRUE.)
ENDDO
C
DO JK1=1,NFLEV
DO JLAT=1,NJ
DO JLON=1,NI
ZBUF(JLON,JLAT)=XMTT(JLON,JK1,NJ+1-JLAT)
ENDDO
ENDDO
IERR = VFSTECR(ZBUF,ZBUF,IPAK,IKULFILE,IDATEO,0,0,NI,NJ,
+ 1,NIP1(JK1),IP2,IP3,'E',CFSTVAR(3),'MEAN3D ',
+ 'G',0,0,0,0,IDATYP,.TRUE.)
ENDDO
C
IF (NCONF .EQ. 500) THEN ! FOR PTOT CALCULATION
DO JK1=1,NFLEV
DO JLAT=1,NJ
DO JLON=1,NI
ZBUF(JLON,JLAT)=XMLQ(JLON,JK1,NJ+1-JLAT)
ENDDO
ENDDO
if(nfstvar.ge.4) then
IERR = VFSTECR(ZBUF,ZBUF,IPAK,IKULFILE,IDATEO,0,0,NI,NJ,
+ 1,NIP1(JK1),IP2,IP3,'E',CFSTVAR(4),'MEAN3D ',
+ 'G',0,0,0,0,IDATYP,.TRUE.)
endif
ENDDO
DO JK1=1,NFLEV
DO JLAT=1,NJ
DO JLON=1,NI
ZBUF(JLON,JLAT)=XMPP(JLON,JK1,NJ+1-JLAT)
ENDDO
ENDDO
IERR = VFSTECR(ZBUF,ZBUF,IPAK,IKULFILE,IDATEO,0,0,NI,NJ,
+ 1,NIP1(JK1),IP2,IP3,'E','PP','MEAN3D ',
+ 'G',0,0,0,0,IDATYP,.TRUE.)
ENDDO
DO JK1=1,NFLEV
DO JLAT=1,NJ
DO JLON=1,NI
ZBUF(JLON,JLAT)=XMCC(JLON,JK1,NJ+1-JLAT)
ENDDO
ENDDO
IERR = VFSTECR(ZBUF,ZBUF,IPAK,IKULFILE,IDATEO,0,0,NI,NJ,
+ 1,NIP1(JK1),IP2,IP3,'E','CC','MEAN3D ',
+ 'G',0,0,0,0,IDATYP,.TRUE.)
ENDDO
ENDIF
C
DO JLAT=1,NJ
DO JLON=1,NI
ZBUF(JLON,JLAT)=XMP0(JLON,1,NJ+1-JLAT)*0.01
ENDDO
ENDDO
IERR = VFSTECR(ZBUF,ZBUF,IPAK,IKULFILE,IDATEO,0,0,NI,NJ,
+ 1 ,0,IP2,IP3,'E',CFSTVAR2D(1),'MEAN3D ',
+ 'G',0,0,0,0,IDATYP,.TRUE.)
C
IF (NCONF .EQ. 500 .AND. NGEXIST(NGTG).eq.1) THEN ! FOR PTOT CALCULATION
DO JLAT=1,NJ
DO JLON=1,NI
ZBUF(JLON,JLAT)=XMTG(JLON,1,NJ+1-JLAT)
ENDDO
ENDDO
if(nfstvar2d.ge.2) then
IERR = VFSTECR(ZBUF,ZBUF,IPAK,IKULFILE,IDATEO,0,0,NI,NJ,
+ 1 ,0,IP2,IP3,'E',CFSTVAR2D(2),'MEAN3D ',
+ 'G',0,0,0,0,IDATYP,.TRUE.)
endif
ENDIF
C
IERR = FSTFRM(IKULFILE)
IERR = FCLOS(IKULFILE)
c ********************************************************************
C
C ACCUMULATE ZONAL VALUES OF VARIANCES
C
DO JK1=1,NFLEV
DO JLAT = 1, NJ
STDUU(JLAT,JK1) = 0.0d0
STDVV(JLAT,JK1) = 0.0d0
STDTT(JLAT,JK1) = 0.0d0
STDLQ(JLAT,JK1) = 0.0d0
STDPP(JLAT,JK1) = 0.0d0
STDCC(JLAT,JK1) = 0.0d0
ENDDO
ENDDO
DO JLAT = 1, NJ
STDP0(JLAT) = 0.0d0
IF (NGEXIST(NGTG).eq.1) STDTG(JLAT) = 0.0d0
ENDDO
C
DO JLAT = 1, NJ
DO JK1 = 1, NFLEV
DO JLON = 1, NI
STDUU(JLAT,JK1) = STDUU(JLAT,JK1) + SUU(JLON,JK1,JLAT)*SUU(JLON,JK1,JLAT)
STDVV(JLAT,JK1) = STDVV(JLAT,JK1) + SVV(JLON,JK1,JLAT)*SVV(JLON,JK1,JLAT)
STDTT(JLAT,JK1) = STDTT(JLAT,JK1) + STT(JLON,JK1,JLAT)*STT(JLON,JK1,JLAT)
STDLQ(JLAT,JK1) = STDLQ(JLAT,JK1) + SLQ(JLON,JK1,JLAT)*SLQ(JLON,JK1,JLAT)
STDPP(JLAT,JK1) = STDPP(JLAT,JK1) + SPP(JLON,JK1,JLAT)*SPP(JLON,JK1,JLAT)
STDCC(JLAT,JK1) = STDCC(JLAT,JK1) + SCC(JLON,JK1,JLAT)*SCC(JLON,JK1,JLAT)
ENDDO
ENDDO
ENDDO
DO JLAT = 1, NJ
DO JLON = 1, NI
STDP0(JLAT) = STDP0(JLAT) + SP0(JLON,1,JLAT)*SP0(JLON,1,JLAT)
IF (NGEXIST(NGTG).eq.1) THEN
STDTG(JLAT) = STDTG(JLAT) + STG(JLON,1,JLAT)*STG(JLON,1,JLAT)
ENDIF
ENDDO
ENDDO
C
C STD DEV = SQRT OF ZONAL AVERAGE OF VARIANCES
C
DO JLAT = 1, NJ
DO JK1=1,NFLEV
IF(STDUU(JLAT,JK1).gt.0.0) THEN
STDUU(JLAT,JK1) = SQRT(STDUU(JLAT,JK1)/NILON(JLAT))
ELSE
STDUU(JLAT,JK1) = 0.0d0
ENDIF
IF(STDVV(JLAT,JK1).gt.0.0) THEN
STDVV(JLAT,JK1) = SQRT(STDVV(JLAT,JK1)/NILON(JLAT))
ELSE
STDVV(JLAT,JK1) = 0.0d0
ENDIF
IF(STDTT(JLAT,JK1).gt.0.0) THEN
STDTT(JLAT,JK1) = SQRT(STDTT(JLAT,JK1)/NILON(JLAT))
ELSE
STDTT(JLAT,JK1) = 0.0d0
ENDIF
IF(STDLQ(JLAT,JK1).gt.0.0) THEN
STDLQ(JLAT,JK1) = SQRT(STDLQ(JLAT,JK1)/NILON(JLAT))
ELSE
STDLQ(JLAT,JK1) = 0.0d0
ENDIF
IF(STDPP(JLAT,JK1).gt.0.0) THEN
STDPP(JLAT,JK1) = SQRT(STDPP(JLAT,JK1)/NILON(JLAT))
ELSE
STDPP(JLAT,JK1) = 0.0d0
ENDIF
IF(STDCC(JLAT,JK1).gt.0.0) THEN
STDCC(JLAT,JK1) = SQRT(STDCC(JLAT,JK1)/NILON(JLAT))
ELSE
STDCC(JLAT,JK1) = 0.0d0
ENDIF
ENDDO
ENDDO
DO JLAT = 1, NJ
IF(STDP0(JLAT).gt.0.0) THEN
STDP0(JLAT) = SQRT(STDP0(JLAT)/NILON(JLAT))
ELSE
STDP0(JLAT) = 0.0d0
ENDIF
IF (NGEXIST(NGTG).eq.1) THEN
IF(STDTG(JLAT).gt.0.0) THEN
STDTG(JLAT) = SQRT(STDTG(JLAT)/NILON(JLAT))
ELSE
STDTG(JLAT) = 0.0d0
ENDIF
ENDIF
ENDDO
C
C OUTPUT STD DEV OF EITHER UU VV TT LQ PP CC P0 TG
C OR UC UT UP
C
IPAK = -32
IDATYP = 5
IP1 = 0
IP2 = 0
IP3 = NENSEMBLE
IDATEO = NDATESTAT
C
IF (NCONF .EQ. 500) THEN ! FOR PTOT CALCULATION
CLFLFILE = CFLPTOT
ELSE
CLFLFILE = CFLSTDEV
ENDIF
write(nulout,*) 'TRYING TO OPEN FILE:',CLFLFILE
call flush(nulout)
C
IERR = FNOM(IKULFILE,CLFLFILE,'RND',0)
IERR = FSTOUV(IKULFILE,'RND')
C
IF (NCONF .EQ. 500) THEN ! FOR PTOT CALCULATION
DO JK1=1,NFLEV
DO JLAT=1,NJ
ZFACT = 1. / (CONIMA(JLAT) * RMSKNT) ! TO GET TRUE UU VV IN KTS
ZBUFYZ(JLAT,JK1)=STDUU(NJ-JLAT+1,JK1)*zfact
ENDDO
ENDDO
IERR = VFSTECR(ZBUFYZ,ZBUFYZ,IPAK,IKULFILE,IDATEO,0,0,1,NJ,
+ NFLEV,IP1,IP2,IP3,'E',CFSTVAR(1),'STDDEV ',
+ 'X',0,0,0,0,IDATYP,.TRUE.)
ENDIF
C
DO JK1=1,NFLEV
DO JLAT=1,NJ
IF (NCONF .EQ. 500) THEN ! FOR PTOT CALCULATION
ZFACT = 1. / (CONIMA(JLAT) * RMSKNT) ! TO GET TRUE UU VV IN KTS
ELSE
ZFACT = 1.0d0
ENDIF
ZBUFYZ(JLAT,JK1)=STDVV(NJ-JLAT+1,JK1)*zfact
ENDDO
ENDDO
IERR = VFSTECR(ZBUFYZ,ZBUFYZ,IPAK,IKULFILE,IDATEO,0,0,1,NJ,
+ NFLEV,IP1,IP2,IP3,'E',CFSTVAR(2),'STDDEV ',
+ 'X',0,0,0,0,IDATYP,.TRUE.)
C
DO JK1=1,NFLEV
DO JLAT=1,NJ
ZBUFYZ(JLAT,JK1)=STDTT(NJ-JLAT+1,JK1)
ENDDO
ENDDO
IERR = VFSTECR(ZBUFYZ,ZBUFYZ,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 ! FOR PTOT CALCULATION
if(nfstvar.ge.4) then
DO JK1=1,NFLEV
DO JLAT=1,NJ
ZBUFYZ(JLAT,JK1)=STDLQ(NJ-JLAT+1,JK1)
ENDDO
ENDDO
IERR = VFSTECR(ZBUFYZ,ZBUFYZ,IPAK,IKULFILE,IDATEO,0,0,1,NJ,
+ NFLEV,IP1,IP2,IP3,'E',CFSTVAR(4),'STDDEV ',
+ 'X',0,0,0,0,IDATYP,.TRUE.)
endif
C
DO JK1=1,NFLEV
DO JLAT=1,NJ
ZBUFYZ(JLAT,JK1)=STDPP(NJ-JLAT+1,JK1)
ENDDO
ENDDO
IERR = VFSTECR(ZBUFYZ,ZBUFYZ,IPAK,IKULFILE,IDATEO,0,0,1,NJ,
+ NFLEV,IP1,IP2,IP3,'E','PP','STDDEV ',
+ 'X',0,0,0,0,IDATYP,.TRUE.)
DO JK1=1,NFLEV
DO JLAT=1,NJ
ZBUFYZ(JLAT,JK1)=STDCC(NJ-JLAT+1,JK1)
ENDDO
ENDDO
IERR = VFSTECR(ZBUFYZ,ZBUFYZ,IPAK,IKULFILE,IDATEO,0,0,1,NJ,
+ NFLEV,IP1,IP2,IP3,'E','CC','STDDEV ',
+ 'X',0,0,0,0,IDATYP,.TRUE.)
ENDIF
C
DO JLAT=1,NJ
ZBUFY(JLAT)=STDP0(NJ-JLAT+1)*0.01
ENDDO
IERR = VFSTECR(ZBUFY,ZBUFY,IPAK,IKULFILE,IDATEO,0,0,1,NJ,
+ 1 ,IP1,IP2,IP3,'E',CFSTVAR2D(1),'STDDEV ',
+ 'X',0,0,0,0,IDATYP,.TRUE.)
C
IF ( NCONF .EQ. 500 .AND. NGEXIST(NGTG).eq.1) THEN ! FOR PTOT CALCULATION
if(nfstvar2d.ge.2) then
DO JLAT=1,NJ
ZBUFY(JLAT)=STDTG(NJ-JLAT+1)
ENDDO
IERR = VFSTECR(ZBUFY,ZBUFY,IPAK,IKULFILE,IDATEO,0,0,1,NJ,
+ 1 ,IP1,IP2,IP3,'E',CFSTVAR2D(2),'STDDEV ',
+ 'X',0,0,0,0,IDATYP,.TRUE.)
endif
ENDIF
IERR = FSTFRM(IKULFILE)
IERR = FCLOS(IKULFILE)
C
C STD DEV = SQRT OF ZONAL AVERAGE OF VARIANCES
C
DO JK1=1,NFLEV
STDUUG(JK1) = 0.0d0
STDVVG(JK1) = 0.0d0
STDTTG(JK1) = 0.0d0
STDLQG(JK1) = 0.0d0
STDPPG(JK1) = 0.0d0
STDCCG(JK1) = 0.0d0
ENDDO
DO JK1=1,NFLEV
DO JLAT = 1, NJ
STDUUG(JK1) = STDUUG(JK1)+STDUU(JLAT,JK1)*STDUU(JLAT,JK1)
STDVVG(JK1) = STDVVG(JK1)+STDVV(JLAT,JK1)*STDVV(JLAT,JK1)
STDTTG(JK1) = STDTTG(JK1)+STDTT(JLAT,JK1)*STDTT(JLAT,JK1)
STDLQG(JK1) = STDLQG(JK1)+STDLQ(JLAT,JK1)*STDLQ(JLAT,JK1)
STDPPG(JK1) = STDPPG(JK1)+STDPP(JLAT,JK1)*STDPP(JLAT,JK1)
STDCCG(JK1) = STDCCG(JK1)+STDCC(JLAT,JK1)*STDCC(JLAT,JK1)
ENDDO
ENDDO
DO JK1=1,NFLEV
IF(STDUUG(JK1).gt.0.0) THEN
STDUUG(JK1) = SQRT(STDUUG(JK1)/NJ)
ELSE
STDUUG(JK1) = 0.0d0
ENDIF
IF(STDVVG(JK1).gt.0.0) THEN
STDVVG(JK1) = SQRT(STDVVG(JK1)/NJ)
ELSE
STDVVG(JK1) = 0.0d0
ENDIF
IF(STDTTG(JK1).gt.0.0) THEN
STDTTG(JK1) = SQRT(STDTTG(JK1)/NJ)
ELSE
STDTTG(JK1) = 0.0d0
ENDIF
IF(STDLQG(JK1).gt.0.0) THEN
STDLQG(JK1) = SQRT(STDLQG(JK1)/NJ)
ELSE
STDLQG(JK1) = 0.0d0
ENDIF
IF(STDPPG(JK1).gt.0.0) THEN
STDPPG(JK1) = SQRT(STDPPG(JK1)/NJ)
ELSE
STDPPG(JK1) = 0.0d0
ENDIF
IF(STDCCG(JK1).gt.0.0) THEN
STDCCG(JK1) = SQRT(STDCCG(JK1)/NJ)
ELSE
STDCCG(JK1) = 0.0d0
ENDIF
ENDDO
STDP0G = 0.0d0
DO JLAT = 1, NJ
STDP0G = STDP0G+STDP0(JLAT)*STDP0(JLAT)
ENDDO
IF(STDP0G.gt.0.0) THEN
STDP0G = SQRT(STDP0G/NJ)
ELSE
STDP0G = 0.0d0
ENDIF
IF (NGEXIST(NGTG).eq.1) THEN
STDTGG = 0.0d0
DO JLAT = 1, NJ
STDTGG = STDTGG+STDTG(JLAT)*STDTG(JLAT)
ENDDO
IF(STDTGG.gt.0.0) THEN
STDTGG = SQRT(STDTGG/NJ)
ELSE
STDTGG = 0.0d0
ENDIF
ENDIF
C
NENSEMBLE=0
C
RETURN
END