!-------------------------------------- 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 qsfft8( a, inc, jump, lot, isign ) 2
implicit none
#include "taglam4d.cdk"
integer inc, jump, lot, isign
real*8 a(*)
real*8 ai, as, ya, ys, c, s, rr
integer i, j, k, is, k1, kk
integer n, m, nstore
real*8 ssin, ccos, qsin
pointer ( ptss,ssin(n-m-1) ), ( ptcc,ccos(n-m-1) )
pointer ( ptqs,qsin(0:m-1) )
common / comfft8x / ptss, ptcc, ptqs, n, m, nstore
integer iwrd
external stkmemw, unstakw
integer j0, jlot
real*8 w
pointer ( pw, w(511*nstore) )
real*8 pdwrd(2)
real prwrd(2)
real*8 zero, half, one, two, four
parameter( zero = 0.0 )
parameter( half = 0.5 )
parameter( one = 1.0 )
parameter( two = 2.0 )
parameter( four = 4.0 )
integer ijg, ijf, ijw
ijg(i,j) = 1 + (j0+j-1)*jump + i*inc
ijf(i,j) = 1 + (j0+j-1)*jump + (i-1)*inc
ijw(i,j) = j + i*511
C
C allocate w work array
C
iwrd = ( loc( pdwrd(2) ) - loc( pdwrd(1) ) )/
% ( loc( prwrd(2) ) - loc( prwrd(1) ) )
call stkmemw( iwrd*511*nstore , pw )
do 100 j0=0,lot-1,511
jlot = min( 511, lot - j0 )
if ( isign .eq. -1 ) then
C
C transform from gridpoint to Fourier
C
do i=0,m-1
is = n - i - 1
do j=1,jlot
ai = a( ijg(i ,j) )
as = a( ijg(is,j) )
ya = as - ai
ys = two * qsin( i ) * ( as + ai )
w( ijw(i ,j) ) = ys + ya
w( ijw(is,j) ) = ys - ya
enddo
enddo
if ( n .ne. 2 * m ) then
do j=1,jlot
w( ijw(m,j) ) = four * a( ijg(m,j) )
enddo
endif
call ffft8( w, 511, 1, jlot, -1 )
do k=1,m
if ( k .lt. m .or. n .ne. 2*m ) then
c = ccos( k )
s = ssin( k )
else
c = zero
s = one
endif
kk = 2 * k
k1 = kk + 1
do j=1,jlot
rr = w( ijw(kk,j) )
w( ijw(kk,j) ) = c * rr + s * w( ijw(k1,j) )
w( ijw(k1,j) ) = - s * rr + c * w( ijw(k1,j) )
enddo
enddo
do j=1,jlot
a( ijf(1,j) ) = half * w( ijw(0,j) )
enddo
do k=2,n-1,2
do j=1,jlot
a( ijf(k+1,j) ) = w( ijw(k ,j) ) + a( ijf(k-1,j) )
a( ijf(k ,j) ) = w( ijw(k+1,j) )
enddo
enddo
if ( n .eq. 2 * m ) then
do j=1,jlot
a( ijf(n,j) ) = w( ijw(n+1,j) )
enddo
endif
do j=1,jlot
a( ijf(n,j) ) = half * a( ijf(n,j) )
enddo
elseif ( isign .eq. +1 ) then
C
C transform from Fourier to gridpoint
C
do j=1,jlot
w( ijw(0,j) ) = a( ijf(1,j) )
w( ijw(1,j) ) = zero
enddo
do k=2,n-1,2
do j=1,jlot
w( ijw(k ,j) ) = half * ( a( ijf(k+1,j) ) -
% a( ijf(k-1,j) ) )
w( ijw(k+1,j) ) = half * a( ijf(k,j) )
enddo
enddo
if ( n .eq. 2 * m ) then
do j=1,jlot
w( ijw(n+1,j) ) = a( ijf(n,j) )
enddo
else
do j=1,jlot
w( ijw(n-1,j) ) = w( ijw(n-1,j) ) + half * a( ijf(n,j) )
enddo
endif
do k = 1 , m
if ( k .lt. m .or. n .ne. 2*m ) then
c = ccos( k )
s = ssin( k )
else
c = zero
s = one
endif
kk = 2 * k
k1 = kk + 1
do j=1,jlot
rr = w( ijw(kk,j) )
w( ijw(kk,j) ) = c * rr - s * w( ijw(k1,j) )
w( ijw(k1,j) ) = s * rr + c * w( ijw(k1,j) )
enddo
enddo
call ffft8( w, 511, 1, jlot, +1 )
do i=0,m-1
is = n - i - 1
do j=1,jlot
ys = ( w( ijw(i ,j) ) + w( ijw(is,j) ) )/
% ( four * qsin( i ) )
ya = ( w( ijw(is,j) ) - w( ijw(i ,j) ) ) * half
a( ijg(i, j) ) = ys + ya
a( ijg(is,j) ) = ys - ya
enddo
enddo
if ( n .ne. 2 * m ) then
do j=1,jlot
a( ijg(m,j) ) = w( ijw(m,j) ) * half
enddo
endif
endif
100 continue
C
C deallocate w work array
C
call unstakw( pw )
return
end