subroutine ffttp_1d( nx, a, b, csign, prim )
! 1d の fft を csign をもとに, 正変換, 逆変換するルーチン
! Temperton's FFT
implicit none
integer, intent(in) :: nx ! 入力配列の要素数
complex, intent(in), dimension(0:nx-1) :: a ! 入力配列
complex, intent(inout), dimension(0:nx-1) :: b ! 出力配列
character(1), intent(in) :: csign ! 正逆変換判定 [r=正変換, i=逆変換]
character(1), optional, intent(in) :: prim ! 素因数分解をするかどうか
! [o=分解する, x=分解しない] default=分解しない. その場合は, 通常の DFT.
! 素因数分解する場合, nx=2^a*3^b*5^c*7^d までしか分解しないようにする.
integer, allocatable, dimension(:) :: l, m, n ! 要素等の作業用配列
real, parameter :: pi=3.14159265
complex, parameter :: img=(0.0,1.0)
complex :: fact, ctmp
integer :: stat, counter, base
integer :: i, j, k, id, jd, kd ! do loop 用配列
integer, parameter, dimension(4) :: prim_dim=(/2, 3, 5, 7/) ! 素因数
integer, dimension(4) :: prim_num ! 各素因数のべき数
complex, dimension(0:1,0:1) :: omega2
complex, dimension(0:2,0:2) :: omega3
complex, dimension(0:4,0:4) :: omega5
complex, dimension(0:6,0:6) :: omega7
complex, allocatable, dimension(:,:) :: omega
complex, dimension(0:nx-1,0:nx-1) :: omegan
complex, dimension(0:nx-1) :: c ! tmp array
base=nx
prim_num=0
counter=0
do i=0,nx-1
b(i)=a(i)
end do
!-- 素因数分解する処理
if(present(prim))then
if(prim=='o')then
do i=1,4
do while(mod(base,prim_dim(i))==0)
base=base/prim_dim(i)
prim_num(i)=prim_num(i)+1
counter=counter+1
end do
end do
if(base==1)then
counter=counter-1
end if
if(counter/=0)then ! prim=='o' であっても, 素因数分解できなければ DFT に送る.
allocate(l(counter+1))
allocate(m(counter+1))
allocate(n(counter+1))
stat=0
do i=1,4
if(prim_num(i)/=0)then
select case(prim_dim(i))
case(2)
n(stat+1:stat+prim_num(i))=2
stat=stat+prim_num(i)
case(3)
n(stat+1:stat+prim_num(i))=3
stat=stat+prim_num(i)
case(5)
n(stat+1:stat+prim_num(i))=5
stat=stat+prim_num(i)
case(7)
n(stat+1:stat+prim_num(i))=7
stat=stat+prim_num(i)
end select
end if
end do
if(base/=1)then
n(counter+1)=base
end if
end if
end if
end if
!-- 回転行列を定義
select case(csign)
case('r')
fact=cos(2.0*pi/real(nx))-img*sin(2.0*pi/real(nx))
if(counter/=0)then
omega2=1.0
omega2(1,1)=-1.0
do j=0,2
do i=0,2
omega3(i,j)=cos(2.0*pi*i*j/3.0)-img*sin(2.0*pi*i*j/3.0)
end do
end do
do j=0,4
do i=0,4
omega5(i,j)=cos(2.0*pi*i*j/5.0)-img*sin(2.0*pi*i*j/5.0)
end do
end do
do j=0,6
do i=0,6
omega7(i,j)=cos(2.0*pi*i*j/7.0)-img*sin(2.0*pi*i*j/7.0)
end do
end do
if(base/=1)then
allocate(omega(0:base-1,0:base-1))
do j=0,base-1
do i=0,base-1
omega(i,j)=cos(2.0*pi*i*j/real(base))-img*sin(2.0*pi*i*j/real(base))
end do
end do
end if
else
allocate(omega(0:nx-1,0:nx-1))
do j=0,nx-1
do i=0,nx-1
omega(i,j)=cos(2.0*pi*i*j/real(nx))-img*sin(2.0*pi*i*j/real(nx))
end do
end do
end if
do j=0,nx-1
do i=0,nx-1
omegan(i,j)=cos(2.0*pi*i*j/real(nx))-img*sin(2.0*pi*i*j/real(nx))
end do
end do
case('i')
if(counter/=0)then
fact=exp(2.0*img*pi/real(nx))
fact=cos(2.0*pi/real(nx))+img*sin(2.0*pi/real(nx))
omega2=1.0
omega2(1,1)=-1.0
do j=0,2
do i=0,2
omega3(i,j)=cos(2.0*pi*i*j/3.0)+img*sin(2.0*pi*i*j/3.0)
end do
end do
do j=0,4
do i=0,4
omega5(i,j)=cos(2.0*pi*i*j/5.0)+img*sin(2.0*pi*i*j/5.0)
end do
end do
do j=0,6
do i=0,6
omega7(i,j)=cos(2.0*pi*i*j/7.0)+img*sin(2.0*pi*i*j/7.0)
end do
end do
if(base/=1)then
allocate(omega(0:base-1,0:base-1))
do j=0,base-1
do i=0,base-1
omega(i,j)=cos(2.0*pi*i*j/real(base))+img*sin(2.0*pi*i*j/real(base))
end do
end do
end if
end if
do j=0,nx-1
do i=0,nx-1
omegan(i,j)=cos(2.0*pi*i*j/real(nx))+img*sin(2.0*pi*i*j/real(nx))
end do
end do
case default
write(*,*) "******** ERROR : csign is bad. **********"
write(*,*) "Stop!"
stop
end select
!-- FFT 開始
if(counter/=0)then
!-- 係数行列定義
m(1)=1
l(1)=nx/(n(1)*m(1))
do i=2,counter+1
m(i)=m(i-1)*n(i-1)
l(i)=nx/(n(i)*m(i))
end do
!-- 変換行列 W の定義
do kd=1,counter+1
do jd=0,l(kd)-1
do id=0,n(kd)-1
do k=0,m(kd)-1
ctmp=b(jd*m(kd)+k)
do j=1,n(kd)-1
select case(n(kd))
case(2)
ctmp=ctmp+omega2(id,j)*b(j*l(kd)*m(kd)+jd*m(kd)+k)
case(3)
ctmp=ctmp+omega3(id,j)*b(j*l(kd)*m(kd)+jd*m(kd)+k)
case(5)
ctmp=ctmp+omega5(id,j)*b(j*l(kd)*m(kd)+jd*m(kd)+k)
case(7)
ctmp=ctmp+omega7(id,j)*b(j*l(kd)*m(kd)+jd*m(kd)+k)
case default
ctmp=ctmp+omega(id,j)*b(j*l(kd)*m(kd)+jd*m(kd)+k)
end select
end do
c(jd*n(kd)*m(kd)+id*m(kd)+k)=ctmp*omegan(m(kd),(id*jd))
end do
end do
end do
do id=0,nx-1
b(id)=c(id)
end do
end do
else
do j=0,nx-1
b(j)=a(0)
do i=1,nx-1
b(j)=b(j)+a(i)*omegan(i,j)
end do
end do
end if
do j=0,nx-1
b(j)=2.0*b(j)/real(nx)
end do
end subroutine