!-------------------------------------- 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 corrlengthla(kfile,ldoutfile,lduse) 4,6
*
#if defined (DOC)
*
***s/r corrlengthla: For lam4d option: calculate and output correlation lengths.
*
*Author: Luc Fillion - ARMA/MSC - Oct 2005.
*Revision: Luc Fillion - ARMA/EC - Oct 2008. - Ensure validation still valid under v_10_1_1.
* . Introduce argument ldoutfile.
*Revision: Luc Fillion - ARMA/EC - 27 Aug 2008 - Include lduse argument to save local estimated Length into array rhcorl.
*Revision: Luc Fillion - ARMA/EC - Sept 2008 - Output correlation scales on file for specific use.
*Revision: Luc Fillion - ARMA/EC - 31 May 2010 - Output correlation scales on file for scientific paper.
*
*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 "comlunla.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"
#include "comgem.cdk"
*
* Arguments
*
logical ldoutfile,lduse
INTEGER kfile
*
* Local Variables
*
character*2 cllvar(5)
integer jk, jband, jvar,idim
REAL*8 ZLPSI(JPNFLEV), ZLCHI(JPNFLEV), ZLTT(JPNFLEV),
& ZLLQ(JPNFLEV)
REAL*8 ZLPS,zminscale,zltg
REAL*8 zk2,zd,zdx
REAL*8 ZLN, ZLTEMP, ZLLENGTH(4*JPNFLEV),
& ZLA(4*JPNFLEV), ZLB(4*JPNFLEV), zbeta
*
**
cllvar(1) = 'PP'
cllvar(2) = 'CU'
cllvar(3) = 'TU'
cllvar(4) = 'LQ'
cllvar(5) = 'PU'
!
zminscale = 1.0
*
* 1. Normalization constants
* . -----------------------
*
WRITE(NULOUT,9000)'CORRLENGTHLA- Computing correlation lengths'
DO JK = 1, NKSDIM
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, NKSDIM
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, NKSDIM
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)
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, nksdim
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,nksdim
if(rhcorl(jk).le.zminscale) then
write(nulout,*) 'CORRLENGTHLA: jk,nksdim = ',jk,nksdim
write(nulout,*) 'CORRLENGTHLA: rhcorl(jk)=',rhcorl(jk)
if(jk.eq.nksdim.and.NFSTVAR2D.gt.1) then
write(nulout,*) 'CORRLENGTHLA: TG stats missing probably...'
write(nulout,*) 'CORRLENGTHLA: Will use RCSCLTG from NAMPSTAT'
CALL READNML('NAMPSTAT',IERR)
ZLTG = RCSCLTG
rhcorl(NKSDIM) = ZLTG
endif
if(jk.ne.nksdim) then
!cluc call abort3d(nulout,'CORRLENGTHLA:
! & Problem with estimated correlation Length')
endif
endif
enddo
endif
*
* PRINT THE RESULTS
*
open (unit=nutemp,file='lam_correl_scales.od')
write(nutemp,910) nflev
!
IF(NFSTVAR2D.gt.1) THEN
WRITE(NULOUT,FMT=9006)'CHARACTERISTIC LENGTHS (KM)',
& 'PP', 'UC', 'UT', 'LQ', 'UP', 'TG'
DO JK = 1, NFLEV
WRITE(NULOUT,FMT=9007) JK,
& ZLPSI(JK)/1000., ZLCHI(JK)/1000., ZLTT(JK)/1000.,
& ZLLQ(JK)/1000., ZLPS/1000., ZLTG/1000.
write(nutemp,900) vlev(jk)*1000.,ZLPSI(JK)/1000.,
& ZLCHI(JK)/1000.,ZLTT(JK)/1000.,ZLLQ(JK)/1000.
END DO
ELSE
WRITE(NULOUT,FMT=9004)'CHARACTERISTIC LENGTHS (KM)',
& 'PP', 'UC', 'UT', 'LQ', 'UP'
DO JK = 1, NFLEV
WRITE(NULOUT,FMT=9005) JK,
& ZLPSI(JK)/1000., ZLCHI(JK)/1000., ZLTT(JK)/1000.,
& ZLLQ(JK)/1000., ZLPS/1000.
write(nutemp,900) vlev(jk)*1000.,ZLPSI(JK)/1000.,
& ZLCHI(JK)/1000.,ZLTT(JK)/1000.,ZLLQ(JK)/1000.
END DO
ENDIF
!
close(nutemp)
*
900 format(5(E13.7,1X))
910 format(I4)
9000 FORMAT(/,8X,A,/)
9004 FORMAT(///,'%%',22X,A,/,2x,'Level (hPa)'
& ,8x,A,14x,A
& ,14x,A,14x,A,14x,A,14x,A,14x,A)
9005 FORMAT('%%',2X,I6,8X,G12.6,4X,G12.6,4X,G12.6,4X,G12.6
& ,4X,G12.6,4X,G12.6,4X,G12.6)
9006 FORMAT(///,'%%',12X,A,/,2x,'Level (hPa)'
& ,6x,A,8x,A
& ,12x,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
& ,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, 5
!
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.)
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