!-------------------------------------- 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 meancvgd_glb1(kulstat,koutfile,ldhelm,ldfplane,ldtb_psi, 1,59
& ldcoriol_one)
#if defined (DOC)
*
* * s/r meancvgd_glb1: Compute mean and variances of gridpoint control-vector
* variables from forecast error samples for the
* LAM4D configuration. Then, store on file.
*
* Author: L. Fillion - ARMA/EC - 28 May 2009.
* Revision:
* L. Fillion - ARMA/EC - 22 Sept 09 - Zonal computations validated.
* WARNING: ****************** : All fields written on file are to be read by a subsequent subroutine
* to compute B-correlations except zonal fields. PS is scaled before writing
* and the inverse scaling is applied by the following subroutine that reads it
* (cf. cse1glb.ftn).
*
* Zonal fields can be used from this writing on file
* for a later minimization experiment. Those fields are scaled and pole-flipped
* to agree with RPN standard files structure.
* L. Fillion - ARMA/EC - May 2010 - Clean the dode a bit.
*
* 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 "comgd1.cdk"
#include "comgdpar.cdk"
#include "comcse1.cdk"
#include "comcva.cdk"
#include "comleg.cdk"
*
logical ldhelm,ldfplane,ldtb_psi,llzdpc,ldcoriol_one
INTEGER KULSTAT,koutfile
!
logical llfiltersdev,llfilt,llvproj,llvfilt
INTEGER JENS, IENS, jk1, IERR, JFILE, iensemble, iflag
integer ji,jj,jk,jvar,jla,inbvar,icase,itrunc,indjj
parameter(inbvar=7)
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
!
integer idum1,idum2,idum3,idum4
real*8 zthreshold,zni,zdla2,zcon
REAL*8 DLA2
REAL*8 ZFACT,zmin,zmax
INTEGER IPAK, IDATEO
CHARACTER*128 CLFLFILE
!
real*8 zx8(ni),zy8(nj)
!
real*8 zmpp(ni,nflev,nj)
real*8 zmcu(ni,nflev,nj)
real*8 zmtu(ni,nflev,nj)
real*8 zmlq(ni,nflev,nj)
real*8 zmtb(ni,nflev,nj)
!
real*8 zmpsu(ni,nj)
real*8 zmpsb(ni,nj)
real*8 zmtg(ni,nj)
!
real*8 zstb(ni,nflev,nj)
!
real*8 zspsu(ni,nj)
real*8 zspsb(ni,nj)
real*8 zstg(ni,nj)
!
real*8 z2d(ni,nj)
!
real*8 zpb(ni,nflev,nj)
real*8 zt0(ni,nflev,nj)
real*8 ztb(ni,nflev,nj)
real*8 ztu(ni,nflev,nj)
!
real*8 zpsb(ni,nj)
real*8 zpsu(ni,nj)
!
!
real*8 zonalpp(nj,nflev)
real*8 zonalcu(nj,nflev)
real*8 zonaltu(nj,nflev)
real*8 zonaltb(nj,nflev)
real*8 zonallq(nj,nflev)
real*8 zonalpsu(nj)
real*8 zonaltg(nj)
real*8 zonalpb(nj)
!
!
!!
!
zonalpp(:,:) = 0.
zonalcu(:,:) = 0.
zonaltu(:,:) = 0.
zonaltb(:,:) = 0.
zonallq(:,:) = 0.
zonalpsu(:) = 0.
zonaltg(:) = 0.
zonalpb(:) = 0.
!
llfiltersdev = .false.
llfilt = .false.
if(lflt_low) then
llfilt = .true.
clflt = 'L'
else if(lflt_high) then
llfilt = .true.
clflt = 'H'
endif
llvfilt = .false.
llvproj = .false.
!
clvar(1) = 'PP'
clvar(2) = 'CC'
if(.not.ldhelm) then
clvar(1) = 'QQ'
clvar(2) = 'DD'
endif
llzdpc = .false.
if(cfstvar(1).eq.'UU') llzdpc = .true.
write(nulout,*) 'meancvgd_glb1: cfstvar(1) = ',cfstvar(1)
write(nulout,*) 'meancvgd_glb1: llzdpc=',llzdpc
clvar(3) = 'TT'
clvar(4) = 'LQ'
clvar(5) = 'TB'
clvar(6) = 'PU'
clvar(7) = 'PB'
!
!
zthreshold = 1.e-15
DLA2 = DBLE(RA) * DBLE(RA)
IDIMAX = 100
write(nulout,*) 'meancvgd_glb1: BEGIN '
write(nulout,*) 'meancvgd_glb1: NFLSTAT = ',NFLSTAT
! -----------------------
!*1 Initialize accumulators
! -----------------------
zmpp(:,:,:) = 0.0
zmcu(:,:,:) = 0.0
zmtu(:,:,:) = 0.0
zmlq(:,:,:) = 0.0
zmtb(:,:,:) = 0.0
zmpsu(:,:) = 0.0
zmpsb(:,:) = 0.0
zmtg(:,:) = 0.0
!
call transfer('ZGD1')
zstb(:,:,:) = 0.0
zspsb(:,:) = 0.0
zspsu(:,:) = 0.0
zstg(:,:) = 0.0
!
! -------------------------------------------------------------
!*2 Access the increments from a set of files (loop on the files)
! -------------------------------------------------------------
!
iensemble = 0
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'
write(NULOUT,*)
IERR = FSTINL (KULSTAT,INI,INJ,INK
& ,-1,CETIKETERR,IP1,IP2,IP3,' '
& ,CLNOMVAR,ILISTE,INFON,IDIMAX)
!
WRITE(NULOUT,9210)INFON
9210 FORMAT(//,4X,"meancvgd_glb1: Ensemble of ",I4," increments")
IF(INFON.EQ.0) THEN
WRITE(NULOUT,*)' THIS FILE IS EMPTY.
$ CHECK THE SELECTION CRITERIA'
CALL ABORT3D(NULOUT,'meancvgd_glb1: 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)
!
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
!
! 2.3.1
call geterr(kulstat,'G','E',icase)
!
do ji=1,ni
do jj=1,nj
zpsb(ji,jj)=gps0(ji,1,jj)
enddo
enddo
!
call maxmin(zpsb,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'meancvgd_glb1',
& 'P0 ')
!
! 2.3.2
!
if(llzdpc) then
call gdsp ! (U,V) --> (spvor,spdiv)
if(ldhelm) then
!
! CONVERT FROM VORT/DIV TO PSI/CHI
!
zdla2 = DBLE(RA)*DBLE(RA)
DO JK = 1, NFLEV
DO jla = 1, NLA
SPVOR(jla,1,JK) = SPVOR(jla,1,JK) * ZDLA2*R1SNP1(jla)
SPVOR(jla,2,JK) = SPVOR(jla,2,JK) * ZDLA2*R1SNP1(jla)
SPDIV(jla,1,JK) = SPDIV(jla,1,JK) * ZDLA2*R1SNP1(jla)
SPDIV(jla,2,JK) = SPDIV(jla,2,JK) * ZDLA2*R1SNP1(jla)
ENDDO
ENDDO
endif
CALL SPEREE(NKSDIM,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,nksdim)
!cluc to test f*psi approach ... remove !!!
! do jj=1,nj
! zcon = 2.*ROMEGA*RMU(jj)
! do ji=1,ni
! do jk=1,nflev
! ut0(ji,jk,jj) = zcon*ut0(ji,jk,jj)
! enddo
! enddo
! enddo
!cluc to test f*psi approach ... remove !!!
endif
!
if(llfilt) then
write(nulout,*) 'meancvgd_glb1: **************************************'
write(nulout,*) 'meancvgd_glb1: PP error sample is spectrally filtered'
write(nulout,*) 'meancvgd_glb1: **************************************'
else
write(nulout,*) 'meancvgd_glb1: NO FILTER applied to PP error sample'
endif
!
ztb(:,:,:) = 0.0
zpb(:,:,:) = 0.0
zpsb(:,:) = 0.0
zt0(:,:,:) = 0.0
!
write(nulout,*) ' '
write(nulout,*) 'meancvgd_glb1: ****************************************'
write(nulout,*) 'meancvgd_glb1: Uses Balance operators of Order = ',mbal_order
write(nulout,*) 'meancvgd_glb1: ****************************************'
write(nulout,*) ' '
!
if(mbal_order.eq.1) then
!
! Linear-Geostrophic
! ------------------
!
if(ldtb_psi) then
! CALL LINBAL(+1,.FALSE.) ! add code after to use spgz ...
else
do jk=1,nflev
do jj=1,nj
do ji=1,ni
! zpb(ji,jk,jj)=zvort(ji,jk,jj)
enddo
enddo
enddo
endif
if(llvfilt) call vfilt(zpb,5,'L')
if(llvproj) call vproj(zpb,zpb,nflev)
!
! call p2tpsb(zt0,zpsb,zpb,cptot,.false.,.true.) ! build Tb, psb from psi
!
if(llvproj) call viproj(zt0,zt0,nflev)
!
else if(mbal_order.eq.2) then
!
! Tangent-Linear 2nd-Order Balance
! ---------------------------------
!
endif
!
if(llvfilt) call vfilt(zt0,5,'L')
call maxmin(zt0,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'meancvgd_glb1',
& 'T0 ')
!
do ji=1,ni
do jj=1,nj
do jk=1,nflev
tt0(ji,jk,jj) = tt0(ji,jk,jj)-zt0(ji,jk,jj)
enddo
enddo
enddo
!
do ji=1,ni
do jj=1,nj
zpsu(ji,jj)=gps0(ji,1,jj)-zpsb(ji,jj)
enddo
enddo
!
write(nulout,*) 'meancvgd_glb1: Balanced Surface Pressure'
! call maxmin(zpsb,ni,nj,1,zmin,zmax,
! & idum1,idum2,idum3,idum4,'meancvgd_glb1',
! & 'P0B')
!
!
! ACCUMULATE SUM OF ELEMENTS AND SUM OF SQUARED ELEMENTS
!
! ldhelm: Loop for Psi, Chi, Tu, lq, ps_u, TG (control variables)
! .not.ldhelm: Loop for Vort , Div, Tu, lq, ps_u, TG (control variables)
!
do jj = 1, nj
do ji = 1, ni
do jk1 = 1, nflev
zmpp(ji,jk1,jj) = zmpp(ji,jk1,jj) + ut0(ji,jk1,jj)
zmcu(ji,jk1,jj) = zmcu(ji,jk1,jj) + vt0(ji,jk1,jj)
zmtu(ji,jk1,jj) = zmtu(ji,jk1,jj) + tt0(ji,jk1,jj)
zmlq(ji,jk1,jj) = zmlq(ji,jk1,jj) + q0(ji,jk1,jj)
!
ut1(ji,jk1,jj) = ut1(ji,jk1,jj)
& + ut0(ji,jk1,jj)*ut0(ji,jk1,jj)
vt1(ji,jk1,jj) = vt1(ji,jk1,jj)
& + vt0(ji,jk1,jj)*vt0(ji,jk1,jj)
tt1(ji,jk1,jj) = tt1(ji,jk1,jj)
& + tt0(ji,jk1,jj)*tt0(ji,jk1,jj)
q1(ji,jk1,jj) = q1(ji,jk1,jj)
& + q0(ji,jk1,jj)*q0(ji,jk1,jj)
enddo
zmpsu(ji,jj) = zmpsu(ji,jj) + gps0(ji,1,jj)
zmtg(ji,jj) = zmtg(ji,jj) + tt0(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)
& + tt0(ji,nflev,jj)*tt0(ji,nflev,jj) ! Use Tu at surface until TG is abord.... cluc
enddo
enddo
call maxmin(zmpp,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'meancvgd_glb1',
& 'ZMP')
! Loop for Tb, Psb (extra variables)
!
do jj = 1, nj
do jk1 = 1, NFLEV
do ji = 1, ni
zmtb(ji,jk1,jj) = zmtb(ji,jk1,jj) + ztb(ji,jk1,jj)
zstb(ji,jk1,jj) = zstb(ji,jk1,jj) +
$ ztb(ji,jk1,jj)*ztb(ji,jk1,jj)
enddo
enddo
enddo
do jj = 1, nj
do ji = 1, ni
zmpsb(ji,jj) = zmpsb(ji,jj) + zpsb(ji,jj)
zspsb(ji,jj) = zspsb(ji,jj) +
$ zpsb(ji,jj)*zpsb(ji,jj)
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,*) 'meancvgd_glb1: iensemble = ',iensemble
!
! write(nulout,*) 'meancvgd_glb1: zmtb apres loop sur les echantillons'
if(mbal_order.gt.0) then
! call maxmin(zmtb,ni,nj,nflev,zmin,zmax,
! & idum1,idum2,idum3,idum4,'meancvgd_glb1',
! & 'TB ')
endif
! ----------------------------------------
!*3. COMPUTE VARIANCES OF GD FOR THE ENSEMBLE
! ----------------------------------------
! Loop for Psi, Chi, Tu, Psu, lq (control variables)
DO jj = 1,nj
DO ji = 1,ni
do jk1 = 1, nflev
ut1(ji,jk1,jj) = ( ut1(ji,jk1,jj) -
+ ((zmpp(ji,jk1,jj)*zmpp(ji,jk1,jj)) / iensemble )) /
+ (iensemble - 1)
if (ut1(ji,jk1,jj).eq.0.0) ut1(ji,jk1,jj)=zthreshold
!
vt1(ji,jk1,jj) = ( vt1(ji,jk1,jj) -
+ ((zmcu(ji,jk1,jj)*zmcu(ji,jk1,jj)) / iensemble )) /
+ (iensemble - 1)
if (vt1(ji,jk1,jj).eq.0.0) vt1(ji,jk1,jj)=zthreshold
!
tt1(ji,jk1,jj) = ( tt1(ji,jk1,jj) -
+ ((zmtu(ji,jk1,jj)*zmtu(ji,jk1,jj)) / iensemble )) /
+ (iensemble - 1)
if (tt1(ji,jk1,jj).eq.0.0) tt1(ji,jk1,jj)=zthreshold
!
q1(ji,jk1,jj) = ( q1(ji,jk1,jj) -
+ ((zmlq(ji,jk1,jj)*zmlq(ji,jk1,jj)) / iensemble )) /
+ (iensemble - 1)
if (q1(ji,jk1,jj).eq.0.0) q1(ji,jk1,jj)=zthreshold
ENDDO
zspsu(ji,jj) = ( zspsu(ji,jj) -
+ ((zmpsu(ji,jj)*zmpsu(ji,jj)) / iensemble )) /
+ (iensemble - 1)
if (zspsu(ji,jj).eq.0.0) zspsu(ji,jj)=zthreshold
zstg(ji,jj) = ( zstg(ji,jj) -
+ ((zmtg(ji,jj)*zmtg(ji,jj)) / iensemble )) /
+ (iensemble - 1)
if (zstg(ji,jj).eq.0.0) zstg(ji,jj)=zthreshold
ENDDO
ENDDO
! Loop for Tb, Psb (extra variables)
DO jj = 1,nj
do jk1 = 1, NFLEV
DO ji = 1,ni
ZSTB(ji,jk1,jj) = ( ZSTB(ji,jk1,jj) -
+ ((zmtb(ji,jk1,jj)*zmtb(ji,jk1,jj)) / iensemble )) /
+ (iensemble - 1)
if (zstb(ji,jk1,jj).eq.0.0) zstb(ji,jk1,jj)=zthreshold
ENDDO
ENDDO
ENDDO
DO jj = 1,nj
DO ji = 1,ni
ZSPSB(ji,jj) = ( ZSPSB(ji,jj) -
+ ((ZMPSB(ji,jj)*ZMPSB(ji,jj)) / iensemble )) /
+ (iensemble - 1)
if (zspsb(ji,jj).eq.0.0) zspsb(ji,jj)=zthreshold
ENDDO
ENDDO
!
! ---------------------------------------
!*4. COMPUTE THE MEAN OF GD FOR THE ENSEMBLE
! ---------------------------------------
c Loop for Psi, Chi, Tu, Psu, lq (control variables)
DO jj = 1,nj
DO ji = 1,ni
do jk1 = 1, nflev
zmpp(ji,jk1,jj) = zmpp(ji,jk1,jj) / iensemble
zmcu(ji,jk1,jj) = zmcu(ji,jk1,jj) / iensemble
zmtu(ji,jk1,jj) = zmtu(ji,jk1,jj) / iensemble
zmlq(ji,jk1,jj) = zmlq(ji,jk1,jj) / iensemble
zmtb(ji,jk1,jj) = zmtb(ji,jk1,jj) / iensemble
ENDDO
zmpsu(ji,jj) = zmpsu(ji,jj) / iensemble
zmtg(ji,jj) = zmtg(ji,jj) / iensemble
zmpsb(ji,jj) = zmpsb(ji,jj) / iensemble
ENDDO
ENDDO
!
! call maxmin(zmeanpsu,ni,nj,1,zmin,zmax,
! & idum1,idum2,idum3,idum4,'meancvgd_glb1',
! & 'PUM')
! call maxmin(zmeantg,ni,nj,1,zmin,zmax,
! & idum1,idum2,idum3,idum4,'meancvgd_glb1',
! & 'TGM')
!
! -------
!*5 STD DEV
! -------
do jj=1,nj
do ji=1,ni
! Psu
if (zspsu(ji,jj).le.0.0) then
write(nulout,*) 'meancvgd_glb1: ji,jj,zspsu=',
& ji,jj,zspsu(ji,jj)
call abort3d(nulout,'meancvgd_glb1: ps_u st-dev problem!')
endif
zspsu(ji,jj) = sqrt(zspsu(ji,jj))
! TG
if (zstg(ji,jj).le.0.0) then
write(nulout,*) 'meancvgd_glb1: ji,jj,zstg=',
& ji,jj,zstg(ji,jj)
call abort3d(nulout,'meancvgd_glb1: TG st-dev problem!')
endif
zstg(ji,jj) = sqrt(zstg(ji,jj))
! Psb
if (zspsb(ji,jj).le.0.0) then
write(nulout,*) 'meancvgd_glb1: ji,jj,zspspb=',
& ji,jj,zspsb(ji,jj)
call abort3d(nulout,'meancvgd_glb1: ps_b st-dev problem!')
endif
zspsb(ji,jj) = sqrt(zspsb(ji,jj))
do jk=1,nflev
!
if(ut1(ji,jk,jj).le.0.0) then ! Psi
write(nulout,*) 'meancvgd_glb1: ji,jk,jj,ut1=',
& ji,jk,jj,ut1(ji,jk,jj)
call abort3d(nulout,'meancvgd_glb1: PSI st-dev problem!')
else if(vt1(ji,jk,jj).le.0.0) then ! Chi
write(nulout,*) 'meancvgd_glb1: ji,jk,jj,ut1=',
& ji,jk,jj,ut1(ji,jk,jj)
call abort3d(nulout,'meancvgd_glb1: CHI_u st-dev problem!')
else if(tt1(ji,jk,jj).le.0.0) then ! Tu
write(nulout,*) 'meancvgd_glb1: ji,jk,jj,tt1=',
& ji,jk,jj,tt1(ji,jk,jj)
call abort3d(nulout,'meancvgd_glb1: T_u st-dev problem!')
else if(q1(ji,jk,jj).le.0.0) then ! lq
write(nulout,*) 'meancvgd_glb1: ji,jk,jj,q1=',
& ji,jk,jj,q1(ji,jk,jj)
call abort3d(nulout,'meancvgd_glb1: Lnq st-dev problem!')
else if(zstb(ji,jk,jj).le.0.0) then ! Tb
write(nulout,*) 'meancvgd_glb1: ji,jk,jj,zstb=',
& ji,jk,jj,zstb(ji,jk,jj)
call abort3d(nulout,'meancvgd_glb1: T_b st-dev problem!')
endif
!
ut1(ji,jk,jj) = sqrt(ut1(ji,jk,jj))
vt1(ji,jk,jj) = sqrt(vt1(ji,jk,jj))
tt1(ji,jk,jj) = sqrt(tt1(ji,jk,jj))
q1(ji,jk,jj) = sqrt(q1(ji,jk,jj))
zstb(ji,jk,jj) = sqrt(zstb(ji,jk,jj))
!
zonalpp(jj,jk) = zonalpp(jj,jk)+ut1(ji,jk,jj)
zonalcu(jj,jk) = zonalcu(jj,jk)+vt1(ji,jk,jj)
zonaltu(jj,jk) = zonaltu(jj,jk)+tt1(ji,jk,jj)
zonallq(jj,jk) = zonallq(jj,jk)+q1(ji,jk,jj)
zonaltb(jj,jk) = zonaltb(jj,jk)+zstb(ji,jk,jj)
enddo
zonalpsu(jj) = zonalpsu(jj)+zspsu(ji,jj)
zonaltg(jj) = zonaltg(jj)+zstg(ji,jj)
zonalpb(jj) = zonalpb(jj)+zspsb(ji,jj)
enddo
enddo
!
zni=real(ni)
do jj=1,nj
do jk=1,nflev
zonalpp(jj,jk) = zonalpp(jj,jk)/zni
zonalcu(jj,jk) = zonalcu(jj,jk)/zni
zonaltu(jj,jk) = zonaltu(jj,jk)/zni
zonallq(jj,jk) = zonallq(jj,jk)/zni
zonaltb(jj,jk) = zonaltb(jj,jk)/zni
enddo
zonalpsu(jj) = zonalpsu(jj)/zni
zonaltg(jj) = zonaltg(jj)/zni
zonalpb(jj) = zonalpb(jj)/zni
enddo
!
! -----------------
!*6. OUTPUT Statistics
! -----------------
IPAK = -32
IDATYP = 5
IP1 = 0
IP2 = 0
IP3 = iensemble
IDATEO = NDATESTAT
!
cletik = 'CVGDMEAN'
!
write(nulout,*) 'meancvgd_glb1: print_mean'
write(nulout,*) 'meancvgd_glb1: PP MEAN'
!
call maxmin(zmpp,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'meancvgd_glb',
& 'PPM')
write(nulout,*) 'meancvgd_glb1: CU MEAN'
call maxmin(zmcu,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'meancvgd_glb',
& 'CUM')
write(nulout,*) 'meancvgd_glb1: TU MEAN'
call maxmin(zmtu,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'meancvgd_glb',
& 'TUM')
write(nulout,*) 'meancvgd_glb1: LQ MEAN'
call maxmin(zmlq,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'meancvgd_glb',
& 'LQM')
write(nulout,*) 'meancvgd_glb1: TB MEAN'
call maxmin(zmtb,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'meancvgd_glb',
& 'TBM')
!
do jvar=1,inbvar
do jk = 1,nflev
IP1 = NIP1(jk)
if(clvar(jvar).eq.'UU') then
do jj=1,nj
do ji=1,ni
z2d(ji,jj) = zmpp(ji,jk,jj)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
$ IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'G',0,0,0,0,IDATYP,.TRUE.)
!
else if(clvar(jvar).eq.'VV') then
do jj=1,nj
do ji=1,ni
z2d(ji,jj) = zmcu(ji,jk,jj)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
$ IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'G',0,0,0,0,IDATYP,.TRUE.)
!
else if((clvar(jvar).eq.'PP').or.(clvar(jvar).eq.'QQ')) then
do jj=1,nj
do ji=1,ni
z2d(ji,jj) = zmpp(ji,jk,jj)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
$ IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'G',0,0,0,0,IDATYP,.TRUE.)
!
else if((clvar(jvar).eq.'CC').or.(clvar(jvar).eq.'DD')) then
do jj=1,nj
do ji=1,ni
z2d(ji,jj) = zmcu(ji,jk,jj)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
$ IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'G',0,0,0,0,IDATYP,.TRUE.)
!
else if(clvar(jvar).eq.'TT') then
do jj=1,nj
do ji=1,ni
z2d(ji,jj) = zmtu(ji,jk,jj)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
$ IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'G',0,0,0,0,IDATYP,.TRUE.)
!
else if(clvar(jvar).eq.'TB') then
do jj=1,nj
do ji=1,ni
z2d(ji,jj) = zmtb(ji,jk,jj)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
$ IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),
$ cletik,'G',0,0,0,0,IDATYP,.TRUE.)
!
else if(clvar(jvar).eq.'LQ') then
do jj=1,nj
do ji=1,ni
z2d(ji,jj) = zmlq(ji,jk,jj)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
$ IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'G',0,0,0,0,IDATYP,.TRUE.)
endif
enddo
enddo
! Convert Pa to hPa
do jj=1,nj
do ji=1,ni
zmpsu(ji,jj) = zmpsu(ji,jj) * 0.01
zmpsb(ji,jj) = zmpsb(ji,jj) * 0.01
enddo
enddo
!
IP1=0
IP2=0
!
write(nulout,*) 'meancvgd_glb1: Pb MEAN'
! call maxmin(zmpsb,ni,nj,1,zmin,zmax,
! & idum1,idum2,idum3,idum4,'meancvgd_glb1',
! & 'Pbm')
IERR = VFSTECR(zmpsb,zmpsb,IPAK,koutfile,IDATEO,0,0,ni,nj,1,
$ IP1,IP2,IP3,'E','PB',cletik,'G',0,0,0,
$ 0,IDATYP,.TRUE.)
write(nulout,*) 'meancvgd_glb1: Pu MEAN'
! call maxmin(zmpsu,ni,nj,1,zmin,zmax,
! & idum1,idum2,idum3,idum4,'meancvgd_glb1',
! & 'Pum')
IERR = VFSTECR(zmpsu,zmpsu,IPAK,koutfile,IDATEO,0,0,ni,nj,1,
$ IP1,IP2,IP3,'E','PU',cletik,'G',0,0,0,
$ 0,IDATYP,.TRUE.)
write(nulout,*) 'meancvgd_glb1: Tg MEAN'
! call maxmin(zmtg,ni,nj,1,zmin,zmax,
! & idum1,idum2,idum3,idum4,'meancvgd_glb1',
! & 'Tgm')
IERR = VFSTECR(zmtg,zmtg,IPAK,koutfile,IDATEO,0,0,ni,nj,1,
$ IP1,IP2,IP3,'E','TG',cletik,'G',0,0,0,
$ 0,IDATYP,.TRUE.)
!
IERR = VFSTECR(zpsb,zpsb,IPAK,koutfile,IDATEO,0,0,ni,nj,1,
$ IP1,IP2,IP3,'E','P0','PSB ','G',0,0,0,
$ 0,IDATYP,.TRUE.)
!
! ---------------------------------------------
!*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 = 'CVGDSDEV'
!
write(nulout,*) 'meancvgd_glb1: print_stdev'
write(nulout,*) 'meancvgd_glb1: PP ST-DEV'
! call maxmin(zspp,ni,nj,nflev,zmin,zmax, ! attention aux dimensions ici....
! & idum1,idum2,idum3,idum4,'meancvgd_glb1',
! & 'PP ')
write(nulout,*) 'meancvgd_glb1: CU ST-DEV'
! call maxmin(zscu,ni,nj,nflev,zmin,zmax, ! attention aux dimensions ici....
! & idum1,idum2,idum3,idum4,'meancvgd_glb1',
! & 'CU ')
write(nulout,*) 'meancvgd_glb1: TU ST-DEV'
! call maxmin(zstu,ni,nj,nflev,zmin,zmax, ! attention aux dimensions ici....
! & idum1,idum2,idum3,idum4,'meancvgd_glb1',
! & 'TU ')
write(nulout,*) 'meancvgd_glb1: LQ ST-DEV'
! call maxmin(zslq,ni,nj,nflev,zmin,zmax, ! attention aux dimensions ici....
! & idum1,idum2,idum3,idum4,'meancvgd_glb1',
! & 'LQ ')
write(nulout,*) 'meancvgd_glb1: TB ST-DEV'
call maxmin(zstb,ni,nj,nflev,zmin,zmax, ! attention aux dimensions ici....
& idum1,idum2,idum3,idum4,'meancvgd_glb1',
& 'TB ')
!
do jvar=1,inbvar
do jk=1,nflev
IP1 = NIP1(jk)
if(clvar(jvar).eq.'UU') then
do jj=1,nj
do ji=1,ni
z2d(ji,jj) = ut1(ji,jk,jj)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'G',0,0,0,0,IDATYP,.TRUE.)
!
else if(clvar(jvar).eq.'VV') then
do jj=1,nj
do ji=1,ni
z2d(ji,jj) = vt1(ji,jk,jj)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'G',0,0,0,0,IDATYP,.TRUE.)
!
else if((clvar(jvar).eq.'PP').or.(clvar(jvar).eq.'QQ')) then
do jj=1,nj
do ji=1,ni
z2d(ji,jj) = ut1(ji,jk,jj)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'G',0,0,0,0,IDATYP,.TRUE.)
do jj=1,nj
indjj = nj-jj+1
do ji=1,ni
z2d(ji,jj) = zonalpp(indjj,jk)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),'PPDEVZON',
& 'G',0,0,0,0,IDATYP,.TRUE.)
!
else if((clvar(jvar).eq.'CC').or.(clvar(jvar).eq.'DD')) then
do jj=1,nj
do ji=1,ni
z2d(ji,jj) = vt1(ji,jk,jj)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'G',0,0,0,0,IDATYP,.TRUE.)
do jj=1,nj
indjj = nj-jj+1
do ji=1,ni
z2d(ji,jj) = zonalcu(indjj,jk)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),'CUDEVZON',
& 'G',0,0,0,0,IDATYP,.TRUE.)
!
else if(clvar(jvar).eq.'TT') then
! Tu
do jj=1,nj
do ji=1,ni
z2d(ji,jj) = tt1(ji,jk,jj)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'G',0,0,0,0,IDATYP,.TRUE.)
do jj=1,nj
indjj = nj-jj+1
do ji=1,ni
z2d(ji,jj) = zonaltu(indjj,jk)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),'TUDEVZON',
& 'G',0,0,0,0,IDATYP,.TRUE.)
do ji=1,ni
do jj=1,nj
z2d(ji,jj) = tt1(ji,jj,jk)*tt1(ji,jj,jk)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),
& 'TTU_VAR ','G',0,0,0,0,IDATYP,.TRUE.)
!
else if(clvar(jvar).eq.'TB') then
! Tb
do jj=1,nj
do ji=1,ni
z2d(ji,jj) = zstb(ji,jk,jj)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),
& cletik,'G',0,0,0,0,IDATYP,.TRUE.)
do jj=1,nj
indjj = nj-jj+1
do ji=1,ni
z2d(ji,jj) = zonaltb(indjj,jk)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),'TBDEVZON',
& 'G',0,0,0,0,IDATYP,.TRUE.)
do ji=1,ni
do jj=1,nj
z2d(ji,jj) = z2d(ji,jj)*z2d(ji,jj)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),
& 'TTB_VAR ','G',0,0,0,0,IDATYP,.TRUE.)
!
! TT
!
write(nulout,*) 'meancvgd_glb1: mbal_order = ',mbal_order
if(mbal_order.eq.0) then
do jj=1,nj
indjj = nj-jj+1
do ji=1,ni
z2d(ji,jj) = zonaltu(indjj,jk)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),'TTDEVZON',
& 'G',0,0,0,0,IDATYP,.TRUE.)
endif
!
! do ji=1,ni
! do jj=1,nj
! zstt(ji,jj,jk) = zstt(ji,jj,jk)*zstt(ji,jj,jk)
! enddo
! enddo
! IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
! & IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),
! & 'TTT_VAR ','G',0,0,0,0,IDATYP,.TRUE.)
!
else if(clvar(jvar).eq.'LQ') then
do jj=1,nj
do ji=1,ni
z2d(ji,jj) = q1(ji,jk,jj)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),cletik,
& 'G',0,0,0,0,IDATYP,.TRUE.)
do jj=1,nj
indjj = nj-jj+1
do ji=1,ni
z2d(ji,jj) = zonallq(indjj,jk)
enddo
enddo
IERR = VFSTECR(z2d,z2d,IPAK,koutfile,
& IDATEO,0,0,ni,nj,1,IP1,IP2,IP3,'E',clvar(jvar),'LQDEVZON',
& 'G',0,0,0,0,IDATYP,.TRUE.)
endif
enddo
enddo
! Convert Pa to hPa
do jj=1,nj
do ji=1,ni
zspsu(ji,jj) = zspsu(ji,jj) * 0.01
zspsb(ji,jj) = zspsb(ji,jj) * 0.01
enddo
enddo
write(nulout,*) 'meancvgd_glb1: Pb ST-DEV'
call maxmin(zspsb,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'meancvgd_glb1',
& 'Pb')
!
IP1=0
IP2=0
IERR = VFSTECR(zspsu,zspsu,IPAK,koutfile,IDATEO,0,0,ni,nj,1,
& IP1,IP2,IP3,'E','PU',cletik,'G',0,0,0,
& 0,IDATYP,.TRUE.)
IERR = VFSTECR(zstg,zstg,IPAK,koutfile,IDATEO,0,0,ni,nj,1,
& IP1,IP2,IP3,'E','TG',cletik,'G',0,0,0,
& 0,IDATYP,.TRUE.)
IERR = VFSTECR(zspsb,zspsb,IPAK,koutfile,IDATEO,0,0,ni,nj,1,
& IP1,IP2,IP3,'E','PB',cletik,'G',0,0,0,
& 0,IDATYP,.TRUE.)
!
! Zonal PS
!
do jj=1,nj
indjj = nj-jj+1
do ji=1,ni
z2d(ji,jj) = zonalpsu(indjj)
enddo
enddo
!
IERR = VFSTECR(z2d,zonalpsu,IPAK,koutfile,IDATEO,0,0,ni,nj,
& 1 ,IP1,IP2,IP3,'E','P0','PSUDEVZO',
& 'G',0,0,0,0,IDATYP,.TRUE.)
do jj=1,nj
indjj = nj-jj+1
do ji=1,ni
z2d(ji,jj) = zonalpb(indjj)
enddo
enddo
IERR = VFSTECR(z2d,zonalpb,IPAK,koutfile,IDATEO,0,0,ni,nj,
& 1 ,IP1,IP2,IP3,'E','P0','PSBDEVZO',
& 'G',0,0,0,0,IDATYP,.TRUE.)
!
write(nulout,*) 'meancvgd_glb1: END '
nensemble = iensemble
!
return
end