!--------------------------------------- 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 --------------------------------------
!--------------------------------------------------------------------------
! MODULE fft (prefix="fft")
!
! Subroutines:
! fft_sufft (public)
! fft_fft3dvar (public)
! ngfft
!
! Public variables:
! NONE
!
! Dependencies:
!
!--------------------------------------------------------------------------
module fft 1
implicit none
save
private
! public procedures
public :: fft_fft3dvar,fft_fft3dvar2,fft_sufft
integer,parameter :: nMaxFft = 10
integer :: nFftAlreadyAllocated = 0
integer :: nlfft= 1024
integer :: ni_l(nMaxFft),nj_l(nMaxFft)
integer :: myLatBeg(nMaxFft),myLatEnd(nMaxFft)
contains
integer FUNCTION fft_SUFFT(KULOUT,NI_in,NJ_in,myLatBeg_in,myLatEnd_in) 1,1
IMPLICIT NONE
integer jk,ni_in,nj_in,myLatBeg_in,myLatEnd_in
INTEGER IERR, KULOUT, i, fftID
if(nFftAlreadyAllocated.eq.nMaxFft) then
write(*,*) 'fft_SUFFT: Already reached maximum FFTs allowed!'
call exit(-1)
endif
nFftAlreadyAllocated=nFftAlreadyAllocated+1
fftID=nFftAlreadyAllocated
ni_l(fftID)=ni_in
nj_l(fftID)=nj_in
myLatBeg(fftID)=myLatBeg_in
myLatEnd(fftID)=myLatEnd_in
! 1. Allocate memory for the constant arrays required by the FFT
WRITE(KULOUT,*) 'SUFFT- Memory allocation and initialisation for the fast Fourier transform'
IF(NLFFT.GT.1024)THEN
NLFFT = 1024
WRITE(KULOUT,*) '*** The FFT cannot handle more than 1024 transforms at the time. NLFFT reset to ',NLFFT
END IF
!* 2. Initialisation of the constants of the FFT
i = ni_l(fftID)
call ngfft
( i )
if ( i.ne.ni_l(fftID) ) then
write(kulout,*) 'SUFFT: NI = ',ni_l(fftID),' I = ',i
stop
else
write(kulout,*) 'SUFFT: NI = ',ni_l(fftID)
endif
call setfft8(ni_l(fftID))
fft_SUFFT=fftID
RETURN
END FUNCTION fft_SUFFT
SUBROUTINE fft_FFT3DVAR(PGD,KFIELD,KDIM,KDIR,FFTID) 1
IMPLICIT NONE
INTEGER KDIM,KFIELD,KDIR,FFTID
REAL*8 PGD(NI_l(fftID),KDIM,NJ_l(fftID))
REAL*8 PGD2(NI_l(fftID)+2,KFIELD,NJ_l(fftID))
integer ji,jj,jk
INTEGER ILATBD,IJUMP,INFFT
INTEGER nfftstrid
!$OMP PARALLEL
!$OMP DO PRIVATE (jj,jk,ji)
do jj=1,nj_l(fftID)
do jk=1,kfield
do ji=ni_l(fftID)+1,ni_l(fftID)+2
pgd2(ji,jk,jj)=0.0d0
enddo
do ji=1,ni_l(fftID)
pgd2(ji,jk,jj)=pgd(ji,jk,jj)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
IJUMP = NI_l(fftID) + 2
NFFTSTRID=1
!$OMP PARALLEL PRIVATE (ILATBD,INFFT)
!$OMP DO PRIVATE (JJ)
DO JJ = 1,nj_l(fftID), NFFTSTRID
ILATBD = MIN(NFFTSTRID,nj_l(fftID) - JJ + 1)
INFFT = KFIELD*ILATBD
CALL FFFT8(PGD2(1,1,JJ),1,IJUMP,INFFT,KDIR)
!* subroutine ffft8( a, inc, jump, lot, isign )
!* a is the array containing input & output data
!* inc is the increment within each data 'vector'
!* (e.g. inc=1 for consecutively stored data)
!* jump is the increment between the start of each data vector
!* lot is the number of data vectors
!* isign = +1 for transform from spectral to gridpoint
!* = -1 for transform from gridpoint to spectral
END DO
!$OMP END DO
!$OMP END PARALLEL
!$OMP PARALLEL
!$OMP DO PRIVATE (jj,jk,ji)
do jj=1,nj_l(fftID)
do jk=1,kfield
do ji=1,ni_l(fftID)
pgd(ji,jk,jj)=pgd2(ji,jk,jj)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
RETURN
END subroutine fft_fft3dvar
SUBROUTINE fft_FFT3DVAR2(PGD,KFIELD,KDIM,KDIR,FFTID) 10
IMPLICIT NONE
INTEGER KDIM,KFIELD,KDIR,FFTID
REAL*8 PGD(NI_l(fftID),KDIM,myLatBeg(fftID):myLatEnd(fftID))
REAL*8 PGD2(NI_l(fftID)+2,KFIELD,myLatBeg(fftID):myLatEnd(fftID))
integer ji,jj,jk
INTEGER ILATBD,IJUMP,INFFT
INTEGER nfftstrid
! Copy over input data into over-dimensioned array
!$OMP PARALLEL
!$OMP DO PRIVATE (jj,jk,ji)
do jj=myLatBeg(fftID),myLatEnd(fftID)
do jk=1,kfield
do ji=ni_l(fftID)+1,ni_l(fftID)+2
pgd2(ji,jk,jj)=0.0d0
enddo
do ji=1,ni_l(fftID)
pgd2(ji,jk,jj)=pgd(ji,jk,jj)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
IJUMP = NI_l(fftID) + 2
NFFTSTRID=1
!$OMP PARALLEL PRIVATE (ILATBD,INFFT)
!$OMP DO PRIVATE (JJ)
DO JJ = myLatBeg(fftID),myLatEnd(fftID), NFFTSTRID
ILATBD = MIN(NFFTSTRID,myLatEnd(fftID) - JJ + 1)
INFFT = KFIELD*ILATBD
CALL FFFT8(PGD2(1,1,JJ),1,IJUMP,INFFT,KDIR)
!* subroutine ffft8( a, inc, jump, lot, isign )
!* a is the array containing input & output data
!* inc is the increment within each data 'vector'
!* (e.g. inc=1 for consecutively stored data)
!* jump is the increment between the start of each data vector
!* lot is the number of data vectors
!* isign = +1 for transform from spectral to gridpoint
!* = -1 for transform from gridpoint to spectral
END DO
!$OMP END DO
!$OMP END PARALLEL
!$OMP PARALLEL
!$OMP DO PRIVATE (jj,jk,ji)
do jj=myLatBeg(fftID),myLatEnd(fftID)
do jk=1,kfield
do ji=1,ni_l(fftID)
pgd(ji,jk,jj)=pgd2(ji,jk,jj)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
RETURN
END subroutine fft_fft3dvar2
subroutine ngfft( n ) 4
implicit none
integer n
integer l
parameter ( l = 3 )
integer k( l ) , m
data m , k / 8 , 2 , 3 , 5 /
integer i,j
if ( n.le.m ) n = m + 1
n = n - 1
1 n = n + 1
i = n
2 do 3 j=1,l
if( mod(i,k(j)) .eq. 0 ) go to 4
3 continue
go to 1
4 i = i/k(j)
if( i .ne. 1 ) go to 2
return
end subroutine ngfft
end module fft