!-------------------------------------- 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 SUTG(KULSSF) 1,8
#if defined (DOC)
*
***s/r SUTG - Read the standard deviations for TG from a RPN standard file.
* - Compute the correlation for TG using a specified length scale.
*
*
*Author : J. Halle *CMDA/AES November, 1999
*
*Revision:
* J. Halle *CMDA/AES February 2000
* - Assume stats file is already open.
* JM Belanger CMDA/SMC Jul 2000
* . 32 bits conversion
* S. Pellerin *ARMASPE Feb. 2002
* . Interpolation of variances to working grid
* resolution
* C. Charette - ARMA/SMC - Sep. 2004
* . Conversion to hybrid vertical coordinate
* A. Beaulne - CMDA/SMC - June 2006
* . Do not accept std for TG to be more than limit
* Bin He *ARMA/SMC Apr. 2008
* . Reading multiple trial files
* M. Buehner ARMA May 2008
* . Copy TG correlations to multiple latitude
* bands of correlations (NANALVAR=4)
* S. Pellerin ARMA August 2008
* . Call to getfstprm2
* C. Charette ARMA February 2010
* . When required Interpolate to a gaussian grid
* stored from North to South (ie. IG2=1 instead of 0
* in call to ezqkdef )
*
* Arguments:
* KULSSF : logical unit to be used to access the SSF file
#endif
IMPLICIT NONE
*implicits
*
* Global variables
*
#include "comlun.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comcorr.cdk"
#include "compstat.cdk"
#include "comstate.cdk"
#include "comsp.cdk"
#include "comgd0.cdk"
#include "comspg.cdk"
#include "rpnstd.cdk"
#include "comleg.cdk"
#include "comcst.cdk"
*
* Arguments
*
INTEGER KULSSF
*
* Local variables
*
LOGICAL LLPB
C
INTEGER IKEY, ILEN, JLAT, JLON, JLA, ezgprm, igdgid, ezqkdef
INTEGER JN, JM, JM0, ILA, inlev, itggid, inmxlev,ier, iset
integer ezdefset, vezsint
integer ip1style,ip1kind,jlatbin
C
REAL*8, allocatable, dimension(:,:) :: dltg
REAL*8 ZSPCORR(NTRUNC+1)
*
REAL*8 ZABS, ZPOLE, ZCONST, DLFAC, DLCORR
*
POINTER (PXSPCORR ,ZSPCORR)
integer vfstlir
integer koutmpg
external vfstlir
*---------------------------------------------------------------------
**
write(nulout,fmt='(8x,2A)')'SUTG- initialisation of TG background error',' variances'
clnomvar='TG'
idateo=-1
inmxlev=1
call getfldprm2(IP1,IP2,IP3,INLEV,CLETIKET,CLTYPVAR,ITGGID,
& clnomvar, idateo, inmxlev, kulssf, nulout,ip1style,ip1kind,
& ntrials,koutmpg)
ier = ezgprm(itggid,CLGRTYP,INI,INJ,IG1,IG2,IG3,IG4)
allocate(dltg(ini,inj))
write(nulout,*)'reading TG variances'
ikey = vfstlir(dltg,koutmpg,ini,inj,ink,idateo,cletiket,ip1,
& ip2, ip3, cltypvar, clnomvar)
if(clgrtyp == 'G' .and. ni == ini .and. nj == inj .and. ig1 == 0
& .and. ig2 ==0 .and. ig3 == 0 .and.ig4 == 0) then
do jlat = 1, nj
do jlon = 1,ni
tgstdbg(jlon,jlat) = dltg(jlon,nj-jlat+1)
enddo
enddo
elseif(clgrtyp == 'G' .and. ni == ini .and. nj == inj .and. ig1 ==
& 0 .and. ig2 ==1 .and. ig3 == 0 .and.ig4 == 0) then
do jlat = 1, nj
do jlon = 1,ni
tgstdbg(jlon,jlat) = dltg(jlon,jlat)
enddo
enddo
else
* Interpolate to a gaussian grid stored from North to South(IG2=1)
*
igdgid = ezqkdef(ni, nj, 'G', 0, 1, 0, 0 ,0)
iset = ezdefset(igdgid,itggid)
ier = vezsint(tgstdbg,dltg,ni,nj,1,ini,inj,1)
endif
* If specified in namelist Do not accept tg errors
* of more than value specified in namelist
if ( llimtg ) then
where ( tgstdbg > rlimsuptg) tgstdbg = rlimsuptg
endif
* 0. Allocating local arrays
C --------------------------
*
*
ILEN = NTRUNC+1
CALL HPALLOC(PXSPCORR,MAX(ILEN,1),IERR,8)
*
* 1. Opening the statistics file
C ------------------------------
*
* .. file not opened anynore .. jh
*
9420 FORMAT(//,6x,'--Reading standard deviations for TG in'
S ,' physical space from the file ',A)
*
* 4. Compute correlations
C -----------------------
*
* . 4.1 Initialisation
C
CALL TRANSFER('ZGD0')
CALL TRANSFER('ZSP0')
*
DO JLA = 1, NLA
CORTGG(JLA,1,1) = 0.0
CORTGG(JLA,2,1) = 0.0
ENDDO
*
* . 4.2 Compute correlations in physical space
*
write(nulout,*) ' SUTG. RCSCLTG = ', RCSCLTG
write(nulout,*) ' SUTG. NTGCORRTYP = ', NTGCORRTYP
if (ngexist(ngtg) .eq. 1) then
call calccorr(ngposit(ngtg),RCSCLTG,1,NTGCORRTYP)
endif
*
* . 4.3 Bring back the result in spectral space
C
CALL REESPE(NKSDIM,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
*
* . 4.4 Check positiveness
C
LLPB = .FALSE.
DO JLA=1,NTRUNC+1
ZABS = ABS(SPTG(JLA,1,1))
LLPB = LLPB.OR.((SPTG(JLA,1,1).LT.0.)
S .AND.(ZABS.GT.RPRECIS))
END DO
IF(LLPB) THEN
WRITE(UNIT=NULOUT
S ,FMT='(" AUTOCORRELATION NEGATIVES ")')
CALL ABORT3D(NULOUT,' Problem in SUTG')
ENDIF
DO JLA = 1, NTRUNC+1
SPTG(JLA,1,1) = ABS(SPTG(JLA,1,1))
END DO
C
ZPOLE = 0.
DO JLA = 1, NTRUNC+1
JN = JLA-1
ZPOLE = ZPOLE + SPTG(JLA,1,1)*SQRT((2.*JN+1.)/2.)
END DO
IF(ZPOLE.LE.0.) THEN
WRITE(UNIT=NULOUT
S ,FMT='("POLE VALUE NEGATIVE IN SUTG")')
CALL ABORT3D(NULOUT,'SUTG:')
ENDIF
DO JLA = 1, NTRUNC+1
SPTG(JLA,1,1) = SPTG(JLA,1,1)/ZPOLE
SPTG(JLA,2,1) = SPTG(JLA,2,1)/ZPOLE
END DO
*
* . 4.5 Correlation
C
ZCONST = 1.E10
C
DO JN = 1, NTRUNC + 1
ZSPCORR(JN) = SPTG(JN,1,1)
END DO
C
DO JM = 0, NTRUNC
DO JN = JM, NTRUNC
JLA = NIND(JM) + JN - JM
JM0 = JN + 1
DLFAC = 0.5/DSQRT((2*JN+1.D0)/2.D0)
DLCORR = DLFAC * ZSPCORR(JM0)
CORTGG(JLA,1,1) = DLCORR
CORTGG(JLA,2,1) = DLCORR
ENDDO
ENDDO
*
* 5. For zonal modes : set to zero the imaginary part
C and set the correct factor 1.0 for the real part
C ------------------------------------------------
C
DO JLA = 1, NTRUNC + 1
CORTGG(JLA,1,1) = 0.5*CORTGG(JLA,1,1)
CORTGG(JLA,2,1) = 0.0
END DO
*
* 6. Result in corns array
C ---------------------
C
DO JN = 0, NTRUNC
ILA = JN + 1
DO JLATBIN=1,NLATBIN
CORNS(nsposit(nstg),nsposit(nstg),JN,JLATBIN) = 2.D0*CORTGG(ILA,1,1)
END DO
END DO
*
*
* 7. Deallocate local arrays
*
deallocate(dltg)
CALL HPDEALLC(PXSPCORR,IERR,1)
WRITE(nulout,*)'DONE in SUTG'
RETURN
END