external/fftpack/fftpack5/d1f3kf.F

   1 subroutine d1f3kf ( ido, l1, cc, in1, ch, in2, wa1, wa2 )
   2
   3 !*****************************************************************************80
   4 !
   5 !! D1F3KF is an FFTPACK5 auxiliary routine.
   6 !
   7 !
   8 !
   9 !  Modified:
  10 !
  11 !    07 February 2006
  12 !
  13 !  Author:
  14 !
  15 !    Original real single precision by Paul Swarztrauber, Richard Valent.
  16 !    Real double precision version by John Burkardt.
  17 !
  18 !  Reference:
  19 !
  20 !    Paul Swarztrauber,
  21 !    Vectorizing the Fast Fourier Transforms,
  22 !    in Parallel Computations,
  23 !    edited by G. Rodrigue,
  24 !    Academic Press, 1982.
  25 !
  26 !    Paul Swarztrauber,
  27 !    Fast Fourier Transform Algorithms for Vector Computers,
  28 !    Parallel Computing, pages 45-63, 1984.
  29 !
  30 !  Parameters:
  31 !
  32   implicit none
  33
  34   integer ( kind = 4 ) ido
  35   integer ( kind = 4 ) in1
  36   integer ( kind = 4 ) in2
  37   integer ( kind = 4 ) l1
  38
  39   real ( kind = 8 ) arg
  40   real ( kind = 8 ) cc(in1,ido,l1,3)
  41   real ( kind = 8 ) ch(in2,ido,3,l1)
  42   integer ( kind = 4 ) i
  43   integer ( kind = 4 ) ic
  44   integer ( kind = 4 ) idp2
  45   integer ( kind = 4 ) k
  46   real ( kind = 8 ) taui
  47   real ( kind = 8 ) taur
  48   real ( kind = 8 ) wa1(ido)
  49   real ( kind = 8 ) wa2(ido)
  50
  51   arg = 2.0D+00 * 4.0D+00 * atan ( 1.0D+00 ) / 3.0D+00
  52   taur = cos ( arg )
  53   taui = sin ( arg )
  54
  55   do k = 1, l1
  56     ch(1,1,1,k) = cc(1,1,k,1)          + ( cc(1,1,k,2) + cc(1,1,k,3) )
  57     ch(1,1,3,k) =                 taui * ( cc(1,1,k,3) - cc(1,1,k,2) )
  58     ch(1,ido,2,k) = cc(1,1,k,1) + taur * ( cc(1,1,k,2) + cc(1,1,k,3) )
  59   end do
  60
  61   if ( ido == 1 ) then
  62     return
  63   end if
  64
  65   idp2 = ido + 2
  66
  67   do k = 1, l1
  68     do i = 3, ido, 2
  69       ic = idp2 - i
  70       ch(1,i-1,1,k) = cc(1,i-1,k,1)+((wa1(i-2)*cc(1,i-1,k,2)+ &
  71         wa1(i-1)*cc(1,i,k,2))+(wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
  72         cc(1,i,k,3)))
  73       ch(1,i,1,k) = cc(1,i,k,1)+((wa1(i-2)*cc(1,i,k,2)- &
  74         wa1(i-1)*cc(1,i-1,k,2))+(wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
  75         cc(1,i-1,k,3)))
  76       ch(1,i-1,3,k) = (cc(1,i-1,k,1)+taur*((wa1(i-2)* &
  77         cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2))+(wa2(i-2)* &
  78         cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3))))+(taui*((wa1(i-2)* &
  79         cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2))-(wa2(i-2)* &
  80         cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3))))
  81       ch(1,ic-1,2,k) = (cc(1,i-1,k,1)+taur*((wa1(i-2)* &
  82         cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2))+(wa2(i-2)* &
  83         cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3))))-(taui*((wa1(i-2)* &
  84         cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2))-(wa2(i-2)* &
  85         cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3))))
  86       ch(1,i,3,k) = (cc(1,i,k,1)+taur*((wa1(i-2)*cc(1,i,k,2)- &
  87         wa1(i-1)*cc(1,i-1,k,2))+(wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
  88         cc(1,i-1,k,3))))+(taui*((wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
  89         cc(1,i,k,3))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
  90         cc(1,i,k,2))))
  91       ch(1,ic,2,k) = (taui*((wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
  92         cc(1,i,k,3))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
  93         cc(1,i,k,2))))-(cc(1,i,k,1)+taur*((wa1(i-2)*cc(1,i,k,2)- &
  94         wa1(i-1)*cc(1,i-1,k,2))+(wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
  95         cc(1,i-1,k,3))))
  96     end do
  97   end do
  98
  99   return
 100 end