!-------------------------------------- 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 cfft8( a, inc, jump, lot ) 2

      implicit none
#include "taglam4d.cdk"

      integer inc, jump, lot
      real*8  a(*)

      real*8  ai, as, ya, ys, xnor
      integer i, j, k, is

      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 ija, ijw
      ija(i,j) = 1 + (j0+j-1)*jump + i*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 )

      xnor = sqrt( half * n )

      do 100 j0=0,lot-1,511
      jlot  = min( 511, lot - j0 )

      i  = 1
      is = n - i
      do j=1,jlot
         ai= a( ija(i ,j) )
         as= a( ija(is,j) )
         ya = ( as - ai )
         a( ija( 1,j) ) = - ya * ccos( i )
         ya = two *  ssin( i ) * ya * xnor
         ys = ( as + ai ) * xnor 
         w( ijw(i ,j) ) = ys + ya
         w( ijw(is,j) ) = ys - ya
         ys = ( a( ija(n,j) ) + a( ija(0,j) ) ) * xnor
         a( ija(1,j) ) = a( ija(1,j) ) -
     %                   half * ( a( ija(n,j) ) - a( ija(0,j) ) )
         w( ijw(0,j) ) = ys
         w( ijw(n,j) ) = ys
      enddo

      do i=2,n-m-1

         is = n - i
         do j=1,jlot
            ai= a( ija(i ,j) )
            as= a( ija(is,j) )
            ya = ( as - ai )
            a( ija( 1,j) ) = a( ija(1,j) ) - ya * ccos( i )
            ya = two *  ssin( i ) * ya * xnor
            ys = ( as + ai ) * xnor 
            w( ijw(i ,j) ) = ys + ya
            w( ijw(is,j) ) = ys - ya
         enddo

      enddo

      do j=1,jlot
         a( ija(1,j) ) = a( ija(1,j) )/xnor
      enddo

      if ( n .eq. 2 * m ) then
         do j=1,jlot
            w( ijw( m,j) ) = two * a( ija( m,j) ) * xnor
         enddo
      endif

      call ffft8( w, 511, 1, jlot, -1 )

      do j=1,jlot
         a( ija(0,j) ) = w( ijw(0,j) )
      enddo

      do k=1,m-1
         do j=1,jlot
            a( ija(2*k  ,j) ) = w( ijw(2*k  ,j) )
            a( ija(2*k+1,j) ) = a( ija(2*k-1,j) ) - w( ijw(2*k+1,j) )
         enddo
      enddo

      do j=1,jlot
         a( ija(2*m,j) ) = w( ijw(2*m,j) )
      enddo

      if ( n .ne. 2 * m ) then
         do j=1,jlot
            a( ija(n,j) ) = a( ija(n-2,j) ) - w( ijw(n,j) )
         enddo
      endif

  100 continue
      return
      end