!-------------------------------------- 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 CSE2_2(KULSTAT,KULCORNS,KULSTDEV) 1,13
#if defined (DOC)
*
***s/r CSE2_2 - Statistical Estimation at level 2
*
*
*Author : P. Gauthier *ARMA/AES January, 1995
*Revision: 001 R. Sarrazin Oct. 98
* remove ensemble mean and global mean
* normalizisation option and call to corrlength
* . 002 P. Koclas *CMC/AES June 1999:
* . - Y2K conversion
* . 003 C. Charette *ARMA/SMC Sept 2004
* - Conversion to hybrid vertical coordinate
* 004 M. Buehner May 2008
* - New version of CSE2 adapted for new PtoT approach
* with localization for Tb correlations
*
* -------------------
** Purpose: to estimate the forecast error correlation from an
* . ensemble of normalized and unbiased residuals such
* . as differences between 24/48h forecast valid at the
* . same time
*Arguments
* -NONE-
#endif
IMPLICIT NONE
*implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comgem.cdk"
#include "comleg.cdk"
#include "comcorr.cdk"
#include "comsp.cdk"
#include "comgd0.cdk"
#include "comgdpar.cdk"
#include "comcse1.cdk"
#include "comstdd.cdk"
*
INTEGER KULSTAT, KULCORNS, KULSTDEV
C
INTEGER JENS, IENS, JK1, JK2, JLA,JN, JM, ILA
S ,IERR, JFILE, JK, JLAT,ILON, JLON
C
INTEGER FNOM, FSTOUV, FSTFRM, FCLOS, FSTPRM, FSTINF, FSTINL
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(600),IDATE(600), IDATV(600), IDIMAX, INFON, IFSTRUN, IHH
integer iip1s(jpnflev),iip2,iip3,itrlnlev,jlev, itrlgid
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 ZFACT, ZCORIOLIS
REAL*8 DLFACT, DLFACT2
EXTERNAL FNOM, FSTOUV, FSTFRM, FCLOS, FSTPRM, FSTINF, FSTINL
C
INTEGER ICOUNT
POINTER(PXGLBM, ZGLBMEAN)
REAL*8 ZGLBMEAN(NKGDIM)
CALL HPALLOC(PXGLBM, MAX(1,NKGDIM), IERR, 8)
C
WRITE(NULOUT,FMT=9000)
9000 FORMAT(3(/,3x,80('.')),//
S ,4x,' CSE2- Estimation of Forecast error correlations',//)
C
C* 1. Restore CORNS as an accumulator
C
100 CONTINUE
IF (LSTATCON) THEN
DLFACT = DSQRT(DBLE(NENSEMBLE - 1))
DO JN = 0, NTRUNC
DLFACT2 = DSQRT(2.0D0*JN + 1.0D0)
DO JK1 = 1, NKSDIM
RSTDDEV(JK1,JN) = RSTDDEV(JK1,JN)*DLFACT*DLFACT2
END DO
END DO
END IF
C
DO JN = 0, NTRUNC
DO JK1 = 1, NKSDIM
DO JK2 = 1, NKSDIM
CORNS(JK1,JK2,JN,1) = RSTDDEV(JK1,JN)*RSTDDEV(JK2,JN)
S * CORNS(JK1,JK2,JN,1)
END DO
END DO
END DO
C
C ALLOCATE SPACE FOR ACCUMULATORS
C
CALL STDDALL
C
C* 2. Access the (normalized) increments from a set of files
C . (loop on the files)
C
200 CONTINUE
IDIMAX = 600
C
C COMPUTES MEAN OF GD DATA BLOC
C ALSO OUTPUT STD DEV OF GD FIELDS
C
CALL MEANGD_2(KULSTAT)
C
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)
c set up only for eta levels:
if (CLNOMVAR.eq.'UP') 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)
c---------Read in nomvar at the surface (at zlev(itrlnlev)
ipmode = ip1_pak_trl
call CONVIP(IP1,zlev(itrlnlev),ip1_vco_trl
& ,ipmode,clstring, .false. )
endif
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,'CSE2: 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)
DHEURES = DBLE(INPAS*IDEET/3600)
*
CALL INCDATR(IDATV(JENS),IDATE(JENS),SNGL(DHEURES))
CALL NEWDATE(IDATV(JENS),IFSTRUN,IHH,-3)
WRITE(NULOUT,9111)JENS, IFSTRUN,IHH
END DO
9111 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',-1)
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 REMOVE THE ENSEMBLE MEAN FROM FIELDS IN GD
C
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JK1 = 1, NKGDIM
GD(JLON,JK1,JLAT) = GD(JLON,JK1,JLAT) -
+ XMGD(JLON,JK1,JLAT)
ENDDO
ENDDO
ENDDO
c
c Normalize by local stddev
c
if(.true.) then
c
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JK1 = 1, NFLEV
IF(SUU(JLON,JK1,JLAT).gt.0) THEN
UT0(JLON,JK1,JLAT) = UT0(JLON,JK1,JLAT) /
+ SUU(JLON,JK1,JLAT)
ELSE
UT0(JLON,JK1,JLAT) = 0.0
WRITE(NULOUT,*) "SUU NON-POSITIVE:",
+ SUU(JLON,JK1,JLAT)
ENDIF
IF(SVV(JLON,JK1,JLAT).gt.0) THEN
VT0(JLON,JK1,JLAT) = VT0(JLON,JK1,JLAT) /
+ SVV(JLON,JK1,JLAT)
ELSE
VT0(JLON,JK1,JLAT) = 0.0
WRITE(NULOUT,*) "SVV NON-POSITIVE:",
+ SVV(JLON,JK1,JLAT)
ENDIF
IF(STT(JLON,JK1,JLAT).gt.0) THEN
TT0(JLON,JK1,JLAT) = TT0(JLON,JK1,JLAT) /
+ STT(JLON,JK1,JLAT)
ELSE
TT0(JLON,JK1,JLAT) = 0.0
WRITE(NULOUT,*) "STT NON-POSITIVE:",
+ STT(JLON,JK1,JLAT)
ENDIF
IF(SLQ(JLON,JK1,JLAT).gt.0) THEN
Q0(JLON,JK1,JLAT) = Q0(JLON,JK1,JLAT) /
+ SLQ(JLON,JK1,JLAT)
ELSE
Q0(JLON,JK1,JLAT) = 0.0
if(jlon.eq.1.and.jlat.eq.1) then
WRITE(NULOUT,*) "SLQ NON-POSITIVE:",jlon,jlat,jk1,
+ SLQ(JLON,JK1,JLAT)
endif
ENDIF
ENDDO
IF(SP0(JLON,1,JLAT).gt.0) THEN
GPS0(JLON,1,JLAT) = GPS0(JLON,1,JLAT) /
+ SP0(JLON,1,JLAT)
ELSE
GPS0(JLON,1,JLAT) = 0.0
WRITE(NULOUT,*) "SP0 NON-POSITIVE:",
+ SP0(JLON,1,JLAT)
ENDIF
ENDDO
ENDDO
endif
C
C IF REQUESTED DIVIDE BY THE ZONAL AVG OF STD DEV
C
IF ( .false. ) THEN
WRITE(NULOUT,*) " "
WRITE(NULOUT,*) " NORMALIZE PP UC UT LQ P0 BY / STD DEV "
WRITE(NULOUT,*) " "
C
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JK1 = 1, NFLEV
UT0(JLON,JK1,JLAT) = UT0(JLON,JK1,JLAT) /
+ STDUU(NJ-JLAT+1,JK1)
VT0(JLON,JK1,JLAT) = VT0(JLON,JK1,JLAT) /
+ STDVV(NJ-JLAT+1,JK1)
TT0(JLON,JK1,JLAT) = TT0(JLON,JK1,JLAT) /
+ STDTT(NJ-JLAT+1,JK1)
Q0(JLON,JK1,JLAT) = Q0(JLON,JK1,JLAT) /
+ STDLQ(NJ-JLAT+1,JK1)
ENDDO
GPS0(JLON,1,JLAT) = GPS0(JLON,1,JLAT) /
+ STDP0(NJ-JLAT+1)
ENDDO
ENDDO
C
ENDIF
C
C COMPUTE THE GLOBAL MEAN FOR THE CURRENT FILE
C
DO JK1 = 1, NKGDIM
ICOUNT = 0
ZGLBMEAN(JK1) = 0.0
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
ICOUNT = ICOUNT + 1
ZGLBMEAN(JK1) = ZGLBMEAN(JK1) + GD(JLON,JK1,JLAT)
ENDDO
ENDDO
ZGLBMEAN(JK1) = ZGLBMEAN(JK1) / ICOUNT
ENDDO
C
C REMOVE GLOBAL MEAN
C
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JK1 = 1, NKGDIM
GD(JLON,JK1,JLAT) = GD(JLON,JK1,JLAT) - ZGLBMEAN(JK1)
ENDDO
ENDDO
ENDDO
C
C APPLY MASKLAT
C
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JK1 = 1, NKGDIM
GD(JLON,JK1,JLAT) = GD(JLON,JK1,JLAT)*MASKLAT(JLAT)
ENDDO
ENDDO
ENDDO
C
C 5. Estimation of forecast error correlations
C
500 CONTINUE
C
CALL TRANSFER('ZSP0')
WRITE(NULOUT,*)' -CSE2: spectral transform (REESPE)'
CALL REESPE(NKSDIM,SP,GD,NLA
S ,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
* CALL GDSP
C
C * . 5.1 Update the correlation estimate
C
350 CONTINUE
C
DO JN = 0, NTRUNC
DO JM = 0, JN
ZFACT = 2.
IF (JM .EQ.0)ZFACT = 1.
ILA = NIND(JM) + JN - JM
DO JK1 = 1, NKSDIM
DO JK2 = 1, NKSDIM
CORNS(JK1,JK2,JN,1) = CORNS(JK1,JK2,JN,1)
S + ZFACT*(SP(ILA,1,JK1)*SP(ILA,1,JK2)
S + SP(ILA,2,JK1)*SP(ILA,2,JK2))
END DO
END DO
END DO
END DO
C
321 CONTINUE
C
C* . 3.7 Ending the processing of one file
C
370 CONTINUE
NENSEMBLE = NENSEMBLE + IENS
WRITE(NULOUT,9370) IENS, NENSEMBLE
9370 FORMAT(5X,I4," cases have been processed",
S 5x,"Current size of the ensemble: ",I4)
C
IERR = FSTFRM (KULSTAT)
IERR = FCLOS (KULSTAT)
C
C* ---- Ending the loop on files -----
C
201 CONTINUE
C
C* . 6. Normalize the result according to the size of the ensemble
C . ----------------------------------------------------------
C
600 CONTINUE
*
CALL ENS2CORNS
C
C WRITE CHARACTERISTIC LENGTHS TO STD FILE
C
CALL CORRLENGTH(KULSTDEV)
C
C DEALLOCATION OF MEMORY SPACE
C
CALL STDDDAL
CALL HPDEALLC(PXGLBM, IERR, 1)
C
RETURN
END