!-------------------------------------- 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 sufftla 1,9
*
***s/r sufftla - Initializes Fourier for Limited-Area (LA) configuration.
*
*
*Author: Luc Fillion *CGD/NCAR - 29 nov 99
*
*Revision: sept 02: L. Fillion - NCAR - Introduce NCAR FFT
*Revision: 29 jan 03: L. Fillion - MSC - Introduce Spectral-band partitioning
*Revision: 19 jun 03: C. Page - UQAM - Adaptation to CMC 3D-var
*Revision: 06 jul 04: L. Fillion - MSC - New NCAR fftpack5 FFT transform
* L. Fillion ARMA/MSC May 2006: Mesovar upgrade to v10_0_0.
*
IMPLICIT NONE
*implicits
#include "taglam4d.cdk"
#include "comct0.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comsp.cdk"
#include "comfftla.cdk"
#include "comgem.cdk"
#include "comgdpar.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
*
logical llprint
integer ji,jj,index,ila,inio2,injo2,isave,iminus
integer ibeg,iend,iwv,idel
integer jband,jla,ix,iband,jm
integer imin,imid,ik,iy
integer istat, ierr
real*8 zx,zkx,zky,zk2,zk,zremainder,zmid,zcorr
real*8 ztrunc,zlx,zly,zd,zdx,zdy
integer iwvband(0:nbimax)
real*8 ztotwv(nbimax)
real*8 zsdft2d(mlen2d)
real*8 zarray(ni/2,nj/2)
*
**
write(nulout,*) 'sufftla: nbimax = ',nbimax
llprint = .false.
!
ztrunc=real(ntrunc)
!
!
!*1 Initialize 2D Fourier Coeff. location w.r.t. jla
! in agreement with RPN or NCAR's arrangement of Fourier 2D coeff.
! ----------------------------------------------------------------
!
if(lrpnfft) then ! lrpnfft was initialized in sudim
call suwvnb_rpn
else
injo2=nj/2+1
ila=0
do ji=1,nfi
do jj=1,nfj ! order of loops important here!
ila=ila+1
nindxy(ji,jj)=ila
! I-direction: kx=0,1,2,...,nfi
mwvnbx(ila)=(ji-1)
! J-direction: ky=0,1,2,...,+-nj/2,...,-2,-1
if(jj.eq.injo2) isave=ila
if(jj.le.injo2) then ! wrap-around
mwvnby(ila)=(jj-1)
else
iminus=ila-isave
mwvnby(ila)=-mwvnby(isave-iminus)
endif
enddo
enddo
call rfft2i_8(ni,1,sdft1d,mlen1d,ierr)
call rfft2i_8(ni,nj,sdft2d,mlen2d,ierr)
endif
call rfft2i_8(ni,1,sdft1d,mlen1d,ierr) ! a enlever quand 1d DFT RPN sera installe dans les operateurs
!
!
!*2 Build ila location for each element in spectral band, over all bands
! and define band dimensions
! --------------------------------------------------------------------
!
if (rwvband.lt.0) then
write(nulout,fmt='(//,'' SUFFTLA: rwvband must be a Whole''
$ ,'' Positive Real Number.'')')
write(nulout,fmt='(/,'' SUFFTLA: PROGRAM STOPS'')')
else if(rwvband.eq.0.) then
write(nulout,fmt='(//,'' SUFFTLA: rwvband=0.0'')')
write(nulout,fmt='(/,'' SUFFTLA: Possible only for GLOBAL''
$ ,'' Geometry'')')
write(nulout,fmt='(/,'' SUFFTLA: PROGRAM STOPS'')')
endif
!
idel=aint(rwvband)
ibeg=0
iend=idel
iwv=1
10 do jj=ibeg,iend
iwvband(jj)=iwv
ztotwv(iwv)=real((ibeg+iend)/2)
enddo
ibeg=iend+1
iend=ibeg+idel
if(idel.eq.0) iend=ibeg
iwv=iwv+1
if(iend.lt.nbimax) goto 10
!
do jband=0,nbimax
mbandsp(jband)=0
enddo
!
nbandtot=-999
maxbpop=-999
zdx=grd_dx*111.0
zdy=grd_dy*111.0
zlx=(ni-1)*zdx
zly=(nj-1)*zdy
zd=max(zlx,zly)
rns = real(max(ni,nj))
!
do jla=1,nla
zkx=real(mwvnbx(jla))
zky=real(mwvnby(jla))
zk2=(zkx/zlx)**2+(zky/zly)**2
zk=zd*sqrt(zk2)
ik=nint(zk)
if(ik.gt.nbimax) then
write(nulout,*) 'sufftla: jla = ',jla
write(nulout,*) 'sufftla: mwvnbx(jla)=',mwvnbx(jla)
write(nulout,*) 'sufftla: mwvnby(jla)=',mwvnby(jla)
write(nulout,*) 'sufftla: grd_dx=',grd_dx
write(nulout,*) 'sufftla: grd_dy=',grd_dy
write(nulout,*) 'sufftla: zlx=',zlx
write(nulout,*) 'sufftla: zly=',zly
write(nulout,*) 'sufftla: zd=',zd
write(nulout,*) 'sufftla: zk2=',zk2
write(nulout,*) 'sufftla: zk=',zk
write(nulout,*) 'sufftla: ik,nbimax = ',ik,nbimax
call abort3d(nulout,'sufftla: ik.gt.nbimax')
endif
iband=iwvband(ik)
if(iband.gt.nbimax) then
call abort3d(nulout,'sufftla: iband.gt.nbimax')
endif
mbandsp(iband)=mbandsp(iband)+1
if(iband.gt.nbandtot) nbandtot=iband
if(mbandsp(iband).gt.maxbpop) maxbpop=mbandsp(iband)
if(mbandsp(iband).gt.(nfi*nfj)) then
call abort3d(nulout,'sufftla: mbandsp(iband).gt.(nfi+nfj)')
endif
mila(mbandsp(iband),iband)=jla
wvnbtot(iband)=ztotwv(iband)
enddo
!
write(nulout,fmt='(//,'' SUFFTLA: Maximal nb of elements in a''
$ ,'' band found ='',i8)') maxbpop
!
!*3 Choose NB. of Spectral band to retain due to Truncation
! -------------------------------------------------------
!
write(nulout,*) 'sufftla: Truncation: ntrunc = ',ntrunc
write(nulout,*) 'sufftla: wvnbtot=',wvnbtot
iband=0
31 iband=iband+1
if(wvnbtot(iband).lt.ztrunc) go to 31
nband=iband
!
write(nulout,fmt='(//,'' SUFFTLA: Total Nb of Spectral Bands = '',
$ i8)') nbandtot
!
write(nulout,fmt='(//,'' SUFFTLA: Spectral Band-width = '',
$ f5.2)') rwvband
!
if(nband.gt.(ntrunc+1)) then
call abort3d(nulout,'SUFFTLA: nband.gt.(ntrunc+1)! nband badly estimated')
else
write(nulout,fmt='(//,'' SUFFTLA: Nb of Spectral Bands Retained''
$ ,''= '',i8)') nband
endif
!
! set total number of spectral elements per annulus. Usefull for statistics computations
!
rbandtot(1)= 1.
do jband = 2, nband
rbandtot(jband)= 2.*mbandsp(jband)-2.
enddo
!
if(llprint) then
do jband=1,nband
write(nulout,fmt='(//,'' SUFFTLA: Spectral Band '',i8)')
$ jband
write(nulout,fmt='(/,'' SUFFTLA: ---------------'')')
write(nulout,fmt='(/,'' SUFFTLA: Total Wavenumber: '',E13.7)')
$ wvnbtot(jband)
write(nulout,fmt='(/,'' SUFFTLA: Nb. of elements in that''
$ ,'' band: '',i8)') mbandsp(jband)
do jm=1,mbandsp(jband)
ila=mila(jm,jband)
write(nulout,fmt='(/,'' SUFFTLA: Spectral Index ila = '',
$ i8)') ila
write(nulout,fmt='(/,'' SUFFTLA: Wavenumber in X: '',
$ i8)') mwvnbx(ila)
write(nulout,fmt='(/,'' SUFFTLA: Wavenumber in Y: '',
$ i8)') mwvnby(ila)
enddo
enddo
endif
!
!
! Output band localization array for visialization of correctness
! ---------------------------------------------------------------
!
call zero((ni/2)*(nj/2),zarray)
do jband = 1, nband
do jm = 1, mbandsp(jband)
ila=mila(jm,jband)
ix = mwvnbx(ila)+1
iy = mwvnby(ila)+1
zarray(ix,iy) = 1.0
enddo
enddo
!
! call ecr_la(zarray,'TT',0,'FFTHI',ibrpstamp,ideet,npas,
! & .true.,nulinclr,ni/2,nj/2,1)
!
return
end