!-------------------------------------- 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 trans1d(ar,r1,r2,r3,maxsize,N,NLOT,ICAS,IAXE,IWAY) 2,24
!
! Author: Jean Cote -ARMN/EC - Date of creation unknown.
!
! Revision 3.1 2003/10/24 21:05:48 dugas
! Implementer du code compatible RS6000
! Revision 3.0 2000/07/24 20:39:14 armnrbd
! Revision Luc Fillion -ARMA/EC - 17 Jun 2010 - Include author and revisions. Include taglam4d.cdk.
IMPLICIT none
#include "taglam4d.cdk"
C * THIS ROUTINE DOES THE SPECTRAL TRANSFORMS (FORWARD AND INVERSE)
C * IT WORKS ON MULTIPLE ROW OR COLUMN AT A TIME.
C * IT CAN DO FIVE KINDS OF TRANSFORM:
C 1 => SIN ONLY.
C 2 => COS ONLY.
C 3 => SIN SHIFTED ONLY.
C 4 => COS SHIFTED ONLY.
C 5 => REGULAR SIN & COS.
C
integer MAXSIZE,N,NLOT,ICAS,IAXE,IWAY
real*8 ar(MAXSIZE), r1(MAXSIZE),r2(MAXSIZE),r3(MAXSIZE)
integer NX,NY, nn, lot, nis, lots, nic, lotc
real*8 cnorm, fac
C<< JUST FOR DEBUGGING:
real*8 scors2, scorc2, scors3, scorc3, scors4, scorc4
real*8 scorqs2, scorqc2, scorqs3, scorqc3, scorqs4, scorqc4
real*8 scorr2, scorr3, scorr4
C>>
real*8 del, angle
real*8 zero, half, one, two
parameter( zero = 0.0 )
parameter( half = 0.5 )
parameter( one = 1.0 )
parameter( two = 2.0 )
LOGICAL FAST_FT
logical lprint, lsin, lcos, lqsin, lqcos, lrft
integer i, j, k, inc, jump, incs, jumps, incc, jumpc
integer incr, jumpr, nfact, lotr
integer ndx, nds, ndc, ndr
ndx(i,j) = 1 + ( j - 1 ) * jump + i * inc
ndr(i,j) = 1 + ( j - 1 ) * jumpr + i * incr
nds(i,j) = 1 + ( j - 1 ) * jumps + ( i - 1 ) * incs
ndc(i,j) = 1 + j * jumpc + i * incc
lprint = .false.
lsin = icas .eq. 1
lcos = icas .eq. 2
lqsin = icas .eq. 3
lqcos = icas .eq. 4
lrft = icas .eq. 5
if (lprint) then
print *,'*********************'
if ( lsin ) print *,'* sft8, sfft8 *'
if ( lcos ) print *,'* cft8, cfft8 *'
if ( lqsin ) print *,'* qsft8, qsfft8 *'
if ( lqcos ) print *,'* qcft8, qcfft8 *'
if ( lrft ) print *,'* rft8, ffft8 *'
print *,'*********************'
endif
C<< JUST FOR DEBUGGING:
scors2 = zero
scorc2 = zero
scors3 = zero
scorc3 = zero
scors4 = zero
scorc4 = zero
scorqs2 = zero
scorqc2 = zero
scorqs3 = zero
scorqc3 = zero
scorqs4 = zero
scorqc4 = zero
scorr2 = zero
scorr3 = zero
scorr4 = zero
C>>
C * SELECT THE FAST OR THE SLOW FOURIER TRANSFORM
C * BASED ON FACTORIZATION.
NFACT=N
CALL NGFFT( NFACT )
If(NFACT.EQ.N) THEN
FAST_FT=.TRUE.
if ( lsin ) call setscqr( n-1, 'SIN' )
if ( lcos ) call setscqr( n+1, 'COS' )
if ( lqsin ) call setscqr( n , 'QSIN' )
if ( lqcos ) call setscqr( n , 'QCOS' )
if ( lrft ) call setscqr( n , 'REAL' )
ELSE
FAST_FT=.FALSE.
ENDIF
cnorm = sqrt( two/n )
del = acos( - one )/n
nis = n - 1
nic = n + 1
if ( IAXE .eq. 0 ) then
C * On veut par exemple:
C appel de trans1d liste d'arguments appel pour
c dans main de trans1d routine fft
C ================= ================= ===========
C
C NX=NID --> N --> n=jump=N=NID
C NY=NJD --> NLOT --> lot=NLOT=NJD
C inc=1
C>>
lot = NLOT
lots = lot ! a verifier !!
lotc = lot ! a verifier !!
C>>
inc = 1
jump = n
incr = 1
jumpr = n + 2
incs = 1
jumps = n-1
incc = 1
jumpc = n+1
else
C appel de trans1d liste d'arguments appel pour
c dans main de trans1d routine fft
C ================= ================= ===========
C
C NX=NJD --> N --> n=NJD
C NY=NID --> NLOT --> lot=inc=NLOT=NID
C jump=1
C>>
lot = NLOT
lotr = NLOT + 2
lots = NLOT - 1 ! a verifier !!
lotc = NLOT + 1 ! a verifier !!
C>>
inc = NLOT ! il sont tous a verifer!!
jump = 1
incr = lotr
jumpr = 1
incs = lots
jumps = 1
incc = lotc
jumpc = 1
endif
C------------------------------------------------------------------
C
C case of sft8, sfft8
C
C------------------------------------------------------------------
if ( lsin ) then
do j=1,lots ! a verifier
do i=1,nis
C=== ar(nds(i,j)) = cnorm * sin( i * angle )
r3(nds(i,j)) = ar(nds(i,j))
enddo
enddo ! a verifier
call sft8 ( r1, ar, incs, jumps, lots, n )
call sfft8( r3, incs, jumps, lots )
do j=1,lots
do i=1,nis
scors2 = max( scors2, abs(r1(nds(i,j))-r3(nds(i,j))) )
enddo
enddo
print *,'scors2 = ',scors2
if ( lprint ) then
print *,'r1, r3'
do j=1,lots
print *,'j = ',j,(r1(nds(i,j)),i=1,nis)
print *,'j = ',j,(r3(nds(i,j)),i=1,nis)
enddo
endif
call sft8 ( r2, r1, incs, jumps, lots, n )
call sfft8( r3, incs, jumps, lots )
do j=1,lots
do i=1,nis
scors3 = max( scors3, abs(ar(nds(i,j))-r2(nds(i,j))) )
scors4 = max( scors4, abs(ar(nds(i,j))-r3(nds(i,j))) )
enddo
enddo
print *,'scors3, scors4 = ',scors3,scors4
if ( lprint ) then
print *,'r2, r3'
do j=1,lots
print *,'j = ',j,(r2(nds(i,j)),i=1,nis)
print *,'j = ',j,(r3(nds(i,j)),i=1,nis)
enddo
endif
endif
C------------------------------------------------------------------
C
C case of cft8, cfft8
C
C------------------------------------------------------------------
if ( lcos ) then
do j=0,n
c== angle = j * del
c== fac = one
c== if ( j .eq. 0 .or. j.eq. n ) fac = half
do i=0,n
c== ar(ndc(i,j)) = fac * cnorm * cos( i * angle )
r3(ndc(i,j)) = ar(ndc(i,j))
enddo
enddo
call cft8 ( r1, ar, incc, jumpc, lotc, n )
call cfft8( r3, incc, jumpc, lotc )
do j=0,n
do i=0,n
scorc2 = max( scorc2, abs(r1(ndc(i,j))-r3(ndc(i,j))) )
enddo
enddo
print *,'scorc2 = ',scorc2
if ( lprint ) then
print *,'r1, r3'
do j=0,n
print *,'j = ',j,(r1(ndc(i,j)),i=0,n)
print *,'j = ',j,(r3(ndc(i,j)),i=0,n)
enddo
endif
call cft8 ( r2, r1, incc, jumpc, lotc, n )
call cfft8( r3, incc, jumpc, lotc )
do j=0,n
do i=0,n
scorc3 = max( scorc3, abs(ar(ndc(i,j))-r2(ndc(i,j))) )
scorc4 = max( scorc4, abs(ar(ndc(i,j))-r3(ndc(i,j))) )
enddo
enddo
print *,'scorc3, scorc4 = ',scorc3,scorc4
if ( lprint ) then
print *,'r2, r3'
do j=0,n
print *,'j = ',j,(r2(ndc(i,j)),i=0,n)
print *,'j = ',j,(r3(ndc(i,j)),i=0,n)
enddo
endif
endif
C------------------------------------------------------------------
C
C case of qsft8, qsfft8
C
C------------------------------------------------------------------
if ( lqsin ) then
if (IWAY.eq.-1) then
if (FAST_FT) then
call qsfft8(ar, inc,jump,lot,-1)
else
call qsft8 (r1,ar,inc,jump,lot,-1,n )
do k=1,n*lot
ar(k)=r1(k)
enddo
endif
else ! Fourier -> gridpoint
if (FAST_FT) then
call qsfft8(ar, inc,jump,lot,+1)
else
call qsft8 (r1,ar,inc,jump,lot,+1,n )
do k=1,n*lot
ar(k)=r1(k)
enddo
endif
endif
endif
C------------------------------------------------------------------
C
C case of qcft8, qcfft8
C
C------------------------------------------------------------------
if ( lqcos ) then
if (IWAY.eq.-1) then
if (FAST_FT) then
call qcfft8(ar, inc,jump,lot,-1)
else
call qcft8 (r1,ar,inc,jump,lot,-1,n )
do k=1,n*lot
ar(k)=r1(k)
enddo
endif
else ! Fourier -> gridpoint
if (FAST_FT) then
call qcfft8(ar, inc,jump,lot,+1)
else
call qcft8 (r1,ar,inc,jump,lot,+1,n )
do k=1,n*lot
ar(k)=r1(k)
enddo
endif
endif
endif
C------------------------------------------------------------------
C
C case of rft8, ffft8
C
C------------------------------------------------------------------
if ( lrft ) then
C== do j=1,lot
C== do i=0,n-1
C== r3(ndr(i,j)) = ar(ndr(i,j))
C== enddo
C== enddo
if ( lprint ) then
print *,' On imprime ar avant transforme'
do j=1,lot
print *,'j = ',j,(ar(ndr(i,j)),i=0,2*(n/2)+1)
enddo
endif
if (IWAY.eq.-1) then
if (FAST_FT) then
C== print *,'USING FFT'
call ffft8(ar, incr,jumpr,lot,-1) ! gridpoint -> Fourier
else
call rft8 ( r1,ar,incr,jumpr,lot,-1,n)
do k=1,(n+2)*lot
ar(k)=r1(k)
enddo
endif
else ! Fourier -> gridpoint
if (FAST_FT) then
! print *,'USING FFT'
call ffft8(ar, incr,jumpr,lot,+1)
else
call rft8 (r1,ar,incr,jumpr,lot,+1,n)
do k=1,(n+2)*lot
ar(k)=r1(k)
enddo
endif
endif
if ( lprint ) then
print *,' On imprime ar apres transforme'
do j=1,lot
print *,'j = ',j,(ar(ndr(i,j)),i=0,2*(n/2)+1)
enddo
endif
endif
C== print *,'------------------------------------------------------
C== %-------------'
return
end