!-------------------------------------- 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 sub_test(kulstat,koutfile,ldhelm,ldfplane,ldtb_psi,,43
& ldcoriol_one,pmfpp,pmfcu,pmftu,pmflq,pmfpsu,pmftg)
#if defined (DOC)
*
* * s/r sub_test: Used to test specific subroutines.
*
* Author: L. Fillion - ARMA/MSC - 1 Oct 2005.
* 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_param.cdk"
#include "comgrd.cdk"
#include "comgemla.cdk"
#include "comfftla.cdk"
#include "comcva.cdk"
#include "namgdpar.cdk"
*
logical ldhelm,ldfplane,ldtb_psi,llzdpc,ldcoriol_one
INTEGER KULSTAT,koutfile
real*8 pmfpp(ni,nflev,nj)
real*8 pmfcu(ni,nflev,nj)
real*8 pmftu(ni,nflev,nj)
real*8 pmflq(ni,nflev,nj)
real*8 pmfpsu(ni,nj)
real*8 pmftg(ni,nj)
!
logical llfiltersdev,llfilt,llvproj,llvfilt
INTEGER JENS, IENS, jk1, IERR, JFILE, iensemble
integer ji,jj,jk,jvar,inbvar,icase,itrunc,inip1,injp1
parameter(inbvar=20)
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(ni),zy8(nj)
!
real*8 bufwk3dijk(ni,nj,nflev)
!
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 zmpsu(ni,nj)
real*8 zmtg(ni,nj)
!
real*8 zspp(ni,nflev,nj)
real*8 zscu(ni,nflev,nj)
real*8 zstu(ni,nflev,nj)
real*8 zslq(ni,nflev,nj)
real*8 zspsu(ni,nj)
real*8 zstg(ni,nj)
!
real*8 zmeanpp(ni,nj,nflev)
real*8 zmeancu(ni,nj,nflev)
real*8 zmeantu(ni,nj,nflev)
real*8 zmeantb(ni,nj,nflev)
real*8 zmeanlq(ni,nj,nflev)
real*8 zmeanpsu(ni,nj)
real*8 zmeantg(ni,nj)
real*8 zmeanpb(ni,nj)
!
real*8 zstdpp(ni,nj,nflev)
real*8 zstdcu(ni,nj,nflev)
real*8 zstdtu(ni,nj,nflev)
real*8 zstdtb(ni,nj,nflev)
real*8 zstdlq(ni,nj,nflev)
real*8 zstdpsu(ni,nj)
real*8 zstdtg(ni,nj)
real*8 zstdpb(ni,nj)
!
real*8 z2d(ni,nj)
real*8 z2d_in(mni_in,mnj_in)
real*8 zwork2d(ni,nj)
real*8 zstdtt(ni,nj,nflev)
real*8 zvaratiob(ni,nj,nflev)
real*8 zvaratiou(ni,nj,nflev)
real*8 zsavet0(ni,nj,nflev)
real*8 zsavetb(ni,nj,nflev)
real*8 zsavepsi(ni,nj,nflev)
real*8 zsavevort(ni,nj,nflev)
!
real*8 zgdpsi(ni,nflev,nj)
real*8 zgdpsis(ni,nflev,nj)
real*8 zgdchi(ni,nflev,nj)
real*8 zvort(ni,nflev,nj)
real*8 zvorts(ni,nflev,nj)
real*8 zdiv(ni,nflev,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 zxmtb(ni,nflev,nj)
real*8 zstb(ni,nflev,nj)
real*8 zxmpsb(ni,nj)
real*8 zspsb(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)
!
real*8 zwrkflt(ni,nflev,nj)
!
real*8 zsptt(nla,2,nflev)
real*8 zsptb(nla,2,nflev)
real*8 zsptu(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
llvfilt = .false.
llvproj = .false.
!
clvar(1) = 'PP'
clvar(2) = 'CC'
if(.not.ldhelm) then
clvar(1) = 'QQ'
clvar(2) = 'DD'
endif
llzdpc = .false.
if(ldhelm.and.cfstvar(1).eq.'UU') llzdpc = .true.
write(nulout,*) 'sub_test: ldhelm = ',ldhelm
write(nulout,*) 'sub_test: cfstvar(1) = ',cfstvar(1)
write(nulout,*) 'sub_test: llzdpc = ',llzdpc
clvar(3) = 'TT'
clvar(4) = 'LQ'
clvar(5) = 'TB'
clvar(6) = 'PU'
clvar(7) = 'PB'
!
!
inip1 = ni+1
injp1 = nj+1
!
zthreshold = 1.e-15
DLA2 = DBLE(RA) * DBLE(RA)
IDIMAX = 100
write(nulout,*) 'sub_test: BEGIN '
write(nulout,*) 'sub_test: NFLSTAT = ',NFLSTAT
! -----------------------
!*1 Initialize accumulators
! -----------------------
zmpp(:,:,:) = 0.0
zmcu(:,:,:) = 0.0
zmtu(:,:,:) = 0.0
zmlq(:,:,:) = 0.0
zxmtb(:,:,:) = 0.0
zmpsu(:,:) = 0.0
zxmpsb(:,:) = 0.0
zmtg(:,:) = 0.0
!
zspp(:,:,:) = 0.0
zscu(:,:,:) = 0.0
zstu(:,:,:) = 0.0
zstb(:,:,:) = 0.0
zslq(:,:,:) = 0.0
zspsb(:,:) = 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 = 'P0'
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,*) 'sub_test: mni_in,INI=',mni_in,INI
call abort3d(nulout,'sub_test: mni_in.gt.INI')
write(nulout,*) 'sub_test: verify CETIKETERR in NAMCSE1 as compared to input file etiket...'
else if(mnj_in.gt.inj) then
write(nulout,*) 'sub_test: mnj_in,INJ=',mnj_in,INJ
call abort3d(nulout,'sub_test: mnj_in.gt.INJ')
endif
!
WRITE(NULOUT,9210)INFON
9210 FORMAT(//,4X,"sub_test: Ensemble of ",I4," increments")
IF(INFON.EQ.0) THEN
WRITE(NULOUT,*)' THIS FILE IS EMPTY.
$ CHECK THE SELECTION CRITERIA'
CALL ABORT3D(NULOUT,'sub_test: 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,*) 'sub_test: INI, mni_in = ',INI,mni_in
call abort3d(nulout,'sub_test: mni_in.gt.INI')
else if(mnj_in.gt.inj) then
write(nulout,*) 'sub_test: INJ, mnj_in = ',INJ,mnj_in
call abort3d(nulout,'sub_test: 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
!
! 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,'sub_test ',
& 'P0 ')
!
! 2.3.2 Adjusts fields according to B.C.
! N.B.: At the end of this sub-section 2.3.2, psi,chi will contain vort,div if .not.ldhelm
!
call transfer('GD01')
call initgdla(zvort,zdiv,zgdpsi,zgdchi,'U',llzdpc)
call transfer('GD10')
!
if(llzdpc) then
write(nulout,*) 'sub_test: after initgdla'
call maxmin(zvort,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'sub_test ',
& 'QQ ')
endif
!
if(cfstvar(1).ne.'UU') then ! get PSI or QQ from input file kulstat
do jk=1,nflev
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
endif
if(cfstvar(1).eq.'UU'.and.(.not.ldhelm)) then
do jk=1,nflev
do jj=1,mnj_in
do ji=1,mni_in
zgdpsi(ji,jk,jj) = zvort(ji,jk,jj)
zgdchi(ji,jk,jj) = zdiv(ji,jk,jj)
enddo
enddo
enddo
endif
!
call mach3(zgdpsi,ni,nj,nflev,inip1,injp1)
call mach3(zgdchi,ni,nj,nflev,inip1,injp1)
! call setmean(zgdchi,0.0,nflev)
!
!2.3.4 Subtract forecast mean if in MC mode
!
write(nulout,*) 'sub_test: lmcstats = ',lmcstats
if(lmcstats) then
write(nulout,*) 'sub_test: Subtract fsct ensemble mean from current fcst sample'
do jj=1,nj
do ji=1,ni
do jk=1,nflev
zgdpsi(ji,jk,jj) = zgdpsi(ji,jk,jj) - pmfpp(ji,jk,jj)
zgdchi(ji,jk,jj) = zgdchi(ji,jk,jj) - pmfcu(ji,jk,jj)
tt0(ji,jk,jj) = tt0(ji,jk,jj) - pmftu(ji,jk,jj)
q0(ji,jk,jj) = q0(ji,jk,jj) - pmflq(ji,jk,jj)
enddo
gps0(ji,1,jj) = gps0(ji,1,jj) - pmfpsu(ji,jj)
gtg0(ji,1,jj) = gtg0(ji,1,jj) - pmftg(ji,jj)
enddo
enddo
endif
!
if(llfilt) then
write(nulout,*) 'sub_test: **************************************'
write(nulout,*) 'sub_test: PP error sample is spectrally filtered'
write(nulout,*) 'sub_test: **************************************'
call gdtruncr(zgdpsi,'T',mflt_trunc,clflt,nflev)
else
write(nulout,*) 'sub_test: NO FILTER applied to PP error sample'
endif
!
ztb(:,:,:) = 0.0
zpb(:,:,:) = 0.0
zpsb(:,:) = 0.0
zt0(:,:,:) = tt0(:,:,:)
!
write(nulout,*) ' '
write(nulout,*) 'sub_test: ****************************************'
write(nulout,*) 'sub_test: Uses Balance operators of Order = ',mbal_order
write(nulout,*) 'sub_test: ****************************************'
write(nulout,*) ' '
!
if(mbal_order.eq.1) then
!
! Linear-Geostrophic
! ------------------
!
write(nulout,*) 'sub_test: ldcoriol_one =',ldcoriol_one
if(ldtb_psi) then
clgrid = 'P'
if (lpsifromglb) clgrid = 'S'
call linbal_la(zpb,zgdpsi,ldfplane,ldcoriol_one,clgrid)
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(ztb,zpsb,zpb,cptot,.false.,.true.) ! build Tb, psb from psi
if(llvproj) call viproj(ztb,ztb,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,'sub_test ',
& 'T0 ')
!
do ji=1,ni
do jj=1,nj
do jk=1,nflev
ut0(ji,jk,jj) = zgdpsi(ji,jk,jj)
vt0(ji,jk,jj) = zgdchi(ji,jk,jj)
ztu(ji,jk,jj) = zt0(ji,jk,jj)-ztb(ji,jk,jj)
zsavet0(ji,jj,jk) = zt0(ji,jk,jj)
zsavetb(ji,jj,jk) = ztb(ji,jk,jj)
zsavepsi(ji,jj,jk) = zgdpsi(ji,jk,jj)
zsavevort(ji,jj,jk) = zvort(ji,jk,jj)
enddo
enddo
enddo
!
! ensure T_u, Ps_u are bi-periodic
!
if(mbal_order.ne.0) then
call mach3(ztu,ni,nj,nflev,inip1,injp1)
call mach3(ztb,ni,nj,nflev,inip1,injp1)
!
! Transfer Tu to tt0
!
do ji=1,ni
do jj=1,nj
do jk=1,nflev
tt0(ji,jk,jj) = ztu(ji,jk,jj)
enddo
enddo
enddo
!
call maxmin(ztb,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'sub_test ',
& 'TB ')
!
call maxmin(ztu,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'sub_test ',
& 'TU ')
!
do ji=1,ni
do jj=1,nj
zpsu(ji,jj)=gps0(ji,1,jj)-zpsb(ji,jj)
enddo
enddo
!
write(nulout,*) 'sub_test: Balanced Surface Pressure'
call maxmin(zpsb,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'sub_test ',
& 'P0B')
!
! ensure ps_u is bi-periodic
!
call mach2(zpsu,ni,nj,inip1,injp1)
!
call maxmin(zpsu,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'sub_test ',
& 'P0U')
write(nulout,*) 'sub_test: point 2: P0, (min,max)=',zmin,zmax
!
do ji=1,ni
do jj=1,nj
gps0(ji,1,jj) = zpsu(ji,jj)
enddo
enddo
endif
!
! 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)
!
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)
& + tt0(ji,jk1,jj)*tt0(ji,jk1,jj)
zslq(ji,jk1,jj) = zslq(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
! Loop for Tb, Psb (extra variables)
!
do jj = 1, nj
do jk1 = 1, NFLEV
do ji = 1, ni
zxmtb(ji,jk1,jj) = zxmtb(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
zxmpsb(ji,jj) = zxmpsb(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,*) 'sub_test: iensemble = ',iensemble
!
write(nulout,*) 'sub_test: zxmtb apres loop sur les echantillons'
if(mbal_order.gt.0) then
call maxmin(zxmtb,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'sub_test ',
& '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
zspp(ji,jk1,jj) = ( zspp(ji,jk1,jj) -
+ ((zmpp(ji,jk1,jj)*zmpp(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) -
+ ((zmcu(ji,jk1,jj)*zmcu(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) -
+ ((zmtu(ji,jk1,jj)*zmtu(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) -
+ ((zmlq(ji,jk1,jj)*zmlq(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) -
+ ((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) -
+ ((ZXMTB(ji,jk1,jj)*ZXMTB(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) -
+ ((ZXMPSB(ji,jj)*ZXMPSB(ji,jj)) / iensemble )) /
+ (iensemble - 1)
if (zspsb(ji,jj).eq.0.0) zspsb(ji,jj)=zthreshold
ENDDO
ENDDO
! Loop for temperature (total, balance and unbalance) spectral components
DO jk1 = 1, nflev
DO ji = 1, nband
zspvartt(ji,jk1) = ( zspsumsqtt(ji,jk1) -
+ ((zspsumtt(ji,jk1)*zspsumtt(ji,jk1)) / iensemble )) /
+ (iensemble - 1)
if (zspvartt(ji,jk1).eq.0.0) zspvartt(ji,jk1)=zthreshold
zspvartb(ji,jk1) = ( zspsumsqtb(ji,jk1) -
+ ((zspsumtb(ji,jk1)*zspsumtb(ji,jk1)) / iensemble )) /
+ (iensemble - 1)
if (zspvartb(ji,jk1).eq.0.0) zspvartb(ji,jk1)=zthreshold
zspvartu(ji,jk1) = ( zspsumsqtu(ji,jk1) -
+ ((zspsumtu(ji,jk1)*zspsumtu(ji,jk1)) / iensemble )) /
+ (iensemble - 1)
if (zspvartu(ji,jk1).eq.0.0) zspvartu(ji,jk1)=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
ENDDO
zmpsu(ji,jj) = zmpsu(ji,jj) / iensemble
zmtg(ji,jj) = zmtg(ji,jj) / iensemble
ENDDO
ENDDO
c Loop for Tb, Psb (extra variables)
DO jj = 1,nj
do jk1 = 1, NFLEV
DO ji = 1,ni
ZXMTB(ji,jk1,jj) = ZXMTB(ji,jk1,jj) / iensemble
ENDDO
ENDDO
ENDDO
DO jj = 1,nj
DO ji = 1,ni
ZXMPSB(ji,jj) = ZXMPSB(ji,jj) / iensemble
ENDDO
ENDDO
! Transfer data
do jj=1,nj
do ji=1,ni
zmeanpsu(ji,jj) = zmpsu(ji,jj)
zmeantg(ji,jj) = zmtg(ji,jj)
zmeanpb(ji,jj) = zxmpsb(ji,jj)
do jk=1,nflev
zmeanpp(ji,jj,jk) = zmpp(ji,jk,jj)
zmeancu(ji,jj,jk) = zmcu(ji,jk,jj)
zmeantu(ji,jj,jk) = zmtu(ji,jk,jj)
zmeanlq(ji,jj,jk) = zmlq(ji,jk,jj)
zmeantb(ji,jj,jk) = zxmtb(ji,jk,jj)
enddo
enddo
enddo
!
call maxmin(zmeanpsu,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'sub_test ',
& 'PUM')
call maxmin(zmeantg,ni,nj,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'sub_test ',
& 'TGM')
!
! -------
!*5 STD DEV
! -------
do jj=1,nj
do ji=1,ni
! Psu
if (zspsu(ji,jj).le.0.0) then
write(nulout,*) 'sub_test: ji,jj,zspsu=',
& ji,jj,zspsu(ji,jj)
call abort3d(nulout,'sub_test: 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,*) 'sub_test: ji,jj,zstg=',
& ji,jj,zstg(ji,jj)
call abort3d(nulout,'sub_test: TG st-dev problem!')
endif
zstg(ji,jj) = sqrt(zstg(ji,jj))
zstdtg(ji,jj) = zstg(ji,jj)
! Psb
if (zspsb(ji,jj).le.0.0) then
write(nulout,*) 'sub_test: ji,jj,zspspb=',
& ji,jj,zspsb(ji,jj)
call abort3d(nulout,'sub_test: ps_b st-dev problem!')
endif
zstdpb(ji,jj) = sqrt(zspsb(ji,jj))
do jk=1,nflev
!
if(zspp(ji,jk,jj).le.0.0) then ! Psi
write(nulout,*) 'sub_test: ji,jk,jj,zspp=',
& ji,jk,jj,zspp(ji,jk,jj)
call abort3d(nulout,'sub_test: PSI st-dev problem!')
else if(zscu(ji,jk,jj).le.0.0) then ! Chi
write(nulout,*) 'sub_test: ji,jk,jj,zspp=',
& ji,jk,jj,zspp(ji,jk,jj)
call abort3d(nulout,'sub_test: CHI_u st-dev problem!')
else if(zstu(ji,jk,jj).le.0.0) then ! Tu
write(nulout,*) 'sub_test: ji,jk,jj,zstu=',
& ji,jk,jj,zstu(ji,jk,jj)
call abort3d(nulout,'sub_test: T_u st-dev problem!')
else if(zslq(ji,jk,jj).le.0.0) then ! lq
write(nulout,*) 'sub_test: ji,jk,jj,zslq=',
& ji,jk,jj,zslq(ji,jk,jj)
call abort3d(nulout,'sub_test: Lnq st-dev problem!')
else if(zstb(ji,jk,jj).le.0.0) then ! Tb
write(nulout,*) 'sub_test: ji,jk,jj,zstb=',
& ji,jk,jj,zstb(ji,jk,jj)
call abort3d(nulout,'sub_test: T_b 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))
zstb(ji,jk,jj) = sqrt(zstb(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)
zstdtb(ji,jj,jk) = zstb(ji,jk,jj)
!
zonalpp(jj,jk) = zonalpp(jj,jk)+zstdpp(ji,jj,jk)
zonalcu(jj,jk) = zonalcu(jj,jk)+zstdcu(ji,jj,jk)
zonaltu(jj,jk) = zonaltu(jj,jk)+zstdtu(ji,jj,jk)
zonallq(jj,jk) = zonallq(jj,jk)+zstdlq(ji,jj,jk)
zonaltb(jj,jk) = zonaltb(jj,jk)+zstdtb(ji,jj,jk)
enddo
zonalpsu(jj) = zonalpsu(jj)+zstdpsu(ji,jj)
zonaltg(jj) = zonaltg(jj)+zstdtg(ji,jj)
zonalpb(jj) = zonalpb(jj)+zstdpb(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
! -----------------------------
! Writing positional parameters
! -----------------------------
cletiket = ' '
cltypvar = ' '
!
do ji=1,ni
zx8(ji)=grd_x_8(ji)
enddo
do jj=1,nj
zy8(jj)=grd_y_8(jj)
enddo
!
ierr = vfstecr(zx8,zx8,ipak,koutfile,idateo,
& 0,0,ni,1,1,mig1flda,mig2flda,mig3flda,cltypvar
& ,'>>',cletiket,'E',mig1tic,mig2tic,mig3tic,mig4tic,idatyp
& ,.true.)
!
ierr = vfstecr(zy8, zy8, ipak, koutfile, idateo,
& 0,0, 1, nj, 1, mig1flda,mig2flda,mig3flda,cltypvar
& ,'^^',cletiket,'E',mig1tic,mig2tic,mig3tic,mig4tic,idatyp
& ,.true.)
!
write(nulout,*) 'sub_test: END '
nensemble = iensemble
!
call tinvlap(koutfile,idateo)
!
return
end