!-------------------------------------- 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 corrlengthla2(kfile,ldoutfile,lduse) 2,7
*
#if defined (DOC)
*
***s/r corrlengthla2: For lam4d option: Extension of corrlengthla.ftn
*
*Author: Luc Fillion - ARMA/EC - 5 Mar 2009.
*
*Arguments
* kfile: file number
* ldoutfile: .true. will also output correlation scales on RPN standard file.
*
#endif
IMPLICIT NONE
*implicits
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comgrd_param.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "rpnstd.cdk"
#include "comcorr.cdk"
#include "comcse1.cdk"
#include "comgdpar.cdk"
#include "comfftla.cdk"
#include "comgrd.cdk"
#include "compstat.cdk"
*
* Arguments
*
logical ldoutfile,lduse
INTEGER kfile
*
* Local Variables
*
character*2 cllvar(6)
integer jk, jband, jvar,idim
REAL*8 ZLPS,zminscale,zltg,zltemp
REAL*8 zk2,zd,zdx, zbeta
real*8 ZLLQ(nflev), ZLTB(nflev)
REAL*8 ZLPSI(nflev), ZLCHI(nflev), ZLTT(nflev)
REAL*8 ZLLENGTH(nksdim2)
real*8 ZLA(nksdim2), ZLB(nksdim2)
*
**
cllvar(1) = 'PP'
cllvar(2) = 'CU'
cllvar(3) = 'TU'
cllvar(4) = 'LQ'
cllvar(5) = 'TB'
cllvar(6) = 'PU'
!
zminscale = 1.0
*
* 1. Normalization constants
* . -----------------------
*
WRITE(NULOUT,9000)'corrlengthla2- Computing correlation lengths'
DO JK = 1, nksdim2
ZLA(JK) = 0.0
ZLB(JK) = 0.0
END DO
*
zdx=dxlam(ni/2,nj/2)
zd=rns*zdx
zbeta = (zd/(2.d0*rpi))**2
do jband = 1, nband
zk2 = wvnbtot(jband)**3
DO JK = 1, nksdim2
ZLTEMP = (RSTDDEV(JK,jband-1)**2)
ZLA(JK) = ZLA(JK) + ZLTEMP*wvnbtot(jband)
ZLB(JK) = ZLB(JK) + ZLTEMP*zk2
END DO
END DO
*
DO JK = 1, nksdim2
if(ZLB(JK).le.0.) then
ZLLENGTH(JK) = 0.0
else
ZLLENGTH(JK) = SQRT(2.d0*ZLA(JK)*zbeta/ZLB(JK))
endif
END DO
*
DO JK = 1, NFLEV
ZLPSI(JK) = ZLLENGTH(JK)
ZLCHI(JK) = ZLLENGTH(JK+NFLEV)
ZLTT(JK) = ZLLENGTH(JK+2*NFLEV)
ZLLQ(JK) = ZLLENGTH(JK+3*NFLEV)
ZLTB(JK) = ZLLENGTH(JK+4*NFLEV)
END DO
!
IF(NFSTVAR2D.gt.1) THEN
ZLPS = ZLLENGTH(nksdim-1)
ZLTG = ZLLENGTH(nksdim)
ELSE
ZLPS = ZLLENGTH(nksdim)
ENDIF
!
! Save into arrays for use through 3dvar
! --------------------------------------
!
if(lduse) then
do jk = 1, nksdim2
rhcorl(jk) = ZLLENGTH(JK)
enddo
IF(NFSTVAR2D.gt.1) THEN
rhcorl(NKSDIM-1) = ZLPS
rhcorl(NKSDIM) = ZLTG
ELSE
rhcorl(NKSDIM) = ZLPS
ENDIF
!
do jk=1,nksdim2
if(rhcorl(jk).le.zminscale) then
write(nulout,*) 'corrlengthla2: jk,nksdim = ',jk,nksdim
write(nulout,*) 'corrlengthla2: rhcorl(jk)=',rhcorl(jk)
if(jk.eq.nksdim.and.NFSTVAR2D.gt.1) then
write(nulout,*) 'corrlengthla2: TG stats missing probably...'
write(nulout,*) 'corrlengthla2: Will use RCSCLTG from NAMPSTAT'
CALL READNML('NAMPSTAT',IERR)
ZLTG = RCSCLTG
rhcorl(NKSDIM) = ZLTG
endif
if(jk.ne.nksdim) then
!cluc call abort3d(nulout,'corrlengthla2:
! & Problem with estimated correlation Length')
endif
endif
enddo
endif
*
* PRINT THE RESULTS
*
WRITE(NULOUT,FMT=9006)'CHARACTERISTIC LENGTHS (KM)',
+ 'PP', 'UC', 'UT', 'LQ', 'TB', 'UP', 'TG'
!
DO JK = 1, NFLEV
WRITE(NULOUT,FMT=9007) JK,
S ZLPSI(JK)/1000., ZLCHI(JK)/1000., ZLTT(JK)/1000.,
S ZLLQ(JK)/1000., ZLTB(JK)/1000., ZLPS/1000., ZLTG/1000.
END DO
*
9000 FORMAT(/,8X,A,/)
9006 FORMAT(///,'%%',12X,A,/,2x,'Level (hPa)'
S ,6x,A,10x,A
S ,15x,A,10x,A,12x,A,10x,A,10x,A,10x,A)
9007 FORMAT('%%',2X,I6,8X,G12.6,4X,G12.6,4X,G12.6,4X,G12.6
S ,4X,G12.6,4X,G12.6,4X,G12.6,4X,G12.6,4X,G12.6)
!
if(ldoutfile) then
!
! write out the length scales
INK = NFLEV
INI = 1
INJ = 1
CLETIKET='LONGCORR'
CLGRTYP = 'X'
IP1 = 0
IP2 = 0
IP3 = nensemble
idateo = ndatestat
IDEET = 0
IPAS = 0
IG1 = 0
IG2 = 0
IG3 = 0
IG4 = 0
IDATYP = 5
CLTYPVAR = 'X'
IPAK = -32
!
do jvar = 1, 6
!
CLNOMVAR = cllvar(jvar)
!
if(CLNOMVAR.eq.'PP') then
IERR =VFSTECR(ZLPSI,ZLPSI,IPAK,
& kfile,IDATEO,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,
& CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,
& IDATYP,.TRUE.)
!
else if(CLNOMVAR.eq.'CU') then
IERR =VFSTECR(ZLCHI,ZLCHI,IPAK,
& kfile,IDATEO,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,
& CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,
& IDATYP,.TRUE.)
!
else if(CLNOMVAR.eq.'TU') then
IERR =VFSTECR(ZLTT,ZLTT,IPAK,
& kfile,IDATEO,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,
& CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,
& IDATYP,.TRUE.)
!
else if(CLNOMVAR.eq.'LQ') then
IERR =VFSTECR(ZLLQ,ZLLQ,IPAK,
& kfile,IDATEO,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,
& CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,
& IDATYP,.TRUE.)
!
else if(CLNOMVAR.eq.'TB') then
IERR =VFSTECR(ZLTB,ZLTB,IPAK,
& kfile,IDATEO,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,
& CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,
& IDATYP,.TRUE.)
endif
enddo
!
INK=1
IERR =VFSTECR(ZLPS,ZLPS,IPAK,
& kfile,IDATEO,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,
& CLTYPVAR,'PU',CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,
& IDATYP,.TRUE.)
endif
!
return
end