!-------------------------------------- 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 --------------------------------------
!
C
C X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X
C
subroutine corlocla 2,10
*
***s/r corlocla - Compactification of horizontal spectral densities.
* The output is rstddev array = sqrt(spectral density)
* It is assumed the array rhcorl of horizontal correlation scales has been previously set.
*
*Author : Luc Fillon - ARMA-EC - 5 Sept 2008.
*Revision: Luc Fillon - ARMA-EC - 11 Sept 2008. - Improve specification of zeroing length array zlensc in terms
* of original horizontal correlation scales for each analysis variables.
* -------------------
*
*Arguments
*
*
implicit none
*implicits
#include "taglam4d.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comct0.cdk"
#include "comcva.cdk"
#include "comcorr.cdk"
#include "comsp.cdk"
#include "comgd1.cdk"
#include "comfftla.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "rpnstd.cdk"
#include "comsim.cdk"
#include "comin.cdk"
*
character*2 clcorspace
character*3 clvar
logical llprint
integer jfi,jfj,jk,ik2,inf2,ji,jj,jla,ila,ilev,iip3
integer in,ix,jband,ik,imin,imax,imid,jm
real*8 zsum,zsumb,zd,zbeta,zlength
real*8 zk,zx,zremainder,zmid,zdx
real*8 zcon,zfacpp,znorm,zfac,ztol
real*8 ztrunc2,zkx,zky,zhscal,zlpsi,zmaxscale
real*8 zd,zd2,zcor0,zlne,znum,zdenom
!
real*8 zcscl(nksdim)
real*8 zfld(ni,nj)
real*8 z2d(ni,nj)
real*8 zgdxy(ni,nj)
real*8 zwindow(ni,nksdim,nj)
real*8 zcorr(ni,nksdim,nj)
real*8 zsp2(nla,2)
real*8 zsp(nla,2,nksdim)
real*8 zrstddev(nksdim,0:ntrunc)
real*8 zdensities(nksdim,0:ntrunc)
*
**
write(nulout,*) 'corlocla: ACTIVE'
ztol = 1.e-12
llprint = .true.
!
if(dxlam(1,nj/2).le.0) then
write(nulout,*) 'corlocla: dxlam(1,nj/2)=',dxlam(1,nj/2)
call abort3d(nulout,'corlocla: Problem with dxlam(1,nj/2) value')
endif
!
! Set the scale of the Gaussian window used for compactification
!
zd = real(mextendx)*dxlam(1,nj/2)
zd2 = zd**2
zlne = abs(alog(5.0))
do jk = 1, nksdim
znum = rhcorl(jk)*zd
zdenom = sqrt((zd2+2.*(rhcorl(jk)**2)*zlne))
!cluc zcscl(jk) = znum/zdenom
zcscl(jk) = 3.0*rhcorl(jk)
if(zcscl(jk).eq.0.) zcscl(jk) = dxlam(1,nj/2) ! to avoid numerical problems
if(zcscl(jk).lt.0.) then
write(nulout,*) 'corlocla: jk = ',jk
call abort3d(nulout,'corlocla: Negative zcscl detected')
endif
enddo
c
c Contruct the Gaussian window
c ----------------------------
c
do jk = 1, nksdim
call cormdl(z2d,zcscl(jk),'G',1,1,1,1)
do jj = 1, nj
do ji = 1, ni
zwindow(ji,jk,jj) = z2d(ji,jj)
enddo
enddo
enddo
c
do jk = 1, nksdim
call cormdl(z2d,zcscl(jk),'G',1,ni,1,1)
do jj = 1, nj
do ji = 1, ni
zwindow(ji,jk,jj) = z2d(ji,jj) + zwindow(ji,jk,jj)
enddo
enddo
enddo
c
do jk = 1, nksdim
call cormdl(z2d,zcscl(jk),'G',1,1,nj,1)
do jj = 1, nj
do ji = 1, ni
zwindow(ji,jk,jj) = z2d(ji,jj) + zwindow(ji,jk,jj)
enddo
enddo
enddo
c
do jk = 1, nksdim
call cormdl(z2d,zcscl(jk),'G',1,ni,nj,1)
do jj = 1, nj
do ji = 1, ni
zwindow(ji,jk,jj) = z2d(ji,jj) + zwindow(ji,jk,jj)
enddo
enddo
enddo
!
!*2 Compute spectral densities starting from rstddev array
!
do jk = 1, nksdim
do jband = 1, nband
zdensities(jk,jband-1) = (rstddev(jk,jband-1))**2
enddo
enddo
!
!*3 Get original gridpoint correlation
!
do jk = 1, nksdim
do jband = 1, nband
do jm = 1, mbandsp(jband)
ila=mila(jm,jband)
zsp2(ila,1) = zdensities(jk,jband-1)
zsp2(ila,2) = 0.0
enddo
enddo
if(lrpnfft) then
call zero(ni*nj,zgdxy)
call idft2dr(zgdxy,zsp2)
do jj=1,nj
do ji=1,ni
zcorr(ji,jk,jj) = zgdxy(ji,jj)
enddo
enddo
endif
enddo
!
!*4 Multiply Window with gridpoint correlation
!
do jk = 1, nksdim
do jj=1,nj
do ji=1,ni
zcorr(ji,jk,jj) = zwindow(ji,jk,jj)*zcorr(ji,jk,jj)
enddo
enddo
enddo
!
!*5 Compute the new spectral densities
!
!
do jk = 1, nksdim
do jj = 1, nj
do ji = 1, ni
zgdxy(ji,jj) = zcorr(ji,jk,jj)
enddo
enddo
call dft2dr(zsp(1,1,jk),zgdxy)
enddo
!
zrstddev(:,:) = 0.0
!
do jk = 1, nksdim
do jband = 1, nband
do jm = 1, mbandsp(jband)
ila=mila(jm,jband)
zrstddev(jk,jband-1)=zrstddev(jk,jband-1)+zsp(ila,1,jk) ! sp(ila,2) never used (cf. transp.ftn)
if(zrstddev(jk,jband-1).lt.ztol) zrstddev(jk,jband-1)=ztol
enddo
enddo
enddo
!
do jband = 1, nband
do jk = 1, nksdim
zrstddev(jk,jband-1)=zrstddev(jk,jband-1)/mbandsp(jband)
enddo
enddo
!
! Ensure normalization of compactified correlation
!
do jk = 1, nksdim
zsum = 0.
do jband = 1, nband
zsum = zsum + (zrstddev(jk,jband-1))*wvnbtot(jband)
enddo
if(zsum.lt.0.) then
write(nulout,*) 'corlocla: jk = ',jk
write(nulout,*) 'corlocla: zsum = ',zsum
call abort3d(nulout,'corlocla: Problem with compactified
& spectral densities...')
endif
if(zsum.eq.0.) then
zcon=1.0 ! means there is no original spectral densities...
else
zcon=1.0/zsum
endif
do jband = 1, nband
zrstddev(jk,jband-1) = zcon*zrstddev(jk,jband-1)
enddo
enddo
!
! Build rstddev as sqrt(spectral density)
!
do jk = 1, nksdim
do jband = 1, nband
rstddev(jk,jband-1) = sqrt(zrstddev(jk,jband-1))
enddo
enddo
!
! Estimate the Microscale correlation length
!
if(llprint) then
do jk = 1, nksdim
zsum = 0.
zsumb = 0.
do jband = 1, nband
zsum = zsum + (rstddev(jk,jband-1)**2)*wvnbtot(jband)
zsumb = zsumb + (rstddev(jk,jband-1)**2)*(wvnbtot(jband)**3)
enddo
!
zdx=dxlam(ni/2,nj/2)
zd=rns*zdx
zbeta=(zd/(2.*rpi))**2
zlength=sqrt(2.*zsum*zbeta/zsumb)
!
write(nulout,*) ' '
write(nulout,*) '*********************************************'
write(nulout,*) 'corlocla: From Spectral form of rstddev:
& jk, zlength (km) = ',jk,zlength/1.e3
write(nulout,*) '*********************************************'
write(nulout,*) ' '
enddo
endif
c
return
end