Class ffts
In: ffts.f90

fft 関連のサブルーチン集

Methods

ffttp_1d   ffttp_2d  

Public Instance methods

Subroutine :
nx :integer, intent(in)
: 入力配列の要素数
a :complex, intent(in), dimension(0:nx-1)
: 入力配列
b :complex, intent(inout), dimension(0:nx-1)
: 出力配列
csign :character(1), intent(in)
: 正逆変換判定 [r=正変換, i=逆変換]
prim :character(1), optional, intent(in)
: 素因数分解をするかどうか
o=分解する, x=分解しない
default=分解しない. その場合は, 通常の DFT.

素因数分解する場合, nx=2^a*3^b*5^c*7^d までしか分解しないようにする.

 1d の fft を csign をもとに, 正変換, 逆変換するルーチン
 Temperton's FFT

[Source]

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
Subroutine :
nx :integer, intent(in)
: 入力配列の要素数 1
ny :integer, intent(in)
: 入力配列の要素数 2
a :complex, intent(in), dimension(0:nx-1,0:ny-1)
: 入力配列
b :complex, intent(inout), dimension(0:nx-1,0:ny-1)
: 出力配列
csign :character(1), intent(in)
: 正逆変換判定 [r=正変換, i=逆変換]
prim :character(1), optional, intent(in)
: 素因数分解をするかどうか
o=分解する, x=分解しない
default=分解しない. その場合は, 通常の DFT.

素因数分解する場合, nx=2^a*3^b*5^c*7^d までしか分解しないようにする.

 2d の fft を csign をもとに, 正変換, 逆変換するルーチン
 Temperton's FFT

[Source]

subroutine ffttp_2d( nx, ny, a, b, csign, prim )
!  2d の fft を csign をもとに, 正変換, 逆変換するルーチン
!  Temperton's FFT
  implicit none
  integer, intent(in) :: nx  ! 入力配列の要素数 1
  integer, intent(in) :: ny  ! 入力配列の要素数 2
  complex, intent(in), dimension(0:nx-1,0:ny-1) :: a  ! 入力配列
  complex, intent(inout), dimension(0:nx-1,0:ny-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 :: i

  do i=0,ny-1
     call ffttp_1d( nx, a(0:nx-1,i), b(0:nx-1,i), csign, prim )
  end do

end subroutine