From b3795702235409cc814f4f3913e196b44a779c6b Mon Sep 17 00:00:00 2001 From: "Harris M. Snyder" Date: Sat, 11 Sep 2021 23:09:32 -0400 Subject: [PATCH 01/10] the kind used by fftpack can now be chosen at build time by modifying the defintion of 'rk' in 'src/rk.f' --- src/cfftb1.f | 3 +- src/cfftf1.f | 3 +- src/cffti1.f | 3 +- src/cosqb1.f | 3 +- src/cosqf1.f | 3 +- src/dcosqb.f | 3 +- src/dcosqf.f | 3 +- src/dcosqi.f | 3 +- src/dcost.f | 3 +- src/dcosti.f | 3 +- src/dfftb.f | 3 +- src/dfftf.f | 3 +- src/dffti.f | 3 +- src/dsinqb.f | 3 +- src/dsinqf.f | 3 +- src/dsinqi.f | 3 +- src/dsint.f | 3 +- src/dsinti.f | 3 +- src/dzfftb.f | 3 +- src/dzfftf.f | 3 +- src/dzffti.f | 3 +- src/ezfft1.f | 3 +- src/fftpack.f90 | 155 ++++++++++++++++---------------- src/fftpack_fft.f90 | 12 +-- src/fftpack_fftshift.f90 | 20 ++--- src/fftpack_ifft.f90 | 12 +-- src/fftpack_ifftshift.f90 | 20 ++--- src/fftpack_iqct.f90 | 12 +-- src/fftpack_irfft.f90 | 12 +-- src/fftpack_qct.f90 | 12 +-- src/fftpack_rfft.f90 | 12 +-- src/passb.f | 3 +- src/passb2.f | 3 +- src/passb3.f | 3 +- src/passb4.f | 3 +- src/passb5.f | 3 +- src/passf.f | 3 +- src/passf2.f | 3 +- src/passf3.f | 3 +- src/passf4.f | 3 +- src/passf5.f | 3 +- src/radb2.f | 3 +- src/radb3.f | 3 +- src/radb4.f | 3 +- src/radb5.f | 3 +- src/radbg.f | 3 +- src/radf2.f | 3 +- src/radf3.f | 3 +- src/radf4.f | 3 +- src/radf5.f | 3 +- src/radfg.f | 3 +- src/rfftb1.f | 3 +- src/rfftf1.f | 3 +- src/rffti1.f | 3 +- src/rk.f | 4 + src/sint1.f | 3 +- src/zfftb.f | 3 +- src/zfftf.f | 3 +- src/zffti.f | 3 +- test/test_fftpack_dcosq.f90 | 15 ++-- test/test_fftpack_dfft.f90 | 11 +-- test/test_fftpack_dzfft.f90 | 17 ++-- test/test_fftpack_fft.f90 | 11 +-- test/test_fftpack_fftshift.f90 | 30 ++++--- test/test_fftpack_ifft.f90 | 15 ++-- test/test_fftpack_ifftshift.f90 | 30 ++++--- test/test_fftpack_iqct.f90 | 25 +++--- test/test_fftpack_irfft.f90 | 15 ++-- test/test_fftpack_qct.f90 | 13 +-- test/test_fftpack_rfft.f90 | 11 +-- test/test_fftpack_zfft.f90 | 14 +-- 71 files changed, 347 insertions(+), 278 deletions(-) create mode 100644 src/rk.f diff --git a/src/cfftb1.f b/src/cfftb1.f index 9faebe2..bd2a2c4 100644 --- a/src/cfftb1.f +++ b/src/cfftb1.f @@ -1,5 +1,6 @@ SUBROUTINE CFFTB1 (N,C,CH,WA,IFAC) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) NF = IFAC(2) NA = 0 diff --git a/src/cfftf1.f b/src/cfftf1.f index 2eacd2a..ac847b6 100644 --- a/src/cfftf1.f +++ b/src/cfftf1.f @@ -1,5 +1,6 @@ SUBROUTINE CFFTF1 (N,C,CH,WA,IFAC) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) NF = IFAC(2) NA = 0 diff --git a/src/cffti1.f b/src/cffti1.f index e1f45e9..923cdfe 100644 --- a/src/cffti1.f +++ b/src/cffti1.f @@ -1,5 +1,6 @@ SUBROUTINE CFFTI1 (N,WA,IFAC) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION WA(*) ,IFAC(*) ,NTRYH(4) DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/ NL = N diff --git a/src/cosqb1.f b/src/cosqb1.f index 5c8b6ec..1515d9e 100644 --- a/src/cosqb1.f +++ b/src/cosqb1.f @@ -1,5 +1,6 @@ SUBROUTINE COSQB1 (N,X,W,XH) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION X(1) ,W(1) ,XH(1) NS2 = (N+1)/2 NP2 = N+2 diff --git a/src/cosqf1.f b/src/cosqf1.f index 87a0612..409cb95 100644 --- a/src/cosqf1.f +++ b/src/cosqf1.f @@ -1,5 +1,6 @@ SUBROUTINE COSQF1 (N,X,W,XH) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION X(1) ,W(1) ,XH(1) NS2 = (N+1)/2 NP2 = N+2 diff --git a/src/dcosqb.f b/src/dcosqb.f index 341d8c3..e054c6c 100644 --- a/src/dcosqb.f +++ b/src/dcosqb.f @@ -1,5 +1,6 @@ SUBROUTINE DCOSQB (N,X,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION X(*) ,WSAVE(*) DATA TSQRT2 /2.82842712474619009760D0/ IF (N-2) 101,102,103 diff --git a/src/dcosqf.f b/src/dcosqf.f index ca585bb..911657e 100644 --- a/src/dcosqf.f +++ b/src/dcosqf.f @@ -1,5 +1,6 @@ SUBROUTINE DCOSQF (N,X,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION X(*) ,WSAVE(*) DATA SQRT2 /1.41421356237309504880D0/ IF (N-2) 102,101,103 diff --git a/src/dcosqi.f b/src/dcosqi.f index 215e5c1..9c09127 100644 --- a/src/dcosqi.f +++ b/src/dcosqi.f @@ -1,5 +1,6 @@ SUBROUTINE DCOSQI (N,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION WSAVE(1) DATA PIH /1.57079632679489661923D0/ DT = PIH/FLOAT(N) diff --git a/src/dcost.f b/src/dcost.f index fbf90f2..77544ab 100644 --- a/src/dcost.f +++ b/src/dcost.f @@ -1,5 +1,6 @@ SUBROUTINE DCOST (N,X,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION X(*) ,WSAVE(*) NM1 = N-1 NP1 = N+1 diff --git a/src/dcosti.f b/src/dcosti.f index 4c6d7bb..4993339 100644 --- a/src/dcosti.f +++ b/src/dcosti.f @@ -1,5 +1,6 @@ SUBROUTINE DCOSTI (N,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION WSAVE(1) DATA PI /3.14159265358979323846D0/ IF (N .LE. 3) RETURN diff --git a/src/dfftb.f b/src/dfftb.f index e4adfca..dabef1a 100644 --- a/src/dfftb.f +++ b/src/dfftb.f @@ -1,5 +1,6 @@ SUBROUTINE DFFTB (N,R,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION R(1) ,WSAVE(1) IF (N .EQ. 1) RETURN CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) diff --git a/src/dfftf.f b/src/dfftf.f index 7511a66..49dae32 100644 --- a/src/dfftf.f +++ b/src/dfftf.f @@ -1,5 +1,6 @@ SUBROUTINE DFFTF (N,R,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION R(1) ,WSAVE(1) IF (N .EQ. 1) RETURN CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) diff --git a/src/dffti.f b/src/dffti.f index d70250c..1166966 100644 --- a/src/dffti.f +++ b/src/dffti.f @@ -1,5 +1,6 @@ SUBROUTINE DFFTI (N,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION WSAVE(1) IF (N .EQ. 1) RETURN CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1)) diff --git a/src/dsinqb.f b/src/dsinqb.f index d8d7835..ae11841 100644 --- a/src/dsinqb.f +++ b/src/dsinqb.f @@ -1,5 +1,6 @@ SUBROUTINE DSINQB (N,X,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION X(1) ,WSAVE(1) IF (N .GT. 1) GO TO 101 X(1) = 4.0D0*X(1) diff --git a/src/dsinqf.f b/src/dsinqf.f index 1b257ea..7ff4de7 100644 --- a/src/dsinqf.f +++ b/src/dsinqf.f @@ -1,5 +1,6 @@ SUBROUTINE DSINQF (N,X,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION X(1) ,WSAVE(1) IF (N .EQ. 1) RETURN NS2 = N/2 diff --git a/src/dsinqi.f b/src/dsinqi.f index c4897c2..0aa3beb 100644 --- a/src/dsinqi.f +++ b/src/dsinqi.f @@ -1,5 +1,6 @@ SUBROUTINE DSINQI (N,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION WSAVE(1) CALL DCOSQI (N,WSAVE) RETURN diff --git a/src/dsint.f b/src/dsint.f index feae4e0..12313f1 100644 --- a/src/dsint.f +++ b/src/dsint.f @@ -1,5 +1,6 @@ SUBROUTINE DSINT (N,X,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION X(1) ,WSAVE(1) NP1 = N+1 IW1 = N/2+1 diff --git a/src/dsinti.f b/src/dsinti.f index e655c0a..fbb283c 100644 --- a/src/dsinti.f +++ b/src/dsinti.f @@ -1,5 +1,6 @@ SUBROUTINE DSINTI (N,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION WSAVE(1) DATA PI /3.14159265358979323846D0/ IF (N .LE. 1) RETURN diff --git a/src/dzfftb.f b/src/dzfftb.f index 07ced9b..045f59b 100644 --- a/src/dzfftb.f +++ b/src/dzfftb.f @@ -1,5 +1,6 @@ SUBROUTINE DZFFTB (N,R,AZERO,A,B,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION R(*) ,A(*) ,B(*) ,WSAVE(*) IF (N-2) 101,102,103 101 R(1) = AZERO diff --git a/src/dzfftf.f b/src/dzfftf.f index f4c86de..13b4f6b 100644 --- a/src/dzfftf.f +++ b/src/dzfftf.f @@ -1,8 +1,9 @@ SUBROUTINE DZFFTF (N,R,AZERO,A,B,WSAVE) + USE fftpack_kind C C VERSION 3 JUNE 1979 C - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION R(*) ,A(*) ,B(*) ,WSAVE(*) IF (N-2) 101,102,103 101 AZERO = R(1) diff --git a/src/dzffti.f b/src/dzffti.f index 8985149..c0a6f69 100644 --- a/src/dzffti.f +++ b/src/dzffti.f @@ -1,5 +1,6 @@ SUBROUTINE DZFFTI (N,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION WSAVE(1) IF (N .EQ. 1) RETURN CALL EZFFT1 (N,WSAVE(2*N+1),WSAVE(3*N+1)) diff --git a/src/ezfft1.f b/src/ezfft1.f index 230944a..2600c89 100644 --- a/src/ezfft1.f +++ b/src/ezfft1.f @@ -1,5 +1,6 @@ SUBROUTINE EZFFT1 (N,WA,IFAC) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION WA(*) ,IFAC(*) ,NTRYH(4) DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ 1 ,TPI/6.28318530717958647692D0/ diff --git a/src/fftpack.f90 b/src/fftpack.f90 index 6a3b9f7..ae54319 100644 --- a/src/fftpack.f90 +++ b/src/fftpack.f90 @@ -1,10 +1,9 @@ module fftpack + use fftpack_kind implicit none private - integer, parameter :: dp = kind(1.0d0) - public :: dp public :: zffti, zfftf, zfftb public :: fft, ifft public :: fftshift, ifftshift @@ -24,9 +23,9 @@ module fftpack !> Initialize `zfftf` and `zfftb`. !> ([Specification](../page/specs/fftpack.html#zffti)) pure subroutine zffti(n, wsave) - import dp + import rk integer, intent(in) :: n - real(kind=dp), intent(out) :: wsave(*) + real(kind=rk), intent(out) :: wsave(*) end subroutine zffti !> Version: experimental @@ -34,10 +33,10 @@ end subroutine zffti !> Forward transform of a double complex periodic sequence. !> ([Specification](../page/specs/fftpack.html#zfftf)) pure subroutine zfftf(n, c, wsave) - import dp + import rk integer, intent(in) :: n - complex(kind=dp), intent(inout) :: c(*) - real(kind=dp), intent(in) :: wsave(*) + complex(kind=rk), intent(inout) :: c(*) + real(kind=rk), intent(in) :: wsave(*) end subroutine zfftf !> Version: experimental @@ -45,10 +44,10 @@ end subroutine zfftf !> Unnormalized inverse of `zfftf`. !> ([Specification](../page/specs/fftpack.html#zfftb)) pure subroutine zfftb(n, c, wsave) - import dp + import rk integer, intent(in) :: n - complex(kind=dp), intent(inout) :: c(*) - real(kind=dp), intent(in) :: wsave(*) + complex(kind=rk), intent(inout) :: c(*) + real(kind=rk), intent(in) :: wsave(*) end subroutine zfftb !> Version: experimental @@ -56,9 +55,9 @@ end subroutine zfftb !> Initialize `dfftf` and `dfftb`. !> ([Specification](../page/specs/fftpack.html#dffti)) pure subroutine dffti(n, wsave) - import dp + import rk integer, intent(in) :: n - real(kind=dp), intent(out) :: wsave(*) + real(kind=rk), intent(out) :: wsave(*) end subroutine dffti !> Version: experimental @@ -66,10 +65,10 @@ end subroutine dffti !> Forward transform of a double real periodic sequence. !> ([Specification](../page/specs/fftpack.html#dfftf)) pure subroutine dfftf(n, r, wsave) - import dp + import rk integer, intent(in) :: n - real(kind=dp), intent(inout) :: r(*) - real(kind=dp), intent(in) :: wsave(*) + real(kind=rk), intent(inout) :: r(*) + real(kind=rk), intent(in) :: wsave(*) end subroutine dfftf !> Version: experimental @@ -77,10 +76,10 @@ end subroutine dfftf !> Unnormalized inverse of `dfftf`. !> ([Specification](../page/specs/fftpack.html#dfftb)) pure subroutine dfftb(n, r, wsave) - import dp + import rk integer, intent(in) :: n - real(kind=dp), intent(inout) :: r(*) - real(kind=dp), intent(in) :: wsave(*) + real(kind=rk), intent(inout) :: r(*) + real(kind=rk), intent(in) :: wsave(*) end subroutine dfftb !> Version: experimental @@ -88,9 +87,9 @@ end subroutine dfftb !> Initialize `dzfftf` and `dzfftb`. !> ([Specification](../page/specs/fftpack.html#dzffti)) pure subroutine dzffti(n, wsave) - import dp + import rk integer, intent(in) :: n - real(kind=dp), intent(out) :: wsave(*) + real(kind=rk), intent(out) :: wsave(*) end subroutine dzffti !> Version: experimental @@ -98,12 +97,12 @@ end subroutine dzffti !> Simplified forward transform of a double real periodic sequence. !> ([Specification](../page/specs/fftpack.html#dzfftf)) pure subroutine dzfftf(n, r, azero, a, b, wsave) - import dp + import rk integer, intent(in) :: n - real(kind=dp), intent(in) :: r(*) - real(kind=dp), intent(out) :: azero - real(kind=dp), intent(out) :: a(*), b(*) - real(kind=dp), intent(in) :: wsave(*) + real(kind=rk), intent(in) :: r(*) + real(kind=rk), intent(out) :: azero + real(kind=rk), intent(out) :: a(*), b(*) + real(kind=rk), intent(in) :: wsave(*) end subroutine dzfftf !> Version: experimental @@ -111,12 +110,12 @@ end subroutine dzfftf !> Unnormalized inverse of `dzfftf`. !> ([Specification](../page/specs/fftpack.html#dzfftb)) pure subroutine dzfftb(n, r, azero, a, b, wsave) - import dp + import rk integer, intent(in) :: n - real(kind=dp), intent(out) :: r(*) - real(kind=dp), intent(in) :: azero - real(kind=dp), intent(in) :: a(*), b(*) - real(kind=dp), intent(in) :: wsave(*) + real(kind=rk), intent(out) :: r(*) + real(kind=rk), intent(in) :: azero + real(kind=rk), intent(in) :: a(*), b(*) + real(kind=rk), intent(in) :: wsave(*) end subroutine dzfftb !> Version: experimental @@ -124,9 +123,9 @@ end subroutine dzfftb !> Initialize `dcosqf` and `dcosqb`. !> ([Specification](../page/specs/fftpack.html#dcosqi)) pure subroutine dcosqi(n, wsave) - import dp + import rk integer, intent(in) :: n - real(kind=dp), intent(out) :: wsave(*) + real(kind=rk), intent(out) :: wsave(*) end subroutine dcosqi !> Version: experimental @@ -134,10 +133,10 @@ end subroutine dcosqi !> Forward transform of quarter wave data. !> ([Specification](../page/specs/fftpack.html#dcosqf)) pure subroutine dcosqf(n, x, wsave) - import dp + import rk integer, intent(in) :: n - real(kind=dp), intent(inout) :: x(*) - real(kind=dp), intent(in) :: wsave(*) + real(kind=rk), intent(inout) :: x(*) + real(kind=rk), intent(in) :: wsave(*) end subroutine dcosqf !> Version: experimental @@ -145,10 +144,10 @@ end subroutine dcosqf !> Unnormalized inverse of `dcosqf`. !> ([Specification](../page/specs/fftpack.html#dcosqb)) pure subroutine dcosqb(n, x, wsave) - import dp + import rk integer, intent(in) :: n - real(kind=dp), intent(inout) :: x(*) - real(kind=dp), intent(in) :: wsave(*) + real(kind=rk), intent(inout) :: x(*) + real(kind=rk), intent(in) :: wsave(*) end subroutine dcosqb end interface @@ -158,11 +157,11 @@ end subroutine dcosqb !> Forward transform of a double complex periodic sequence. !> ([Specifiction](../page/specs/fftpack.html#fft)) interface fft - pure module function fft_dp(x, n) result(result) - complex(kind=dp), intent(in) :: x(:) + pure module function fft_rk(x, n) result(result) + complex(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n - complex(kind=dp), allocatable :: result(:) - end function fft_dp + complex(kind=rk), allocatable :: result(:) + end function fft_rk end interface fft !> Version: experimental @@ -170,11 +169,11 @@ end function fft_dp !> Backward transform of a double complex periodic sequence. !> ([Specifiction](../page/specs/fftpack.html#ifft)) interface ifft - pure module function ifft_dp(x, n) result(result) - complex(kind=dp), intent(in) :: x(:) + pure module function ifft_rk(x, n) result(result) + complex(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n - complex(kind=dp), allocatable :: result(:) - end function ifft_dp + complex(kind=rk), allocatable :: result(:) + end function ifft_rk end interface ifft !> Version: experimental @@ -182,11 +181,11 @@ end function ifft_dp !> Forward transform of a double real periodic sequence. !> ([Specifiction](../page/specs/fftpack.html#rfft)) interface rfft - pure module function rfft_dp(x, n) result(result) - real(kind=dp), intent(in) :: x(:) + pure module function rfft_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n - real(kind=dp), allocatable :: result(:) - end function rfft_dp + real(kind=rk), allocatable :: result(:) + end function rfft_rk end interface rfft !> Version: experimental @@ -194,11 +193,11 @@ end function rfft_dp !> Backward transform of a double real periodic sequence. !> ([Specifiction](../page/specs/fftpack.html#irfft)) interface irfft - pure module function irfft_dp(x, n) result(result) - real(kind=dp), intent(in) :: x(:) + pure module function irfft_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n - real(kind=dp), allocatable :: result(:) - end function irfft_dp + real(kind=rk), allocatable :: result(:) + end function irfft_rk end interface irfft !> Version: experimental @@ -206,11 +205,11 @@ end function irfft_dp !> Forward transform of quarter wave data. !> ([Specifiction](../page/specs/fftpack.html#qct)) interface qct - pure module function qct_dp(x, n) result(result) - real(kind=dp), intent(in) :: x(:) + pure module function qct_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n - real(kind=dp), allocatable :: result(:) - end function qct_dp + real(kind=rk), allocatable :: result(:) + end function qct_rk end interface qct !> Version: experimental @@ -218,11 +217,11 @@ end function qct_dp !> Backward transform of quarter wave data. !> ([Specifiction](../page/specs/fftpack.html#iqct)) interface iqct - pure module function iqct_dp(x, n) result(result) - real(kind=dp), intent(in) :: x(:) + pure module function iqct_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n - real(kind=dp), allocatable :: result(:) - end function iqct_dp + real(kind=rk), allocatable :: result(:) + end function iqct_rk end interface iqct !> Version: experimental @@ -230,14 +229,14 @@ end function iqct_dp !> Shifts zero-frequency component to center of spectrum. !> ([Specifiction](../page/specs/fftpack.html#fftshift)) interface fftshift - pure module function fftshift_cdp(x) result(result) - complex(kind=dp), intent(in) :: x(:) - complex(kind=dp), allocatable :: result(:) - end function fftshift_cdp - pure module function fftshift_rdp(x) result(result) - real(kind=dp), intent(in) :: x(:) - real(kind=dp), allocatable :: result(:) - end function fftshift_rdp + pure module function fftshift_crk(x) result(result) + complex(kind=rk), intent(in) :: x(:) + complex(kind=rk), allocatable :: result(:) + end function fftshift_crk + pure module function fftshift_rrk(x) result(result) + real(kind=rk), intent(in) :: x(:) + real(kind=rk), allocatable :: result(:) + end function fftshift_rrk end interface fftshift !> Version: experimental @@ -245,14 +244,14 @@ end function fftshift_rdp !> Shifts zero-frequency component to beginning of spectrum. !> ([Specifiction](../page/specs/fftpack.html#ifftshift)) interface ifftshift - pure module function ifftshift_cdp(x) result(result) - complex(kind=dp), intent(in) :: x(:) - complex(kind=dp), allocatable :: result(:) - end function ifftshift_cdp - pure module function ifftshift_rdp(x) result(result) - real(kind=dp), intent(in) :: x(:) - real(kind=dp), allocatable :: result(:) - end function ifftshift_rdp + pure module function ifftshift_crk(x) result(result) + complex(kind=rk), intent(in) :: x(:) + complex(kind=rk), allocatable :: result(:) + end function ifftshift_crk + pure module function ifftshift_rrk(x) result(result) + real(kind=rk), intent(in) :: x(:) + real(kind=rk), allocatable :: result(:) + end function ifftshift_rrk end interface ifftshift end module fftpack diff --git a/src/fftpack_fft.f90 b/src/fftpack_fft.f90 index b6e362f..bf21eb5 100644 --- a/src/fftpack_fft.f90 +++ b/src/fftpack_fft.f90 @@ -3,20 +3,20 @@ contains !> Forward transform of a double complex periodic sequence. - pure module function fft_dp(x, n) result(result) - complex(kind=dp), intent(in) :: x(:) + pure module function fft_rk(x, n) result(result) + complex(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n - complex(kind=dp), allocatable :: result(:) + complex(kind=rk), allocatable :: result(:) integer :: lenseq, lensav, i - real(kind=dp), allocatable :: wsave(:) + real(kind=rk), allocatable :: wsave(:) if (present(n)) then lenseq = n if (lenseq <= size(x)) then result = x(:lenseq) else if (lenseq > size(x)) then - result = [x, ((0.0_dp, 0.0_dp), i=1, lenseq - size(x))] + result = [x, ((0.0_rk, 0.0_rk), i=1, lenseq - size(x))] end if else lenseq = size(x) @@ -31,6 +31,6 @@ pure module function fft_dp(x, n) result(result) !> Forward transformation call zfftf(lenseq, result, wsave) - end function fft_dp + end function fft_rk end submodule fftpack_fft diff --git a/src/fftpack_fftshift.f90 b/src/fftpack_fftshift.f90 index 8cb937b..a22dfc6 100644 --- a/src/fftpack_fftshift.f90 +++ b/src/fftpack_fftshift.f90 @@ -3,21 +3,21 @@ contains !> Shifts zero-frequency component to center of spectrum for `complex` type. - pure module function fftshift_cdp(x) result(result) - complex(kind=dp), intent(in) :: x(:) - complex(kind=dp), allocatable :: result(:) + pure module function fftshift_crk(x) result(result) + complex(kind=rk), intent(in) :: x(:) + complex(kind=rk), allocatable :: result(:) - result = cshift(x, shift=-floor(0.5_dp*size(x))) + result = cshift(x, shift=-floor(0.5_rk*size(x))) - end function fftshift_cdp + end function fftshift_crk !> Shifts zero-frequency component to center of spectrum for `real` type. - pure module function fftshift_rdp(x) result(result) - real(kind=dp), intent(in) :: x(:) - real(kind=dp), allocatable :: result(:) + pure module function fftshift_rrk(x) result(result) + real(kind=rk), intent(in) :: x(:) + real(kind=rk), allocatable :: result(:) - result = cshift(x, shift=-floor(0.5_dp*size(x))) + result = cshift(x, shift=-floor(0.5_rk*size(x))) - end function fftshift_rdp + end function fftshift_rrk end submodule fftpack_fftshift diff --git a/src/fftpack_ifft.f90 b/src/fftpack_ifft.f90 index 9e6dea0..40068d4 100644 --- a/src/fftpack_ifft.f90 +++ b/src/fftpack_ifft.f90 @@ -3,20 +3,20 @@ contains !> Backward transform of a double complex periodic sequence. - pure module function ifft_dp(x, n) result(result) - complex(kind=dp), intent(in) :: x(:) + pure module function ifft_rk(x, n) result(result) + complex(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n - complex(kind=dp), allocatable :: result(:) + complex(kind=rk), allocatable :: result(:) integer :: lenseq, lensav, i - real(kind=dp), allocatable :: wsave(:) + real(kind=rk), allocatable :: wsave(:) if (present(n)) then lenseq = n if (lenseq <= size(x)) then result = x(:lenseq) else if (lenseq > size(x)) then - result = [x, ((0.0_dp, 0.0_dp), i=1, lenseq - size(x))] + result = [x, ((0.0_rk, 0.0_rk), i=1, lenseq - size(x))] end if else lenseq = size(x) @@ -31,6 +31,6 @@ pure module function ifft_dp(x, n) result(result) !> Backward transformation call zfftb(lenseq, result, wsave) - end function ifft_dp + end function ifft_rk end submodule fftpack_ifft diff --git a/src/fftpack_ifftshift.f90 b/src/fftpack_ifftshift.f90 index da8132a..49830a7 100644 --- a/src/fftpack_ifftshift.f90 +++ b/src/fftpack_ifftshift.f90 @@ -3,21 +3,21 @@ contains !> Shifts zero-frequency component to beginning of spectrum for `complex` type. - pure module function ifftshift_cdp(x) result(result) - complex(kind=dp), intent(in) :: x(:) - complex(kind=dp), allocatable :: result(:) + pure module function ifftshift_crk(x) result(result) + complex(kind=rk), intent(in) :: x(:) + complex(kind=rk), allocatable :: result(:) - result = cshift(x, shift=-ceiling(0.5_dp*size(x))) + result = cshift(x, shift=-ceiling(0.5_rk*size(x))) - end function ifftshift_cdp + end function ifftshift_crk !> Shifts zero-frequency component to beginning of spectrum for `real` type. - pure module function ifftshift_rdp(x) result(result) - real(kind=dp), intent(in) :: x(:) - real(kind=dp), allocatable :: result(:) + pure module function ifftshift_rrk(x) result(result) + real(kind=rk), intent(in) :: x(:) + real(kind=rk), allocatable :: result(:) - result = cshift(x, shift=-ceiling(0.5_dp*size(x))) + result = cshift(x, shift=-ceiling(0.5_rk*size(x))) - end function ifftshift_rdp + end function ifftshift_rrk end submodule fftpack_ifftshift diff --git a/src/fftpack_iqct.f90 b/src/fftpack_iqct.f90 index f116fef..1ae2a20 100644 --- a/src/fftpack_iqct.f90 +++ b/src/fftpack_iqct.f90 @@ -3,20 +3,20 @@ contains !> Backward transform of quarter wave data. - pure module function iqct_dp(x, n) result(result) - real(kind=dp), intent(in) :: x(:) + pure module function iqct_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n - real(kind=dp), allocatable :: result(:) + real(kind=rk), allocatable :: result(:) integer :: lenseq, lensav, i - real(kind=dp), allocatable :: wsave(:) + real(kind=rk), allocatable :: wsave(:) if (present(n)) then lenseq = n if (lenseq <= size(x)) then result = x(:lenseq) else if (lenseq > size(x)) then - result = [x, (0.0_dp, i=1, lenseq - size(x))] + result = [x, (0.0_rk, i=1, lenseq - size(x))] end if else lenseq = size(x) @@ -31,6 +31,6 @@ pure module function iqct_dp(x, n) result(result) !> Backward transformation call dcosqb(lenseq, result, wsave) - end function iqct_dp + end function iqct_rk end submodule fftpack_iqct diff --git a/src/fftpack_irfft.f90 b/src/fftpack_irfft.f90 index eeb6d34..97565cb 100644 --- a/src/fftpack_irfft.f90 +++ b/src/fftpack_irfft.f90 @@ -3,20 +3,20 @@ contains !> Backward transform of a double real periodic sequence. - pure module function irfft_dp(x, n) result(result) - real(kind=dp), intent(in) :: x(:) + pure module function irfft_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n - real(kind=dp), allocatable :: result(:) + real(kind=rk), allocatable :: result(:) integer :: lenseq, lensav, i - real(kind=dp), allocatable :: wsave(:) + real(kind=rk), allocatable :: wsave(:) if (present(n)) then lenseq = n if (lenseq <= size(x)) then result = x(:lenseq) else if (lenseq > size(x)) then - result = [x, (0.0_dp, i=1, lenseq - size(x))] + result = [x, (0.0_rk, i=1, lenseq - size(x))] end if else lenseq = size(x) @@ -31,6 +31,6 @@ pure module function irfft_dp(x, n) result(result) !> Backward transformation call dfftb(lenseq, result, wsave) - end function irfft_dp + end function irfft_rk end submodule fftpack_irfft diff --git a/src/fftpack_qct.f90 b/src/fftpack_qct.f90 index 582918b..ceb2f6b 100644 --- a/src/fftpack_qct.f90 +++ b/src/fftpack_qct.f90 @@ -3,20 +3,20 @@ contains !> Forward transform of quarter wave data. - pure module function qct_dp(x, n) result(result) - real(kind=dp), intent(in) :: x(:) + pure module function qct_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n - real(kind=dp), allocatable :: result(:) + real(kind=rk), allocatable :: result(:) integer :: lenseq, lensav, i - real(kind=dp), allocatable :: wsave(:) + real(kind=rk), allocatable :: wsave(:) if (present(n)) then lenseq = n if (lenseq <= size(x)) then result = x(:lenseq) else if (lenseq > size(x)) then - result = [x, (0.0_dp, i=1, lenseq - size(x))] + result = [x, (0.0_rk, i=1, lenseq - size(x))] end if else lenseq = size(x) @@ -31,6 +31,6 @@ pure module function qct_dp(x, n) result(result) !> Forward transformation call dcosqf(lenseq, result, wsave) - end function qct_dp + end function qct_rk end submodule fftpack_qct diff --git a/src/fftpack_rfft.f90 b/src/fftpack_rfft.f90 index 6cbcdac..a0c6260 100644 --- a/src/fftpack_rfft.f90 +++ b/src/fftpack_rfft.f90 @@ -3,20 +3,20 @@ contains !> Forward transform of a double real periodic sequence. - pure module function rfft_dp(x, n) result(result) - real(kind=dp), intent(in) :: x(:) + pure module function rfft_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n - real(kind=dp), allocatable :: result(:) + real(kind=rk), allocatable :: result(:) integer :: lenseq, lensav, i - real(kind=dp), allocatable :: wsave(:) + real(kind=rk), allocatable :: wsave(:) if (present(n)) then lenseq = n if (lenseq <= size(x)) then result = x(:lenseq) else if (lenseq > size(x)) then - result = [x, (0.0_dp, i=1, lenseq - size(x))] + result = [x, (0.0_rk, i=1, lenseq - size(x))] end if else lenseq = size(x) @@ -31,6 +31,6 @@ pure module function rfft_dp(x, n) result(result) !> Forward transformation call dfftf(lenseq, result, wsave) - end function rfft_dp + end function rfft_rk end submodule fftpack_rfft diff --git a/src/passb.f b/src/passb.f index 43dba87..f347d5c 100644 --- a/src/passb.f +++ b/src/passb.f @@ -1,5 +1,6 @@ SUBROUTINE PASSB (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , 1 C1(IDO,L1,IP) ,WA(1) ,C2(IDL1,IP), 2 CH2(IDL1,IP) diff --git a/src/passb2.f b/src/passb2.f index 22f6279..7fcdc45 100644 --- a/src/passb2.f +++ b/src/passb2.f @@ -1,5 +1,6 @@ SUBROUTINE PASSB2 (IDO,L1,CC,CH,WA1) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , 1 WA1(1) IF (IDO .GT. 2) GO TO 102 diff --git a/src/passb3.f b/src/passb3.f index ee8ef10..613b528 100644 --- a/src/passb3.f +++ b/src/passb3.f @@ -1,5 +1,6 @@ SUBROUTINE PASSB3 (IDO,L1,CC,CH,WA1,WA2) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , 1 WA1(1) ,WA2(1) C *** TAUI IS SQRT(3)/2 *** diff --git a/src/passb4.f b/src/passb4.f index fd9fbab..06c7b13 100644 --- a/src/passb4.f +++ b/src/passb4.f @@ -1,5 +1,6 @@ SUBROUTINE PASSB4 (IDO,L1,CC,CH,WA1,WA2,WA3) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , 1 WA1(1) ,WA2(1) ,WA3(1) IF (IDO .NE. 2) GO TO 102 diff --git a/src/passb5.f b/src/passb5.f index f8a6f53..48c6e69 100644 --- a/src/passb5.f +++ b/src/passb5.f @@ -1,5 +1,6 @@ SUBROUTINE PASSB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) C *** TR11=COS(2*PI/5), TI11=SIN(2*PI/5) diff --git a/src/passf.f b/src/passf.f index cb97d12..1689851 100644 --- a/src/passf.f +++ b/src/passf.f @@ -1,5 +1,6 @@ SUBROUTINE PASSF (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , 1 C1(IDO,L1,IP) ,WA(1) ,C2(IDL1,IP), 2 CH2(IDL1,IP) diff --git a/src/passf2.f b/src/passf2.f index 765b69f..cddf984 100644 --- a/src/passf2.f +++ b/src/passf2.f @@ -1,5 +1,6 @@ SUBROUTINE PASSF2 (IDO,L1,CC,CH,WA1) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , 1 WA1(1) IF (IDO .GT. 2) GO TO 102 diff --git a/src/passf3.f b/src/passf3.f index d3547ca..a64d207 100644 --- a/src/passf3.f +++ b/src/passf3.f @@ -1,5 +1,6 @@ SUBROUTINE PASSF3 (IDO,L1,CC,CH,WA1,WA2) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , 1 WA1(1) ,WA2(1) C *** TAUI IS -SQRT(3)/2 *** diff --git a/src/passf4.f b/src/passf4.f index d14ad61..09daafe 100644 --- a/src/passf4.f +++ b/src/passf4.f @@ -1,5 +1,6 @@ SUBROUTINE PASSF4 (IDO,L1,CC,CH,WA1,WA2,WA3) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , 1 WA1(1) ,WA2(1) ,WA3(1) IF (IDO .NE. 2) GO TO 102 diff --git a/src/passf5.f b/src/passf5.f index 9e56a3b..6e3da88 100644 --- a/src/passf5.f +++ b/src/passf5.f @@ -1,5 +1,6 @@ SUBROUTINE PASSF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) C *** TR11=COS(2*PI/5), TI11=-SIN(2*PI/5) diff --git a/src/radb2.f b/src/radb2.f index e8f18a1..8a05aed 100644 --- a/src/radb2.f +++ b/src/radb2.f @@ -1,5 +1,6 @@ SUBROUTINE RADB2 (IDO,L1,CC,CH,WA1) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , 1 WA1(1) DO 101 K=1,L1 diff --git a/src/radb3.f b/src/radb3.f index 6f2b689..b5722e3 100644 --- a/src/radb3.f +++ b/src/radb3.f @@ -1,5 +1,6 @@ SUBROUTINE RADB3 (IDO,L1,CC,CH,WA1,WA2) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , 1 WA1(1) ,WA2(1) C *** TAUI IS SQRT(3)/2 *** diff --git a/src/radb4.f b/src/radb4.f index 6917fb5..72ff6a4 100644 --- a/src/radb4.f +++ b/src/radb4.f @@ -1,5 +1,6 @@ SUBROUTINE RADB4 (IDO,L1,CC,CH,WA1,WA2,WA3) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , 1 WA1(1) ,WA2(1) ,WA3(1) DATA SQRT2 /1.41421356237309504880D0/ diff --git a/src/radb5.f b/src/radb5.f index e1a8664..3b90b46 100644 --- a/src/radb5.f +++ b/src/radb5.f @@ -1,5 +1,6 @@ SUBROUTINE RADB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) C *** TR11=COS(2*PI/5), TI11=SIN(2*PI/5) diff --git a/src/radbg.f b/src/radbg.f index deaed58..47472d6 100644 --- a/src/radbg.f +++ b/src/radbg.f @@ -1,5 +1,6 @@ SUBROUTINE RADBG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , 1 C1(IDO,L1,IP) ,C2(IDL1,IP), 2 CH2(IDL1,IP) ,WA(1) diff --git a/src/radf2.f b/src/radf2.f index 831682f..184da2d 100644 --- a/src/radf2.f +++ b/src/radf2.f @@ -1,5 +1,6 @@ SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CH(IDO,2,L1) ,CC(IDO,L1,2) , 1 WA1(1) DO 101 K=1,L1 diff --git a/src/radf3.f b/src/radf3.f index f6f402f..078b6b2 100644 --- a/src/radf3.f +++ b/src/radf3.f @@ -1,5 +1,6 @@ SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CH(IDO,3,L1) ,CC(IDO,L1,3) , 1 WA1(1) ,WA2(1) C *** TAUI IS -SQRT(3)/2 *** diff --git a/src/radf4.f b/src/radf4.f index 1a33060..c7305f1 100644 --- a/src/radf4.f +++ b/src/radf4.f @@ -1,5 +1,6 @@ SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CC(IDO,L1,4) ,CH(IDO,4,L1) , 1 WA1(1) ,WA2(1) ,WA3(1) DATA HSQT2 /0.70710678118654752440D0/ diff --git a/src/radf5.f b/src/radf5.f index e45521f..bd79c6d 100644 --- a/src/radf5.f +++ b/src/radf5.f @@ -1,5 +1,6 @@ SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CC(IDO,L1,5) ,CH(IDO,5,L1) , 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) DATA TR11,TI11,TR12,TI12 /0.3090169943749474241D0, diff --git a/src/radfg.f b/src/radfg.f index f0ad326..a7d91c6 100644 --- a/src/radfg.f +++ b/src/radfg.f @@ -1,5 +1,6 @@ SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , 1 C1(IDO,L1,IP) ,C2(IDL1,IP), 2 CH2(IDL1,IP) ,WA(1) diff --git a/src/rfftb1.f b/src/rfftb1.f index be45445..36f122c 100644 --- a/src/rfftb1.f +++ b/src/rfftb1.f @@ -1,5 +1,6 @@ SUBROUTINE RFFTB1 (N,C,CH,WA,IFAC) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) NF = IFAC(2) NA = 0 diff --git a/src/rfftf1.f b/src/rfftf1.f index 46c3acd..bbe6520 100644 --- a/src/rfftf1.f +++ b/src/rfftf1.f @@ -1,5 +1,6 @@ SUBROUTINE RFFTF1 (N,C,CH,WA,IFAC) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) NF = IFAC(2) NA = 1 diff --git a/src/rffti1.f b/src/rffti1.f index 0fb3b87..5dd1f41 100644 --- a/src/rffti1.f +++ b/src/rffti1.f @@ -1,5 +1,6 @@ SUBROUTINE RFFTI1 (N,WA,IFAC) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION WA(*) ,IFAC(*) ,NTRYH(4) DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ NL = N diff --git a/src/rk.f b/src/rk.f new file mode 100644 index 0000000..24ab713 --- /dev/null +++ b/src/rk.f @@ -0,0 +1,4 @@ + module fftpack_kind + implicit none + integer,parameter :: rk = kind(1.0d0) + end module diff --git a/src/sint1.f b/src/sint1.f index e6e328c..3619df6 100644 --- a/src/sint1.f +++ b/src/sint1.f @@ -1,5 +1,6 @@ SUBROUTINE SINT1(N,WAR,WAS,XH,X,IFAC) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION WAR(*),WAS(*),X(*),XH(*),IFAC(*) DATA SQRT3 /1.73205080756887729352D0/ DO 100 I=1,N diff --git a/src/zfftb.f b/src/zfftb.f index e4f5204..a2af5ee 100644 --- a/src/zfftb.f +++ b/src/zfftb.f @@ -1,5 +1,6 @@ SUBROUTINE ZFFTB (N,C,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION C(1) ,WSAVE(1) IF (N .EQ. 1) RETURN IW1 = N+N+1 diff --git a/src/zfftf.f b/src/zfftf.f index d16e7e4..78cb869 100644 --- a/src/zfftf.f +++ b/src/zfftf.f @@ -1,5 +1,6 @@ SUBROUTINE ZFFTF (N,C,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION C(1) ,WSAVE(1) IF (N .EQ. 1) RETURN IW1 = N+N+1 diff --git a/src/zffti.f b/src/zffti.f index df69b15..ee64c84 100644 --- a/src/zffti.f +++ b/src/zffti.f @@ -1,5 +1,6 @@ SUBROUTINE ZFFTI (N,WSAVE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION WSAVE(1) IF (N .EQ. 1) RETURN IW1 = N+N+1 diff --git a/test/test_fftpack_dcosq.f90 b/test/test_fftpack_dcosq.f90 index b5735f5..7169be6 100644 --- a/test/test_fftpack_dcosq.f90 +++ b/test/test_fftpack_dcosq.f90 @@ -12,17 +12,18 @@ subroutine check(condition, msg) end subroutine check subroutine test_fftpack_dcosq_real - use fftpack, only: dcosqi, dcosqf, dcosqb, dp - real(kind=dp) :: w(3*4 + 15) - real(kind=dp) :: x(4) = [1, 2, 3, 4] - real(kind=dp) :: eps = 1.0e-10_dp + use fftpack, only: dcosqi, dcosqf, dcosqb + use fftpack_kind + real(kind=rk) :: w(3*4 + 15) + real(kind=rk) :: x(4) = [1, 2, 3, 4] + real(kind=rk) :: eps = 1.0e-10_rk call dcosqi(4, w) call dcosqf(4, x, w) - call check(sum(abs(x - [11.999626276085150_dp, -9.1029432177492193_dp, & - 2.6176618435106480_dp, -1.5143449018465791_dp])) < eps, msg="`dcosqf` failed.") + call check(sum(abs(x - [11.999626276085150_rk, -9.1029432177492193_rk, & + 2.6176618435106480_rk, -1.5143449018465791_rk])) < eps, msg="`dcosqf` failed.") call dcosqb(4, x, w) !! - call check(sum(abs(x/(4.0_dp*4.0_dp) - [real(kind=dp) :: 1, 2, 3, 4])) < eps, msg="`dcosqb` failed.") + call check(sum(abs(x/(4.0_rk*4.0_rk) - [real(kind=rk) :: 1, 2, 3, 4])) < eps, msg="`dcosqb` failed.") end subroutine test_fftpack_dcosq_real diff --git a/test/test_fftpack_dfft.f90 b/test/test_fftpack_dfft.f90 index 1b69479..bbad26a 100644 --- a/test/test_fftpack_dfft.f90 +++ b/test/test_fftpack_dfft.f90 @@ -12,20 +12,21 @@ subroutine check(condition, msg) end subroutine check subroutine test_fftpack_dfft() - use fftpack, only: dffti, dfftf, dfftb, dp + use fftpack, only: dffti, dfftf, dfftb + use fftpack_kind - real(kind=dp) :: x(4) - real(kind=dp) :: w(31) + real(kind=rk) :: x(4) + real(kind=rk) :: w(31) x = [1, 2, 3, 4] call dffti(4, w) call dfftf(4, x, w) - call check(all(x == [real(kind=dp) :: 10, -2, 2, -2]), & + call check(all(x == [real(kind=rk) :: 10, -2, 2, -2]), & msg="`dfftf` failed.") call dfftb(4, x, w) - call check(all(x/4.0_dp == [real(kind=dp) :: 1, 2, 3, 4]), & + call check(all(x/4.0_rk == [real(kind=rk) :: 1, 2, 3, 4]), & msg="`dfftb` failed.") end subroutine test_fftpack_dfft diff --git a/test/test_fftpack_dzfft.f90 b/test/test_fftpack_dzfft.f90 index 0464feb..31f3ebc 100644 --- a/test/test_fftpack_dzfft.f90 +++ b/test/test_fftpack_dzfft.f90 @@ -12,21 +12,22 @@ subroutine check(condition, msg) end subroutine check subroutine test_fftpack_dzfft - use fftpack, only: dzffti, dzfftf, dzfftb, dp + use fftpack, only: dzffti, dzfftf, dzfftb + use fftpack_kind - real(kind=dp) :: x(4) = [1, 2, 3, 4] - real(kind=dp) :: w(3*4 + 15) - real(kind=dp) :: azero, a(4/2), b(4/2) + real(kind=rk) :: x(4) = [1, 2, 3, 4] + real(kind=rk) :: w(3*4 + 15) + real(kind=rk) :: azero, a(4/2), b(4/2) call dzffti(4, w) call dzfftf(4, x, azero, a, b, w) - call check(azero == 2.5_dp, msg="azero == 2.5_dp failed.") - call check(all(a == [-1.0_dp, -0.5_dp]), msg="all(a == [-1.0, -0.5]) failed.") - call check(all(b == [-1.0_dp, 0.0_dp]), msg="all(b == [-1.0, 0.0]) failed.") + call check(azero == 2.5_rk, msg="azero == 2.5_rk failed.") + call check(all(a == [-1.0_rk, -0.5_rk]), msg="all(a == [-1.0, -0.5]) failed.") + call check(all(b == [-1.0_rk, 0.0_rk]), msg="all(b == [-1.0, 0.0]) failed.") x = 0 call dzfftb(4, x, azero, a, b, w) - call check(all(x == [real(kind=dp) :: 1, 2, 3, 4]), msg="all(x = [real(kind=dp) :: 1, 2, 3, 4]) failed.") + call check(all(x == [real(kind=rk) :: 1, 2, 3, 4]), msg="all(x = [real(kind=rk) :: 1, 2, 3, 4]) failed.") end subroutine test_fftpack_dzfft diff --git a/test/test_fftpack_fft.f90 b/test/test_fftpack_fft.f90 index 0e2387d..1770065 100644 --- a/test/test_fftpack_fft.f90 +++ b/test/test_fftpack_fft.f90 @@ -12,16 +12,17 @@ subroutine check(condition, msg) end subroutine check subroutine test_fftpack_fft - use fftpack, only: fft, dp - real(kind=dp) :: eps = 1.0e-10_dp + use fftpack, only: fft + use fftpack_kind + real(kind=rk) :: eps = 1.0e-10_rk - complex(kind=dp) :: x(3) = [1.0_dp, 2.0_dp, 3.0_dp] + complex(kind=rk) :: x(3) = [1.0_rk, 2.0_rk, 3.0_rk] - call check(sum(abs(fft(x, 2) - [(3.0_dp, 0.0_dp), (-1.0_dp, 0.0_dp)])) < eps, & + call check(sum(abs(fft(x, 2) - [(3.0_rk, 0.0_rk), (-1.0_rk, 0.0_rk)])) < eps, & msg="`fft(x, 2)` failed.") call check(sum(abs(fft(x, 3) - fft(x))) < eps, & msg="`fft(x, 3)` failed.") - call check(sum(abs(fft(x, 4) - [(6.0_dp, 0.0_dp), (-2.0_dp, -2.0_dp), (2.0_dp, 0.0_dp), (-2.0_dp, 2.0_dp)])) < eps, & + call check(sum(abs(fft(x, 4) - [(6.0_rk, 0.0_rk), (-2.0_rk, -2.0_rk), (2.0_rk, 0.0_rk), (-2.0_rk, 2.0_rk)])) < eps, & msg="`fft(x, 4)` failed.") end subroutine test_fftpack_fft diff --git a/test/test_fftpack_fftshift.f90 b/test/test_fftpack_fftshift.f90 index 32de4bf..2b90b3c 100644 --- a/test/test_fftpack_fftshift.f90 +++ b/test/test_fftpack_fftshift.f90 @@ -13,28 +13,30 @@ subroutine check(condition, msg) end subroutine check subroutine test_fftpack_fftshift_complex - use fftpack, only: fftshift, dp + use fftpack, only: fftshift + use fftpack_kind - complex(kind=dp) :: xeven(4) = [1, 2, 3, 4] - complex(kind=dp) :: xodd(5) = [1, 2, 3, 4, 5] + complex(kind=rk) :: xeven(4) = [1, 2, 3, 4] + complex(kind=rk) :: xodd(5) = [1, 2, 3, 4, 5] - call check(all(fftshift(xeven) == [complex(kind=dp) :: 3, 4, 1, 2]), & - msg="all(fftshift(xeven) == [complex(kind=dp) :: 3, 4, 1, 2]) failed.") - call check(all(fftshift(xodd) == [complex(kind=dp) :: 4, 5, 1, 2, 3]), & - msg="all(fftshift(xodd) == [complex(kind=dp) :: 4, 5, 1, 2, 3]) failed.") + call check(all(fftshift(xeven) == [complex(kind=rk) :: 3, 4, 1, 2]), & + msg="all(fftshift(xeven) == [complex(kind=rk) :: 3, 4, 1, 2]) failed.") + call check(all(fftshift(xodd) == [complex(kind=rk) :: 4, 5, 1, 2, 3]), & + msg="all(fftshift(xodd) == [complex(kind=rk) :: 4, 5, 1, 2, 3]) failed.") end subroutine test_fftpack_fftshift_complex subroutine test_fftpack_fftshift_real - use fftpack, only: fftshift, dp + use fftpack, only: fftshift + use fftpack_kind - real(kind=dp) :: xeven(4) = [1, 2, 3, 4] - real(kind=dp) :: xodd(5) = [1, 2, 3, 4, 5] + real(kind=rk) :: xeven(4) = [1, 2, 3, 4] + real(kind=rk) :: xodd(5) = [1, 2, 3, 4, 5] - call check(all(fftshift(xeven) == [real(kind=dp) :: 3, 4, 1, 2]), & - msg="all(fftshift(xeven) == [real(kind=dp) :: 3, 4, 1, 2]) failed.") - call check(all(fftshift(xodd) == [real(kind=dp) :: 4, 5, 1, 2, 3]), & - msg="all(fftshift(xodd) == [real(kind=dp) :: 4, 5, 1, 2, 3]) failed.") + call check(all(fftshift(xeven) == [real(kind=rk) :: 3, 4, 1, 2]), & + msg="all(fftshift(xeven) == [real(kind=rk) :: 3, 4, 1, 2]) failed.") + call check(all(fftshift(xodd) == [real(kind=rk) :: 4, 5, 1, 2, 3]), & + msg="all(fftshift(xodd) == [real(kind=rk) :: 4, 5, 1, 2, 3]) failed.") end subroutine test_fftpack_fftshift_real diff --git a/test/test_fftpack_ifft.f90 b/test/test_fftpack_ifft.f90 index b052b95..d7c7f73 100644 --- a/test/test_fftpack_ifft.f90 +++ b/test/test_fftpack_ifft.f90 @@ -12,16 +12,17 @@ subroutine check(condition, msg) end subroutine check subroutine test_fftpack_ifft - use fftpack, only: fft, ifft, dp - real(kind=dp) :: eps = 1.0e-10_dp + use fftpack, only: fft, ifft + use fftpack_kind + real(kind=rk) :: eps = 1.0e-10_rk - complex(kind=dp) :: x(4) = [1, 2, 3, 4] + complex(kind=rk) :: x(4) = [1, 2, 3, 4] - call check(sum(abs(ifft(fft(x))/4.0_dp - [complex(kind=dp) :: 1, 2, 3, 4])) < eps, & - msg="`ifft(fft(x))/4.0_dp` failed.") - call check(sum(abs(ifft(fft(x), 2) - [complex(kind=dp) ::(8, 2), (12, -2)])) < eps, & + call check(sum(abs(ifft(fft(x))/4.0_rk - [complex(kind=rk) :: 1, 2, 3, 4])) < eps, & + msg="`ifft(fft(x))/4.0_rk` failed.") + call check(sum(abs(ifft(fft(x), 2) - [complex(kind=rk) ::(8, 2), (12, -2)])) < eps, & msg="`ifft(fft(x), 2)` failed.") - call check(sum(abs(ifft(fft(x, 2), 4) - [complex(kind=dp) ::(2, 0), (3, -1), (4, 0), (3, 1)])) < eps, & + call check(sum(abs(ifft(fft(x, 2), 4) - [complex(kind=rk) ::(2, 0), (3, -1), (4, 0), (3, 1)])) < eps, & msg="`ifft(fft(x, 2), 4)` failed.") end subroutine test_fftpack_ifft diff --git a/test/test_fftpack_ifftshift.f90 b/test/test_fftpack_ifftshift.f90 index 640fd92..88f56ed 100644 --- a/test/test_fftpack_ifftshift.f90 +++ b/test/test_fftpack_ifftshift.f90 @@ -13,30 +13,32 @@ subroutine check(condition, msg) end subroutine check subroutine test_fftpack_ifftshift_complex - use fftpack, only: ifftshift, dp + use fftpack, only: ifftshift + use fftpack_kind integer :: i - complex(kind=dp) :: xeven(4) = [3, 4, 1, 2] - complex(kind=dp) :: xodd(5) = [4, 5, 1, 2, 3] + complex(kind=rk) :: xeven(4) = [3, 4, 1, 2] + complex(kind=rk) :: xodd(5) = [4, 5, 1, 2, 3] - call check(all(ifftshift(xeven) == [complex(kind=dp) ::(i, i=1, 4)]), & - msg="all(ifftshift(xeven) == [complex(kind=dp) ::(i, i=1, 4)]) failed.") - call check(all(ifftshift(xodd) == [complex(kind=dp) ::(i, i=1, 5)]), & - msg="all(ifftshift(xodd) == [complex(kind=dp) ::(i, i=1, 5)]) failed.") + call check(all(ifftshift(xeven) == [complex(kind=rk) ::(i, i=1, 4)]), & + msg="all(ifftshift(xeven) == [complex(kind=rk) ::(i, i=1, 4)]) failed.") + call check(all(ifftshift(xodd) == [complex(kind=rk) ::(i, i=1, 5)]), & + msg="all(ifftshift(xodd) == [complex(kind=rk) ::(i, i=1, 5)]) failed.") end subroutine test_fftpack_ifftshift_complex subroutine test_fftpack_ifftshift_real - use fftpack, only: ifftshift, dp + use fftpack, only: ifftshift + use fftpack_kind integer :: i - real(kind=dp) :: xeven(4) = [3, 4, 1, 2] - real(kind=dp) :: xodd(5) = [4, 5, 1, 2, 3] + real(kind=rk) :: xeven(4) = [3, 4, 1, 2] + real(kind=rk) :: xodd(5) = [4, 5, 1, 2, 3] - call check(all(ifftshift(xeven) == [real(kind=dp) ::(i, i=1, 4)]), & - msg="all(ifftshift(xeven) == [real(kind=dp) ::(i, i=1, 4)]) failed.") - call check(all(ifftshift(xodd) == [real(kind=dp) ::(i, i=1, 5)]), & - msg="all(ifftshift(xodd) == [real(kind=dp) ::(i, i=1, 5)]) failed.") + call check(all(ifftshift(xeven) == [real(kind=rk) ::(i, i=1, 4)]), & + msg="all(ifftshift(xeven) == [real(kind=rk) ::(i, i=1, 4)]) failed.") + call check(all(ifftshift(xodd) == [real(kind=rk) ::(i, i=1, 5)]), & + msg="all(ifftshift(xodd) == [real(kind=rk) ::(i, i=1, 5)]) failed.") end subroutine test_fftpack_ifftshift_real diff --git a/test/test_fftpack_iqct.f90 b/test/test_fftpack_iqct.f90 index 7f5d97c..62f535b 100644 --- a/test/test_fftpack_iqct.f90 +++ b/test/test_fftpack_iqct.f90 @@ -12,18 +12,19 @@ subroutine check(condition, msg) end subroutine check subroutine test_fftpack_iqct - use fftpack, only: qct, iqct, dp - real(kind=dp) :: eps = 1.0e-10_dp - - real(kind=dp) :: x(4) = [1, 2, 3, 4] - - call check(sum(abs(iqct(qct(x))/(4.0_dp*4.0_dp) - [real(kind=dp) :: 1, 2, 3, 4])) < eps, & - msg="`iqct(qct(x)/(4.0_dp*4.0_dp)` failed.") - call check(sum(abs(iqct(qct(x), 2)/(4.0_dp*2.0_dp) - [1.4483415291679655_dp, 7.4608849947753271_dp])) < eps, & - msg="`iqct(qct(x), 2)/(4.0_dp*2.0_dp)` failed.") - call check(sum(abs(iqct(qct(x, 2), 4)/(4.0_dp*4.0_dp) - [0.5_dp, 0.70932417358418376_dp, 1.0_dp, & - 0.78858050747473762_dp])) < eps, & - msg="`iqct(qct(x, 2), 4)/(4.0_dp*4.0_dp)` failed.") + use fftpack, only: qct, iqct + use fftpack_kind + real(kind=rk) :: eps = 1.0e-10_rk + + real(kind=rk) :: x(4) = [1, 2, 3, 4] + + call check(sum(abs(iqct(qct(x))/(4.0_rk*4.0_rk) - [real(kind=rk) :: 1, 2, 3, 4])) < eps, & + msg="`iqct(qct(x)/(4.0_rk*4.0_rk)` failed.") + call check(sum(abs(iqct(qct(x), 2)/(4.0_rk*2.0_rk) - [1.4483415291679655_rk, 7.4608849947753271_rk])) < eps, & + msg="`iqct(qct(x), 2)/(4.0_rk*2.0_rk)` failed.") + call check(sum(abs(iqct(qct(x, 2), 4)/(4.0_rk*4.0_rk) - [0.5_rk, 0.70932417358418376_rk, 1.0_rk, & + 0.78858050747473762_rk])) < eps, & + msg="`iqct(qct(x, 2), 4)/(4.0_rk*4.0_rk)` failed.") end subroutine test_fftpack_iqct diff --git a/test/test_fftpack_irfft.f90 b/test/test_fftpack_irfft.f90 index 7ac0112..0c7e970 100644 --- a/test/test_fftpack_irfft.f90 +++ b/test/test_fftpack_irfft.f90 @@ -12,16 +12,17 @@ subroutine check(condition, msg) end subroutine check subroutine test_fftpack_irfft - use fftpack, only: rfft, irfft, dp - real(kind=dp) :: eps = 1.0e-10_dp + use fftpack, only: rfft, irfft + use fftpack_kind + real(kind=rk) :: eps = 1.0e-10_rk - real(kind=dp) :: x(4) = [1, 2, 3, 4] + real(kind=rk) :: x(4) = [1, 2, 3, 4] - call check(sum(abs(irfft(rfft(x))/4.0_dp - [real(kind=dp) :: 1, 2, 3, 4])) < eps, & - msg="`irfft(rfft(x))/4.0_dp` failed.") - call check(sum(abs(irfft(rfft(x), 2) - [real(kind=dp) :: 8, 12])) < eps, & + call check(sum(abs(irfft(rfft(x))/4.0_rk - [real(kind=rk) :: 1, 2, 3, 4])) < eps, & + msg="`irfft(rfft(x))/4.0_rk` failed.") + call check(sum(abs(irfft(rfft(x), 2) - [real(kind=rk) :: 8, 12])) < eps, & msg="`irfft(rfft(x), 2)` failed.") - call check(sum(abs(irfft(rfft(x, 2), 4) - [real(kind=dp) :: 1, 3, 5, 3])) < eps, & + call check(sum(abs(irfft(rfft(x, 2), 4) - [real(kind=rk) :: 1, 3, 5, 3])) < eps, & msg="`irfft(rfft(x, 2), 4)` failed.") end subroutine test_fftpack_irfft diff --git a/test/test_fftpack_qct.f90 b/test/test_fftpack_qct.f90 index af92545..850d989 100644 --- a/test/test_fftpack_qct.f90 +++ b/test/test_fftpack_qct.f90 @@ -12,17 +12,18 @@ subroutine check(condition, msg) end subroutine check subroutine test_fftpack_qct - use fftpack, only: qct, dp - real(kind=dp) :: eps = 1.0e-10_dp + use fftpack, only: qct + use fftpack_kind + real(kind=rk) :: eps = 1.0e-10_rk - real(kind=dp) :: x(3) = [9, -9, 3] + real(kind=rk) :: x(3) = [9, -9, 3] - call check(sum(abs(qct(x, 2) - [-3.7279220613578570_dp, 21.727922061357859_dp])) < eps, & + call check(sum(abs(qct(x, 2) - [-3.7279220613578570_rk, 21.727922061357859_rk])) < eps, & msg="`qct(x, 2)` failed.") call check(sum(abs(qct(x, 3) - qct(x))) < eps, & msg="`qct(x,3)` failed.") - call check(sum(abs(qct(x, 4) - [-3.3871908980838743_dp, -2.1309424696909023_dp, & - 11.645661095452331_dp, 29.872472272322447_dp])) < eps, & + call check(sum(abs(qct(x, 4) - [-3.3871908980838743_rk, -2.1309424696909023_rk, & + 11.645661095452331_rk, 29.872472272322447_rk])) < eps, & msg="`qct(x, 4)` failed.") end subroutine test_fftpack_qct diff --git a/test/test_fftpack_rfft.f90 b/test/test_fftpack_rfft.f90 index c9079b9..cf37192 100644 --- a/test/test_fftpack_rfft.f90 +++ b/test/test_fftpack_rfft.f90 @@ -12,16 +12,17 @@ subroutine check(condition, msg) end subroutine check subroutine test_fftpack_rfft - use fftpack, only: rfft, dp - real(kind=dp) :: eps = 1.0e-10_dp + use fftpack, only: rfft + use fftpack_kind + real(kind=rk) :: eps = 1.0e-10_rk - real(kind=dp) :: x(3) = [9, -9, 3] + real(kind=rk) :: x(3) = [9, -9, 3] - call check(sum(abs(rfft(x, 2) - [real(kind=dp) :: 0, 18])) < eps, & + call check(sum(abs(rfft(x, 2) - [real(kind=rk) :: 0, 18])) < eps, & msg="`rfft(x, 2)` failed.") call check(sum(abs(rfft(x, 3) - rfft(x))) < eps, & msg="`rfft(x, 3)` failed.") - call check(sum(abs(rfft(x, 4) - [real(kind=dp) :: 3, 6, 9, 21])) < eps, & + call check(sum(abs(rfft(x, 4) - [real(kind=rk) :: 3, 6, 9, 21])) < eps, & msg="`rfft(x, 4)` failed.") end subroutine test_fftpack_rfft diff --git a/test/test_fftpack_zfft.f90 b/test/test_fftpack_zfft.f90 index 7e30646..b45ab3b 100644 --- a/test/test_fftpack_zfft.f90 +++ b/test/test_fftpack_zfft.f90 @@ -12,18 +12,22 @@ subroutine check(condition, msg) end subroutine check subroutine test_fftpack_zfft() - use fftpack, only: zffti, zfftf, zfftb, dp + use fftpack_kind - complex(kind=dp) :: x(4) = [1, 2, 3, 4] - real(kind=dp) :: w(31) + use fftpack_kind + use fftpack, only: zffti, zfftf, zfftb + use fftpack_kind + + complex(kind=rk) :: x(4) = [1, 2, 3, 4] + real(kind=rk) :: w(31) call zffti(4, w) call zfftf(4, x, w) - call check(all(x == [complex(kind=dp) ::(10, 0), (-2, 2), (-2, 0), (-2, -2)]), & + call check(all(x == [complex(kind=rk) ::(10, 0), (-2, 2), (-2, 0), (-2, -2)]), & msg="`zfftf` failed.") call zfftb(4, x, w) - call check(all(x/4.0_dp == [complex(kind=dp) ::(1, 0), (2, 0), (3, 0), (4, 0)]), & + call check(all(x/4.0_rk == [complex(kind=rk) ::(1, 0), (2, 0), (3, 0), (4, 0)]), & msg="`zfftb` failed.") end subroutine test_fftpack_zfft From b4bc983c701c9cf28df7caea64d9704292824856 Mon Sep 17 00:00:00 2001 From: "Harris M. Snyder" Date: Sat, 11 Sep 2021 23:14:32 -0400 Subject: [PATCH 02/10] a few cleanup fixes to previous commit --- src/fftpack.f90 | 14 +++++++------- src/fftpack_fft.f90 | 2 +- src/fftpack_ifft.f90 | 2 +- src/fftpack_irfft.f90 | 2 +- src/fftpack_rfft.f90 | 2 +- test/tstfft.f | 5 +++-- 6 files changed, 14 insertions(+), 13 deletions(-) diff --git a/src/fftpack.f90 b/src/fftpack.f90 index ae54319..5a27c95 100644 --- a/src/fftpack.f90 +++ b/src/fftpack.f90 @@ -30,7 +30,7 @@ end subroutine zffti !> Version: experimental !> - !> Forward transform of a double complex periodic sequence. + !> Forward transform of a complex periodic sequence. !> ([Specification](../page/specs/fftpack.html#zfftf)) pure subroutine zfftf(n, c, wsave) import rk @@ -62,7 +62,7 @@ end subroutine dffti !> Version: experimental !> - !> Forward transform of a double real periodic sequence. + !> Forward transform of a real periodic sequence. !> ([Specification](../page/specs/fftpack.html#dfftf)) pure subroutine dfftf(n, r, wsave) import rk @@ -94,7 +94,7 @@ end subroutine dzffti !> Version: experimental !> - !> Simplified forward transform of a double real periodic sequence. + !> Simplified forward transform of a real periodic sequence. !> ([Specification](../page/specs/fftpack.html#dzfftf)) pure subroutine dzfftf(n, r, azero, a, b, wsave) import rk @@ -154,7 +154,7 @@ end subroutine dcosqb !> Version: experimental !> - !> Forward transform of a double complex periodic sequence. + !> Forward transform of a complex periodic sequence. !> ([Specifiction](../page/specs/fftpack.html#fft)) interface fft pure module function fft_rk(x, n) result(result) @@ -166,7 +166,7 @@ end function fft_rk !> Version: experimental !> - !> Backward transform of a double complex periodic sequence. + !> Backward transform of a complex periodic sequence. !> ([Specifiction](../page/specs/fftpack.html#ifft)) interface ifft pure module function ifft_rk(x, n) result(result) @@ -178,7 +178,7 @@ end function ifft_rk !> Version: experimental !> - !> Forward transform of a double real periodic sequence. + !> Forward transform of a real periodic sequence. !> ([Specifiction](../page/specs/fftpack.html#rfft)) interface rfft pure module function rfft_rk(x, n) result(result) @@ -190,7 +190,7 @@ end function rfft_rk !> Version: experimental !> - !> Backward transform of a double real periodic sequence. + !> Backward transform of a real periodic sequence. !> ([Specifiction](../page/specs/fftpack.html#irfft)) interface irfft pure module function irfft_rk(x, n) result(result) diff --git a/src/fftpack_fft.f90 b/src/fftpack_fft.f90 index bf21eb5..8f02ee0 100644 --- a/src/fftpack_fft.f90 +++ b/src/fftpack_fft.f90 @@ -2,7 +2,7 @@ contains - !> Forward transform of a double complex periodic sequence. + !> Forward transform of a complex periodic sequence. pure module function fft_rk(x, n) result(result) complex(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n diff --git a/src/fftpack_ifft.f90 b/src/fftpack_ifft.f90 index 40068d4..680e64b 100644 --- a/src/fftpack_ifft.f90 +++ b/src/fftpack_ifft.f90 @@ -2,7 +2,7 @@ contains - !> Backward transform of a double complex periodic sequence. + !> Backward transform of a complex periodic sequence. pure module function ifft_rk(x, n) result(result) complex(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n diff --git a/src/fftpack_irfft.f90 b/src/fftpack_irfft.f90 index 97565cb..13cdb05 100644 --- a/src/fftpack_irfft.f90 +++ b/src/fftpack_irfft.f90 @@ -2,7 +2,7 @@ contains - !> Backward transform of a double real periodic sequence. + !> Backward transform of a real periodic sequence. pure module function irfft_rk(x, n) result(result) real(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n diff --git a/src/fftpack_rfft.f90 b/src/fftpack_rfft.f90 index a0c6260..2d10767 100644 --- a/src/fftpack_rfft.f90 +++ b/src/fftpack_rfft.f90 @@ -2,7 +2,7 @@ contains - !> Forward transform of a double real periodic sequence. + !> Forward transform of a real periodic sequence. pure module function rfft_rk(x, n) result(result) real(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n diff --git a/test/tstfft.f b/test/tstfft.f index 5111c69..24ced38 100644 --- a/test/tstfft.f +++ b/test/tstfft.f @@ -53,11 +53,12 @@ PROGRAM TSTFFT C - IMPLICIT DOUBLE PRECISION (A-H,O-Z) + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION ND(10) ,X(200) ,Y(200) ,W(2000) , 1 A(100) ,B(100) ,AH(100) ,BH(100) , 2 XH(200) ,CX(200) ,CY(200) - DOUBLE COMPLEX CX ,CY + COMPLEX(RK) CX ,CY DATA ND(1),ND(2),ND(3),ND(4),ND(5),ND(6),ND(7)/120,54,49,32,4,3,2/ SQRT2 = SQRT(2.0D0) NNS = 7 From 03f14ead03d84f2df5e8618789f95527014757dc Mon Sep 17 00:00:00 2001 From: "Harris M. Snyder" Date: Sun, 12 Sep 2021 22:35:02 -0400 Subject: [PATCH 03/10] Changed FLOAT() calls to REAL(,RK) --- src/cffti1.f | 4 ++-- src/dcosqi.f | 2 +- src/dcosti.f | 2 +- src/dsinti.f | 2 +- src/dzfftf.f | 2 +- src/ezfft1.f | 4 ++-- src/radbg.f | 2 +- src/radfg.f | 2 +- src/rffti1.f | 4 ++-- test/tstfft.f | 64 +++++++++++++++++++++++++-------------------------- 10 files changed, 44 insertions(+), 44 deletions(-) diff --git a/src/cffti1.f b/src/cffti1.f index 923cdfe..f962cd3 100644 --- a/src/cffti1.f +++ b/src/cffti1.f @@ -28,7 +28,7 @@ SUBROUTINE CFFTI1 (N,WA,IFAC) IFAC(1) = N IFAC(2) = NF TPI = 6.28318530717958647692D0 - ARGH = TPI/FLOAT(N) + ARGH = TPI/REAL(N,RK) I = 2 L1 = 1 DO 110 K1=1,NF @@ -44,7 +44,7 @@ SUBROUTINE CFFTI1 (N,WA,IFAC) WA(I) = 0.0D0 LD = LD+L1 FI = 0.0D0 - ARGLD = FLOAT(LD)*ARGH + ARGLD = REAL(LD,RK)*ARGH DO 108 II=4,IDOT,2 I = I+2 FI = FI+1.D0 diff --git a/src/dcosqi.f b/src/dcosqi.f index 9c09127..b4cc80d 100644 --- a/src/dcosqi.f +++ b/src/dcosqi.f @@ -3,7 +3,7 @@ SUBROUTINE DCOSQI (N,WSAVE) IMPLICIT REAL(RK) (A-H,O-Z) DIMENSION WSAVE(1) DATA PIH /1.57079632679489661923D0/ - DT = PIH/FLOAT(N) + DT = PIH/REAL(N,RK) FK = 0.0D0 DO 101 K=1,N FK = FK+1.0D0 diff --git a/src/dcosti.f b/src/dcosti.f index 4993339..1a28918 100644 --- a/src/dcosti.f +++ b/src/dcosti.f @@ -7,7 +7,7 @@ SUBROUTINE DCOSTI (N,WSAVE) NM1 = N-1 NP1 = N+1 NS2 = N/2 - DT = PI/FLOAT(NM1) + DT = PI/REAL(NM1,RK) FK = 0.0D0 DO 101 K=2,NS2 KC = NP1-K diff --git a/src/dsinti.f b/src/dsinti.f index fbb283c..aaae25b 100644 --- a/src/dsinti.f +++ b/src/dsinti.f @@ -6,7 +6,7 @@ SUBROUTINE DSINTI (N,WSAVE) IF (N .LE. 1) RETURN NS2 = N/2 NP1 = N+1 - DT = PI/FLOAT(NP1) + DT = PI/REAL(NP1,RK) DO 101 K=1,NS2 WSAVE(K) = 2.0D0*SIN(K*DT) 101 CONTINUE diff --git a/src/dzfftf.f b/src/dzfftf.f index 13b4f6b..2781e61 100644 --- a/src/dzfftf.f +++ b/src/dzfftf.f @@ -15,7 +15,7 @@ SUBROUTINE DZFFTF (N,R,AZERO,A,B,WSAVE) WSAVE(I) = R(I) 104 CONTINUE CALL DFFTF (N,WSAVE,WSAVE(N+1)) - CF = 2.0D0/FLOAT(N) + CF = 2.0D0/REAL(N,RK) CFM = -CF AZERO = 0.5D0*CF*WSAVE(1) NS2 = (N+1)/2 diff --git a/src/ezfft1.f b/src/ezfft1.f index 2600c89..8c21abe 100644 --- a/src/ezfft1.f +++ b/src/ezfft1.f @@ -28,7 +28,7 @@ SUBROUTINE EZFFT1 (N,WA,IFAC) 107 IF (NL .NE. 1) GO TO 104 IFAC(1) = N IFAC(2) = NF - ARGH = TPI/FLOAT(N) + ARGH = TPI/REAL(N,RK) IS = 0 NFM1 = NF-1 L1 = 1 @@ -38,7 +38,7 @@ SUBROUTINE EZFFT1 (N,WA,IFAC) L2 = L1*IP IDO = N/L2 IPM = IP-1 - ARG1 = FLOAT(L1)*ARGH + ARG1 = REAL(L1,RK)*ARGH CH1 = 1.0D0 SH1 = 0.0D0 DCH1 = COS(ARG1) diff --git a/src/radbg.f b/src/radbg.f index 47472d6..c38e501 100644 --- a/src/radbg.f +++ b/src/radbg.f @@ -5,7 +5,7 @@ SUBROUTINE RADBG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) 1 C1(IDO,L1,IP) ,C2(IDL1,IP), 2 CH2(IDL1,IP) ,WA(1) DATA TPI/6.28318530717958647692D0/ - ARG = TPI/FLOAT(IP) + ARG = TPI/REAL(IP,RK) DCP = COS(ARG) DSP = SIN(ARG) IDP2 = IDO+2 diff --git a/src/radfg.f b/src/radfg.f index a7d91c6..eac2006 100644 --- a/src/radfg.f +++ b/src/radfg.f @@ -5,7 +5,7 @@ SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) 1 C1(IDO,L1,IP) ,C2(IDL1,IP), 2 CH2(IDL1,IP) ,WA(1) DATA TPI/6.28318530717958647692D0/ - ARG = TPI/FLOAT(IP) + ARG = TPI/REAL(IP,RK) DCP = COS(ARG) DSP = SIN(ARG) IPPH = (IP+1)/2 diff --git a/src/rffti1.f b/src/rffti1.f index 5dd1f41..7d4a8e0 100644 --- a/src/rffti1.f +++ b/src/rffti1.f @@ -28,7 +28,7 @@ SUBROUTINE RFFTI1 (N,WA,IFAC) IFAC(1) = N IFAC(2) = NF TPI = 6.28318530717958647692D0 - ARGH = TPI/FLOAT(N) + ARGH = TPI/REAL(N,RK) IS = 0 NFM1 = NF-1 L1 = 1 @@ -42,7 +42,7 @@ SUBROUTINE RFFTI1 (N,WA,IFAC) DO 109 J=1,IPM LD = LD+L1 I = IS - ARGLD = FLOAT(LD)*ARGH + ARGLD = REAL(LD,RK)*ARGH FI = 0.0D0 DO 108 II=3,IDO,2 I = I+2 diff --git a/test/tstfft.f b/test/tstfft.f index 24ced38..36a9a3f 100644 --- a/test/tstfft.f +++ b/test/tstfft.f @@ -65,12 +65,12 @@ PROGRAM TSTFFT DO 157 NZ=1,NNS N = ND(NZ) MODN = MOD(N,2) - FN = FLOAT(N) + FN = REAL(N,RK) TFN = FN+FN NP1 = N+1 NM1 = N-1 DO 101 J=1,NP1 - X(J) = SIN(FLOAT(J)*SQRT2) + X(J) = SIN(REAL(J,RK)*SQRT2) Y(J) = X(J) XH(J) = X(J) 101 CONTINUE @@ -85,9 +85,9 @@ PROGRAM TSTFFT DO 103 K=2,NS2 SUM1 = 0.0D0 SUM2 = 0.0D0 - ARG = FLOAT(K-1)*DT + ARG = REAL(K-1,RK)*DT DO 102 I=1,N - ARG1 = FLOAT(I-1)*ARG + ARG1 = REAL(I-1,RK)*ARG SUM1 = SUM1+X(I)*COS(ARG1) SUM2 = SUM2+X(I)*SIN(ARG1) 102 CONTINUE @@ -112,13 +112,13 @@ PROGRAM TSTFFT RFTF = RFTF/FN DO 109 I=1,N SUM = 0.5D0*X(1) - ARG = FLOAT(I-1)*DT + ARG = REAL(I-1,RK)*DT IF (NS2 .LT. 2) GO TO 108 DO 107 K=2,NS2 - ARG1 = FLOAT(K-1)*ARG + ARG1 = REAL(K-1,RK)*ARG SUM = SUM+X(2*K-2)*COS(ARG1)-X(2*K-1)*SIN(ARG1) 107 CONTINUE - 108 IF (MODN .EQ. 0) SUM = SUM+.5*FLOAT((-1)**(I-1))*X(N) + 108 IF (MODN .EQ. 0) SUM = SUM+.5*REAL((-1)**(I-1),RK)*X(N) Y(I) = SUM+SUM 109 CONTINUE CALL DFFTB (N,X,W) @@ -144,9 +144,9 @@ PROGRAM TSTFFT 112 CONTINUE DO 114 I=1,NM1 Y(I) = 0.0D0 - ARG1 = FLOAT(I)*DT + ARG1 = REAL(I,RK)*DT DO 113 K=1,NM1 - Y(I) = Y(I)+X(K)*SIN(FLOAT(K)*ARG1) + Y(I) = Y(I)+X(K)*SIN(REAL(K,RK)*ARG1) 113 CONTINUE Y(I) = Y(I)+Y(I) 114 CONTINUE @@ -173,10 +173,10 @@ PROGRAM TSTFFT X(I) = XH(I) 117 CONTINUE DO 119 I=1,NP1 - Y(I) = 0.5D0*(X(1)+FLOAT((-1)**(I+1))*X(N+1)) - ARG = FLOAT(I-1)*DT + Y(I) = 0.5D0*(X(1)+REAL((-1)**(I+1),RK)*X(N+1)) + ARG = REAL(I-1,RK)*DT DO 118 K=2,N - Y(I) = Y(I)+X(K)*COS(FLOAT(K-1)*ARG) + Y(I) = Y(I)+X(K)*COS(REAL(K-1,RK)*ARG) 118 CONTINUE Y(I) = Y(I)+Y(I) 119 CONTINUE @@ -205,9 +205,9 @@ PROGRAM TSTFFT DT = PI/(FN+FN) DO 124 I=1,N X(I) = 0.0D0 - ARG = DT*FLOAT(I) + ARG = DT*REAL(I,RK) DO 123 K=1,N - X(I) = X(I)+Y(K)*SIN(FLOAT(K+K-1)*ARG) + X(I) = X(I)+Y(K)*SIN(REAL(K+K-1,RK)*ARG) 123 CONTINUE X(I) = 4.0D0*X(I) 124 CONTINUE @@ -220,10 +220,10 @@ PROGRAM TSTFFT 125 CONTINUE SINQBT = CF*SINQBT DO 127 I=1,N - ARG = FLOAT(I+I-1)*DT - Y(I) = 0.5D0*FLOAT((-1)**(I+1))*X(N) + ARG = REAL(I+I-1,RK)*DT + Y(I) = 0.5D0*REAL((-1)**(I+1),RK)*X(N) DO 126 K=1,NM1 - Y(I) = Y(I)+X(K)*SIN(FLOAT(K)*ARG) + Y(I) = Y(I)+X(K)*SIN(REAL(K,RK)*ARG) 126 CONTINUE Y(I) = Y(I)+Y(I) 127 CONTINUE @@ -248,9 +248,9 @@ PROGRAM TSTFFT 130 CONTINUE DO 132 I=1,N X(I) = 0.0D0 - ARG = FLOAT(I-1)*DT + ARG = REAL(I-1,RK)*DT DO 131 K=1,N - X(I) = X(I)+Y(K)*COS(FLOAT(K+K-1)*ARG) + X(I) = X(I)+Y(K)*COS(REAL(K+K-1,RK)*ARG) 131 CONTINUE X(I) = 4.0D0*X(I) 132 CONTINUE @@ -264,9 +264,9 @@ PROGRAM TSTFFT COSQBT = CF*COSQBT DO 135 I=1,N Y(I) = 0.5D0*X(1) - ARG = FLOAT(I+I-1)*DT + ARG = REAL(I+I-1,RK)*DT DO 134 K=2,N - Y(I) = Y(I)+X(K)*COS(FLOAT(K-1)*ARG) + Y(I) = Y(I)+X(K)*COS(REAL(K-1,RK)*ARG) 134 CONTINUE Y(I) = Y(I)+Y(I) 135 CONTINUE @@ -292,17 +292,17 @@ PROGRAM TSTFFT X(I) = XH(I) 138 CONTINUE TPI = 8.0D0*ATAN(1.0D0) - DT = TPI/FLOAT(N) + DT = TPI/REAL(N,RK) NS2 = (N+1)/2 - CF = 2.0D0/FLOAT(N) + CF = 2.0D0/REAL(N,RK) NS2M = NS2-1 IF (NS2M .LE. 0) GO TO 141 DO 140 K=1,NS2M SUM1 = 0.0D0 SUM2 = 0.0D0 - ARG = FLOAT(K)*DT + ARG = REAL(K,RK)*DT DO 139 I=1,N - ARG1 = FLOAT(I-1)*ARG + ARG1 = REAL(I-1,RK)*ARG SUM1 = SUM1+X(I)*COS(ARG1) SUM2 = SUM2+X(I)*SIN(ARG1) 139 CONTINUE @@ -330,9 +330,9 @@ PROGRAM TSTFFT IF (MODN .EQ. 0) B(NS2) = 0.0D0 DO 146 I=1,N SUM = AZERO - ARG1 = FLOAT(I-1)*DT + ARG1 = REAL(I-1,RK)*DT DO 145 K=1,NS2 - ARG2 = FLOAT(K)*ARG1 + ARG2 = REAL(K,RK)*ARG1 SUM = SUM+A(K)*COS(ARG2)+B(K)*SIN(ARG2) 145 CONTINUE X(I) = SUM @@ -353,14 +353,14 @@ PROGRAM TSTFFT C TEST CFFTI,CFFTF,CFFTB C DO 149 I=1,N - CX(I) = DCMPLX(COS(SQRT2*FLOAT(I)),SIN(SQRT2*FLOAT(I*I))) + CX(I) =DCMPLX(COS(SQRT2*REAL(I,RK)),SIN(SQRT2*REAL(I*I,RK))) 149 CONTINUE DT = (PI+PI)/FN DO 151 I=1,N - ARG1 = -FLOAT(I-1)*DT + ARG1 = -REAL(I-1,RK)*DT CY(I) = (0.0D0,0.0D0) DO 150 K=1,N - ARG2 = FLOAT(K-1)*ARG1 + ARG2 = REAL(K-1,RK)*ARG1 CY(I) = CY(I)+DCMPLX(COS(ARG2),SIN(ARG2))*CX(K) 150 CONTINUE 151 CONTINUE @@ -373,10 +373,10 @@ PROGRAM TSTFFT 152 CONTINUE DCFFTF = DCFFTF/FN DO 154 I=1,N - ARG1 = FLOAT(I-1)*DT + ARG1 = REAL(I-1,RK)*DT CY(I) = (0.0D0,0.0D0) DO 153 K=1,N - ARG2 = FLOAT(K-1)*ARG1 + ARG2 = REAL(K-1,RK)*ARG1 CY(I) = CY(I)+DCMPLX(COS(ARG2),SIN(ARG2))*CX(K) 153 CONTINUE 154 CONTINUE From 5af7237ccf1cbab4caabda26a4562cc9f8f27b12 Mon Sep 17 00:00:00 2001 From: Jacob Williams Date: Tue, 14 Sep 2021 13:22:45 -0500 Subject: [PATCH 04/10] Initial fixed to free processing by SPAG --- src/cfftb1.f | 63 ----------------- src/cfftb1.f90 | 72 +++++++++++++++++++ src/cfftf1.f | 63 ----------------- src/cfftf1.f90 | 72 +++++++++++++++++++ src/cffti1.f | 62 ----------------- src/cffti1.f90 | 73 +++++++++++++++++++ src/cosqb1.f | 29 -------- src/cosqb1.f90 | 34 +++++++++ src/cosqf1.f | 27 -------- src/cosqf1.f90 | 32 +++++++++ src/dcosqb.f | 15 ---- src/dcosqb.f90 | 23 ++++++ src/dcosqf.f | 13 ---- src/dcosqf.f90 | 22 ++++++ src/dcosqi.f | 14 ---- src/dcosqi.f90 | 19 +++++ src/dcost.f | 44 ------------ src/dcost.f90 | 53 ++++++++++++++ src/dcosti.f | 20 ------ src/dcosti.f90 | 25 +++++++ src/dfftb.f | 8 --- src/dfftb.f90 | 13 ++++ src/dfftf.f | 8 --- src/dfftf.f90 | 13 ++++ src/dffti.f | 8 --- src/dffti.f90 | 13 ++++ src/dsinqb.f | 20 ------ src/dsinqb.f90 | 27 ++++++++ src/dsinqf.f | 18 ----- src/dsinqf.f90 | 23 ++++++ src/dsinqi.f | 7 -- src/dsinqi.f90 | 12 ++++ src/dsint.f | 11 --- src/dsint.f90 | 16 +++++ src/dsinti.f | 15 ---- src/dsinti.f90 | 20 ++++++ src/dzfftb.f | 20 ------ src/dzfftb.f90 | 28 ++++++++ src/dzfftf.f | 31 --------- src/dzfftf.f90 | 39 +++++++++++ src/dzffti.f | 8 --- src/dzffti.f90 | 13 ++++ src/ezfft1.f | 64 ----------------- src/ezfft1.f90 | 75 ++++++++++++++++++++ src/passb.f | 118 ------------------------------- src/passb.f90 | 129 ++++++++++++++++++++++++++++++++++ src/passb2.f | 25 ------- src/passb2.f90 | 31 +++++++++ src/passb3.f | 45 ------------ src/passb3.f90 | 52 ++++++++++++++ src/passb4.f | 53 -------------- src/passb4.f90 | 62 +++++++++++++++++ src/passb5.f | 80 --------------------- src/passb5.f90 | 91 ++++++++++++++++++++++++ src/passf.f | 118 ------------------------------- src/passf.f90 | 129 ++++++++++++++++++++++++++++++++++ src/passf2.f | 25 ------- src/passf2.f90 | 31 +++++++++ src/passf3.f | 45 ------------ src/passf3.f90 | 52 ++++++++++++++ src/passf4.f | 53 -------------- src/passf4.f90 | 62 +++++++++++++++++ src/passf5.f | 80 --------------------- src/passf5.f90 | 91 ++++++++++++++++++++++++ src/radb2.f | 29 -------- src/radb2.f90 | 35 ++++++++++ src/radb3.f | 40 ----------- src/radb3.f90 | 45 ++++++++++++ src/radb4.f | 59 ---------------- src/radb4.f90 | 67 ++++++++++++++++++ src/radb5.f | 68 ------------------ src/radb5.f90 | 77 ++++++++++++++++++++ src/radbg.f | 162 ------------------------------------------- src/radbg.f90 | 178 +++++++++++++++++++++++++++++++++++++++++++++++ src/radf2.f | 29 -------- src/radf2.f90 | 35 ++++++++++ src/radf3.f | 38 ---------- src/radf3.f90 | 43 ++++++++++++ src/radf4.f | 55 --------------- src/radf4.f90 | 63 +++++++++++++++++ src/radf5.f | 62 ----------------- src/radf5.f90 | 71 +++++++++++++++++++ src/radfg.f | 168 -------------------------------------------- src/radfg.f90 | 185 +++++++++++++++++++++++++++++++++++++++++++++++++ src/rfftb1.f | 61 ---------------- src/rfftb1.f90 | 70 +++++++++++++++++++ src/rfftf1.f | 61 ---------------- src/rfftf1.f90 | 70 +++++++++++++++++++ src/rffti1.f | 59 ---------------- src/rffti1.f90 | 69 ++++++++++++++++++ src/rk.f | 4 -- src/sint1.f | 42 ----------- src/sint1.f90 | 47 +++++++++++++ src/zfftb.f | 10 --- src/zfftb.f90 | 15 ++++ src/zfftf.f | 10 --- src/zfftf.f90 | 15 ++++ src/zffti.f | 10 --- src/zffti.f90 | 15 ++++ 99 files changed, 2547 insertions(+), 2177 deletions(-) delete mode 100644 src/cfftb1.f create mode 100644 src/cfftb1.f90 delete mode 100644 src/cfftf1.f create mode 100644 src/cfftf1.f90 delete mode 100644 src/cffti1.f create mode 100644 src/cffti1.f90 delete mode 100644 src/cosqb1.f create mode 100644 src/cosqb1.f90 delete mode 100644 src/cosqf1.f create mode 100644 src/cosqf1.f90 delete mode 100644 src/dcosqb.f create mode 100644 src/dcosqb.f90 delete mode 100644 src/dcosqf.f create mode 100644 src/dcosqf.f90 delete mode 100644 src/dcosqi.f create mode 100644 src/dcosqi.f90 delete mode 100644 src/dcost.f create mode 100644 src/dcost.f90 delete mode 100644 src/dcosti.f create mode 100644 src/dcosti.f90 delete mode 100644 src/dfftb.f create mode 100644 src/dfftb.f90 delete mode 100644 src/dfftf.f create mode 100644 src/dfftf.f90 delete mode 100644 src/dffti.f create mode 100644 src/dffti.f90 delete mode 100644 src/dsinqb.f create mode 100644 src/dsinqb.f90 delete mode 100644 src/dsinqf.f create mode 100644 src/dsinqf.f90 delete mode 100644 src/dsinqi.f create mode 100644 src/dsinqi.f90 delete mode 100644 src/dsint.f create mode 100644 src/dsint.f90 delete mode 100644 src/dsinti.f create mode 100644 src/dsinti.f90 delete mode 100644 src/dzfftb.f create mode 100644 src/dzfftb.f90 delete mode 100644 src/dzfftf.f create mode 100644 src/dzfftf.f90 delete mode 100644 src/dzffti.f create mode 100644 src/dzffti.f90 delete mode 100644 src/ezfft1.f create mode 100644 src/ezfft1.f90 delete mode 100644 src/passb.f create mode 100644 src/passb.f90 delete mode 100644 src/passb2.f create mode 100644 src/passb2.f90 delete mode 100644 src/passb3.f create mode 100644 src/passb3.f90 delete mode 100644 src/passb4.f create mode 100644 src/passb4.f90 delete mode 100644 src/passb5.f create mode 100644 src/passb5.f90 delete mode 100644 src/passf.f create mode 100644 src/passf.f90 delete mode 100644 src/passf2.f create mode 100644 src/passf2.f90 delete mode 100644 src/passf3.f create mode 100644 src/passf3.f90 delete mode 100644 src/passf4.f create mode 100644 src/passf4.f90 delete mode 100644 src/passf5.f create mode 100644 src/passf5.f90 delete mode 100644 src/radb2.f create mode 100644 src/radb2.f90 delete mode 100644 src/radb3.f create mode 100644 src/radb3.f90 delete mode 100644 src/radb4.f create mode 100644 src/radb4.f90 delete mode 100644 src/radb5.f create mode 100644 src/radb5.f90 delete mode 100644 src/radbg.f create mode 100644 src/radbg.f90 delete mode 100644 src/radf2.f create mode 100644 src/radf2.f90 delete mode 100644 src/radf3.f create mode 100644 src/radf3.f90 delete mode 100644 src/radf4.f create mode 100644 src/radf4.f90 delete mode 100644 src/radf5.f create mode 100644 src/radf5.f90 delete mode 100644 src/radfg.f create mode 100644 src/radfg.f90 delete mode 100644 src/rfftb1.f create mode 100644 src/rfftb1.f90 delete mode 100644 src/rfftf1.f create mode 100644 src/rfftf1.f90 delete mode 100644 src/rffti1.f create mode 100644 src/rffti1.f90 delete mode 100644 src/rk.f delete mode 100644 src/sint1.f create mode 100644 src/sint1.f90 delete mode 100644 src/zfftb.f create mode 100644 src/zfftb.f90 delete mode 100644 src/zfftf.f create mode 100644 src/zfftf.f90 delete mode 100644 src/zffti.f create mode 100644 src/zffti.f90 diff --git a/src/cfftb1.f b/src/cfftb1.f deleted file mode 100644 index bd2a2c4..0000000 --- a/src/cfftb1.f +++ /dev/null @@ -1,63 +0,0 @@ - SUBROUTINE CFFTB1 (N,C,CH,WA,IFAC) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) - NF = IFAC(2) - NA = 0 - L1 = 1 - IW = 1 - DO 116 K1=1,NF - IP = IFAC(K1+2) - L2 = IP*L1 - IDO = N/L2 - IDOT = IDO+IDO - IDL1 = IDOT*L1 - IF (IP .NE. 4) GO TO 103 - IX2 = IW+IDOT - IX3 = IX2+IDOT - IF (NA .NE. 0) GO TO 101 - CALL PASSB4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) - GO TO 102 - 101 CALL PASSB4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) - 102 NA = 1-NA - GO TO 115 - 103 IF (IP .NE. 2) GO TO 106 - IF (NA .NE. 0) GO TO 104 - CALL PASSB2 (IDOT,L1,C,CH,WA(IW)) - GO TO 105 - 104 CALL PASSB2 (IDOT,L1,CH,C,WA(IW)) - 105 NA = 1-NA - GO TO 115 - 106 IF (IP .NE. 3) GO TO 109 - IX2 = IW+IDOT - IF (NA .NE. 0) GO TO 107 - CALL PASSB3 (IDOT,L1,C,CH,WA(IW),WA(IX2)) - GO TO 108 - 107 CALL PASSB3 (IDOT,L1,CH,C,WA(IW),WA(IX2)) - 108 NA = 1-NA - GO TO 115 - 109 IF (IP .NE. 5) GO TO 112 - IX2 = IW+IDOT - IX3 = IX2+IDOT - IX4 = IX3+IDOT - IF (NA .NE. 0) GO TO 110 - CALL PASSB5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 111 - 110 CALL PASSB5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - 111 NA = 1-NA - GO TO 115 - 112 IF (NA .NE. 0) GO TO 113 - CALL PASSB (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) - GO TO 114 - 113 CALL PASSB (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) - 114 IF (NAC .NE. 0) NA = 1-NA - 115 L1 = L2 - IW = IW+(IP-1)*IDOT - 116 CONTINUE - IF (NA .EQ. 0) RETURN - N2 = N+N - DO 117 I=1,N2 - C(I) = CH(I) - 117 CONTINUE - RETURN - END diff --git a/src/cfftb1.f90 b/src/cfftb1.f90 new file mode 100644 index 0000000..b09113a --- /dev/null +++ b/src/cfftb1.f90 @@ -0,0 +1,72 @@ +!*==CFFTB1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE CFFTB1(N,C,Ch,Wa,Ifac) + USE FFTPACK_KIND + IMPLICIT NONE +!*--CFFTB15 +!*** Start of declarations inserted by SPAG + REAL C , Ch , FFTPACK_KIND , rk , Wa + INTEGER i , idl1 , ido , idot , Ifac , ip , iw , ix2 , ix3 , ix4 ,& + & k1 , l1 , l2 , N , n2 , na , nac , nf +!*** End of declarations inserted by SPAG + DIMENSION Ch(*) , C(*) , Wa(*) , Ifac(*) + nf = Ifac(2) + na = 0 + l1 = 1 + iw = 1 + DO k1 = 1 , nf + ip = Ifac(k1+2) + l2 = ip*l1 + ido = N/l2 + idot = ido + ido + idl1 = idot*l1 + IF ( ip==4 ) THEN + ix2 = iw + idot + ix3 = ix2 + idot + IF ( na/=0 ) THEN + CALL PASSB4(idot,l1,Ch,C,Wa(iw),Wa(ix2),Wa(ix3)) + ELSE + CALL PASSB4(idot,l1,C,Ch,Wa(iw),Wa(ix2),Wa(ix3)) + ENDIF + na = 1 - na + ELSEIF ( ip==2 ) THEN + IF ( na/=0 ) THEN + CALL PASSB2(idot,l1,Ch,C,Wa(iw)) + ELSE + CALL PASSB2(idot,l1,C,Ch,Wa(iw)) + ENDIF + na = 1 - na + ELSEIF ( ip==3 ) THEN + ix2 = iw + idot + IF ( na/=0 ) THEN + CALL PASSB3(idot,l1,Ch,C,Wa(iw),Wa(ix2)) + ELSE + CALL PASSB3(idot,l1,C,Ch,Wa(iw),Wa(ix2)) + ENDIF + na = 1 - na + ELSEIF ( ip/=5 ) THEN + IF ( na/=0 ) THEN + CALL PASSB(nac,idot,ip,l1,idl1,Ch,Ch,Ch,C,C,Wa(iw)) + ELSE + CALL PASSB(nac,idot,ip,l1,idl1,C,C,C,Ch,Ch,Wa(iw)) + ENDIF + IF ( nac/=0 ) na = 1 - na + ELSE + ix2 = iw + idot + ix3 = ix2 + idot + ix4 = ix3 + idot + IF ( na/=0 ) THEN + CALL PASSB5(idot,l1,Ch,C,Wa(iw),Wa(ix2),Wa(ix3),Wa(ix4)) + ELSE + CALL PASSB5(idot,l1,C,Ch,Wa(iw),Wa(ix2),Wa(ix3),Wa(ix4)) + ENDIF + na = 1 - na + ENDIF + l1 = l2 + iw = iw + (ip-1)*idot + ENDDO + IF ( na==0 ) RETURN + n2 = N + N + DO i = 1 , n2 + C(i) = Ch(i) + ENDDO + END subroutine cfftb1 \ No newline at end of file diff --git a/src/cfftf1.f b/src/cfftf1.f deleted file mode 100644 index ac847b6..0000000 --- a/src/cfftf1.f +++ /dev/null @@ -1,63 +0,0 @@ - SUBROUTINE CFFTF1 (N,C,CH,WA,IFAC) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) - NF = IFAC(2) - NA = 0 - L1 = 1 - IW = 1 - DO 116 K1=1,NF - IP = IFAC(K1+2) - L2 = IP*L1 - IDO = N/L2 - IDOT = IDO+IDO - IDL1 = IDOT*L1 - IF (IP .NE. 4) GO TO 103 - IX2 = IW+IDOT - IX3 = IX2+IDOT - IF (NA .NE. 0) GO TO 101 - CALL PASSF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) - GO TO 102 - 101 CALL PASSF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) - 102 NA = 1-NA - GO TO 115 - 103 IF (IP .NE. 2) GO TO 106 - IF (NA .NE. 0) GO TO 104 - CALL PASSF2 (IDOT,L1,C,CH,WA(IW)) - GO TO 105 - 104 CALL PASSF2 (IDOT,L1,CH,C,WA(IW)) - 105 NA = 1-NA - GO TO 115 - 106 IF (IP .NE. 3) GO TO 109 - IX2 = IW+IDOT - IF (NA .NE. 0) GO TO 107 - CALL PASSF3 (IDOT,L1,C,CH,WA(IW),WA(IX2)) - GO TO 108 - 107 CALL PASSF3 (IDOT,L1,CH,C,WA(IW),WA(IX2)) - 108 NA = 1-NA - GO TO 115 - 109 IF (IP .NE. 5) GO TO 112 - IX2 = IW+IDOT - IX3 = IX2+IDOT - IX4 = IX3+IDOT - IF (NA .NE. 0) GO TO 110 - CALL PASSF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 111 - 110 CALL PASSF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - 111 NA = 1-NA - GO TO 115 - 112 IF (NA .NE. 0) GO TO 113 - CALL PASSF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) - GO TO 114 - 113 CALL PASSF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) - 114 IF (NAC .NE. 0) NA = 1-NA - 115 L1 = L2 - IW = IW+(IP-1)*IDOT - 116 CONTINUE - IF (NA .EQ. 0) RETURN - N2 = N+N - DO 117 I=1,N2 - C(I) = CH(I) - 117 CONTINUE - RETURN - END diff --git a/src/cfftf1.f90 b/src/cfftf1.f90 new file mode 100644 index 0000000..b061876 --- /dev/null +++ b/src/cfftf1.f90 @@ -0,0 +1,72 @@ +!*==CFFTF1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE CFFTF1(N,C,Ch,Wa,Ifac) + USE FFTPACK_KIND + IMPLICIT NONE +!*--CFFTF177 +!*** Start of declarations inserted by SPAG + REAL C , Ch , FFTPACK_KIND , rk , Wa + INTEGER i , idl1 , ido , idot , Ifac , ip , iw , ix2 , ix3 , ix4 ,& + & k1 , l1 , l2 , N , n2 , na , nac , nf +!*** End of declarations inserted by SPAG + DIMENSION Ch(*) , C(*) , Wa(*) , Ifac(*) + nf = Ifac(2) + na = 0 + l1 = 1 + iw = 1 + DO k1 = 1 , nf + ip = Ifac(k1+2) + l2 = ip*l1 + ido = N/l2 + idot = ido + ido + idl1 = idot*l1 + IF ( ip==4 ) THEN + ix2 = iw + idot + ix3 = ix2 + idot + IF ( na/=0 ) THEN + CALL PASSF4(idot,l1,Ch,C,Wa(iw),Wa(ix2),Wa(ix3)) + ELSE + CALL PASSF4(idot,l1,C,Ch,Wa(iw),Wa(ix2),Wa(ix3)) + ENDIF + na = 1 - na + ELSEIF ( ip==2 ) THEN + IF ( na/=0 ) THEN + CALL PASSF2(idot,l1,Ch,C,Wa(iw)) + ELSE + CALL PASSF2(idot,l1,C,Ch,Wa(iw)) + ENDIF + na = 1 - na + ELSEIF ( ip==3 ) THEN + ix2 = iw + idot + IF ( na/=0 ) THEN + CALL PASSF3(idot,l1,Ch,C,Wa(iw),Wa(ix2)) + ELSE + CALL PASSF3(idot,l1,C,Ch,Wa(iw),Wa(ix2)) + ENDIF + na = 1 - na + ELSEIF ( ip/=5 ) THEN + IF ( na/=0 ) THEN + CALL PASSF(nac,idot,ip,l1,idl1,Ch,Ch,Ch,C,C,Wa(iw)) + ELSE + CALL PASSF(nac,idot,ip,l1,idl1,C,C,C,Ch,Ch,Wa(iw)) + ENDIF + IF ( nac/=0 ) na = 1 - na + ELSE + ix2 = iw + idot + ix3 = ix2 + idot + ix4 = ix3 + idot + IF ( na/=0 ) THEN + CALL PASSF5(idot,l1,Ch,C,Wa(iw),Wa(ix2),Wa(ix3),Wa(ix4)) + ELSE + CALL PASSF5(idot,l1,C,Ch,Wa(iw),Wa(ix2),Wa(ix3),Wa(ix4)) + ENDIF + na = 1 - na + ENDIF + l1 = l2 + iw = iw + (ip-1)*idot + ENDDO + IF ( na==0 ) RETURN + n2 = N + N + DO i = 1 , n2 + C(i) = Ch(i) + ENDDO + END subroutine cfftf1 \ No newline at end of file diff --git a/src/cffti1.f b/src/cffti1.f deleted file mode 100644 index f962cd3..0000000 --- a/src/cffti1.f +++ /dev/null @@ -1,62 +0,0 @@ - SUBROUTINE CFFTI1 (N,WA,IFAC) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION WA(*) ,IFAC(*) ,NTRYH(4) - DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/ - NL = N - NF = 0 - J = 0 - 101 J = J+1 - IF (J-4) 102,102,103 - 102 NTRY = NTRYH(J) - GO TO 104 - 103 NTRY = NTRY+2 - 104 NQ = NL/NTRY - NR = NL-NTRY*NQ - IF (NR) 101,105,101 - 105 NF = NF+1 - IFAC(NF+2) = NTRY - NL = NQ - IF (NTRY .NE. 2) GO TO 107 - IF (NF .EQ. 1) GO TO 107 - DO 106 I=2,NF - IB = NF-I+2 - IFAC(IB+2) = IFAC(IB+1) - 106 CONTINUE - IFAC(3) = 2 - 107 IF (NL .NE. 1) GO TO 104 - IFAC(1) = N - IFAC(2) = NF - TPI = 6.28318530717958647692D0 - ARGH = TPI/REAL(N,RK) - I = 2 - L1 = 1 - DO 110 K1=1,NF - IP = IFAC(K1+2) - LD = 0 - L2 = L1*IP - IDO = N/L2 - IDOT = IDO+IDO+2 - IPM = IP-1 - DO 109 J=1,IPM - I1 = I - WA(I-1) = 1.0D0 - WA(I) = 0.0D0 - LD = LD+L1 - FI = 0.0D0 - ARGLD = REAL(LD,RK)*ARGH - DO 108 II=4,IDOT,2 - I = I+2 - FI = FI+1.D0 - ARG = FI*ARGLD - WA(I-1) = COS(ARG) - WA(I) = SIN(ARG) - 108 CONTINUE - IF (IP .LE. 5) GO TO 109 - WA(I1-1) = WA(I-1) - WA(I1) = WA(I) - 109 CONTINUE - L1 = L2 - 110 CONTINUE - RETURN - END diff --git a/src/cffti1.f90 b/src/cffti1.f90 new file mode 100644 index 0000000..9634494 --- /dev/null +++ b/src/cffti1.f90 @@ -0,0 +1,73 @@ +!*==CFFTI1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE CFFTI1(N,Wa,Ifac) + USE FFTPACK_KIND + IMPLICIT NONE +!*--CFFTI1149 +!*** Start of declarations inserted by SPAG + REAL arg , argh , argld , FFTPACK_KIND , fi , rk , tpi , Wa + INTEGER i , i1 , ib , ido , idot , Ifac , ii , ip , ipm , j , k1 ,& + & l1 , l2 , ld , N , nf , nl , nq , nr , ntry + INTEGER ntryh +!*** End of declarations inserted by SPAG + DIMENSION Wa(*) , Ifac(*) , ntryh(4) + DATA ntryh(1) , ntryh(2) , ntryh(3) , ntryh(4)/3 , 4 , 2 , 5/ + nl = N + nf = 0 + j = 0 + 100 j = j + 1 + IF ( j<=4 ) THEN + ntry = ntryh(j) + ELSE + ntry = ntry + 2 + ENDIF + 200 nq = nl/ntry + nr = nl - ntry*nq + IF ( nr/=0 ) GOTO 100 + nf = nf + 1 + Ifac(nf+2) = ntry + nl = nq + IF ( ntry==2 ) THEN + IF ( nf/=1 ) THEN + DO i = 2 , nf + ib = nf - i + 2 + Ifac(ib+2) = Ifac(ib+1) + ENDDO + Ifac(3) = 2 + ENDIF + ENDIF + IF ( nl/=1 ) GOTO 200 + Ifac(1) = N + Ifac(2) = nf + tpi = 6.28318530717958647692D0 + argh = tpi/REAL(N,rk) + i = 2 + l1 = 1 + DO k1 = 1 , nf + ip = Ifac(k1+2) + ld = 0 + l2 = l1*ip + ido = N/l2 + idot = ido + ido + 2 + ipm = ip - 1 + DO j = 1 , ipm + i1 = i + Wa(i-1) = 1.0D0 + Wa(i) = 0.0D0 + ld = ld + l1 + fi = 0.0D0 + argld = REAL(ld,rk)*argh + DO ii = 4 , idot , 2 + i = i + 2 + fi = fi + 1.D0 + arg = fi*argld + Wa(i-1) = COS(arg) + Wa(i) = SIN(arg) + ENDDO + IF ( ip>5 ) THEN + Wa(i1-1) = Wa(i-1) + Wa(i1) = Wa(i) + ENDIF + ENDDO + l1 = l2 + ENDDO + END subroutine cffti1 \ No newline at end of file diff --git a/src/cosqb1.f b/src/cosqb1.f deleted file mode 100644 index 1515d9e..0000000 --- a/src/cosqb1.f +++ /dev/null @@ -1,29 +0,0 @@ - SUBROUTINE COSQB1 (N,X,W,XH) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION X(1) ,W(1) ,XH(1) - NS2 = (N+1)/2 - NP2 = N+2 - DO 101 I=3,N,2 - XIM1 = X(I-1)+X(I) - X(I) = X(I)-X(I-1) - X(I-1) = XIM1 - 101 CONTINUE - X(1) = X(1)+X(1) - MODN = MOD(N,2) - IF (MODN .EQ. 0) X(N) = X(N)+X(N) - CALL DFFTB (N,X,XH) - DO 102 K=2,NS2 - KC = NP2-K - XH(K) = W(K-1)*X(KC)+W(KC-1)*X(K) - XH(KC) = W(K-1)*X(K)-W(KC-1)*X(KC) - 102 CONTINUE - IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*(X(NS2+1)+X(NS2+1)) - DO 103 K=2,NS2 - KC = NP2-K - X(K) = XH(K)+XH(KC) - X(KC) = XH(K)-XH(KC) - 103 CONTINUE - X(1) = X(1)+X(1) - RETURN - END diff --git a/src/cosqb1.f90 b/src/cosqb1.f90 new file mode 100644 index 0000000..7cbf365 --- /dev/null +++ b/src/cosqb1.f90 @@ -0,0 +1,34 @@ +!*==COSQB1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE COSQB1(N,X,W,Xh) + USE FFTPACK_KIND + IMPLICIT NONE +!*--COSQB1222 +!*** Start of declarations inserted by SPAG + REAL FFTPACK_KIND , rk , W , X , Xh , xim1 + INTEGER i , k , kc , modn , N , np2 , ns2 +!*** End of declarations inserted by SPAG + DIMENSION X(1) , W(1) , Xh(1) + ns2 = (N+1)/2 + np2 = N + 2 + DO i = 3 , N , 2 + xim1 = X(i-1) + X(i) + X(i) = X(i) - X(i-1) + X(i-1) = xim1 + ENDDO + X(1) = X(1) + X(1) + modn = MOD(N,2) + IF ( modn==0 ) X(N) = X(N) + X(N) + CALL DFFTB(N,X,Xh) + DO k = 2 , ns2 + kc = np2 - k + Xh(k) = W(k-1)*X(kc) + W(kc-1)*X(k) + Xh(kc) = W(k-1)*X(k) - W(kc-1)*X(kc) + ENDDO + IF ( modn==0 ) X(ns2+1) = W(ns2)*(X(ns2+1)+X(ns2+1)) + DO k = 2 , ns2 + kc = np2 - k + X(k) = Xh(k) + Xh(kc) + X(kc) = Xh(k) - Xh(kc) + ENDDO + X(1) = X(1) + X(1) + END subroutine cosqb1 \ No newline at end of file diff --git a/src/cosqf1.f b/src/cosqf1.f deleted file mode 100644 index 409cb95..0000000 --- a/src/cosqf1.f +++ /dev/null @@ -1,27 +0,0 @@ - SUBROUTINE COSQF1 (N,X,W,XH) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION X(1) ,W(1) ,XH(1) - NS2 = (N+1)/2 - NP2 = N+2 - DO 101 K=2,NS2 - KC = NP2-K - XH(K) = X(K)+X(KC) - XH(KC) = X(K)-X(KC) - 101 CONTINUE - MODN = MOD(N,2) - IF (MODN .EQ. 0) XH(NS2+1) = X(NS2+1)+X(NS2+1) - DO 102 K=2,NS2 - KC = NP2-K - X(K) = W(K-1)*XH(KC)+W(KC-1)*XH(K) - X(KC) = W(K-1)*XH(K)-W(KC-1)*XH(KC) - 102 CONTINUE - IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*XH(NS2+1) - CALL DFFTF (N,X,XH) - DO 103 I=3,N,2 - XIM1 = X(I-1)-X(I) - X(I) = X(I-1)+X(I) - X(I-1) = XIM1 - 103 CONTINUE - RETURN - END diff --git a/src/cosqf1.f90 b/src/cosqf1.f90 new file mode 100644 index 0000000..72bacc2 --- /dev/null +++ b/src/cosqf1.f90 @@ -0,0 +1,32 @@ +!*==COSQF1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE COSQF1(N,X,W,Xh) + USE FFTPACK_KIND + IMPLICIT NONE +!*--COSQF1256 +!*** Start of declarations inserted by SPAG + REAL FFTPACK_KIND , rk , W , X , Xh , xim1 + INTEGER i , k , kc , modn , N , np2 , ns2 +!*** End of declarations inserted by SPAG + DIMENSION X(1) , W(1) , Xh(1) + ns2 = (N+1)/2 + np2 = N + 2 + DO k = 2 , ns2 + kc = np2 - k + Xh(k) = X(k) + X(kc) + Xh(kc) = X(k) - X(kc) + ENDDO + modn = MOD(N,2) + IF ( modn==0 ) Xh(ns2+1) = X(ns2+1) + X(ns2+1) + DO k = 2 , ns2 + kc = np2 - k + X(k) = W(k-1)*Xh(kc) + W(kc-1)*Xh(k) + X(kc) = W(k-1)*Xh(k) - W(kc-1)*Xh(kc) + ENDDO + IF ( modn==0 ) X(ns2+1) = W(ns2)*Xh(ns2+1) + CALL DFFTF(N,X,Xh) + DO i = 3 , N , 2 + xim1 = X(i-1) - X(i) + X(i) = X(i-1) + X(i) + X(i-1) = xim1 + ENDDO + END subroutine cosqf1 \ No newline at end of file diff --git a/src/dcosqb.f b/src/dcosqb.f deleted file mode 100644 index e054c6c..0000000 --- a/src/dcosqb.f +++ /dev/null @@ -1,15 +0,0 @@ - SUBROUTINE DCOSQB (N,X,WSAVE) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION X(*) ,WSAVE(*) - DATA TSQRT2 /2.82842712474619009760D0/ - IF (N-2) 101,102,103 - 101 X(1) = 4.0D0*X(1) - RETURN - 102 X1 = 4.0D0*(X(1)+X(2)) - X(2) = TSQRT2*(X(1)-X(2)) - X(1) = X1 - RETURN - 103 CALL COSQB1 (N,X,WSAVE,WSAVE(N+1)) - RETURN - END diff --git a/src/dcosqb.f90 b/src/dcosqb.f90 new file mode 100644 index 0000000..d1e9670 --- /dev/null +++ b/src/dcosqb.f90 @@ -0,0 +1,23 @@ +!*==DCOSQB.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE DCOSQB(N,X,Wsave) + USE FFTPACK_KIND + IMPLICIT NONE +!*--DCOSQB288 +!*** Start of declarations inserted by SPAG + REAL FFTPACK_KIND , rk , tsqrt2 , Wsave , X , x1 + INTEGER N +!*** End of declarations inserted by SPAG + DIMENSION X(*) , Wsave(*) + DATA tsqrt2/2.82842712474619009760D0/ + IF ( N<2 ) THEN + X(1) = 4.0D0*X(1) + RETURN + ELSEIF ( N==2 ) THEN + x1 = 4.0D0*(X(1)+X(2)) + X(2) = tsqrt2*(X(1)-X(2)) + X(1) = x1 + RETURN + ELSE + CALL COSQB1(N,X,Wsave,Wsave(N+1)) + ENDIF + END subroutine dcosqb \ No newline at end of file diff --git a/src/dcosqf.f b/src/dcosqf.f deleted file mode 100644 index 911657e..0000000 --- a/src/dcosqf.f +++ /dev/null @@ -1,13 +0,0 @@ - SUBROUTINE DCOSQF (N,X,WSAVE) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION X(*) ,WSAVE(*) - DATA SQRT2 /1.41421356237309504880D0/ - IF (N-2) 102,101,103 - 101 TSQX = SQRT2*X(2) - X(2) = X(1)-TSQX - X(1) = X(1)+TSQX - 102 RETURN - 103 CALL COSQF1 (N,X,WSAVE,WSAVE(N+1)) - RETURN - END diff --git a/src/dcosqf.f90 b/src/dcosqf.f90 new file mode 100644 index 0000000..1ee5fb9 --- /dev/null +++ b/src/dcosqf.f90 @@ -0,0 +1,22 @@ +!*==DCOSQF.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE DCOSQF(N,X,Wsave) + USE FFTPACK_KIND + IMPLICIT NONE +!*--DCOSQF311 +!*** Start of declarations inserted by SPAG + REAL FFTPACK_KIND , rk , sqrt2 , tsqx , Wsave , X + INTEGER N +!*** End of declarations inserted by SPAG + DIMENSION X(*) , Wsave(*) + DATA sqrt2/1.41421356237309504880D0/ + IF ( N<2 ) THEN + ELSEIF ( N==2 ) THEN + tsqx = sqrt2*X(2) + X(2) = X(1) - tsqx + X(1) = X(1) + tsqx + ELSE + CALL COSQF1(N,X,Wsave,Wsave(N+1)) + GOTO 99999 + ENDIF + RETURN +99999 END subroutine dcosqf \ No newline at end of file diff --git a/src/dcosqi.f b/src/dcosqi.f deleted file mode 100644 index b4cc80d..0000000 --- a/src/dcosqi.f +++ /dev/null @@ -1,14 +0,0 @@ - SUBROUTINE DCOSQI (N,WSAVE) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION WSAVE(1) - DATA PIH /1.57079632679489661923D0/ - DT = PIH/REAL(N,RK) - FK = 0.0D0 - DO 101 K=1,N - FK = FK+1.0D0 - WSAVE(K) = COS(FK*DT) - 101 CONTINUE - CALL DFFTI (N,WSAVE(N+1)) - RETURN - END diff --git a/src/dcosqi.f90 b/src/dcosqi.f90 new file mode 100644 index 0000000..42b77c5 --- /dev/null +++ b/src/dcosqi.f90 @@ -0,0 +1,19 @@ +!*==DCOSQI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE DCOSQI(N,Wsave) + USE FFTPACK_KIND + IMPLICIT NONE +!*--DCOSQI333 +!*** Start of declarations inserted by SPAG + REAL dt , FFTPACK_KIND , fk , pih , rk , Wsave + INTEGER k , N +!*** End of declarations inserted by SPAG + DIMENSION Wsave(1) + DATA pih/1.57079632679489661923D0/ + dt = pih/REAL(N,rk) + fk = 0.0D0 + DO k = 1 , N + fk = fk + 1.0D0 + Wsave(k) = COS(fk*dt) + ENDDO + CALL DFFTI(N,Wsave(N+1)) + END subroutine dcosqi \ No newline at end of file diff --git a/src/dcost.f b/src/dcost.f deleted file mode 100644 index 77544ab..0000000 --- a/src/dcost.f +++ /dev/null @@ -1,44 +0,0 @@ - SUBROUTINE DCOST (N,X,WSAVE) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION X(*) ,WSAVE(*) - NM1 = N-1 - NP1 = N+1 - NS2 = N/2 - IF (N-2) 106,101,102 - 101 X1H = X(1)+X(2) - X(2) = X(1)-X(2) - X(1) = X1H - RETURN - 102 IF (N .GT. 3) GO TO 103 - X1P3 = X(1)+X(3) - TX2 = X(2)+X(2) - X(2) = X(1)-X(3) - X(1) = X1P3+TX2 - X(3) = X1P3-TX2 - RETURN - 103 C1 = X(1)-X(N) - X(1) = X(1)+X(N) - DO 104 K=2,NS2 - KC = NP1-K - T1 = X(K)+X(KC) - T2 = X(K)-X(KC) - C1 = C1+WSAVE(KC)*T2 - T2 = WSAVE(K)*T2 - X(K) = T1-T2 - X(KC) = T1+T2 - 104 CONTINUE - MODN = MOD(N,2) - IF (MODN .NE. 0) X(NS2+1) = X(NS2+1)+X(NS2+1) - CALL DFFTF (NM1,X,WSAVE(N+1)) - XIM2 = X(2) - X(2) = C1 - DO 105 I=4,N,2 - XI = X(I) - X(I) = X(I-2)-X(I-1) - X(I-1) = XIM2 - XIM2 = XI - 105 CONTINUE - IF (MODN .NE. 0) X(N) = XIM2 - 106 RETURN - END diff --git a/src/dcost.f90 b/src/dcost.f90 new file mode 100644 index 0000000..5d49a88 --- /dev/null +++ b/src/dcost.f90 @@ -0,0 +1,53 @@ +!*==DCOST.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE DCOST(N,X,Wsave) + USE FFTPACK_KIND + IMPLICIT NONE +!*--DCOST352 +!*** Start of declarations inserted by SPAG + REAL c1 , FFTPACK_KIND , rk , t1 , t2 , tx2 , Wsave , X , x1h , & + & x1p3 , xi , xim2 + INTEGER i , k , kc , modn , N , nm1 , np1 , ns2 +!*** End of declarations inserted by SPAG + DIMENSION X(*) , Wsave(*) + nm1 = N - 1 + np1 = N + 1 + ns2 = N/2 + IF ( N<2 ) GOTO 99999 + IF ( N==2 ) THEN + x1h = X(1) + X(2) + X(2) = X(1) - X(2) + X(1) = x1h + RETURN + ELSEIF ( N>3 ) THEN + c1 = X(1) - X(N) + X(1) = X(1) + X(N) + DO k = 2 , ns2 + kc = np1 - k + t1 = X(k) + X(kc) + t2 = X(k) - X(kc) + c1 = c1 + Wsave(kc)*t2 + t2 = Wsave(k)*t2 + X(k) = t1 - t2 + X(kc) = t1 + t2 + ENDDO + modn = MOD(N,2) + IF ( modn/=0 ) X(ns2+1) = X(ns2+1) + X(ns2+1) + CALL DFFTF(nm1,X,Wsave(N+1)) + xim2 = X(2) + X(2) = c1 + DO i = 4 , N , 2 + xi = X(i) + X(i) = X(i-2) - X(i-1) + X(i-1) = xim2 + xim2 = xi + ENDDO + IF ( modn/=0 ) X(N) = xim2 + GOTO 99999 + ENDIF + x1p3 = X(1) + X(3) + tx2 = X(2) + X(2) + X(2) = X(1) - X(3) + X(1) = x1p3 + tx2 + X(3) = x1p3 - tx2 + RETURN +99999 END subroutine dcost \ No newline at end of file diff --git a/src/dcosti.f b/src/dcosti.f deleted file mode 100644 index 1a28918..0000000 --- a/src/dcosti.f +++ /dev/null @@ -1,20 +0,0 @@ - SUBROUTINE DCOSTI (N,WSAVE) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION WSAVE(1) - DATA PI /3.14159265358979323846D0/ - IF (N .LE. 3) RETURN - NM1 = N-1 - NP1 = N+1 - NS2 = N/2 - DT = PI/REAL(NM1,RK) - FK = 0.0D0 - DO 101 K=2,NS2 - KC = NP1-K - FK = FK+1.0D0 - WSAVE(K) = 2.0D0*SIN(FK*DT) - WSAVE(KC) = 2.0D0*COS(FK*DT) - 101 CONTINUE - CALL DFFTI (NM1,WSAVE(N+1)) - RETURN - END diff --git a/src/dcosti.f90 b/src/dcosti.f90 new file mode 100644 index 0000000..34fac58 --- /dev/null +++ b/src/dcosti.f90 @@ -0,0 +1,25 @@ +!*==DCOSTI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE DCOSTI(N,Wsave) + USE FFTPACK_KIND + IMPLICIT NONE +!*--DCOSTI405 +!*** Start of declarations inserted by SPAG + REAL dt , FFTPACK_KIND , fk , pi , rk , Wsave + INTEGER k , kc , N , nm1 , np1 , ns2 +!*** End of declarations inserted by SPAG + DIMENSION Wsave(1) + DATA pi/3.14159265358979323846D0/ + IF ( N<=3 ) RETURN + nm1 = N - 1 + np1 = N + 1 + ns2 = N/2 + dt = pi/REAL(nm1,rk) + fk = 0.0D0 + DO k = 2 , ns2 + kc = np1 - k + fk = fk + 1.0D0 + Wsave(k) = 2.0D0*SIN(fk*dt) + Wsave(kc) = 2.0D0*COS(fk*dt) + ENDDO + CALL DFFTI(nm1,Wsave(N+1)) + END subroutine dcosti \ No newline at end of file diff --git a/src/dfftb.f b/src/dfftb.f deleted file mode 100644 index dabef1a..0000000 --- a/src/dfftb.f +++ /dev/null @@ -1,8 +0,0 @@ - SUBROUTINE DFFTB (N,R,WSAVE) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION R(1) ,WSAVE(1) - IF (N .EQ. 1) RETURN - CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END diff --git a/src/dfftb.f90 b/src/dfftb.f90 new file mode 100644 index 0000000..5c1933a --- /dev/null +++ b/src/dfftb.f90 @@ -0,0 +1,13 @@ +!*==DFFTB.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE DFFTB(N,R,Wsave) + USE FFTPACK_KIND + IMPLICIT NONE +!*--DFFTB430 +!*** Start of declarations inserted by SPAG + REAL FFTPACK_KIND , R , rk , Wsave + INTEGER N +!*** End of declarations inserted by SPAG + DIMENSION R(1) , Wsave(1) + IF ( N==1 ) RETURN + CALL RFFTB1(N,R,Wsave,Wsave(N+1),Wsave(2*N+1)) + END subroutine dfftb \ No newline at end of file diff --git a/src/dfftf.f b/src/dfftf.f deleted file mode 100644 index 49dae32..0000000 --- a/src/dfftf.f +++ /dev/null @@ -1,8 +0,0 @@ - SUBROUTINE DFFTF (N,R,WSAVE) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION R(1) ,WSAVE(1) - IF (N .EQ. 1) RETURN - CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END diff --git a/src/dfftf.f90 b/src/dfftf.f90 new file mode 100644 index 0000000..269bbce --- /dev/null +++ b/src/dfftf.f90 @@ -0,0 +1,13 @@ +!*==DFFTF.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE DFFTF(N,R,Wsave) + USE FFTPACK_KIND + IMPLICIT NONE +!*--DFFTF443 +!*** Start of declarations inserted by SPAG + REAL FFTPACK_KIND , R , rk , Wsave + INTEGER N +!*** End of declarations inserted by SPAG + DIMENSION R(1) , Wsave(1) + IF ( N==1 ) RETURN + CALL RFFTF1(N,R,Wsave,Wsave(N+1),Wsave(2*N+1)) + END subroutine dfftf \ No newline at end of file diff --git a/src/dffti.f b/src/dffti.f deleted file mode 100644 index 1166966..0000000 --- a/src/dffti.f +++ /dev/null @@ -1,8 +0,0 @@ - SUBROUTINE DFFTI (N,WSAVE) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION WSAVE(1) - IF (N .EQ. 1) RETURN - CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END diff --git a/src/dffti.f90 b/src/dffti.f90 new file mode 100644 index 0000000..80c18b5 --- /dev/null +++ b/src/dffti.f90 @@ -0,0 +1,13 @@ +!*==DFFTI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE DFFTI(N,Wsave) + USE FFTPACK_KIND + IMPLICIT NONE +!*--DFFTI456 +!*** Start of declarations inserted by SPAG + REAL FFTPACK_KIND , rk , Wsave + INTEGER N +!*** End of declarations inserted by SPAG + DIMENSION Wsave(1) + IF ( N==1 ) RETURN + CALL RFFTI1(N,Wsave(N+1),Wsave(2*N+1)) + END subroutine dffti \ No newline at end of file diff --git a/src/dsinqb.f b/src/dsinqb.f deleted file mode 100644 index ae11841..0000000 --- a/src/dsinqb.f +++ /dev/null @@ -1,20 +0,0 @@ - SUBROUTINE DSINQB (N,X,WSAVE) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION X(1) ,WSAVE(1) - IF (N .GT. 1) GO TO 101 - X(1) = 4.0D0*X(1) - RETURN - 101 NS2 = N/2 - DO 102 K=2,N,2 - X(K) = -X(K) - 102 CONTINUE - CALL DCOSQB (N,X,WSAVE) - DO 103 K=1,NS2 - KC = N-K - XHOLD = X(K) - X(K) = X(KC+1) - X(KC+1) = XHOLD - 103 CONTINUE - RETURN - END diff --git a/src/dsinqb.f90 b/src/dsinqb.f90 new file mode 100644 index 0000000..1d60626 --- /dev/null +++ b/src/dsinqb.f90 @@ -0,0 +1,27 @@ +!*==DSINQB.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE DSINQB(N,X,Wsave) + USE FFTPACK_KIND + IMPLICIT NONE +!*--DSINQB469 +!*** Start of declarations inserted by SPAG + REAL FFTPACK_KIND , rk , Wsave , X , xhold + INTEGER k , kc , N , ns2 +!*** End of declarations inserted by SPAG + DIMENSION X(1) , Wsave(1) + IF ( N>1 ) THEN + ns2 = N/2 + DO k = 2 , N , 2 + X(k) = -X(k) + ENDDO + CALL DCOSQB(N,X,Wsave) + DO k = 1 , ns2 + kc = N - k + xhold = X(k) + X(k) = X(kc+1) + X(kc+1) = xhold + ENDDO + GOTO 99999 + ENDIF + X(1) = 4.0D0*X(1) + RETURN +99999 END subroutine dsinqb \ No newline at end of file diff --git a/src/dsinqf.f b/src/dsinqf.f deleted file mode 100644 index 7ff4de7..0000000 --- a/src/dsinqf.f +++ /dev/null @@ -1,18 +0,0 @@ - SUBROUTINE DSINQF (N,X,WSAVE) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION X(1) ,WSAVE(1) - IF (N .EQ. 1) RETURN - NS2 = N/2 - DO 101 K=1,NS2 - KC = N-K - XHOLD = X(K) - X(K) = X(KC+1) - X(KC+1) = XHOLD - 101 CONTINUE - CALL DCOSQF (N,X,WSAVE) - DO 102 K=2,N,2 - X(K) = -X(K) - 102 CONTINUE - RETURN - END diff --git a/src/dsinqf.f90 b/src/dsinqf.f90 new file mode 100644 index 0000000..328f2ea --- /dev/null +++ b/src/dsinqf.f90 @@ -0,0 +1,23 @@ +!*==DSINQF.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE DSINQF(N,X,Wsave) + USE FFTPACK_KIND + IMPLICIT NONE +!*--DSINQF496 +!*** Start of declarations inserted by SPAG + REAL FFTPACK_KIND , rk , Wsave , X , xhold + INTEGER k , kc , N , ns2 +!*** End of declarations inserted by SPAG + DIMENSION X(1) , Wsave(1) + IF ( N==1 ) RETURN + ns2 = N/2 + DO k = 1 , ns2 + kc = N - k + xhold = X(k) + X(k) = X(kc+1) + X(kc+1) = xhold + ENDDO + CALL DCOSQF(N,X,Wsave) + DO k = 2 , N , 2 + X(k) = -X(k) + ENDDO + END subroutine dsinqf \ No newline at end of file diff --git a/src/dsinqi.f b/src/dsinqi.f deleted file mode 100644 index 0aa3beb..0000000 --- a/src/dsinqi.f +++ /dev/null @@ -1,7 +0,0 @@ - SUBROUTINE DSINQI (N,WSAVE) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION WSAVE(1) - CALL DCOSQI (N,WSAVE) - RETURN - END diff --git a/src/dsinqi.f90 b/src/dsinqi.f90 new file mode 100644 index 0000000..4b7d1a6 --- /dev/null +++ b/src/dsinqi.f90 @@ -0,0 +1,12 @@ +!*==DSINQI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE DSINQI(N,Wsave) + USE FFTPACK_KIND + IMPLICIT NONE +!*--DSINQI519 +!*** Start of declarations inserted by SPAG + REAL FFTPACK_KIND , rk , Wsave + INTEGER N +!*** End of declarations inserted by SPAG + DIMENSION Wsave(1) + CALL DCOSQI(N,Wsave) + END subroutine dsinqi \ No newline at end of file diff --git a/src/dsint.f b/src/dsint.f deleted file mode 100644 index 12313f1..0000000 --- a/src/dsint.f +++ /dev/null @@ -1,11 +0,0 @@ - SUBROUTINE DSINT (N,X,WSAVE) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION X(1) ,WSAVE(1) - NP1 = N+1 - IW1 = N/2+1 - IW2 = IW1+NP1 - IW3 = IW2+NP1 - CALL SINT1(N,X,WSAVE,WSAVE(IW1),WSAVE(IW2),WSAVE(IW3)) - RETURN - END diff --git a/src/dsint.f90 b/src/dsint.f90 new file mode 100644 index 0000000..6b02299 --- /dev/null +++ b/src/dsint.f90 @@ -0,0 +1,16 @@ +!*==DSINT.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE DSINT(N,X,Wsave) + USE FFTPACK_KIND + IMPLICIT NONE +!*--DSINT531 +!*** Start of declarations inserted by SPAG + REAL FFTPACK_KIND , rk , Wsave , X + INTEGER iw1 , iw2 , iw3 , N , np1 +!*** End of declarations inserted by SPAG + DIMENSION X(1) , Wsave(1) + np1 = N + 1 + iw1 = N/2 + 1 + iw2 = iw1 + np1 + iw3 = iw2 + np1 + CALL SINT1(N,X,Wsave,Wsave(iw1),Wsave(iw2),Wsave(iw3)) + END subroutine dsint \ No newline at end of file diff --git a/src/dsinti.f b/src/dsinti.f deleted file mode 100644 index aaae25b..0000000 --- a/src/dsinti.f +++ /dev/null @@ -1,15 +0,0 @@ - SUBROUTINE DSINTI (N,WSAVE) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION WSAVE(1) - DATA PI /3.14159265358979323846D0/ - IF (N .LE. 1) RETURN - NS2 = N/2 - NP1 = N+1 - DT = PI/REAL(NP1,RK) - DO 101 K=1,NS2 - WSAVE(K) = 2.0D0*SIN(K*DT) - 101 CONTINUE - CALL DFFTI (NP1,WSAVE(NS2+1)) - RETURN - END diff --git a/src/dsinti.f90 b/src/dsinti.f90 new file mode 100644 index 0000000..fbb7878 --- /dev/null +++ b/src/dsinti.f90 @@ -0,0 +1,20 @@ +!*==DSINTI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE DSINTI(N,Wsave) + USE FFTPACK_KIND + IMPLICIT NONE +!*--DSINTI547 +!*** Start of declarations inserted by SPAG + REAL dt , FFTPACK_KIND , pi , rk , Wsave + INTEGER k , N , np1 , ns2 +!*** End of declarations inserted by SPAG + DIMENSION Wsave(1) + DATA pi/3.14159265358979323846D0/ + IF ( N<=1 ) RETURN + ns2 = N/2 + np1 = N + 1 + dt = pi/REAL(np1,rk) + DO k = 1 , ns2 + Wsave(k) = 2.0D0*SIN(k*dt) + ENDDO + CALL DFFTI(np1,Wsave(ns2+1)) + END subroutine dsinti \ No newline at end of file diff --git a/src/dzfftb.f b/src/dzfftb.f deleted file mode 100644 index 045f59b..0000000 --- a/src/dzfftb.f +++ /dev/null @@ -1,20 +0,0 @@ - SUBROUTINE DZFFTB (N,R,AZERO,A,B,WSAVE) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION R(*) ,A(*) ,B(*) ,WSAVE(*) - IF (N-2) 101,102,103 - 101 R(1) = AZERO - RETURN - 102 R(1) = AZERO+A(1) - R(2) = AZERO-A(1) - RETURN - 103 NS2 = (N-1)/2 - DO 104 I=1,NS2 - R(2*I) = 0.5D0*A(I) - R(2*I+1) = -0.5D0*B(I) - 104 CONTINUE - R(1) = AZERO - IF (MOD(N,2) .EQ. 0) R(N) = A(NS2+1) - CALL DFFTB (N,R,WSAVE(N+1)) - RETURN - END diff --git a/src/dzfftb.f90 b/src/dzfftb.f90 new file mode 100644 index 0000000..b8e5dc4 --- /dev/null +++ b/src/dzfftb.f90 @@ -0,0 +1,28 @@ +!*==DZFFTB.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE DZFFTB(N,R,Azero,A,B,Wsave) + USE FFTPACK_KIND + IMPLICIT NONE +!*--DZFFTB567 +!*** Start of declarations inserted by SPAG + REAL A , Azero , B , FFTPACK_KIND , R , rk , Wsave + INTEGER i , N , ns2 +!*** End of declarations inserted by SPAG + DIMENSION R(*) , A(*) , B(*) , Wsave(*) + IF ( N<2 ) THEN + R(1) = Azero + RETURN + ELSEIF ( N==2 ) THEN + R(1) = Azero + A(1) + R(2) = Azero - A(1) + RETURN + ELSE + ns2 = (N-1)/2 + DO i = 1 , ns2 + R(2*i) = 0.5D0*A(i) + R(2*i+1) = -0.5D0*B(i) + ENDDO + R(1) = Azero + IF ( MOD(N,2)==0 ) R(N) = A(ns2+1) + CALL DFFTB(N,R,Wsave(N+1)) + ENDIF + END subroutine dzfftb \ No newline at end of file diff --git a/src/dzfftf.f b/src/dzfftf.f deleted file mode 100644 index 2781e61..0000000 --- a/src/dzfftf.f +++ /dev/null @@ -1,31 +0,0 @@ - SUBROUTINE DZFFTF (N,R,AZERO,A,B,WSAVE) - USE fftpack_kind -C -C VERSION 3 JUNE 1979 -C - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION R(*) ,A(*) ,B(*) ,WSAVE(*) - IF (N-2) 101,102,103 - 101 AZERO = R(1) - RETURN - 102 AZERO = 0.5D0*(R(1)+R(2)) - A(1) = 0.5D0*(R(1)-R(2)) - RETURN - 103 DO 104 I=1,N - WSAVE(I) = R(I) - 104 CONTINUE - CALL DFFTF (N,WSAVE,WSAVE(N+1)) - CF = 2.0D0/REAL(N,RK) - CFM = -CF - AZERO = 0.5D0*CF*WSAVE(1) - NS2 = (N+1)/2 - NS2M = NS2-1 - DO 105 I=1,NS2M - A(I) = CF*WSAVE(2*I) - B(I) = CFM*WSAVE(2*I+1) - 105 CONTINUE - IF (MOD(N,2) .EQ. 1) RETURN - A(NS2) = 0.5D0*CF*WSAVE(N) - B(NS2) = 0.0D0 - RETURN - END diff --git a/src/dzfftf.f90 b/src/dzfftf.f90 new file mode 100644 index 0000000..eac2c86 --- /dev/null +++ b/src/dzfftf.f90 @@ -0,0 +1,39 @@ +!*==DZFFTF.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE DZFFTF(N,R,Azero,A,B,Wsave) +! +! VERSION 3 JUNE 1979 +! + USE FFTPACK_KIND + IMPLICIT NONE +!*--DZFFTF598 +!*** Start of declarations inserted by SPAG + REAL A , Azero , B , cf , cfm , FFTPACK_KIND , R , rk , Wsave + INTEGER i , N , ns2 , ns2m +!*** End of declarations inserted by SPAG + DIMENSION R(*) , A(*) , B(*) , Wsave(*) + IF ( N<2 ) THEN + Azero = R(1) + RETURN + ELSEIF ( N==2 ) THEN + Azero = 0.5D0*(R(1)+R(2)) + A(1) = 0.5D0*(R(1)-R(2)) + RETURN + ELSE + DO i = 1 , N + Wsave(i) = R(i) + ENDDO + CALL DFFTF(N,Wsave,Wsave(N+1)) + cf = 2.0D0/REAL(N,rk) + cfm = -cf + Azero = 0.5D0*cf*Wsave(1) + ns2 = (N+1)/2 + ns2m = ns2 - 1 + DO i = 1 , ns2m + A(i) = cf*Wsave(2*i) + B(i) = cfm*Wsave(2*i+1) + ENDDO + IF ( MOD(N,2)==1 ) RETURN + A(ns2) = 0.5D0*cf*Wsave(N) + B(ns2) = 0.0D0 + ENDIF + END subroutine dzfftf \ No newline at end of file diff --git a/src/dzffti.f b/src/dzffti.f deleted file mode 100644 index c0a6f69..0000000 --- a/src/dzffti.f +++ /dev/null @@ -1,8 +0,0 @@ - SUBROUTINE DZFFTI (N,WSAVE) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION WSAVE(1) - IF (N .EQ. 1) RETURN - CALL EZFFT1 (N,WSAVE(2*N+1),WSAVE(3*N+1)) - RETURN - END diff --git a/src/dzffti.f90 b/src/dzffti.f90 new file mode 100644 index 0000000..0f934b1 --- /dev/null +++ b/src/dzffti.f90 @@ -0,0 +1,13 @@ +!*==DZFFTI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE DZFFTI(N,Wsave) + USE FFTPACK_KIND + IMPLICIT NONE +!*--DZFFTI634 +!*** Start of declarations inserted by SPAG + REAL FFTPACK_KIND , rk , Wsave + INTEGER N +!*** End of declarations inserted by SPAG + DIMENSION Wsave(1) + IF ( N==1 ) RETURN + CALL EZFFT1(N,Wsave(2*N+1),Wsave(3*N+1)) + END subroutine dzffti \ No newline at end of file diff --git a/src/ezfft1.f b/src/ezfft1.f deleted file mode 100644 index 8c21abe..0000000 --- a/src/ezfft1.f +++ /dev/null @@ -1,64 +0,0 @@ - SUBROUTINE EZFFT1 (N,WA,IFAC) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION WA(*) ,IFAC(*) ,NTRYH(4) - DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ - 1 ,TPI/6.28318530717958647692D0/ - NL = N - NF = 0 - J = 0 - 101 J = J+1 - IF (J-4) 102,102,103 - 102 NTRY = NTRYH(J) - GO TO 104 - 103 NTRY = NTRY+2 - 104 NQ = NL/NTRY - NR = NL-NTRY*NQ - IF (NR) 101,105,101 - 105 NF = NF+1 - IFAC(NF+2) = NTRY - NL = NQ - IF (NTRY .NE. 2) GO TO 107 - IF (NF .EQ. 1) GO TO 107 - DO 106 I=2,NF - IB = NF-I+2 - IFAC(IB+2) = IFAC(IB+1) - 106 CONTINUE - IFAC(3) = 2 - 107 IF (NL .NE. 1) GO TO 104 - IFAC(1) = N - IFAC(2) = NF - ARGH = TPI/REAL(N,RK) - IS = 0 - NFM1 = NF-1 - L1 = 1 - IF (NFM1 .EQ. 0) RETURN - DO 111 K1=1,NFM1 - IP = IFAC(K1+2) - L2 = L1*IP - IDO = N/L2 - IPM = IP-1 - ARG1 = REAL(L1,RK)*ARGH - CH1 = 1.0D0 - SH1 = 0.0D0 - DCH1 = COS(ARG1) - DSH1 = SIN(ARG1) - DO 110 J=1,IPM - CH1H = DCH1*CH1-DSH1*SH1 - SH1 = DCH1*SH1+DSH1*CH1 - CH1 = CH1H - I = IS+2 - WA(I-1) = CH1 - WA(I) = SH1 - IF (IDO .LT. 5) GO TO 109 - DO 108 II=5,IDO,2 - I = I+2 - WA(I-1) = CH1*WA(I-3)-SH1*WA(I-2) - WA(I) = CH1*WA(I-2)+SH1*WA(I-3) - 108 CONTINUE - 109 IS = IS+IDO - 110 CONTINUE - L1 = L2 - 111 CONTINUE - RETURN - END diff --git a/src/ezfft1.f90 b/src/ezfft1.f90 new file mode 100644 index 0000000..853f2ec --- /dev/null +++ b/src/ezfft1.f90 @@ -0,0 +1,75 @@ +!*==EZFFT1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE EZFFT1(N,Wa,Ifac) + USE FFTPACK_KIND + IMPLICIT NONE +!*--EZFFT1647 +!*** Start of declarations inserted by SPAG + REAL arg1 , argh , ch1 , ch1h , dch1 , dsh1 , FFTPACK_KIND , rk , & + & sh1 , tpi , Wa + INTEGER i , ib , ido , Ifac , ii , ip , ipm , is , j , k1 , l1 , & + & l2 , N , nf , nfm1 , nl , nq , nr , ntry , ntryh +!*** End of declarations inserted by SPAG + DIMENSION Wa(*) , Ifac(*) , ntryh(4) + DATA ntryh(1) , ntryh(2) , ntryh(3) , ntryh(4)/4 , 2 , 3 , 5/ , & + & tpi/6.28318530717958647692D0/ + nl = N + nf = 0 + j = 0 + 100 j = j + 1 + IF ( j<=4 ) THEN + ntry = ntryh(j) + ELSE + ntry = ntry + 2 + ENDIF + 200 nq = nl/ntry + nr = nl - ntry*nq + IF ( nr/=0 ) GOTO 100 + nf = nf + 1 + Ifac(nf+2) = ntry + nl = nq + IF ( ntry==2 ) THEN + IF ( nf/=1 ) THEN + DO i = 2 , nf + ib = nf - i + 2 + Ifac(ib+2) = Ifac(ib+1) + ENDDO + Ifac(3) = 2 + ENDIF + ENDIF + IF ( nl/=1 ) GOTO 200 + Ifac(1) = N + Ifac(2) = nf + argh = tpi/REAL(N,rk) + is = 0 + nfm1 = nf - 1 + l1 = 1 + IF ( nfm1==0 ) RETURN + DO k1 = 1 , nfm1 + ip = Ifac(k1+2) + l2 = l1*ip + ido = N/l2 + ipm = ip - 1 + arg1 = REAL(l1,rk)*argh + ch1 = 1.0D0 + sh1 = 0.0D0 + dch1 = COS(arg1) + dsh1 = SIN(arg1) + DO j = 1 , ipm + ch1h = dch1*ch1 - dsh1*sh1 + sh1 = dch1*sh1 + dsh1*ch1 + ch1 = ch1h + i = is + 2 + Wa(i-1) = ch1 + Wa(i) = sh1 + IF ( ido>=5 ) THEN + DO ii = 5 , ido , 2 + i = i + 2 + Wa(i-1) = ch1*Wa(i-3) - sh1*Wa(i-2) + Wa(i) = ch1*Wa(i-2) + sh1*Wa(i-3) + ENDDO + ENDIF + is = is + ido + ENDDO + l1 = l2 + ENDDO + END subroutine ezfft1 \ No newline at end of file diff --git a/src/passb.f b/src/passb.f deleted file mode 100644 index f347d5c..0000000 --- a/src/passb.f +++ /dev/null @@ -1,118 +0,0 @@ - SUBROUTINE PASSB (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , - 1 C1(IDO,L1,IP) ,WA(1) ,C2(IDL1,IP), - 2 CH2(IDL1,IP) - IDOT = IDO/2 - NT = IP*IDL1 - IPP2 = IP+2 - IPPH = (IP+1)/2 - IDP = IP*IDO -C - IF (IDO .LT. L1) GO TO 106 - DO 103 J=2,IPPH - JC = IPP2-J - DO 102 K=1,L1 - DO 101 I=1,IDO - CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) - CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) - 101 CONTINUE - 102 CONTINUE - 103 CONTINUE - DO 105 K=1,L1 - DO 104 I=1,IDO - CH(I,K,1) = CC(I,1,K) - 104 CONTINUE - 105 CONTINUE - GO TO 112 - 106 DO 109 J=2,IPPH - JC = IPP2-J - DO 108 I=1,IDO - DO 107 K=1,L1 - CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) - CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) - 107 CONTINUE - 108 CONTINUE - 109 CONTINUE - DO 111 I=1,IDO - DO 110 K=1,L1 - CH(I,K,1) = CC(I,1,K) - 110 CONTINUE - 111 CONTINUE - 112 IDL = 2-IDO - INC = 0 - DO 116 L=2,IPPH - LC = IPP2-L - IDL = IDL+IDO - DO 113 IK=1,IDL1 - C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) - C2(IK,LC) = WA(IDL)*CH2(IK,IP) - 113 CONTINUE - IDLJ = IDL - INC = INC+IDO - DO 115 J=3,IPPH - JC = IPP2-J - IDLJ = IDLJ+INC - IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP - WAR = WA(IDLJ-1) - WAI = WA(IDLJ) - DO 114 IK=1,IDL1 - C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) - C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC) - 114 CONTINUE - 115 CONTINUE - 116 CONTINUE - DO 118 J=2,IPPH - DO 117 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+CH2(IK,J) - 117 CONTINUE - 118 CONTINUE - DO 120 J=2,IPPH - JC = IPP2-J - DO 119 IK=2,IDL1,2 - CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) - CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) - CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) - CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) - 119 CONTINUE - 120 CONTINUE - NAC = 1 - IF (IDO .EQ. 2) RETURN - NAC = 0 - DO 121 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 121 CONTINUE - DO 123 J=2,IP - DO 122 K=1,L1 - C1(1,K,J) = CH(1,K,J) - C1(2,K,J) = CH(2,K,J) - 122 CONTINUE - 123 CONTINUE - IF (IDOT .GT. L1) GO TO 127 - IDIJ = 0 - DO 126 J=2,IP - IDIJ = IDIJ+2 - DO 125 I=4,IDO,2 - IDIJ = IDIJ+2 - DO 124 K=1,L1 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 124 CONTINUE - 125 CONTINUE - 126 CONTINUE - RETURN - 127 IDJ = 2-IDO - DO 130 J=2,IP - IDJ = IDJ+IDO - DO 129 K=1,L1 - IDIJ = IDJ - DO 128 I=4,IDO,2 - IDIJ = IDIJ+2 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 128 CONTINUE - 129 CONTINUE - 130 CONTINUE - RETURN - END diff --git a/src/passb.f90 b/src/passb.f90 new file mode 100644 index 0000000..a7f005d --- /dev/null +++ b/src/passb.f90 @@ -0,0 +1,129 @@ +!*==PASSB.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE PASSB(Nac,Ido,Ip,L1,Idl1,Cc,C1,C2,Ch,Ch2,Wa) + USE FFTPACK_KIND + IMPLICIT NONE +!*--PASSB722 +!*** Start of declarations inserted by SPAG + REAL C1 , C2 , Cc , Ch , Ch2 , FFTPACK_KIND , rk , Wa , wai , war + INTEGER i , idij , idj , idl , Idl1 , idlj , Ido , idot , idp , & + & ik , inc , Ip , ipp2 , ipph , j , jc , k , l , L1 , lc + INTEGER Nac , nt +!*** End of declarations inserted by SPAG + DIMENSION Ch(Ido,L1,Ip) , Cc(Ido,Ip,L1) , C1(Ido,L1,Ip) , Wa(1) , & + & C2(Idl1,Ip) , Ch2(Idl1,Ip) + idot = Ido/2 + nt = Ip*Idl1 + ipp2 = Ip + 2 + ipph = (Ip+1)/2 + idp = Ip*Ido +! + IF ( Idoidp ) idlj = idlj - idp + war = Wa(idlj-1) + wai = Wa(idlj) + DO ik = 1 , Idl1 + C2(ik,l) = C2(ik,l) + war*Ch2(ik,j) + C2(ik,lc) = C2(ik,lc) + wai*Ch2(ik,jc) + ENDDO + ENDDO + ENDDO + DO j = 2 , ipph + DO ik = 1 , Idl1 + Ch2(ik,1) = Ch2(ik,1) + Ch2(ik,j) + ENDDO + ENDDO + DO j = 2 , ipph + jc = ipp2 - j + DO ik = 2 , Idl1 , 2 + Ch2(ik-1,j) = C2(ik-1,j) - C2(ik,jc) + Ch2(ik-1,jc) = C2(ik-1,j) + C2(ik,jc) + Ch2(ik,j) = C2(ik,j) + C2(ik-1,jc) + Ch2(ik,jc) = C2(ik,j) - C2(ik-1,jc) + ENDDO + ENDDO + Nac = 1 + IF ( Ido==2 ) RETURN + Nac = 0 + DO ik = 1 , Idl1 + C2(ik,1) = Ch2(ik,1) + ENDDO + DO j = 2 , Ip + DO k = 1 , L1 + C1(1,k,j) = Ch(1,k,j) + C1(2,k,j) = Ch(2,k,j) + ENDDO + ENDDO + IF ( idot>L1 ) THEN + idj = 2 - Ido + DO j = 2 , Ip + idj = idj + Ido + DO k = 1 , L1 + idij = idj + DO i = 4 , Ido , 2 + idij = idij + 2 + C1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & + & *Ch(i,k,j) + C1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & + & *Ch(i-1,k,j) + ENDDO + ENDDO + ENDDO + GOTO 99999 + ENDIF + idij = 0 + DO j = 2 , Ip + idij = idij + 2 + DO i = 4 , Ido , 2 + idij = idij + 2 + DO k = 1 , L1 + C1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij)*Ch(i,k,j) + C1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij)*Ch(i-1,k,j) + ENDDO + ENDDO + ENDDO + RETURN +99999 END subroutine passb \ No newline at end of file diff --git a/src/passb2.f b/src/passb2.f deleted file mode 100644 index 7fcdc45..0000000 --- a/src/passb2.f +++ /dev/null @@ -1,25 +0,0 @@ - SUBROUTINE PASSB2 (IDO,L1,CC,CH,WA1) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , - 1 WA1(1) - IF (IDO .GT. 2) GO TO 102 - DO 101 K=1,L1 - CH(1,K,1) = CC(1,1,K)+CC(1,2,K) - CH(1,K,2) = CC(1,1,K)-CC(1,2,K) - CH(2,K,1) = CC(2,1,K)+CC(2,2,K) - CH(2,K,2) = CC(2,1,K)-CC(2,2,K) - 101 CONTINUE - RETURN - 102 DO 104 K=1,L1 - DO 103 I=2,IDO,2 - CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) - TR2 = CC(I-1,1,K)-CC(I-1,2,K) - CH(I,K,1) = CC(I,1,K)+CC(I,2,K) - TI2 = CC(I,1,K)-CC(I,2,K) - CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2 - CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2 - 103 CONTINUE - 104 CONTINUE - RETURN - END diff --git a/src/passb2.f90 b/src/passb2.f90 new file mode 100644 index 0000000..af1cdbb --- /dev/null +++ b/src/passb2.f90 @@ -0,0 +1,31 @@ +!*==PASSB2.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE PASSB2(Ido,L1,Cc,Ch,Wa1) + USE FFTPACK_KIND + IMPLICIT NONE +!*--PASSB2851 +!*** Start of declarations inserted by SPAG + REAL Cc , Ch , FFTPACK_KIND , rk , ti2 , tr2 , Wa1 + INTEGER i , Ido , k , L1 +!*** End of declarations inserted by SPAG + DIMENSION Cc(Ido,2,L1) , Ch(Ido,L1,2) , Wa1(1) + IF ( Ido>2 ) THEN + DO k = 1 , L1 + DO i = 2 , Ido , 2 + Ch(i-1,k,1) = Cc(i-1,1,k) + Cc(i-1,2,k) + tr2 = Cc(i-1,1,k) - Cc(i-1,2,k) + Ch(i,k,1) = Cc(i,1,k) + Cc(i,2,k) + ti2 = Cc(i,1,k) - Cc(i,2,k) + Ch(i,k,2) = Wa1(i-1)*ti2 + Wa1(i)*tr2 + Ch(i-1,k,2) = Wa1(i-1)*tr2 - Wa1(i)*ti2 + ENDDO + ENDDO + GOTO 99999 + ENDIF + DO k = 1 , L1 + Ch(1,k,1) = Cc(1,1,k) + Cc(1,2,k) + Ch(1,k,2) = Cc(1,1,k) - Cc(1,2,k) + Ch(2,k,1) = Cc(2,1,k) + Cc(2,2,k) + Ch(2,k,2) = Cc(2,1,k) - Cc(2,2,k) + ENDDO + RETURN +99999 END subroutine passb2 \ No newline at end of file diff --git a/src/passb3.f b/src/passb3.f deleted file mode 100644 index 613b528..0000000 --- a/src/passb3.f +++ /dev/null @@ -1,45 +0,0 @@ - SUBROUTINE PASSB3 (IDO,L1,CC,CH,WA1,WA2) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , - 1 WA1(1) ,WA2(1) -C *** TAUI IS SQRT(3)/2 *** - DATA TAUR,TAUI /-0.5D0,0.86602540378443864676D0/ - IF (IDO .NE. 2) GO TO 102 - DO 101 K=1,L1 - TR2 = CC(1,2,K)+CC(1,3,K) - CR2 = CC(1,1,K)+TAUR*TR2 - CH(1,K,1) = CC(1,1,K)+TR2 - TI2 = CC(2,2,K)+CC(2,3,K) - CI2 = CC(2,1,K)+TAUR*TI2 - CH(2,K,1) = CC(2,1,K)+TI2 - CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) - CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) - CH(1,K,2) = CR2-CI3 - CH(1,K,3) = CR2+CI3 - CH(2,K,2) = CI2+CR3 - CH(2,K,3) = CI2-CR3 - 101 CONTINUE - RETURN - 102 DO 104 K=1,L1 - DO 103 I=2,IDO,2 - TR2 = CC(I-1,2,K)+CC(I-1,3,K) - CR2 = CC(I-1,1,K)+TAUR*TR2 - CH(I-1,K,1) = CC(I-1,1,K)+TR2 - TI2 = CC(I,2,K)+CC(I,3,K) - CI2 = CC(I,1,K)+TAUR*TI2 - CH(I,K,1) = CC(I,1,K)+TI2 - CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) - CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) - DR2 = CR2-CI3 - DR3 = CR2+CI3 - DI2 = CI2+CR3 - DI3 = CI2-CR3 - CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 - CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 - CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 - CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 - 103 CONTINUE - 104 CONTINUE - RETURN - END diff --git a/src/passb3.f90 b/src/passb3.f90 new file mode 100644 index 0000000..1c867be --- /dev/null +++ b/src/passb3.f90 @@ -0,0 +1,52 @@ +!*==PASSB3.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE PASSB3(Ido,L1,Cc,Ch,Wa1,Wa2) + USE FFTPACK_KIND + IMPLICIT NONE +!*--PASSB3882 +!*** Start of declarations inserted by SPAG + REAL Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , dr2 , dr3 , & + & FFTPACK_KIND , rk , taui , taur , ti2 , tr2 , Wa1 , Wa2 + INTEGER i , Ido , k , L1 +!*** End of declarations inserted by SPAG + DIMENSION Cc(Ido,3,L1) , Ch(Ido,L1,3) , Wa1(1) , Wa2(1) +! *** TAUI IS SQRT(3)/2 *** + DATA taur , taui/ - 0.5D0 , 0.86602540378443864676D0/ + IF ( Ido/=2 ) THEN + DO k = 1 , L1 + DO i = 2 , Ido , 2 + tr2 = Cc(i-1,2,k) + Cc(i-1,3,k) + cr2 = Cc(i-1,1,k) + taur*tr2 + Ch(i-1,k,1) = Cc(i-1,1,k) + tr2 + ti2 = Cc(i,2,k) + Cc(i,3,k) + ci2 = Cc(i,1,k) + taur*ti2 + Ch(i,k,1) = Cc(i,1,k) + ti2 + cr3 = taui*(Cc(i-1,2,k)-Cc(i-1,3,k)) + ci3 = taui*(Cc(i,2,k)-Cc(i,3,k)) + dr2 = cr2 - ci3 + dr3 = cr2 + ci3 + di2 = ci2 + cr3 + di3 = ci2 - cr3 + Ch(i,k,2) = Wa1(i-1)*di2 + Wa1(i)*dr2 + Ch(i-1,k,2) = Wa1(i-1)*dr2 - Wa1(i)*di2 + Ch(i,k,3) = Wa2(i-1)*di3 + Wa2(i)*dr3 + Ch(i-1,k,3) = Wa2(i-1)*dr3 - Wa2(i)*di3 + ENDDO + ENDDO + GOTO 99999 + ENDIF + DO k = 1 , L1 + tr2 = Cc(1,2,k) + Cc(1,3,k) + cr2 = Cc(1,1,k) + taur*tr2 + Ch(1,k,1) = Cc(1,1,k) + tr2 + ti2 = Cc(2,2,k) + Cc(2,3,k) + ci2 = Cc(2,1,k) + taur*ti2 + Ch(2,k,1) = Cc(2,1,k) + ti2 + cr3 = taui*(Cc(1,2,k)-Cc(1,3,k)) + ci3 = taui*(Cc(2,2,k)-Cc(2,3,k)) + Ch(1,k,2) = cr2 - ci3 + Ch(1,k,3) = cr2 + ci3 + Ch(2,k,2) = ci2 + cr3 + Ch(2,k,3) = ci2 - cr3 + ENDDO + RETURN +99999 END subroutine passb3 \ No newline at end of file diff --git a/src/passb4.f b/src/passb4.f deleted file mode 100644 index 06c7b13..0000000 --- a/src/passb4.f +++ /dev/null @@ -1,53 +0,0 @@ - SUBROUTINE PASSB4 (IDO,L1,CC,CH,WA1,WA2,WA3) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , - 1 WA1(1) ,WA2(1) ,WA3(1) - IF (IDO .NE. 2) GO TO 102 - DO 101 K=1,L1 - TI1 = CC(2,1,K)-CC(2,3,K) - TI2 = CC(2,1,K)+CC(2,3,K) - TR4 = CC(2,4,K)-CC(2,2,K) - TI3 = CC(2,2,K)+CC(2,4,K) - TR1 = CC(1,1,K)-CC(1,3,K) - TR2 = CC(1,1,K)+CC(1,3,K) - TI4 = CC(1,2,K)-CC(1,4,K) - TR3 = CC(1,2,K)+CC(1,4,K) - CH(1,K,1) = TR2+TR3 - CH(1,K,3) = TR2-TR3 - CH(2,K,1) = TI2+TI3 - CH(2,K,3) = TI2-TI3 - CH(1,K,2) = TR1+TR4 - CH(1,K,4) = TR1-TR4 - CH(2,K,2) = TI1+TI4 - CH(2,K,4) = TI1-TI4 - 101 CONTINUE - RETURN - 102 DO 104 K=1,L1 - DO 103 I=2,IDO,2 - TI1 = CC(I,1,K)-CC(I,3,K) - TI2 = CC(I,1,K)+CC(I,3,K) - TI3 = CC(I,2,K)+CC(I,4,K) - TR4 = CC(I,4,K)-CC(I,2,K) - TR1 = CC(I-1,1,K)-CC(I-1,3,K) - TR2 = CC(I-1,1,K)+CC(I-1,3,K) - TI4 = CC(I-1,2,K)-CC(I-1,4,K) - TR3 = CC(I-1,2,K)+CC(I-1,4,K) - CH(I-1,K,1) = TR2+TR3 - CR3 = TR2-TR3 - CH(I,K,1) = TI2+TI3 - CI3 = TI2-TI3 - CR2 = TR1+TR4 - CR4 = TR1-TR4 - CI2 = TI1+TI4 - CI4 = TI1-TI4 - CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2 - CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2 - CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 - CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3 - CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4 - CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4 - 103 CONTINUE - 104 CONTINUE - RETURN - END diff --git a/src/passb4.f90 b/src/passb4.f90 new file mode 100644 index 0000000..451c280 --- /dev/null +++ b/src/passb4.f90 @@ -0,0 +1,62 @@ +!*==PASSB4.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE PASSB4(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3) + USE FFTPACK_KIND + IMPLICIT NONE +!*--PASSB4934 +!*** Start of declarations inserted by SPAG + REAL Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , FFTPACK_KIND , & + & rk , ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3 , tr4 , Wa1 , & + & Wa2 + REAL Wa3 + INTEGER i , Ido , k , L1 +!*** End of declarations inserted by SPAG + DIMENSION Cc(Ido,4,L1) , Ch(Ido,L1,4) , Wa1(1) , Wa2(1) , Wa3(1) + IF ( Ido/=2 ) THEN + DO k = 1 , L1 + DO i = 2 , Ido , 2 + ti1 = Cc(i,1,k) - Cc(i,3,k) + ti2 = Cc(i,1,k) + Cc(i,3,k) + ti3 = Cc(i,2,k) + Cc(i,4,k) + tr4 = Cc(i,4,k) - Cc(i,2,k) + tr1 = Cc(i-1,1,k) - Cc(i-1,3,k) + tr2 = Cc(i-1,1,k) + Cc(i-1,3,k) + ti4 = Cc(i-1,2,k) - Cc(i-1,4,k) + tr3 = Cc(i-1,2,k) + Cc(i-1,4,k) + Ch(i-1,k,1) = tr2 + tr3 + cr3 = tr2 - tr3 + Ch(i,k,1) = ti2 + ti3 + ci3 = ti2 - ti3 + cr2 = tr1 + tr4 + cr4 = tr1 - tr4 + ci2 = ti1 + ti4 + ci4 = ti1 - ti4 + Ch(i-1,k,2) = Wa1(i-1)*cr2 - Wa1(i)*ci2 + Ch(i,k,2) = Wa1(i-1)*ci2 + Wa1(i)*cr2 + Ch(i-1,k,3) = Wa2(i-1)*cr3 - Wa2(i)*ci3 + Ch(i,k,3) = Wa2(i-1)*ci3 + Wa2(i)*cr3 + Ch(i-1,k,4) = Wa3(i-1)*cr4 - Wa3(i)*ci4 + Ch(i,k,4) = Wa3(i-1)*ci4 + Wa3(i)*cr4 + ENDDO + ENDDO + GOTO 99999 + ENDIF + DO k = 1 , L1 + ti1 = Cc(2,1,k) - Cc(2,3,k) + ti2 = Cc(2,1,k) + Cc(2,3,k) + tr4 = Cc(2,4,k) - Cc(2,2,k) + ti3 = Cc(2,2,k) + Cc(2,4,k) + tr1 = Cc(1,1,k) - Cc(1,3,k) + tr2 = Cc(1,1,k) + Cc(1,3,k) + ti4 = Cc(1,2,k) - Cc(1,4,k) + tr3 = Cc(1,2,k) + Cc(1,4,k) + Ch(1,k,1) = tr2 + tr3 + Ch(1,k,3) = tr2 - tr3 + Ch(2,k,1) = ti2 + ti3 + Ch(2,k,3) = ti2 - ti3 + Ch(1,k,2) = tr1 + tr4 + Ch(1,k,4) = tr1 - tr4 + Ch(2,k,2) = ti1 + ti4 + Ch(2,k,4) = ti1 - ti4 + ENDDO + RETURN +99999 END subroutine passb4 \ No newline at end of file diff --git a/src/passb5.f b/src/passb5.f deleted file mode 100644 index 48c6e69..0000000 --- a/src/passb5.f +++ /dev/null @@ -1,80 +0,0 @@ - SUBROUTINE PASSB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , - 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) -C *** TR11=COS(2*PI/5), TI11=SIN(2*PI/5) -C *** TR12=COS(4*PI/5), TI12=SIN(4*PI/5) - DATA TR11,TI11,TR12,TI12 /0.3090169943749474241D0, - + 0.95105651629515357212D0, - + -0.8090169943749474241D0,0.58778525229247312917D0/ - IF (IDO .NE. 2) GO TO 102 - DO 101 K=1,L1 - TI5 = CC(2,2,K)-CC(2,5,K) - TI2 = CC(2,2,K)+CC(2,5,K) - TI4 = CC(2,3,K)-CC(2,4,K) - TI3 = CC(2,3,K)+CC(2,4,K) - TR5 = CC(1,2,K)-CC(1,5,K) - TR2 = CC(1,2,K)+CC(1,5,K) - TR4 = CC(1,3,K)-CC(1,4,K) - TR3 = CC(1,3,K)+CC(1,4,K) - CH(1,K,1) = CC(1,1,K)+TR2+TR3 - CH(2,K,1) = CC(2,1,K)+TI2+TI3 - CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - CH(1,K,2) = CR2-CI5 - CH(1,K,5) = CR2+CI5 - CH(2,K,2) = CI2+CR5 - CH(2,K,3) = CI3+CR4 - CH(1,K,3) = CR3-CI4 - CH(1,K,4) = CR3+CI4 - CH(2,K,4) = CI3-CR4 - CH(2,K,5) = CI2-CR5 - 101 CONTINUE - RETURN - 102 DO 104 K=1,L1 - DO 103 I=2,IDO,2 - TI5 = CC(I,2,K)-CC(I,5,K) - TI2 = CC(I,2,K)+CC(I,5,K) - TI4 = CC(I,3,K)-CC(I,4,K) - TI3 = CC(I,3,K)+CC(I,4,K) - TR5 = CC(I-1,2,K)-CC(I-1,5,K) - TR2 = CC(I-1,2,K)+CC(I-1,5,K) - TR4 = CC(I-1,3,K)-CC(I-1,4,K) - TR3 = CC(I-1,3,K)+CC(I-1,4,K) - CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 - CH(I,K,1) = CC(I,1,K)+TI2+TI3 - CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - DR3 = CR3-CI4 - DR4 = CR3+CI4 - DI3 = CI3+CR4 - DI4 = CI3-CR4 - DR5 = CR2+CI5 - DR2 = CR2-CI5 - DI5 = CI2-CR5 - DI2 = CI2+CR5 - CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 - CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 - CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 - CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 - CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4 - CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4 - CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5 - CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5 - 103 CONTINUE - 104 CONTINUE - RETURN - END diff --git a/src/passb5.f90 b/src/passb5.f90 new file mode 100644 index 0000000..03db253 --- /dev/null +++ b/src/passb5.f90 @@ -0,0 +1,91 @@ +!*==PASSB5.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE PASSB5(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) + USE FFTPACK_KIND + IMPLICIT NONE +!*--PASSB5996 +!*** Start of declarations inserted by SPAG + REAL Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , cr4 , cr5 , & + & di2 , di3 , di4 , di5 , dr2 , dr3 , dr4 , dr5 , & + & FFTPACK_KIND , rk + REAL ti11 , ti12 , ti2 , ti3 , ti4 , ti5 , tr11 , tr12 , tr2 , & + & tr3 , tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 + INTEGER i , Ido , k , L1 +!*** End of declarations inserted by SPAG + DIMENSION Cc(Ido,5,L1) , Ch(Ido,L1,5) , Wa1(1) , Wa2(1) , Wa3(1) ,& + & Wa4(1) +! *** TR11=COS(2*PI/5), TI11=SIN(2*PI/5) +! *** TR12=COS(4*PI/5), TI12=SIN(4*PI/5) + DATA tr11 , ti11 , tr12 , ti12/0.3090169943749474241D0 , & + & 0.95105651629515357212D0 , -0.8090169943749474241D0 , & + & 0.58778525229247312917D0/ + IF ( Ido/=2 ) THEN + DO k = 1 , L1 + DO i = 2 , Ido , 2 + ti5 = Cc(i,2,k) - Cc(i,5,k) + ti2 = Cc(i,2,k) + Cc(i,5,k) + ti4 = Cc(i,3,k) - Cc(i,4,k) + ti3 = Cc(i,3,k) + Cc(i,4,k) + tr5 = Cc(i-1,2,k) - Cc(i-1,5,k) + tr2 = Cc(i-1,2,k) + Cc(i-1,5,k) + tr4 = Cc(i-1,3,k) - Cc(i-1,4,k) + tr3 = Cc(i-1,3,k) + Cc(i-1,4,k) + Ch(i-1,k,1) = Cc(i-1,1,k) + tr2 + tr3 + Ch(i,k,1) = Cc(i,1,k) + ti2 + ti3 + cr2 = Cc(i-1,1,k) + tr11*tr2 + tr12*tr3 + ci2 = Cc(i,1,k) + tr11*ti2 + tr12*ti3 + cr3 = Cc(i-1,1,k) + tr12*tr2 + tr11*tr3 + ci3 = Cc(i,1,k) + tr12*ti2 + tr11*ti3 + cr5 = ti11*tr5 + ti12*tr4 + ci5 = ti11*ti5 + ti12*ti4 + cr4 = ti12*tr5 - ti11*tr4 + ci4 = ti12*ti5 - ti11*ti4 + dr3 = cr3 - ci4 + dr4 = cr3 + ci4 + di3 = ci3 + cr4 + di4 = ci3 - cr4 + dr5 = cr2 + ci5 + dr2 = cr2 - ci5 + di5 = ci2 - cr5 + di2 = ci2 + cr5 + Ch(i-1,k,2) = Wa1(i-1)*dr2 - Wa1(i)*di2 + Ch(i,k,2) = Wa1(i-1)*di2 + Wa1(i)*dr2 + Ch(i-1,k,3) = Wa2(i-1)*dr3 - Wa2(i)*di3 + Ch(i,k,3) = Wa2(i-1)*di3 + Wa2(i)*dr3 + Ch(i-1,k,4) = Wa3(i-1)*dr4 - Wa3(i)*di4 + Ch(i,k,4) = Wa3(i-1)*di4 + Wa3(i)*dr4 + Ch(i-1,k,5) = Wa4(i-1)*dr5 - Wa4(i)*di5 + Ch(i,k,5) = Wa4(i-1)*di5 + Wa4(i)*dr5 + ENDDO + ENDDO + GOTO 99999 + ENDIF + DO k = 1 , L1 + ti5 = Cc(2,2,k) - Cc(2,5,k) + ti2 = Cc(2,2,k) + Cc(2,5,k) + ti4 = Cc(2,3,k) - Cc(2,4,k) + ti3 = Cc(2,3,k) + Cc(2,4,k) + tr5 = Cc(1,2,k) - Cc(1,5,k) + tr2 = Cc(1,2,k) + Cc(1,5,k) + tr4 = Cc(1,3,k) - Cc(1,4,k) + tr3 = Cc(1,3,k) + Cc(1,4,k) + Ch(1,k,1) = Cc(1,1,k) + tr2 + tr3 + Ch(2,k,1) = Cc(2,1,k) + ti2 + ti3 + cr2 = Cc(1,1,k) + tr11*tr2 + tr12*tr3 + ci2 = Cc(2,1,k) + tr11*ti2 + tr12*ti3 + cr3 = Cc(1,1,k) + tr12*tr2 + tr11*tr3 + ci3 = Cc(2,1,k) + tr12*ti2 + tr11*ti3 + cr5 = ti11*tr5 + ti12*tr4 + ci5 = ti11*ti5 + ti12*ti4 + cr4 = ti12*tr5 - ti11*tr4 + ci4 = ti12*ti5 - ti11*ti4 + Ch(1,k,2) = cr2 - ci5 + Ch(1,k,5) = cr2 + ci5 + Ch(2,k,2) = ci2 + cr5 + Ch(2,k,3) = ci3 + cr4 + Ch(1,k,3) = cr3 - ci4 + Ch(1,k,4) = cr3 + ci4 + Ch(2,k,4) = ci3 - cr4 + Ch(2,k,5) = ci2 - cr5 + ENDDO + RETURN +99999 END subroutine passb5 \ No newline at end of file diff --git a/src/passf.f b/src/passf.f deleted file mode 100644 index 1689851..0000000 --- a/src/passf.f +++ /dev/null @@ -1,118 +0,0 @@ - SUBROUTINE PASSF (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , - 1 C1(IDO,L1,IP) ,WA(1) ,C2(IDL1,IP), - 2 CH2(IDL1,IP) - IDOT = IDO/2 - NT = IP*IDL1 - IPP2 = IP+2 - IPPH = (IP+1)/2 - IDP = IP*IDO -C - IF (IDO .LT. L1) GO TO 106 - DO 103 J=2,IPPH - JC = IPP2-J - DO 102 K=1,L1 - DO 101 I=1,IDO - CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) - CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) - 101 CONTINUE - 102 CONTINUE - 103 CONTINUE - DO 105 K=1,L1 - DO 104 I=1,IDO - CH(I,K,1) = CC(I,1,K) - 104 CONTINUE - 105 CONTINUE - GO TO 112 - 106 DO 109 J=2,IPPH - JC = IPP2-J - DO 108 I=1,IDO - DO 107 K=1,L1 - CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) - CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) - 107 CONTINUE - 108 CONTINUE - 109 CONTINUE - DO 111 I=1,IDO - DO 110 K=1,L1 - CH(I,K,1) = CC(I,1,K) - 110 CONTINUE - 111 CONTINUE - 112 IDL = 2-IDO - INC = 0 - DO 116 L=2,IPPH - LC = IPP2-L - IDL = IDL+IDO - DO 113 IK=1,IDL1 - C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) - C2(IK,LC) = -WA(IDL)*CH2(IK,IP) - 113 CONTINUE - IDLJ = IDL - INC = INC+IDO - DO 115 J=3,IPPH - JC = IPP2-J - IDLJ = IDLJ+INC - IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP - WAR = WA(IDLJ-1) - WAI = WA(IDLJ) - DO 114 IK=1,IDL1 - C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) - C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC) - 114 CONTINUE - 115 CONTINUE - 116 CONTINUE - DO 118 J=2,IPPH - DO 117 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+CH2(IK,J) - 117 CONTINUE - 118 CONTINUE - DO 120 J=2,IPPH - JC = IPP2-J - DO 119 IK=2,IDL1,2 - CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) - CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) - CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) - CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) - 119 CONTINUE - 120 CONTINUE - NAC = 1 - IF (IDO .EQ. 2) RETURN - NAC = 0 - DO 121 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 121 CONTINUE - DO 123 J=2,IP - DO 122 K=1,L1 - C1(1,K,J) = CH(1,K,J) - C1(2,K,J) = CH(2,K,J) - 122 CONTINUE - 123 CONTINUE - IF (IDOT .GT. L1) GO TO 127 - IDIJ = 0 - DO 126 J=2,IP - IDIJ = IDIJ+2 - DO 125 I=4,IDO,2 - IDIJ = IDIJ+2 - DO 124 K=1,L1 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) - 124 CONTINUE - 125 CONTINUE - 126 CONTINUE - RETURN - 127 IDJ = 2-IDO - DO 130 J=2,IP - IDJ = IDJ+IDO - DO 129 K=1,L1 - IDIJ = IDJ - DO 128 I=4,IDO,2 - IDIJ = IDIJ+2 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) - 128 CONTINUE - 129 CONTINUE - 130 CONTINUE - RETURN - END diff --git a/src/passf.f90 b/src/passf.f90 new file mode 100644 index 0000000..823fbe1 --- /dev/null +++ b/src/passf.f90 @@ -0,0 +1,129 @@ +!*==PASSF.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE PASSF(Nac,Ido,Ip,L1,Idl1,Cc,C1,C2,Ch,Ch2,Wa) + USE FFTPACK_KIND + IMPLICIT NONE +!*--PASSF1087 +!*** Start of declarations inserted by SPAG + REAL C1 , C2 , Cc , Ch , Ch2 , FFTPACK_KIND , rk , Wa , wai , war + INTEGER i , idij , idj , idl , Idl1 , idlj , Ido , idot , idp , & + & ik , inc , Ip , ipp2 , ipph , j , jc , k , l , L1 , lc + INTEGER Nac , nt +!*** End of declarations inserted by SPAG + DIMENSION Ch(Ido,L1,Ip) , Cc(Ido,Ip,L1) , C1(Ido,L1,Ip) , Wa(1) , & + & C2(Idl1,Ip) , Ch2(Idl1,Ip) + idot = Ido/2 + nt = Ip*Idl1 + ipp2 = Ip + 2 + ipph = (Ip+1)/2 + idp = Ip*Ido +! + IF ( Idoidp ) idlj = idlj - idp + war = Wa(idlj-1) + wai = Wa(idlj) + DO ik = 1 , Idl1 + C2(ik,l) = C2(ik,l) + war*Ch2(ik,j) + C2(ik,lc) = C2(ik,lc) - wai*Ch2(ik,jc) + ENDDO + ENDDO + ENDDO + DO j = 2 , ipph + DO ik = 1 , Idl1 + Ch2(ik,1) = Ch2(ik,1) + Ch2(ik,j) + ENDDO + ENDDO + DO j = 2 , ipph + jc = ipp2 - j + DO ik = 2 , Idl1 , 2 + Ch2(ik-1,j) = C2(ik-1,j) - C2(ik,jc) + Ch2(ik-1,jc) = C2(ik-1,j) + C2(ik,jc) + Ch2(ik,j) = C2(ik,j) + C2(ik-1,jc) + Ch2(ik,jc) = C2(ik,j) - C2(ik-1,jc) + ENDDO + ENDDO + Nac = 1 + IF ( Ido==2 ) RETURN + Nac = 0 + DO ik = 1 , Idl1 + C2(ik,1) = Ch2(ik,1) + ENDDO + DO j = 2 , Ip + DO k = 1 , L1 + C1(1,k,j) = Ch(1,k,j) + C1(2,k,j) = Ch(2,k,j) + ENDDO + ENDDO + IF ( idot>L1 ) THEN + idj = 2 - Ido + DO j = 2 , Ip + idj = idj + Ido + DO k = 1 , L1 + idij = idj + DO i = 4 , Ido , 2 + idij = idij + 2 + C1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) + Wa(idij) & + & *Ch(i,k,j) + C1(i,k,j) = Wa(idij-1)*Ch(i,k,j) - Wa(idij) & + & *Ch(i-1,k,j) + ENDDO + ENDDO + ENDDO + GOTO 99999 + ENDIF + idij = 0 + DO j = 2 , Ip + idij = idij + 2 + DO i = 4 , Ido , 2 + idij = idij + 2 + DO k = 1 , L1 + C1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) + Wa(idij)*Ch(i,k,j) + C1(i,k,j) = Wa(idij-1)*Ch(i,k,j) - Wa(idij)*Ch(i-1,k,j) + ENDDO + ENDDO + ENDDO + RETURN +99999 END subroutine passf \ No newline at end of file diff --git a/src/passf2.f b/src/passf2.f deleted file mode 100644 index cddf984..0000000 --- a/src/passf2.f +++ /dev/null @@ -1,25 +0,0 @@ - SUBROUTINE PASSF2 (IDO,L1,CC,CH,WA1) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , - 1 WA1(1) - IF (IDO .GT. 2) GO TO 102 - DO 101 K=1,L1 - CH(1,K,1) = CC(1,1,K)+CC(1,2,K) - CH(1,K,2) = CC(1,1,K)-CC(1,2,K) - CH(2,K,1) = CC(2,1,K)+CC(2,2,K) - CH(2,K,2) = CC(2,1,K)-CC(2,2,K) - 101 CONTINUE - RETURN - 102 DO 104 K=1,L1 - DO 103 I=2,IDO,2 - CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) - TR2 = CC(I-1,1,K)-CC(I-1,2,K) - CH(I,K,1) = CC(I,1,K)+CC(I,2,K) - TI2 = CC(I,1,K)-CC(I,2,K) - CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2 - CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2 - 103 CONTINUE - 104 CONTINUE - RETURN - END diff --git a/src/passf2.f90 b/src/passf2.f90 new file mode 100644 index 0000000..8f496cf --- /dev/null +++ b/src/passf2.f90 @@ -0,0 +1,31 @@ +!*==PASSF2.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE PASSF2(Ido,L1,Cc,Ch,Wa1) + USE FFTPACK_KIND + IMPLICIT NONE +!*--PASSF21216 +!*** Start of declarations inserted by SPAG + REAL Cc , Ch , FFTPACK_KIND , rk , ti2 , tr2 , Wa1 + INTEGER i , Ido , k , L1 +!*** End of declarations inserted by SPAG + DIMENSION Cc(Ido,2,L1) , Ch(Ido,L1,2) , Wa1(1) + IF ( Ido>2 ) THEN + DO k = 1 , L1 + DO i = 2 , Ido , 2 + Ch(i-1,k,1) = Cc(i-1,1,k) + Cc(i-1,2,k) + tr2 = Cc(i-1,1,k) - Cc(i-1,2,k) + Ch(i,k,1) = Cc(i,1,k) + Cc(i,2,k) + ti2 = Cc(i,1,k) - Cc(i,2,k) + Ch(i,k,2) = Wa1(i-1)*ti2 - Wa1(i)*tr2 + Ch(i-1,k,2) = Wa1(i-1)*tr2 + Wa1(i)*ti2 + ENDDO + ENDDO + GOTO 99999 + ENDIF + DO k = 1 , L1 + Ch(1,k,1) = Cc(1,1,k) + Cc(1,2,k) + Ch(1,k,2) = Cc(1,1,k) - Cc(1,2,k) + Ch(2,k,1) = Cc(2,1,k) + Cc(2,2,k) + Ch(2,k,2) = Cc(2,1,k) - Cc(2,2,k) + ENDDO + RETURN +99999 END subroutine passf2 \ No newline at end of file diff --git a/src/passf3.f b/src/passf3.f deleted file mode 100644 index a64d207..0000000 --- a/src/passf3.f +++ /dev/null @@ -1,45 +0,0 @@ - SUBROUTINE PASSF3 (IDO,L1,CC,CH,WA1,WA2) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , - 1 WA1(1) ,WA2(1) -C *** TAUI IS -SQRT(3)/2 *** - DATA TAUR,TAUI /-0.5D0,-0.86602540378443864676D0/ - IF (IDO .NE. 2) GO TO 102 - DO 101 K=1,L1 - TR2 = CC(1,2,K)+CC(1,3,K) - CR2 = CC(1,1,K)+TAUR*TR2 - CH(1,K,1) = CC(1,1,K)+TR2 - TI2 = CC(2,2,K)+CC(2,3,K) - CI2 = CC(2,1,K)+TAUR*TI2 - CH(2,K,1) = CC(2,1,K)+TI2 - CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) - CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) - CH(1,K,2) = CR2-CI3 - CH(1,K,3) = CR2+CI3 - CH(2,K,2) = CI2+CR3 - CH(2,K,3) = CI2-CR3 - 101 CONTINUE - RETURN - 102 DO 104 K=1,L1 - DO 103 I=2,IDO,2 - TR2 = CC(I-1,2,K)+CC(I-1,3,K) - CR2 = CC(I-1,1,K)+TAUR*TR2 - CH(I-1,K,1) = CC(I-1,1,K)+TR2 - TI2 = CC(I,2,K)+CC(I,3,K) - CI2 = CC(I,1,K)+TAUR*TI2 - CH(I,K,1) = CC(I,1,K)+TI2 - CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) - CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) - DR2 = CR2-CI3 - DR3 = CR2+CI3 - DI2 = CI2+CR3 - DI3 = CI2-CR3 - CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 - CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 - CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 - CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 - 103 CONTINUE - 104 CONTINUE - RETURN - END diff --git a/src/passf3.f90 b/src/passf3.f90 new file mode 100644 index 0000000..bf2659e --- /dev/null +++ b/src/passf3.f90 @@ -0,0 +1,52 @@ +!*==PASSF3.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE PASSF3(Ido,L1,Cc,Ch,Wa1,Wa2) + USE FFTPACK_KIND + IMPLICIT NONE +!*--PASSF31247 +!*** Start of declarations inserted by SPAG + REAL Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , dr2 , dr3 , & + & FFTPACK_KIND , rk , taui , taur , ti2 , tr2 , Wa1 , Wa2 + INTEGER i , Ido , k , L1 +!*** End of declarations inserted by SPAG + DIMENSION Cc(Ido,3,L1) , Ch(Ido,L1,3) , Wa1(1) , Wa2(1) +! *** TAUI IS -SQRT(3)/2 *** + DATA taur , taui/ - 0.5D0 , -0.86602540378443864676D0/ + IF ( Ido/=2 ) THEN + DO k = 1 , L1 + DO i = 2 , Ido , 2 + tr2 = Cc(i-1,2,k) + Cc(i-1,3,k) + cr2 = Cc(i-1,1,k) + taur*tr2 + Ch(i-1,k,1) = Cc(i-1,1,k) + tr2 + ti2 = Cc(i,2,k) + Cc(i,3,k) + ci2 = Cc(i,1,k) + taur*ti2 + Ch(i,k,1) = Cc(i,1,k) + ti2 + cr3 = taui*(Cc(i-1,2,k)-Cc(i-1,3,k)) + ci3 = taui*(Cc(i,2,k)-Cc(i,3,k)) + dr2 = cr2 - ci3 + dr3 = cr2 + ci3 + di2 = ci2 + cr3 + di3 = ci2 - cr3 + Ch(i,k,2) = Wa1(i-1)*di2 - Wa1(i)*dr2 + Ch(i-1,k,2) = Wa1(i-1)*dr2 + Wa1(i)*di2 + Ch(i,k,3) = Wa2(i-1)*di3 - Wa2(i)*dr3 + Ch(i-1,k,3) = Wa2(i-1)*dr3 + Wa2(i)*di3 + ENDDO + ENDDO + GOTO 99999 + ENDIF + DO k = 1 , L1 + tr2 = Cc(1,2,k) + Cc(1,3,k) + cr2 = Cc(1,1,k) + taur*tr2 + Ch(1,k,1) = Cc(1,1,k) + tr2 + ti2 = Cc(2,2,k) + Cc(2,3,k) + ci2 = Cc(2,1,k) + taur*ti2 + Ch(2,k,1) = Cc(2,1,k) + ti2 + cr3 = taui*(Cc(1,2,k)-Cc(1,3,k)) + ci3 = taui*(Cc(2,2,k)-Cc(2,3,k)) + Ch(1,k,2) = cr2 - ci3 + Ch(1,k,3) = cr2 + ci3 + Ch(2,k,2) = ci2 + cr3 + Ch(2,k,3) = ci2 - cr3 + ENDDO + RETURN +99999 END subroutine passf3 \ No newline at end of file diff --git a/src/passf4.f b/src/passf4.f deleted file mode 100644 index 09daafe..0000000 --- a/src/passf4.f +++ /dev/null @@ -1,53 +0,0 @@ - SUBROUTINE PASSF4 (IDO,L1,CC,CH,WA1,WA2,WA3) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , - 1 WA1(1) ,WA2(1) ,WA3(1) - IF (IDO .NE. 2) GO TO 102 - DO 101 K=1,L1 - TI1 = CC(2,1,K)-CC(2,3,K) - TI2 = CC(2,1,K)+CC(2,3,K) - TR4 = CC(2,2,K)-CC(2,4,K) - TI3 = CC(2,2,K)+CC(2,4,K) - TR1 = CC(1,1,K)-CC(1,3,K) - TR2 = CC(1,1,K)+CC(1,3,K) - TI4 = CC(1,4,K)-CC(1,2,K) - TR3 = CC(1,2,K)+CC(1,4,K) - CH(1,K,1) = TR2+TR3 - CH(1,K,3) = TR2-TR3 - CH(2,K,1) = TI2+TI3 - CH(2,K,3) = TI2-TI3 - CH(1,K,2) = TR1+TR4 - CH(1,K,4) = TR1-TR4 - CH(2,K,2) = TI1+TI4 - CH(2,K,4) = TI1-TI4 - 101 CONTINUE - RETURN - 102 DO 104 K=1,L1 - DO 103 I=2,IDO,2 - TI1 = CC(I,1,K)-CC(I,3,K) - TI2 = CC(I,1,K)+CC(I,3,K) - TI3 = CC(I,2,K)+CC(I,4,K) - TR4 = CC(I,2,K)-CC(I,4,K) - TR1 = CC(I-1,1,K)-CC(I-1,3,K) - TR2 = CC(I-1,1,K)+CC(I-1,3,K) - TI4 = CC(I-1,4,K)-CC(I-1,2,K) - TR3 = CC(I-1,2,K)+CC(I-1,4,K) - CH(I-1,K,1) = TR2+TR3 - CR3 = TR2-TR3 - CH(I,K,1) = TI2+TI3 - CI3 = TI2-TI3 - CR2 = TR1+TR4 - CR4 = TR1-TR4 - CI2 = TI1+TI4 - CI4 = TI1-TI4 - CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2 - CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2 - CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3 - CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3 - CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4 - CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4 - 103 CONTINUE - 104 CONTINUE - RETURN - END diff --git a/src/passf4.f90 b/src/passf4.f90 new file mode 100644 index 0000000..9ca15b8 --- /dev/null +++ b/src/passf4.f90 @@ -0,0 +1,62 @@ +!*==PASSF4.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE PASSF4(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3) + USE FFTPACK_KIND + IMPLICIT NONE +!*--PASSF41299 +!*** Start of declarations inserted by SPAG + REAL Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , FFTPACK_KIND , & + & rk , ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3 , tr4 , Wa1 , & + & Wa2 + REAL Wa3 + INTEGER i , Ido , k , L1 +!*** End of declarations inserted by SPAG + DIMENSION Cc(Ido,4,L1) , Ch(Ido,L1,4) , Wa1(1) , Wa2(1) , Wa3(1) + IF ( Ido/=2 ) THEN + DO k = 1 , L1 + DO i = 2 , Ido , 2 + ti1 = Cc(i,1,k) - Cc(i,3,k) + ti2 = Cc(i,1,k) + Cc(i,3,k) + ti3 = Cc(i,2,k) + Cc(i,4,k) + tr4 = Cc(i,2,k) - Cc(i,4,k) + tr1 = Cc(i-1,1,k) - Cc(i-1,3,k) + tr2 = Cc(i-1,1,k) + Cc(i-1,3,k) + ti4 = Cc(i-1,4,k) - Cc(i-1,2,k) + tr3 = Cc(i-1,2,k) + Cc(i-1,4,k) + Ch(i-1,k,1) = tr2 + tr3 + cr3 = tr2 - tr3 + Ch(i,k,1) = ti2 + ti3 + ci3 = ti2 - ti3 + cr2 = tr1 + tr4 + cr4 = tr1 - tr4 + ci2 = ti1 + ti4 + ci4 = ti1 - ti4 + Ch(i-1,k,2) = Wa1(i-1)*cr2 + Wa1(i)*ci2 + Ch(i,k,2) = Wa1(i-1)*ci2 - Wa1(i)*cr2 + Ch(i-1,k,3) = Wa2(i-1)*cr3 + Wa2(i)*ci3 + Ch(i,k,3) = Wa2(i-1)*ci3 - Wa2(i)*cr3 + Ch(i-1,k,4) = Wa3(i-1)*cr4 + Wa3(i)*ci4 + Ch(i,k,4) = Wa3(i-1)*ci4 - Wa3(i)*cr4 + ENDDO + ENDDO + GOTO 99999 + ENDIF + DO k = 1 , L1 + ti1 = Cc(2,1,k) - Cc(2,3,k) + ti2 = Cc(2,1,k) + Cc(2,3,k) + tr4 = Cc(2,2,k) - Cc(2,4,k) + ti3 = Cc(2,2,k) + Cc(2,4,k) + tr1 = Cc(1,1,k) - Cc(1,3,k) + tr2 = Cc(1,1,k) + Cc(1,3,k) + ti4 = Cc(1,4,k) - Cc(1,2,k) + tr3 = Cc(1,2,k) + Cc(1,4,k) + Ch(1,k,1) = tr2 + tr3 + Ch(1,k,3) = tr2 - tr3 + Ch(2,k,1) = ti2 + ti3 + Ch(2,k,3) = ti2 - ti3 + Ch(1,k,2) = tr1 + tr4 + Ch(1,k,4) = tr1 - tr4 + Ch(2,k,2) = ti1 + ti4 + Ch(2,k,4) = ti1 - ti4 + ENDDO + RETURN +99999 END subroutine passf4 \ No newline at end of file diff --git a/src/passf5.f b/src/passf5.f deleted file mode 100644 index 6e3da88..0000000 --- a/src/passf5.f +++ /dev/null @@ -1,80 +0,0 @@ - SUBROUTINE PASSF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , - 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) -C *** TR11=COS(2*PI/5), TI11=-SIN(2*PI/5) -C *** TR12=-COS(4*PI/5), TI12=-SIN(4*PI/5) - DATA TR11,TI11,TR12,TI12 /0.3090169943749474241D0, - + -0.95105651629515357212D0, - 1 -0.8090169943749474241D0, -0.58778525229247312917D0/ - IF (IDO .NE. 2) GO TO 102 - DO 101 K=1,L1 - TI5 = CC(2,2,K)-CC(2,5,K) - TI2 = CC(2,2,K)+CC(2,5,K) - TI4 = CC(2,3,K)-CC(2,4,K) - TI3 = CC(2,3,K)+CC(2,4,K) - TR5 = CC(1,2,K)-CC(1,5,K) - TR2 = CC(1,2,K)+CC(1,5,K) - TR4 = CC(1,3,K)-CC(1,4,K) - TR3 = CC(1,3,K)+CC(1,4,K) - CH(1,K,1) = CC(1,1,K)+TR2+TR3 - CH(2,K,1) = CC(2,1,K)+TI2+TI3 - CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - CH(1,K,2) = CR2-CI5 - CH(1,K,5) = CR2+CI5 - CH(2,K,2) = CI2+CR5 - CH(2,K,3) = CI3+CR4 - CH(1,K,3) = CR3-CI4 - CH(1,K,4) = CR3+CI4 - CH(2,K,4) = CI3-CR4 - CH(2,K,5) = CI2-CR5 - 101 CONTINUE - RETURN - 102 DO 104 K=1,L1 - DO 103 I=2,IDO,2 - TI5 = CC(I,2,K)-CC(I,5,K) - TI2 = CC(I,2,K)+CC(I,5,K) - TI4 = CC(I,3,K)-CC(I,4,K) - TI3 = CC(I,3,K)+CC(I,4,K) - TR5 = CC(I-1,2,K)-CC(I-1,5,K) - TR2 = CC(I-1,2,K)+CC(I-1,5,K) - TR4 = CC(I-1,3,K)-CC(I-1,4,K) - TR3 = CC(I-1,3,K)+CC(I-1,4,K) - CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 - CH(I,K,1) = CC(I,1,K)+TI2+TI3 - CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - DR3 = CR3-CI4 - DR4 = CR3+CI4 - DI3 = CI3+CR4 - DI4 = CI3-CR4 - DR5 = CR2+CI5 - DR2 = CR2-CI5 - DI5 = CI2-CR5 - DI2 = CI2+CR5 - CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 - CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 - CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 - CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 - CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4 - CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4 - CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5 - CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5 - 103 CONTINUE - 104 CONTINUE - RETURN - END diff --git a/src/passf5.f90 b/src/passf5.f90 new file mode 100644 index 0000000..a45d0e0 --- /dev/null +++ b/src/passf5.f90 @@ -0,0 +1,91 @@ +!*==PASSF5.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE PASSF5(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) + USE FFTPACK_KIND + IMPLICIT NONE +!*--PASSF51361 +!*** Start of declarations inserted by SPAG + REAL Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , cr4 , cr5 , & + & di2 , di3 , di4 , di5 , dr2 , dr3 , dr4 , dr5 , & + & FFTPACK_KIND , rk + REAL ti11 , ti12 , ti2 , ti3 , ti4 , ti5 , tr11 , tr12 , tr2 , & + & tr3 , tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 + INTEGER i , Ido , k , L1 +!*** End of declarations inserted by SPAG + DIMENSION Cc(Ido,5,L1) , Ch(Ido,L1,5) , Wa1(1) , Wa2(1) , Wa3(1) ,& + & Wa4(1) +! *** TR11=COS(2*PI/5), TI11=-SIN(2*PI/5) +! *** TR12=-COS(4*PI/5), TI12=-SIN(4*PI/5) + DATA tr11 , ti11 , tr12 , ti12/0.3090169943749474241D0 , & + & -0.95105651629515357212D0 , -0.8090169943749474241D0 , & + & -0.58778525229247312917D0/ + IF ( Ido/=2 ) THEN + DO k = 1 , L1 + DO i = 2 , Ido , 2 + ti5 = Cc(i,2,k) - Cc(i,5,k) + ti2 = Cc(i,2,k) + Cc(i,5,k) + ti4 = Cc(i,3,k) - Cc(i,4,k) + ti3 = Cc(i,3,k) + Cc(i,4,k) + tr5 = Cc(i-1,2,k) - Cc(i-1,5,k) + tr2 = Cc(i-1,2,k) + Cc(i-1,5,k) + tr4 = Cc(i-1,3,k) - Cc(i-1,4,k) + tr3 = Cc(i-1,3,k) + Cc(i-1,4,k) + Ch(i-1,k,1) = Cc(i-1,1,k) + tr2 + tr3 + Ch(i,k,1) = Cc(i,1,k) + ti2 + ti3 + cr2 = Cc(i-1,1,k) + tr11*tr2 + tr12*tr3 + ci2 = Cc(i,1,k) + tr11*ti2 + tr12*ti3 + cr3 = Cc(i-1,1,k) + tr12*tr2 + tr11*tr3 + ci3 = Cc(i,1,k) + tr12*ti2 + tr11*ti3 + cr5 = ti11*tr5 + ti12*tr4 + ci5 = ti11*ti5 + ti12*ti4 + cr4 = ti12*tr5 - ti11*tr4 + ci4 = ti12*ti5 - ti11*ti4 + dr3 = cr3 - ci4 + dr4 = cr3 + ci4 + di3 = ci3 + cr4 + di4 = ci3 - cr4 + dr5 = cr2 + ci5 + dr2 = cr2 - ci5 + di5 = ci2 - cr5 + di2 = ci2 + cr5 + Ch(i-1,k,2) = Wa1(i-1)*dr2 + Wa1(i)*di2 + Ch(i,k,2) = Wa1(i-1)*di2 - Wa1(i)*dr2 + Ch(i-1,k,3) = Wa2(i-1)*dr3 + Wa2(i)*di3 + Ch(i,k,3) = Wa2(i-1)*di3 - Wa2(i)*dr3 + Ch(i-1,k,4) = Wa3(i-1)*dr4 + Wa3(i)*di4 + Ch(i,k,4) = Wa3(i-1)*di4 - Wa3(i)*dr4 + Ch(i-1,k,5) = Wa4(i-1)*dr5 + Wa4(i)*di5 + Ch(i,k,5) = Wa4(i-1)*di5 - Wa4(i)*dr5 + ENDDO + ENDDO + GOTO 99999 + ENDIF + DO k = 1 , L1 + ti5 = Cc(2,2,k) - Cc(2,5,k) + ti2 = Cc(2,2,k) + Cc(2,5,k) + ti4 = Cc(2,3,k) - Cc(2,4,k) + ti3 = Cc(2,3,k) + Cc(2,4,k) + tr5 = Cc(1,2,k) - Cc(1,5,k) + tr2 = Cc(1,2,k) + Cc(1,5,k) + tr4 = Cc(1,3,k) - Cc(1,4,k) + tr3 = Cc(1,3,k) + Cc(1,4,k) + Ch(1,k,1) = Cc(1,1,k) + tr2 + tr3 + Ch(2,k,1) = Cc(2,1,k) + ti2 + ti3 + cr2 = Cc(1,1,k) + tr11*tr2 + tr12*tr3 + ci2 = Cc(2,1,k) + tr11*ti2 + tr12*ti3 + cr3 = Cc(1,1,k) + tr12*tr2 + tr11*tr3 + ci3 = Cc(2,1,k) + tr12*ti2 + tr11*ti3 + cr5 = ti11*tr5 + ti12*tr4 + ci5 = ti11*ti5 + ti12*ti4 + cr4 = ti12*tr5 - ti11*tr4 + ci4 = ti12*ti5 - ti11*ti4 + Ch(1,k,2) = cr2 - ci5 + Ch(1,k,5) = cr2 + ci5 + Ch(2,k,2) = ci2 + cr5 + Ch(2,k,3) = ci3 + cr4 + Ch(1,k,3) = cr3 - ci4 + Ch(1,k,4) = cr3 + ci4 + Ch(2,k,4) = ci3 - cr4 + Ch(2,k,5) = ci2 - cr5 + ENDDO + RETURN +99999 END subroutine passf5 \ No newline at end of file diff --git a/src/radb2.f b/src/radb2.f deleted file mode 100644 index 8a05aed..0000000 --- a/src/radb2.f +++ /dev/null @@ -1,29 +0,0 @@ - SUBROUTINE RADB2 (IDO,L1,CC,CH,WA1) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , - 1 WA1(1) - DO 101 K=1,L1 - CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K) - CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) - TR2 = CC(I-1,1,K)-CC(IC-1,2,K) - CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) - TI2 = CC(I,1,K)+CC(IC,2,K) - CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 - CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 DO 106 K=1,L1 - CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K) - CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K)) - 106 CONTINUE - 107 RETURN - END diff --git a/src/radb2.f90 b/src/radb2.f90 new file mode 100644 index 0000000..c26c7ad --- /dev/null +++ b/src/radb2.f90 @@ -0,0 +1,35 @@ +!*==RADB2.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE RADB2(Ido,L1,Cc,Ch,Wa1) + USE FFTPACK_KIND + IMPLICIT NONE +!*--RADB21452 +!*** Start of declarations inserted by SPAG + REAL Cc , Ch , FFTPACK_KIND , rk , ti2 , tr2 , Wa1 + INTEGER i , ic , Ido , idp2 , k , L1 +!*** End of declarations inserted by SPAG + DIMENSION Cc(Ido,2,L1) , Ch(Ido,L1,2) , Wa1(1) + DO k = 1 , L1 + Ch(1,k,1) = Cc(1,1,k) + Cc(Ido,2,k) + Ch(1,k,2) = Cc(1,1,k) - Cc(Ido,2,k) + ENDDO + IF ( Ido<2 ) GOTO 99999 + IF ( Ido/=2 ) THEN + idp2 = Ido + 2 + DO k = 1 , L1 + DO i = 3 , Ido , 2 + ic = idp2 - i + Ch(i-1,k,1) = Cc(i-1,1,k) + Cc(ic-1,2,k) + tr2 = Cc(i-1,1,k) - Cc(ic-1,2,k) + Ch(i,k,1) = Cc(i,1,k) - Cc(ic,2,k) + ti2 = Cc(i,1,k) + Cc(ic,2,k) + Ch(i-1,k,2) = Wa1(i-2)*tr2 - Wa1(i-1)*ti2 + Ch(i,k,2) = Wa1(i-2)*ti2 + Wa1(i-1)*tr2 + ENDDO + ENDDO + IF ( MOD(Ido,2)==1 ) RETURN + ENDIF + DO k = 1 , L1 + Ch(Ido,k,1) = Cc(Ido,1,k) + Cc(Ido,1,k) + Ch(Ido,k,2) = -(Cc(1,2,k)+Cc(1,2,k)) + ENDDO +99999 END subroutine radb2 \ No newline at end of file diff --git a/src/radb3.f b/src/radb3.f deleted file mode 100644 index b5722e3..0000000 --- a/src/radb3.f +++ /dev/null @@ -1,40 +0,0 @@ - SUBROUTINE RADB3 (IDO,L1,CC,CH,WA1,WA2) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , - 1 WA1(1) ,WA2(1) -C *** TAUI IS SQRT(3)/2 *** - DATA TAUR,TAUI /-0.5D0,0.86602540378443864676D0/ - DO 101 K=1,L1 - TR2 = CC(IDO,2,K)+CC(IDO,2,K) - CR2 = CC(1,1,K)+TAUR*TR2 - CH(1,K,1) = CC(1,1,K)+TR2 - CI3 = TAUI*(CC(1,3,K)+CC(1,3,K)) - CH(1,K,2) = CR2-CI3 - CH(1,K,3) = CR2+CI3 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - TR2 = CC(I-1,3,K)+CC(IC-1,2,K) - CR2 = CC(I-1,1,K)+TAUR*TR2 - CH(I-1,K,1) = CC(I-1,1,K)+TR2 - TI2 = CC(I,3,K)-CC(IC,2,K) - CI2 = CC(I,1,K)+TAUR*TI2 - CH(I,K,1) = CC(I,1,K)+TI2 - CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) - CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) - DR2 = CR2-CI3 - DR3 = CR2+CI3 - DI2 = CI2+CR3 - DI3 = CI2-CR3 - CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 - CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 - CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 - CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 - 102 CONTINUE - 103 CONTINUE - RETURN - END diff --git a/src/radb3.f90 b/src/radb3.f90 new file mode 100644 index 0000000..32e0b6b --- /dev/null +++ b/src/radb3.f90 @@ -0,0 +1,45 @@ +!*==RADB3.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE RADB3(Ido,L1,Cc,Ch,Wa1,Wa2) + USE FFTPACK_KIND + IMPLICIT NONE +!*--RADB31487 +!*** Start of declarations inserted by SPAG + REAL Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , dr2 , dr3 , & + & FFTPACK_KIND , rk , taui , taur , ti2 , tr2 , Wa1 , Wa2 + INTEGER i , ic , Ido , idp2 , k , L1 +!*** End of declarations inserted by SPAG + DIMENSION Cc(Ido,3,L1) , Ch(Ido,L1,3) , Wa1(1) , Wa2(1) +! *** TAUI IS SQRT(3)/2 *** + DATA taur , taui/ - 0.5D0 , 0.86602540378443864676D0/ + DO k = 1 , L1 + tr2 = Cc(Ido,2,k) + Cc(Ido,2,k) + cr2 = Cc(1,1,k) + taur*tr2 + Ch(1,k,1) = Cc(1,1,k) + tr2 + ci3 = taui*(Cc(1,3,k)+Cc(1,3,k)) + Ch(1,k,2) = cr2 - ci3 + Ch(1,k,3) = cr2 + ci3 + ENDDO + IF ( Ido==1 ) RETURN + idp2 = Ido + 2 + DO k = 1 , L1 + DO i = 3 , Ido , 2 + ic = idp2 - i + tr2 = Cc(i-1,3,k) + Cc(ic-1,2,k) + cr2 = Cc(i-1,1,k) + taur*tr2 + Ch(i-1,k,1) = Cc(i-1,1,k) + tr2 + ti2 = Cc(i,3,k) - Cc(ic,2,k) + ci2 = Cc(i,1,k) + taur*ti2 + Ch(i,k,1) = Cc(i,1,k) + ti2 + cr3 = taui*(Cc(i-1,3,k)-Cc(ic-1,2,k)) + ci3 = taui*(Cc(i,3,k)+Cc(ic,2,k)) + dr2 = cr2 - ci3 + dr3 = cr2 + ci3 + di2 = ci2 + cr3 + di3 = ci2 - cr3 + Ch(i-1,k,2) = Wa1(i-2)*dr2 - Wa1(i-1)*di2 + Ch(i,k,2) = Wa1(i-2)*di2 + Wa1(i-1)*dr2 + Ch(i-1,k,3) = Wa2(i-2)*dr3 - Wa2(i-1)*di3 + Ch(i,k,3) = Wa2(i-2)*di3 + Wa2(i-1)*dr3 + ENDDO + ENDDO + END subroutine radb3 \ No newline at end of file diff --git a/src/radb4.f b/src/radb4.f deleted file mode 100644 index 72ff6a4..0000000 --- a/src/radb4.f +++ /dev/null @@ -1,59 +0,0 @@ - SUBROUTINE RADB4 (IDO,L1,CC,CH,WA1,WA2,WA3) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , - 1 WA1(1) ,WA2(1) ,WA3(1) - DATA SQRT2 /1.41421356237309504880D0/ - DO 101 K=1,L1 - TR1 = CC(1,1,K)-CC(IDO,4,K) - TR2 = CC(1,1,K)+CC(IDO,4,K) - TR3 = CC(IDO,2,K)+CC(IDO,2,K) - TR4 = CC(1,3,K)+CC(1,3,K) - CH(1,K,1) = TR2+TR3 - CH(1,K,2) = TR1-TR4 - CH(1,K,3) = TR2-TR3 - CH(1,K,4) = TR1+TR4 - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - TI1 = CC(I,1,K)+CC(IC,4,K) - TI2 = CC(I,1,K)-CC(IC,4,K) - TI3 = CC(I,3,K)-CC(IC,2,K) - TR4 = CC(I,3,K)+CC(IC,2,K) - TR1 = CC(I-1,1,K)-CC(IC-1,4,K) - TR2 = CC(I-1,1,K)+CC(IC-1,4,K) - TI4 = CC(I-1,3,K)-CC(IC-1,2,K) - TR3 = CC(I-1,3,K)+CC(IC-1,2,K) - CH(I-1,K,1) = TR2+TR3 - CR3 = TR2-TR3 - CH(I,K,1) = TI2+TI3 - CI3 = TI2-TI3 - CR2 = TR1-TR4 - CR4 = TR1+TR4 - CI2 = TI1+TI4 - CI4 = TI1-TI4 - CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 - CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 - CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 - CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 - CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 - CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 CONTINUE - DO 106 K=1,L1 - TI1 = CC(1,2,K)+CC(1,4,K) - TI2 = CC(1,4,K)-CC(1,2,K) - TR1 = CC(IDO,1,K)-CC(IDO,3,K) - TR2 = CC(IDO,1,K)+CC(IDO,3,K) - CH(IDO,K,1) = TR2+TR2 - CH(IDO,K,2) = SQRT2*(TR1-TI1) - CH(IDO,K,3) = TI2+TI2 - CH(IDO,K,4) = -SQRT2*(TR1+TI1) - 106 CONTINUE - 107 RETURN - END diff --git a/src/radb4.f90 b/src/radb4.f90 new file mode 100644 index 0000000..382a68a --- /dev/null +++ b/src/radb4.f90 @@ -0,0 +1,67 @@ +!*==RADB4.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE RADB4(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3) + USE FFTPACK_KIND + IMPLICIT NONE +!*--RADB41532 +!*** Start of declarations inserted by SPAG + REAL Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , FFTPACK_KIND , & + & rk , sqrt2 , ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3 , tr4 , & + & Wa1 + REAL Wa2 , Wa3 + INTEGER i , ic , Ido , idp2 , k , L1 +!*** End of declarations inserted by SPAG + DIMENSION Cc(Ido,4,L1) , Ch(Ido,L1,4) , Wa1(1) , Wa2(1) , Wa3(1) + DATA sqrt2/1.41421356237309504880D0/ + DO k = 1 , L1 + tr1 = Cc(1,1,k) - Cc(Ido,4,k) + tr2 = Cc(1,1,k) + Cc(Ido,4,k) + tr3 = Cc(Ido,2,k) + Cc(Ido,2,k) + tr4 = Cc(1,3,k) + Cc(1,3,k) + Ch(1,k,1) = tr2 + tr3 + Ch(1,k,2) = tr1 - tr4 + Ch(1,k,3) = tr2 - tr3 + Ch(1,k,4) = tr1 + tr4 + ENDDO + IF ( Ido<2 ) GOTO 99999 + IF ( Ido/=2 ) THEN + idp2 = Ido + 2 + DO k = 1 , L1 + DO i = 3 , Ido , 2 + ic = idp2 - i + ti1 = Cc(i,1,k) + Cc(ic,4,k) + ti2 = Cc(i,1,k) - Cc(ic,4,k) + ti3 = Cc(i,3,k) - Cc(ic,2,k) + tr4 = Cc(i,3,k) + Cc(ic,2,k) + tr1 = Cc(i-1,1,k) - Cc(ic-1,4,k) + tr2 = Cc(i-1,1,k) + Cc(ic-1,4,k) + ti4 = Cc(i-1,3,k) - Cc(ic-1,2,k) + tr3 = Cc(i-1,3,k) + Cc(ic-1,2,k) + Ch(i-1,k,1) = tr2 + tr3 + cr3 = tr2 - tr3 + Ch(i,k,1) = ti2 + ti3 + ci3 = ti2 - ti3 + cr2 = tr1 - tr4 + cr4 = tr1 + tr4 + ci2 = ti1 + ti4 + ci4 = ti1 - ti4 + Ch(i-1,k,2) = Wa1(i-2)*cr2 - Wa1(i-1)*ci2 + Ch(i,k,2) = Wa1(i-2)*ci2 + Wa1(i-1)*cr2 + Ch(i-1,k,3) = Wa2(i-2)*cr3 - Wa2(i-1)*ci3 + Ch(i,k,3) = Wa2(i-2)*ci3 + Wa2(i-1)*cr3 + Ch(i-1,k,4) = Wa3(i-2)*cr4 - Wa3(i-1)*ci4 + Ch(i,k,4) = Wa3(i-2)*ci4 + Wa3(i-1)*cr4 + ENDDO + ENDDO + IF ( MOD(Ido,2)==1 ) RETURN + ENDIF + DO k = 1 , L1 + ti1 = Cc(1,2,k) + Cc(1,4,k) + ti2 = Cc(1,4,k) - Cc(1,2,k) + tr1 = Cc(Ido,1,k) - Cc(Ido,3,k) + tr2 = Cc(Ido,1,k) + Cc(Ido,3,k) + Ch(Ido,k,1) = tr2 + tr2 + Ch(Ido,k,2) = sqrt2*(tr1-ti1) + Ch(Ido,k,3) = ti2 + ti2 + Ch(Ido,k,4) = -sqrt2*(tr1+ti1) + ENDDO +99999 END subroutine radb4 \ No newline at end of file diff --git a/src/radb5.f b/src/radb5.f deleted file mode 100644 index 3b90b46..0000000 --- a/src/radb5.f +++ /dev/null @@ -1,68 +0,0 @@ - SUBROUTINE RADB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , - 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) -C *** TR11=COS(2*PI/5), TI11=SIN(2*PI/5) -C *** TR12=COS(4*PI/5), TI12=SIN(4*PI/5) - DATA TR11,TI11,TR12,TI12 /0.3090169943749474241D0, - + 0.95105651629515357212D0, - + -0.8090169943749474241D0,0.58778525229247312917D0/ - DO 101 K=1,L1 - TI5 = CC(1,3,K)+CC(1,3,K) - TI4 = CC(1,5,K)+CC(1,5,K) - TR2 = CC(IDO,2,K)+CC(IDO,2,K) - TR3 = CC(IDO,4,K)+CC(IDO,4,K) - CH(1,K,1) = CC(1,1,K)+TR2+TR3 - CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 - CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 - CI5 = TI11*TI5+TI12*TI4 - CI4 = TI12*TI5-TI11*TI4 - CH(1,K,2) = CR2-CI5 - CH(1,K,3) = CR3-CI4 - CH(1,K,4) = CR3+CI4 - CH(1,K,5) = CR2+CI5 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - TI5 = CC(I,3,K)+CC(IC,2,K) - TI2 = CC(I,3,K)-CC(IC,2,K) - TI4 = CC(I,5,K)+CC(IC,4,K) - TI3 = CC(I,5,K)-CC(IC,4,K) - TR5 = CC(I-1,3,K)-CC(IC-1,2,K) - TR2 = CC(I-1,3,K)+CC(IC-1,2,K) - TR4 = CC(I-1,5,K)-CC(IC-1,4,K) - TR3 = CC(I-1,5,K)+CC(IC-1,4,K) - CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 - CH(I,K,1) = CC(I,1,K)+TI2+TI3 - CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - DR3 = CR3-CI4 - DR4 = CR3+CI4 - DI3 = CI3+CR4 - DI4 = CI3-CR4 - DR5 = CR2+CI5 - DR2 = CR2-CI5 - DI5 = CI2-CR5 - DI2 = CI2+CR5 - CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 - CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 - CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 - CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 - CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 - CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 - CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 - CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 - 102 CONTINUE - 103 CONTINUE - RETURN - END diff --git a/src/radb5.f90 b/src/radb5.f90 new file mode 100644 index 0000000..c743183 --- /dev/null +++ b/src/radb5.f90 @@ -0,0 +1,77 @@ +!*==RADB5.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE RADB5(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) + USE FFTPACK_KIND + IMPLICIT NONE +!*--RADB51599 +!*** Start of declarations inserted by SPAG + REAL Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , cr4 , cr5 , & + & di2 , di3 , di4 , di5 , dr2 , dr3 , dr4 , dr5 , & + & FFTPACK_KIND , rk + REAL ti11 , ti12 , ti2 , ti3 , ti4 , ti5 , tr11 , tr12 , tr2 , & + & tr3 , tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 + INTEGER i , ic , Ido , idp2 , k , L1 +!*** End of declarations inserted by SPAG + DIMENSION Cc(Ido,5,L1) , Ch(Ido,L1,5) , Wa1(1) , Wa2(1) , Wa3(1) ,& + & Wa4(1) +! *** TR11=COS(2*PI/5), TI11=SIN(2*PI/5) +! *** TR12=COS(4*PI/5), TI12=SIN(4*PI/5) + DATA tr11 , ti11 , tr12 , ti12/0.3090169943749474241D0 , & + & 0.95105651629515357212D0 , -0.8090169943749474241D0 , & + & 0.58778525229247312917D0/ + DO k = 1 , L1 + ti5 = Cc(1,3,k) + Cc(1,3,k) + ti4 = Cc(1,5,k) + Cc(1,5,k) + tr2 = Cc(Ido,2,k) + Cc(Ido,2,k) + tr3 = Cc(Ido,4,k) + Cc(Ido,4,k) + Ch(1,k,1) = Cc(1,1,k) + tr2 + tr3 + cr2 = Cc(1,1,k) + tr11*tr2 + tr12*tr3 + cr3 = Cc(1,1,k) + tr12*tr2 + tr11*tr3 + ci5 = ti11*ti5 + ti12*ti4 + ci4 = ti12*ti5 - ti11*ti4 + Ch(1,k,2) = cr2 - ci5 + Ch(1,k,3) = cr3 - ci4 + Ch(1,k,4) = cr3 + ci4 + Ch(1,k,5) = cr2 + ci5 + ENDDO + IF ( Ido==1 ) RETURN + idp2 = Ido + 2 + DO k = 1 , L1 + DO i = 3 , Ido , 2 + ic = idp2 - i + ti5 = Cc(i,3,k) + Cc(ic,2,k) + ti2 = Cc(i,3,k) - Cc(ic,2,k) + ti4 = Cc(i,5,k) + Cc(ic,4,k) + ti3 = Cc(i,5,k) - Cc(ic,4,k) + tr5 = Cc(i-1,3,k) - Cc(ic-1,2,k) + tr2 = Cc(i-1,3,k) + Cc(ic-1,2,k) + tr4 = Cc(i-1,5,k) - Cc(ic-1,4,k) + tr3 = Cc(i-1,5,k) + Cc(ic-1,4,k) + Ch(i-1,k,1) = Cc(i-1,1,k) + tr2 + tr3 + Ch(i,k,1) = Cc(i,1,k) + ti2 + ti3 + cr2 = Cc(i-1,1,k) + tr11*tr2 + tr12*tr3 + ci2 = Cc(i,1,k) + tr11*ti2 + tr12*ti3 + cr3 = Cc(i-1,1,k) + tr12*tr2 + tr11*tr3 + ci3 = Cc(i,1,k) + tr12*ti2 + tr11*ti3 + cr5 = ti11*tr5 + ti12*tr4 + ci5 = ti11*ti5 + ti12*ti4 + cr4 = ti12*tr5 - ti11*tr4 + ci4 = ti12*ti5 - ti11*ti4 + dr3 = cr3 - ci4 + dr4 = cr3 + ci4 + di3 = ci3 + cr4 + di4 = ci3 - cr4 + dr5 = cr2 + ci5 + dr2 = cr2 - ci5 + di5 = ci2 - cr5 + di2 = ci2 + cr5 + Ch(i-1,k,2) = Wa1(i-2)*dr2 - Wa1(i-1)*di2 + Ch(i,k,2) = Wa1(i-2)*di2 + Wa1(i-1)*dr2 + Ch(i-1,k,3) = Wa2(i-2)*dr3 - Wa2(i-1)*di3 + Ch(i,k,3) = Wa2(i-2)*di3 + Wa2(i-1)*dr3 + Ch(i-1,k,4) = Wa3(i-2)*dr4 - Wa3(i-1)*di4 + Ch(i,k,4) = Wa3(i-2)*di4 + Wa3(i-1)*dr4 + Ch(i-1,k,5) = Wa4(i-2)*dr5 - Wa4(i-1)*di5 + Ch(i,k,5) = Wa4(i-2)*di5 + Wa4(i-1)*dr5 + ENDDO + ENDDO + END subroutine radb5 \ No newline at end of file diff --git a/src/radbg.f b/src/radbg.f deleted file mode 100644 index c38e501..0000000 --- a/src/radbg.f +++ /dev/null @@ -1,162 +0,0 @@ - SUBROUTINE RADBG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , - 1 C1(IDO,L1,IP) ,C2(IDL1,IP), - 2 CH2(IDL1,IP) ,WA(1) - DATA TPI/6.28318530717958647692D0/ - ARG = TPI/REAL(IP,RK) - DCP = COS(ARG) - DSP = SIN(ARG) - IDP2 = IDO+2 - NBD = (IDO-1)/2 - IPP2 = IP+2 - IPPH = (IP+1)/2 - IF (IDO .LT. L1) GO TO 103 - DO 102 K=1,L1 - DO 101 I=1,IDO - CH(I,K,1) = CC(I,1,K) - 101 CONTINUE - 102 CONTINUE - GO TO 106 - 103 DO 105 I=1,IDO - DO 104 K=1,L1 - CH(I,K,1) = CC(I,1,K) - 104 CONTINUE - 105 CONTINUE - 106 DO 108 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 107 K=1,L1 - CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K) - CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K) - 107 CONTINUE - 108 CONTINUE - IF (IDO .EQ. 1) GO TO 116 - IF (NBD .LT. L1) GO TO 112 - DO 111 J=2,IPPH - JC = IPP2-J - DO 110 K=1,L1 - DO 109 I=3,IDO,2 - IC = IDP2-I - CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) - CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) - CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) - CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) - 109 CONTINUE - 110 CONTINUE - 111 CONTINUE - GO TO 116 - 112 DO 115 J=2,IPPH - JC = IPP2-J - DO 114 I=3,IDO,2 - IC = IDP2-I - DO 113 K=1,L1 - CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) - CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) - CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) - CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) - 113 CONTINUE - 114 CONTINUE - 115 CONTINUE - 116 AR1 = 1.0D0 - AI1 = 0.0D0 - DO 120 L=2,IPPH - LC = IPP2-L - AR1H = DCP*AR1-DSP*AI1 - AI1 = DCP*AI1+DSP*AR1 - AR1 = AR1H - DO 117 IK=1,IDL1 - C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2) - C2(IK,LC) = AI1*CH2(IK,IP) - 117 CONTINUE - DC2 = AR1 - DS2 = AI1 - AR2 = AR1 - AI2 = AI1 - DO 119 J=3,IPPH - JC = IPP2-J - AR2H = DC2*AR2-DS2*AI2 - AI2 = DC2*AI2+DS2*AR2 - AR2 = AR2H - DO 118 IK=1,IDL1 - C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J) - C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC) - 118 CONTINUE - 119 CONTINUE - 120 CONTINUE - DO 122 J=2,IPPH - DO 121 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+CH2(IK,J) - 121 CONTINUE - 122 CONTINUE - DO 124 J=2,IPPH - JC = IPP2-J - DO 123 K=1,L1 - CH(1,K,J) = C1(1,K,J)-C1(1,K,JC) - CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC) - 123 CONTINUE - 124 CONTINUE - IF (IDO .EQ. 1) GO TO 132 - IF (NBD .LT. L1) GO TO 128 - DO 127 J=2,IPPH - JC = IPP2-J - DO 126 K=1,L1 - DO 125 I=3,IDO,2 - CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) - CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) - CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) - CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) - 125 CONTINUE - 126 CONTINUE - 127 CONTINUE - GO TO 132 - 128 DO 131 J=2,IPPH - JC = IPP2-J - DO 130 I=3,IDO,2 - DO 129 K=1,L1 - CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) - CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) - CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) - CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) - 129 CONTINUE - 130 CONTINUE - 131 CONTINUE - 132 CONTINUE - IF (IDO .EQ. 1) RETURN - DO 133 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 133 CONTINUE - DO 135 J=2,IP - DO 134 K=1,L1 - C1(1,K,J) = CH(1,K,J) - 134 CONTINUE - 135 CONTINUE - IF (NBD .GT. L1) GO TO 139 - IS = -IDO - DO 138 J=2,IP - IS = IS+IDO - IDIJ = IS - DO 137 I=3,IDO,2 - IDIJ = IDIJ+2 - DO 136 K=1,L1 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 136 CONTINUE - 137 CONTINUE - 138 CONTINUE - GO TO 143 - 139 IS = -IDO - DO 142 J=2,IP - IS = IS+IDO - DO 141 K=1,L1 - IDIJ = IS - DO 140 I=3,IDO,2 - IDIJ = IDIJ+2 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 140 CONTINUE - 141 CONTINUE - 142 CONTINUE - 143 RETURN - END diff --git a/src/radbg.f90 b/src/radbg.f90 new file mode 100644 index 0000000..4f8f358 --- /dev/null +++ b/src/radbg.f90 @@ -0,0 +1,178 @@ +!*==RADBG.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE RADBG(Ido,Ip,L1,Idl1,Cc,C1,C2,Ch,Ch2,Wa) + USE FFTPACK_KIND + IMPLICIT NONE +!*--RADBG1676 +!*** Start of declarations inserted by SPAG + REAL ai1 , ai2 , ar1 , ar1h , ar2 , ar2h , arg , C1 , C2 , Cc , & + & Ch , Ch2 , dc2 , dcp , ds2 , dsp , FFTPACK_KIND , rk , tpi , & + & Wa + INTEGER i , ic , idij , Idl1 , Ido , idp2 , ik , Ip , ipp2 , & + & ipph , is , j , j2 , jc , k , l , L1 , lc , nbd +!*** End of declarations inserted by SPAG + DIMENSION Ch(Ido,L1,Ip) , Cc(Ido,Ip,L1) , C1(Ido,L1,Ip) , & + & C2(Idl1,Ip) , Ch2(Idl1,Ip) , Wa(1) + DATA tpi/6.28318530717958647692D0/ + arg = tpi/REAL(Ip,rk) + dcp = COS(arg) + dsp = SIN(arg) + idp2 = Ido + 2 + nbd = (Ido-1)/2 + ipp2 = Ip + 2 + ipph = (Ip+1)/2 + IF ( IdoL1 ) THEN + is = -Ido + DO j = 2 , Ip + is = is + Ido + DO k = 1 , L1 + idij = is + DO i = 3 , Ido , 2 + idij = idij + 2 + C1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & + & *Ch(i,k,j) + C1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & + & *Ch(i-1,k,j) + ENDDO + ENDDO + ENDDO + ELSE + is = -Ido + DO j = 2 , Ip + is = is + Ido + idij = is + DO i = 3 , Ido , 2 + idij = idij + 2 + DO k = 1 , L1 + C1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & + & *Ch(i,k,j) + C1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & + & *Ch(i-1,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + END subroutine radbg \ No newline at end of file diff --git a/src/radf2.f b/src/radf2.f deleted file mode 100644 index 184da2d..0000000 --- a/src/radf2.f +++ /dev/null @@ -1,29 +0,0 @@ - SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CH(IDO,2,L1) ,CC(IDO,L1,2) , - 1 WA1(1) - DO 101 K=1,L1 - CH(1,1,K) = CC(1,K,1)+CC(1,K,2) - CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - CH(I,1,K) = CC(I,K,1)+TI2 - CH(IC,2,K) = TI2-CC(I,K,1) - CH(I-1,1,K) = CC(I-1,K,1)+TR2 - CH(IC-1,2,K) = CC(I-1,K,1)-TR2 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 DO 106 K=1,L1 - CH(1,2,K) = -CC(IDO,K,2) - CH(IDO,1,K) = CC(IDO,K,1) - 106 CONTINUE - 107 RETURN - END diff --git a/src/radf2.f90 b/src/radf2.f90 new file mode 100644 index 0000000..f0666e3 --- /dev/null +++ b/src/radf2.f90 @@ -0,0 +1,35 @@ +!*==RADF2.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE RADF2(Ido,L1,Cc,Ch,Wa1) + USE FFTPACK_KIND + IMPLICIT NONE +!*--RADF21854 +!*** Start of declarations inserted by SPAG + REAL Cc , Ch , FFTPACK_KIND , rk , ti2 , tr2 , Wa1 + INTEGER i , ic , Ido , idp2 , k , L1 +!*** End of declarations inserted by SPAG + DIMENSION Ch(Ido,2,L1) , Cc(Ido,L1,2) , Wa1(1) + DO k = 1 , L1 + Ch(1,1,k) = Cc(1,k,1) + Cc(1,k,2) + Ch(Ido,2,k) = Cc(1,k,1) - Cc(1,k,2) + ENDDO + IF ( Ido<2 ) GOTO 99999 + IF ( Ido/=2 ) THEN + idp2 = Ido + 2 + DO k = 1 , L1 + DO i = 3 , Ido , 2 + ic = idp2 - i + tr2 = Wa1(i-2)*Cc(i-1,k,2) + Wa1(i-1)*Cc(i,k,2) + ti2 = Wa1(i-2)*Cc(i,k,2) - Wa1(i-1)*Cc(i-1,k,2) + Ch(i,1,k) = Cc(i,k,1) + ti2 + Ch(ic,2,k) = ti2 - Cc(i,k,1) + Ch(i-1,1,k) = Cc(i-1,k,1) + tr2 + Ch(ic-1,2,k) = Cc(i-1,k,1) - tr2 + ENDDO + ENDDO + IF ( MOD(Ido,2)==1 ) RETURN + ENDIF + DO k = 1 , L1 + Ch(1,2,k) = -Cc(Ido,k,2) + Ch(Ido,1,k) = Cc(Ido,k,1) + ENDDO +99999 END subroutine radf2 \ No newline at end of file diff --git a/src/radf3.f b/src/radf3.f deleted file mode 100644 index 078b6b2..0000000 --- a/src/radf3.f +++ /dev/null @@ -1,38 +0,0 @@ - SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CH(IDO,3,L1) ,CC(IDO,L1,3) , - 1 WA1(1) ,WA2(1) -C *** TAUI IS -SQRT(3)/2 *** - DATA TAUR,TAUI /-0.5D0,0.86602540378443864676D0/ - DO 101 K=1,L1 - CR2 = CC(1,K,2)+CC(1,K,3) - CH(1,1,K) = CC(1,K,1)+CR2 - CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2)) - CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - CR2 = DR2+DR3 - CI2 = DI2+DI3 - CH(I-1,1,K) = CC(I-1,K,1)+CR2 - CH(I,1,K) = CC(I,K,1)+CI2 - TR2 = CC(I-1,K,1)+TAUR*CR2 - TI2 = CC(I,K,1)+TAUR*CI2 - TR3 = TAUI*(DI2-DI3) - TI3 = TAUI*(DR3-DR2) - CH(I-1,3,K) = TR2+TR3 - CH(IC-1,2,K) = TR2-TR3 - CH(I,3,K) = TI2+TI3 - CH(IC,2,K) = TI3-TI2 - 102 CONTINUE - 103 CONTINUE - RETURN - END diff --git a/src/radf3.f90 b/src/radf3.f90 new file mode 100644 index 0000000..746ae36 --- /dev/null +++ b/src/radf3.f90 @@ -0,0 +1,43 @@ +!*==RADF3.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE RADF3(Ido,L1,Cc,Ch,Wa1,Wa2) + USE FFTPACK_KIND + IMPLICIT NONE +!*--RADF31889 +!*** Start of declarations inserted by SPAG + REAL Cc , Ch , ci2 , cr2 , di2 , di3 , dr2 , dr3 , FFTPACK_KIND , & + & rk , taui , taur , ti2 , ti3 , tr2 , tr3 , Wa1 , Wa2 + INTEGER i , ic , Ido , idp2 , k , L1 +!*** End of declarations inserted by SPAG + DIMENSION Ch(Ido,3,L1) , Cc(Ido,L1,3) , Wa1(1) , Wa2(1) +! *** TAUI IS -SQRT(3)/2 *** + DATA taur , taui/ - 0.5D0 , 0.86602540378443864676D0/ + DO k = 1 , L1 + cr2 = Cc(1,k,2) + Cc(1,k,3) + Ch(1,1,k) = Cc(1,k,1) + cr2 + Ch(1,3,k) = taui*(Cc(1,k,3)-Cc(1,k,2)) + Ch(Ido,2,k) = Cc(1,k,1) + taur*cr2 + ENDDO + IF ( Ido==1 ) RETURN + idp2 = Ido + 2 + DO k = 1 , L1 + DO i = 3 , Ido , 2 + ic = idp2 - i + dr2 = Wa1(i-2)*Cc(i-1,k,2) + Wa1(i-1)*Cc(i,k,2) + di2 = Wa1(i-2)*Cc(i,k,2) - Wa1(i-1)*Cc(i-1,k,2) + dr3 = Wa2(i-2)*Cc(i-1,k,3) + Wa2(i-1)*Cc(i,k,3) + di3 = Wa2(i-2)*Cc(i,k,3) - Wa2(i-1)*Cc(i-1,k,3) + cr2 = dr2 + dr3 + ci2 = di2 + di3 + Ch(i-1,1,k) = Cc(i-1,k,1) + cr2 + Ch(i,1,k) = Cc(i,k,1) + ci2 + tr2 = Cc(i-1,k,1) + taur*cr2 + ti2 = Cc(i,k,1) + taur*ci2 + tr3 = taui*(di2-di3) + ti3 = taui*(dr3-dr2) + Ch(i-1,3,k) = tr2 + tr3 + Ch(ic-1,2,k) = tr2 - tr3 + Ch(i,3,k) = ti2 + ti3 + Ch(ic,2,k) = ti3 - ti2 + ENDDO + ENDDO + END subroutine radf3 \ No newline at end of file diff --git a/src/radf4.f b/src/radf4.f deleted file mode 100644 index c7305f1..0000000 --- a/src/radf4.f +++ /dev/null @@ -1,55 +0,0 @@ - SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CC(IDO,L1,4) ,CH(IDO,4,L1) , - 1 WA1(1) ,WA2(1) ,WA3(1) - DATA HSQT2 /0.70710678118654752440D0/ - DO 101 K=1,L1 - TR1 = CC(1,K,2)+CC(1,K,4) - TR2 = CC(1,K,1)+CC(1,K,3) - CH(1,1,K) = TR1+TR2 - CH(IDO,4,K) = TR2-TR1 - CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3) - CH(1,3,K) = CC(1,K,4)-CC(1,K,2) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) - CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) - TR1 = CR2+CR4 - TR4 = CR4-CR2 - TI1 = CI2+CI4 - TI4 = CI2-CI4 - TI2 = CC(I,K,1)+CI3 - TI3 = CC(I,K,1)-CI3 - TR2 = CC(I-1,K,1)+CR3 - TR3 = CC(I-1,K,1)-CR3 - CH(I-1,1,K) = TR1+TR2 - CH(IC-1,4,K) = TR2-TR1 - CH(I,1,K) = TI1+TI2 - CH(IC,4,K) = TI1-TI2 - CH(I-1,3,K) = TI4+TR3 - CH(IC-1,2,K) = TR3-TI4 - CH(I,3,K) = TR4+TI3 - CH(IC,2,K) = TR4-TI3 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 CONTINUE - DO 106 K=1,L1 - TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4)) - TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4)) - CH(IDO,1,K) = TR1+CC(IDO,K,1) - CH(IDO,3,K) = CC(IDO,K,1)-TR1 - CH(1,2,K) = TI1-CC(IDO,K,3) - CH(1,4,K) = TI1+CC(IDO,K,3) - 106 CONTINUE - 107 RETURN - END diff --git a/src/radf4.f90 b/src/radf4.f90 new file mode 100644 index 0000000..468ba9a --- /dev/null +++ b/src/radf4.f90 @@ -0,0 +1,63 @@ +!*==RADF4.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE RADF4(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3) + USE FFTPACK_KIND + IMPLICIT NONE +!*--RADF41932 +!*** Start of declarations inserted by SPAG + REAL Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , FFTPACK_KIND , & + & hsqt2 , rk , ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3 , tr4 , & + & Wa1 + REAL Wa2 , Wa3 + INTEGER i , ic , Ido , idp2 , k , L1 +!*** End of declarations inserted by SPAG + DIMENSION Cc(Ido,L1,4) , Ch(Ido,4,L1) , Wa1(1) , Wa2(1) , Wa3(1) + DATA hsqt2/0.70710678118654752440D0/ + DO k = 1 , L1 + tr1 = Cc(1,k,2) + Cc(1,k,4) + tr2 = Cc(1,k,1) + Cc(1,k,3) + Ch(1,1,k) = tr1 + tr2 + Ch(Ido,4,k) = tr2 - tr1 + Ch(Ido,2,k) = Cc(1,k,1) - Cc(1,k,3) + Ch(1,3,k) = Cc(1,k,4) - Cc(1,k,2) + ENDDO + IF ( Ido<2 ) GOTO 99999 + IF ( Ido/=2 ) THEN + idp2 = Ido + 2 + DO k = 1 , L1 + DO i = 3 , Ido , 2 + ic = idp2 - i + cr2 = Wa1(i-2)*Cc(i-1,k,2) + Wa1(i-1)*Cc(i,k,2) + ci2 = Wa1(i-2)*Cc(i,k,2) - Wa1(i-1)*Cc(i-1,k,2) + cr3 = Wa2(i-2)*Cc(i-1,k,3) + Wa2(i-1)*Cc(i,k,3) + ci3 = Wa2(i-2)*Cc(i,k,3) - Wa2(i-1)*Cc(i-1,k,3) + cr4 = Wa3(i-2)*Cc(i-1,k,4) + Wa3(i-1)*Cc(i,k,4) + ci4 = Wa3(i-2)*Cc(i,k,4) - Wa3(i-1)*Cc(i-1,k,4) + tr1 = cr2 + cr4 + tr4 = cr4 - cr2 + ti1 = ci2 + ci4 + ti4 = ci2 - ci4 + ti2 = Cc(i,k,1) + ci3 + ti3 = Cc(i,k,1) - ci3 + tr2 = Cc(i-1,k,1) + cr3 + tr3 = Cc(i-1,k,1) - cr3 + Ch(i-1,1,k) = tr1 + tr2 + Ch(ic-1,4,k) = tr2 - tr1 + Ch(i,1,k) = ti1 + ti2 + Ch(ic,4,k) = ti1 - ti2 + Ch(i-1,3,k) = ti4 + tr3 + Ch(ic-1,2,k) = tr3 - ti4 + Ch(i,3,k) = tr4 + ti3 + Ch(ic,2,k) = tr4 - ti3 + ENDDO + ENDDO + IF ( MOD(Ido,2)==1 ) RETURN + ENDIF + DO k = 1 , L1 + ti1 = -hsqt2*(Cc(Ido,k,2)+Cc(Ido,k,4)) + tr1 = hsqt2*(Cc(Ido,k,2)-Cc(Ido,k,4)) + Ch(Ido,1,k) = tr1 + Cc(Ido,k,1) + Ch(Ido,3,k) = Cc(Ido,k,1) - tr1 + Ch(1,2,k) = ti1 - Cc(Ido,k,3) + Ch(1,4,k) = ti1 + Cc(Ido,k,3) + ENDDO +99999 END subroutine radf4 \ No newline at end of file diff --git a/src/radf5.f b/src/radf5.f deleted file mode 100644 index bd79c6d..0000000 --- a/src/radf5.f +++ /dev/null @@ -1,62 +0,0 @@ - SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CC(IDO,L1,5) ,CH(IDO,5,L1) , - 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) - DATA TR11,TI11,TR12,TI12 /0.3090169943749474241D0, - + 0.95105651629515357212D0, - 1 -0.8090169943749474241D0, 0.58778525229247312917D0/ - DO 101 K=1,L1 - CR2 = CC(1,K,5)+CC(1,K,2) - CI5 = CC(1,K,5)-CC(1,K,2) - CR3 = CC(1,K,4)+CC(1,K,3) - CI4 = CC(1,K,4)-CC(1,K,3) - CH(1,1,K) = CC(1,K,1)+CR2+CR3 - CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3 - CH(1,3,K) = TI11*CI5+TI12*CI4 - CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3 - CH(1,5,K) = TI12*CI5-TI11*CI4 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) - DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) - DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) - DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) - CR2 = DR2+DR5 - CI5 = DR5-DR2 - CR5 = DI2-DI5 - CI2 = DI2+DI5 - CR3 = DR3+DR4 - CI4 = DR4-DR3 - CR4 = DI3-DI4 - CI3 = DI3+DI4 - CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 - CH(I,1,K) = CC(I,K,1)+CI2+CI3 - TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 - TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 - TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 - TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 - TR5 = TI11*CR5+TI12*CR4 - TI5 = TI11*CI5+TI12*CI4 - TR4 = TI12*CR5-TI11*CR4 - TI4 = TI12*CI5-TI11*CI4 - CH(I-1,3,K) = TR2+TR5 - CH(IC-1,2,K) = TR2-TR5 - CH(I,3,K) = TI2+TI5 - CH(IC,2,K) = TI5-TI2 - CH(I-1,5,K) = TR3+TR4 - CH(IC-1,4,K) = TR3-TR4 - CH(I,5,K) = TI3+TI4 - CH(IC,4,K) = TI4-TI3 - 102 CONTINUE - 103 CONTINUE - RETURN - END diff --git a/src/radf5.f90 b/src/radf5.f90 new file mode 100644 index 0000000..ad08267 --- /dev/null +++ b/src/radf5.f90 @@ -0,0 +1,71 @@ +!*==RADF5.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE RADF5(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) + USE FFTPACK_KIND + IMPLICIT NONE +!*--RADF51995 +!*** Start of declarations inserted by SPAG + REAL Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , cr4 , cr5 , & + & di2 , di3 , di4 , di5 , dr2 , dr3 , dr4 , dr5 , & + & FFTPACK_KIND , rk + REAL ti11 , ti12 , ti2 , ti3 , ti4 , ti5 , tr11 , tr12 , tr2 , & + & tr3 , tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 + INTEGER i , ic , Ido , idp2 , k , L1 +!*** End of declarations inserted by SPAG + DIMENSION Cc(Ido,L1,5) , Ch(Ido,5,L1) , Wa1(1) , Wa2(1) , Wa3(1) ,& + & Wa4(1) + DATA tr11 , ti11 , tr12 , ti12/0.3090169943749474241D0 , & + & 0.95105651629515357212D0 , -0.8090169943749474241D0 , & + & 0.58778525229247312917D0/ + DO k = 1 , L1 + cr2 = Cc(1,k,5) + Cc(1,k,2) + ci5 = Cc(1,k,5) - Cc(1,k,2) + cr3 = Cc(1,k,4) + Cc(1,k,3) + ci4 = Cc(1,k,4) - Cc(1,k,3) + Ch(1,1,k) = Cc(1,k,1) + cr2 + cr3 + Ch(Ido,2,k) = Cc(1,k,1) + tr11*cr2 + tr12*cr3 + Ch(1,3,k) = ti11*ci5 + ti12*ci4 + Ch(Ido,4,k) = Cc(1,k,1) + tr12*cr2 + tr11*cr3 + Ch(1,5,k) = ti12*ci5 - ti11*ci4 + ENDDO + IF ( Ido==1 ) RETURN + idp2 = Ido + 2 + DO k = 1 , L1 + DO i = 3 , Ido , 2 + ic = idp2 - i + dr2 = Wa1(i-2)*Cc(i-1,k,2) + Wa1(i-1)*Cc(i,k,2) + di2 = Wa1(i-2)*Cc(i,k,2) - Wa1(i-1)*Cc(i-1,k,2) + dr3 = Wa2(i-2)*Cc(i-1,k,3) + Wa2(i-1)*Cc(i,k,3) + di3 = Wa2(i-2)*Cc(i,k,3) - Wa2(i-1)*Cc(i-1,k,3) + dr4 = Wa3(i-2)*Cc(i-1,k,4) + Wa3(i-1)*Cc(i,k,4) + di4 = Wa3(i-2)*Cc(i,k,4) - Wa3(i-1)*Cc(i-1,k,4) + dr5 = Wa4(i-2)*Cc(i-1,k,5) + Wa4(i-1)*Cc(i,k,5) + di5 = Wa4(i-2)*Cc(i,k,5) - Wa4(i-1)*Cc(i-1,k,5) + cr2 = dr2 + dr5 + ci5 = dr5 - dr2 + cr5 = di2 - di5 + ci2 = di2 + di5 + cr3 = dr3 + dr4 + ci4 = dr4 - dr3 + cr4 = di3 - di4 + ci3 = di3 + di4 + Ch(i-1,1,k) = Cc(i-1,k,1) + cr2 + cr3 + Ch(i,1,k) = Cc(i,k,1) + ci2 + ci3 + tr2 = Cc(i-1,k,1) + tr11*cr2 + tr12*cr3 + ti2 = Cc(i,k,1) + tr11*ci2 + tr12*ci3 + tr3 = Cc(i-1,k,1) + tr12*cr2 + tr11*cr3 + ti3 = Cc(i,k,1) + tr12*ci2 + tr11*ci3 + tr5 = ti11*cr5 + ti12*cr4 + ti5 = ti11*ci5 + ti12*ci4 + tr4 = ti12*cr5 - ti11*cr4 + ti4 = ti12*ci5 - ti11*ci4 + Ch(i-1,3,k) = tr2 + tr5 + Ch(ic-1,2,k) = tr2 - tr5 + Ch(i,3,k) = ti2 + ti5 + Ch(ic,2,k) = ti5 - ti2 + Ch(i-1,5,k) = tr3 + tr4 + Ch(ic-1,4,k) = tr3 - tr4 + Ch(i,5,k) = ti3 + ti4 + Ch(ic,4,k) = ti4 - ti3 + ENDDO + ENDDO + END subroutine radf5 \ No newline at end of file diff --git a/src/radfg.f b/src/radfg.f deleted file mode 100644 index eac2006..0000000 --- a/src/radfg.f +++ /dev/null @@ -1,168 +0,0 @@ - SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - USE fftpack_kind - IMPLICIT REAL(RK) (A-H,O-Z) - DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , - 1 C1(IDO,L1,IP) ,C2(IDL1,IP), - 2 CH2(IDL1,IP) ,WA(1) - DATA TPI/6.28318530717958647692D0/ - ARG = TPI/REAL(IP,RK) - DCP = COS(ARG) - DSP = SIN(ARG) - IPPH = (IP+1)/2 - IPP2 = IP+2 - IDP2 = IDO+2 - NBD = (IDO-1)/2 - IF (IDO .EQ. 1) GO TO 119 - DO 101 IK=1,IDL1 - CH2(IK,1) = C2(IK,1) - 101 CONTINUE - DO 103 J=2,IP - DO 102 K=1,L1 - CH(1,K,J) = C1(1,K,J) - 102 CONTINUE - 103 CONTINUE - IF (NBD .GT. L1) GO TO 107 - IS = -IDO - DO 106 J=2,IP - IS = IS+IDO - IDIJ = IS - DO 105 I=3,IDO,2 - IDIJ = IDIJ+2 - DO 104 K=1,L1 - CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) - CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) - 104 CONTINUE - 105 CONTINUE - 106 CONTINUE - GO TO 111 - 107 IS = -IDO - DO 110 J=2,IP - IS = IS+IDO - DO 109 K=1,L1 - IDIJ = IS - DO 108 I=3,IDO,2 - IDIJ = IDIJ+2 - CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) - CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) - 108 CONTINUE - 109 CONTINUE - 110 CONTINUE - 111 IF (NBD .LT. L1) GO TO 115 - DO 114 J=2,IPPH - JC = IPP2-J - DO 113 K=1,L1 - DO 112 I=3,IDO,2 - C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) - C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) - C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) - C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) - 112 CONTINUE - 113 CONTINUE - 114 CONTINUE - GO TO 121 - 115 DO 118 J=2,IPPH - JC = IPP2-J - DO 117 I=3,IDO,2 - DO 116 K=1,L1 - C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) - C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) - C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) - C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) - 116 CONTINUE - 117 CONTINUE - 118 CONTINUE - GO TO 121 - 119 DO 120 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 120 CONTINUE - 121 DO 123 J=2,IPPH - JC = IPP2-J - DO 122 K=1,L1 - C1(1,K,J) = CH(1,K,J)+CH(1,K,JC) - C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J) - 122 CONTINUE - 123 CONTINUE -C - AR1 = 1.0D0 - AI1 = 0.0D0 - DO 127 L=2,IPPH - LC = IPP2-L - AR1H = DCP*AR1-DSP*AI1 - AI1 = DCP*AI1+DSP*AR1 - AR1 = AR1H - DO 124 IK=1,IDL1 - CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2) - CH2(IK,LC) = AI1*C2(IK,IP) - 124 CONTINUE - DC2 = AR1 - DS2 = AI1 - AR2 = AR1 - AI2 = AI1 - DO 126 J=3,IPPH - JC = IPP2-J - AR2H = DC2*AR2-DS2*AI2 - AI2 = DC2*AI2+DS2*AR2 - AR2 = AR2H - DO 125 IK=1,IDL1 - CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J) - CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC) - 125 CONTINUE - 126 CONTINUE - 127 CONTINUE - DO 129 J=2,IPPH - DO 128 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+C2(IK,J) - 128 CONTINUE - 129 CONTINUE -C - IF (IDO .LT. L1) GO TO 132 - DO 131 K=1,L1 - DO 130 I=1,IDO - CC(I,1,K) = CH(I,K,1) - 130 CONTINUE - 131 CONTINUE - GO TO 135 - 132 DO 134 I=1,IDO - DO 133 K=1,L1 - CC(I,1,K) = CH(I,K,1) - 133 CONTINUE - 134 CONTINUE - 135 DO 137 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 136 K=1,L1 - CC(IDO,J2-2,K) = CH(1,K,J) - CC(1,J2-1,K) = CH(1,K,JC) - 136 CONTINUE - 137 CONTINUE - IF (IDO .EQ. 1) RETURN - IF (NBD .LT. L1) GO TO 141 - DO 140 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 139 K=1,L1 - DO 138 I=3,IDO,2 - IC = IDP2-I - CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) - CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) - CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) - CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) - 138 CONTINUE - 139 CONTINUE - 140 CONTINUE - RETURN - 141 DO 144 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 143 I=3,IDO,2 - IC = IDP2-I - DO 142 K=1,L1 - CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) - CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) - CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) - CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) - 142 CONTINUE - 143 CONTINUE - 144 CONTINUE - RETURN - END diff --git a/src/radfg.f90 b/src/radfg.f90 new file mode 100644 index 0000000..cb855dc --- /dev/null +++ b/src/radfg.f90 @@ -0,0 +1,185 @@ +!*==RADFG.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 + SUBROUTINE RADFG(Ido,Ip,L1,Idl1,Cc,C1,C2,Ch,Ch2,Wa) + USE FFTPACK_KIND + IMPLICIT NONE +!*--RADFG2066 +!*** Start of declarations inserted by SPAG + REAL ai1 , ai2 , ar1 , ar1h , ar2 , ar2h , arg , C1 , C2 , Cc , & + & Ch , Ch2 , dc2 , dcp , ds2 , dsp , FFTPACK_KIND , rk , tpi , & + & Wa + INTEGER i , ic , idij , Idl1 , Ido , idp2 , ik , Ip , ipp2 , & + & ipph , is , j , j2 , jc , k , l , L1 , lc , nbd +!*** End of declarations inserted by SPAG + DIMENSION Ch(Ido,L1,Ip) , Cc(Ido,Ip,L1) , C1(Ido,L1,Ip) , & + & C2(Idl1,Ip) , Ch2(Idl1,Ip) , Wa(1) + DATA tpi/6.28318530717958647692D0/ + arg = tpi/REAL(Ip,rk) + dcp = COS(arg) + dsp = SIN(arg) + ipph = (Ip+1)/2 + ipp2 = Ip + 2 + idp2 = Ido + 2 + nbd = (Ido-1)/2 + IF ( Ido==1 ) THEN + DO ik = 1 , Idl1 + C2(ik,1) = Ch2(ik,1) + ENDDO + ELSE + DO ik = 1 , Idl1 + Ch2(ik,1) = C2(ik,1) + ENDDO + DO j = 2 , Ip + DO k = 1 , L1 + Ch(1,k,j) = C1(1,k,j) + ENDDO + ENDDO + IF ( nbd>L1 ) THEN + is = -Ido + DO j = 2 , Ip + is = is + Ido + DO k = 1 , L1 + idij = is + DO i = 3 , Ido , 2 + idij = idij + 2 + Ch(i-1,k,j) = Wa(idij-1)*C1(i-1,k,j) + Wa(idij) & + & *C1(i,k,j) + Ch(i,k,j) = Wa(idij-1)*C1(i,k,j) - Wa(idij) & + & *C1(i-1,k,j) + ENDDO + ENDDO + ENDDO + ELSE + is = -Ido + DO j = 2 , Ip + is = is + Ido + idij = is + DO i = 3 , Ido , 2 + idij = idij + 2 + DO k = 1 , L1 + Ch(i-1,k,j) = Wa(idij-1)*C1(i-1,k,j) + Wa(idij) & + & *C1(i,k,j) + Ch(i,k,j) = Wa(idij-1)*C1(i,k,j) - Wa(idij) & + & *C1(i-1,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + IF ( nbd Date: Tue, 14 Sep 2021 20:33:03 -0600 Subject: [PATCH 05/10] lowercase --- src/cfftb1.f90 | 96 +++++++++--------- src/cfftf1.f90 | 96 +++++++++--------- src/cffti1.f90 | 82 ++++++++-------- src/cosqb1.f90 | 56 +++++------ src/cosqf1.f90 | 52 +++++----- src/dcosqb.f90 | 38 +++---- src/dcosqf.f90 | 36 +++---- src/dcosqi.f90 | 30 +++--- src/dcost.f90 | 88 ++++++++--------- src/dcosti.f90 | 40 ++++---- src/dfftb.f90 | 18 ++-- src/dfftf.f90 | 18 ++-- src/dffti.f90 | 18 ++-- src/dsinqb.f90 | 46 ++++----- src/dsinqf.f90 | 38 +++---- src/dsinqi.f90 | 16 +-- src/dsint.f90 | 20 ++-- src/dsinti.f90 | 32 +++--- src/dzfftb.f90 | 48 ++++----- src/dzfftf.f90 | 60 +++++------ src/dzffti.f90 | 18 ++-- src/ezfft1.f90 | 78 +++++++-------- src/passb.f90 | 176 ++++++++++++++++----------------- src/passb2.f90 | 34 +++---- src/passb3.f90 | 38 +++---- src/passb4.f90 | 36 +++---- src/passb5.f90 | 44 ++++----- src/passf.f90 | 176 ++++++++++++++++----------------- src/passf2.f90 | 34 +++---- src/passf3.f90 | 38 +++---- src/passf4.f90 | 36 +++---- src/passf5.f90 | 44 ++++----- src/radb2.f90 | 38 +++---- src/radb3.f90 | 32 +++--- src/radb4.f90 | 42 ++++---- src/radb5.f90 | 38 +++---- src/radbg.f90 | 246 +++++++++++++++++++++++----------------------- src/radf2.f90 | 38 +++---- src/radf3.f90 | 30 +++--- src/radf4.f90 | 42 ++++---- src/radf5.f90 | 38 +++---- src/radfg.f90 | 262 ++++++++++++++++++++++++------------------------- src/rfftb1.f90 | 94 +++++++++--------- src/rfftf1.f90 | 98 +++++++++--------- src/rffti1.f90 | 76 +++++++------- src/sint1.f90 | 68 ++++++------- src/zfftb.f90 | 22 ++--- src/zfftf.f90 | 22 ++--- src/zffti.f90 | 22 ++--- 49 files changed, 1444 insertions(+), 1444 deletions(-) diff --git a/src/cfftb1.f90 b/src/cfftb1.f90 index b09113a..efc29bc 100644 --- a/src/cfftb1.f90 +++ b/src/cfftb1.f90 @@ -1,72 +1,72 @@ !*==CFFTB1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE CFFTB1(N,C,Ch,Wa,Ifac) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine cfftb1(n,c,Ch,Wa,Ifac) + use fftpack_kind + implicit none !*--CFFTB15 !*** Start of declarations inserted by SPAG - REAL C , Ch , FFTPACK_KIND , rk , Wa - INTEGER i , idl1 , ido , idot , Ifac , ip , iw , ix2 , ix3 , ix4 ,& - & k1 , l1 , l2 , N , n2 , na , nac , nf + real c , Ch , fftpack_kind , rk , Wa + integer i , idl1 , ido , idot , Ifac , ip , iw , ix2 , ix3 , ix4 ,& + & k1 , l1 , l2 , n , n2 , na , nac , nf !*** End of declarations inserted by SPAG - DIMENSION Ch(*) , C(*) , Wa(*) , Ifac(*) + dimension Ch(*) , c(*) , Wa(*) , Ifac(*) nf = Ifac(2) na = 0 l1 = 1 iw = 1 - DO k1 = 1 , nf + do k1 = 1 , nf ip = Ifac(k1+2) l2 = ip*l1 - ido = N/l2 + ido = n/l2 idot = ido + ido idl1 = idot*l1 - IF ( ip==4 ) THEN + if ( ip==4 ) then ix2 = iw + idot ix3 = ix2 + idot - IF ( na/=0 ) THEN - CALL PASSB4(idot,l1,Ch,C,Wa(iw),Wa(ix2),Wa(ix3)) - ELSE - CALL PASSB4(idot,l1,C,Ch,Wa(iw),Wa(ix2),Wa(ix3)) - ENDIF + if ( na/=0 ) then + call passb4(idot,l1,Ch,c,Wa(iw),Wa(ix2),Wa(ix3)) + else + call passb4(idot,l1,c,Ch,Wa(iw),Wa(ix2),Wa(ix3)) + endif na = 1 - na - ELSEIF ( ip==2 ) THEN - IF ( na/=0 ) THEN - CALL PASSB2(idot,l1,Ch,C,Wa(iw)) - ELSE - CALL PASSB2(idot,l1,C,Ch,Wa(iw)) - ENDIF + elseif ( ip==2 ) then + if ( na/=0 ) then + call passb2(idot,l1,Ch,c,Wa(iw)) + else + call passb2(idot,l1,c,Ch,Wa(iw)) + endif na = 1 - na - ELSEIF ( ip==3 ) THEN + elseif ( ip==3 ) then ix2 = iw + idot - IF ( na/=0 ) THEN - CALL PASSB3(idot,l1,Ch,C,Wa(iw),Wa(ix2)) - ELSE - CALL PASSB3(idot,l1,C,Ch,Wa(iw),Wa(ix2)) - ENDIF + if ( na/=0 ) then + call passb3(idot,l1,Ch,c,Wa(iw),Wa(ix2)) + else + call passb3(idot,l1,c,Ch,Wa(iw),Wa(ix2)) + endif na = 1 - na - ELSEIF ( ip/=5 ) THEN - IF ( na/=0 ) THEN - CALL PASSB(nac,idot,ip,l1,idl1,Ch,Ch,Ch,C,C,Wa(iw)) - ELSE - CALL PASSB(nac,idot,ip,l1,idl1,C,C,C,Ch,Ch,Wa(iw)) - ENDIF - IF ( nac/=0 ) na = 1 - na - ELSE + elseif ( ip/=5 ) then + if ( na/=0 ) then + call passb(nac,idot,ip,l1,idl1,Ch,Ch,Ch,c,c,Wa(iw)) + else + call passb(nac,idot,ip,l1,idl1,c,c,c,Ch,Ch,Wa(iw)) + endif + if ( nac/=0 ) na = 1 - na + else ix2 = iw + idot ix3 = ix2 + idot ix4 = ix3 + idot - IF ( na/=0 ) THEN - CALL PASSB5(idot,l1,Ch,C,Wa(iw),Wa(ix2),Wa(ix3),Wa(ix4)) - ELSE - CALL PASSB5(idot,l1,C,Ch,Wa(iw),Wa(ix2),Wa(ix3),Wa(ix4)) - ENDIF + if ( na/=0 ) then + call passb5(idot,l1,Ch,c,Wa(iw),Wa(ix2),Wa(ix3),Wa(ix4)) + else + call passb5(idot,l1,c,Ch,Wa(iw),Wa(ix2),Wa(ix3),Wa(ix4)) + endif na = 1 - na - ENDIF + endif l1 = l2 iw = iw + (ip-1)*idot - ENDDO - IF ( na==0 ) RETURN - n2 = N + N - DO i = 1 , n2 - C(i) = Ch(i) - ENDDO - END subroutine cfftb1 \ No newline at end of file + enddo + if ( na==0 ) return + n2 = n + n + do i = 1 , n2 + c(i) = Ch(i) + enddo + end subroutine cfftb1 \ No newline at end of file diff --git a/src/cfftf1.f90 b/src/cfftf1.f90 index b061876..39ffbb8 100644 --- a/src/cfftf1.f90 +++ b/src/cfftf1.f90 @@ -1,72 +1,72 @@ !*==CFFTF1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE CFFTF1(N,C,Ch,Wa,Ifac) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine cfftf1(n,c,Ch,Wa,Ifac) + use fftpack_kind + implicit none !*--CFFTF177 !*** Start of declarations inserted by SPAG - REAL C , Ch , FFTPACK_KIND , rk , Wa - INTEGER i , idl1 , ido , idot , Ifac , ip , iw , ix2 , ix3 , ix4 ,& - & k1 , l1 , l2 , N , n2 , na , nac , nf + real c , Ch , fftpack_kind , rk , Wa + integer i , idl1 , ido , idot , Ifac , ip , iw , ix2 , ix3 , ix4 ,& + & k1 , l1 , l2 , n , n2 , na , nac , nf !*** End of declarations inserted by SPAG - DIMENSION Ch(*) , C(*) , Wa(*) , Ifac(*) + dimension Ch(*) , c(*) , Wa(*) , Ifac(*) nf = Ifac(2) na = 0 l1 = 1 iw = 1 - DO k1 = 1 , nf + do k1 = 1 , nf ip = Ifac(k1+2) l2 = ip*l1 - ido = N/l2 + ido = n/l2 idot = ido + ido idl1 = idot*l1 - IF ( ip==4 ) THEN + if ( ip==4 ) then ix2 = iw + idot ix3 = ix2 + idot - IF ( na/=0 ) THEN - CALL PASSF4(idot,l1,Ch,C,Wa(iw),Wa(ix2),Wa(ix3)) - ELSE - CALL PASSF4(idot,l1,C,Ch,Wa(iw),Wa(ix2),Wa(ix3)) - ENDIF + if ( na/=0 ) then + call passf4(idot,l1,Ch,c,Wa(iw),Wa(ix2),Wa(ix3)) + else + call passf4(idot,l1,c,Ch,Wa(iw),Wa(ix2),Wa(ix3)) + endif na = 1 - na - ELSEIF ( ip==2 ) THEN - IF ( na/=0 ) THEN - CALL PASSF2(idot,l1,Ch,C,Wa(iw)) - ELSE - CALL PASSF2(idot,l1,C,Ch,Wa(iw)) - ENDIF + elseif ( ip==2 ) then + if ( na/=0 ) then + call passf2(idot,l1,Ch,c,Wa(iw)) + else + call passf2(idot,l1,c,Ch,Wa(iw)) + endif na = 1 - na - ELSEIF ( ip==3 ) THEN + elseif ( ip==3 ) then ix2 = iw + idot - IF ( na/=0 ) THEN - CALL PASSF3(idot,l1,Ch,C,Wa(iw),Wa(ix2)) - ELSE - CALL PASSF3(idot,l1,C,Ch,Wa(iw),Wa(ix2)) - ENDIF + if ( na/=0 ) then + call passf3(idot,l1,Ch,c,Wa(iw),Wa(ix2)) + else + call passf3(idot,l1,c,Ch,Wa(iw),Wa(ix2)) + endif na = 1 - na - ELSEIF ( ip/=5 ) THEN - IF ( na/=0 ) THEN - CALL PASSF(nac,idot,ip,l1,idl1,Ch,Ch,Ch,C,C,Wa(iw)) - ELSE - CALL PASSF(nac,idot,ip,l1,idl1,C,C,C,Ch,Ch,Wa(iw)) - ENDIF - IF ( nac/=0 ) na = 1 - na - ELSE + elseif ( ip/=5 ) then + if ( na/=0 ) then + call passf(nac,idot,ip,l1,idl1,Ch,Ch,Ch,c,c,Wa(iw)) + else + call passf(nac,idot,ip,l1,idl1,c,c,c,Ch,Ch,Wa(iw)) + endif + if ( nac/=0 ) na = 1 - na + else ix2 = iw + idot ix3 = ix2 + idot ix4 = ix3 + idot - IF ( na/=0 ) THEN - CALL PASSF5(idot,l1,Ch,C,Wa(iw),Wa(ix2),Wa(ix3),Wa(ix4)) - ELSE - CALL PASSF5(idot,l1,C,Ch,Wa(iw),Wa(ix2),Wa(ix3),Wa(ix4)) - ENDIF + if ( na/=0 ) then + call passf5(idot,l1,Ch,c,Wa(iw),Wa(ix2),Wa(ix3),Wa(ix4)) + else + call passf5(idot,l1,c,Ch,Wa(iw),Wa(ix2),Wa(ix3),Wa(ix4)) + endif na = 1 - na - ENDIF + endif l1 = l2 iw = iw + (ip-1)*idot - ENDDO - IF ( na==0 ) RETURN - n2 = N + N - DO i = 1 , n2 - C(i) = Ch(i) - ENDDO - END subroutine cfftf1 \ No newline at end of file + enddo + if ( na==0 ) return + n2 = n + n + do i = 1 , n2 + c(i) = Ch(i) + enddo + end subroutine cfftf1 \ No newline at end of file diff --git a/src/cffti1.f90 b/src/cffti1.f90 index 9634494..4b0cd0c 100644 --- a/src/cffti1.f90 +++ b/src/cffti1.f90 @@ -1,73 +1,73 @@ !*==CFFTI1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE CFFTI1(N,Wa,Ifac) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine cffti1(n,Wa,Ifac) + use fftpack_kind + implicit none !*--CFFTI1149 !*** Start of declarations inserted by SPAG - REAL arg , argh , argld , FFTPACK_KIND , fi , rk , tpi , Wa - INTEGER i , i1 , ib , ido , idot , Ifac , ii , ip , ipm , j , k1 ,& - & l1 , l2 , ld , N , nf , nl , nq , nr , ntry - INTEGER ntryh + real arg , argh , argld , fftpack_kind , fi , rk , tpi , Wa + integer i , i1 , ib , ido , idot , Ifac , ii , ip , ipm , j , k1 ,& + & l1 , l2 , ld , n , nf , nl , nq , nr , ntry + integer ntryh !*** End of declarations inserted by SPAG - DIMENSION Wa(*) , Ifac(*) , ntryh(4) - DATA ntryh(1) , ntryh(2) , ntryh(3) , ntryh(4)/3 , 4 , 2 , 5/ - nl = N + dimension Wa(*) , Ifac(*) , ntryh(4) + data ntryh(1) , ntryh(2) , ntryh(3) , ntryh(4)/3 , 4 , 2 , 5/ + nl = n nf = 0 j = 0 100 j = j + 1 - IF ( j<=4 ) THEN + if ( j<=4 ) then ntry = ntryh(j) - ELSE + else ntry = ntry + 2 - ENDIF + endif 200 nq = nl/ntry nr = nl - ntry*nq - IF ( nr/=0 ) GOTO 100 + if ( nr/=0 ) goto 100 nf = nf + 1 Ifac(nf+2) = ntry nl = nq - IF ( ntry==2 ) THEN - IF ( nf/=1 ) THEN - DO i = 2 , nf + if ( ntry==2 ) then + if ( nf/=1 ) then + do i = 2 , nf ib = nf - i + 2 Ifac(ib+2) = Ifac(ib+1) - ENDDO + enddo Ifac(3) = 2 - ENDIF - ENDIF - IF ( nl/=1 ) GOTO 200 - Ifac(1) = N + endif + endif + if ( nl/=1 ) goto 200 + Ifac(1) = n Ifac(2) = nf - tpi = 6.28318530717958647692D0 - argh = tpi/REAL(N,rk) + tpi = 6.28318530717958647692d0 + argh = tpi/real(n,rk) i = 2 l1 = 1 - DO k1 = 1 , nf + do k1 = 1 , nf ip = Ifac(k1+2) ld = 0 l2 = l1*ip - ido = N/l2 + ido = n/l2 idot = ido + ido + 2 ipm = ip - 1 - DO j = 1 , ipm + do j = 1 , ipm i1 = i - Wa(i-1) = 1.0D0 - Wa(i) = 0.0D0 + Wa(i-1) = 1.0d0 + Wa(i) = 0.0d0 ld = ld + l1 - fi = 0.0D0 - argld = REAL(ld,rk)*argh - DO ii = 4 , idot , 2 + fi = 0.0d0 + argld = real(ld,rk)*argh + do ii = 4 , idot , 2 i = i + 2 - fi = fi + 1.D0 + fi = fi + 1.d0 arg = fi*argld - Wa(i-1) = COS(arg) - Wa(i) = SIN(arg) - ENDDO - IF ( ip>5 ) THEN + Wa(i-1) = cos(arg) + Wa(i) = sin(arg) + enddo + if ( ip>5 ) then Wa(i1-1) = Wa(i-1) Wa(i1) = Wa(i) - ENDIF - ENDDO + endif + enddo l1 = l2 - ENDDO - END subroutine cffti1 \ No newline at end of file + enddo + end subroutine cffti1 \ No newline at end of file diff --git a/src/cosqb1.f90 b/src/cosqb1.f90 index 7cbf365..e50108c 100644 --- a/src/cosqb1.f90 +++ b/src/cosqb1.f90 @@ -1,34 +1,34 @@ !*==COSQB1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE COSQB1(N,X,W,Xh) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine cosqb1(n,x,w,Xh) + use fftpack_kind + implicit none !*--COSQB1222 !*** Start of declarations inserted by SPAG - REAL FFTPACK_KIND , rk , W , X , Xh , xim1 - INTEGER i , k , kc , modn , N , np2 , ns2 + real fftpack_kind , rk , w , x , Xh , xim1 + integer i , k , kc , modn , n , np2 , ns2 !*** End of declarations inserted by SPAG - DIMENSION X(1) , W(1) , Xh(1) - ns2 = (N+1)/2 - np2 = N + 2 - DO i = 3 , N , 2 - xim1 = X(i-1) + X(i) - X(i) = X(i) - X(i-1) - X(i-1) = xim1 - ENDDO - X(1) = X(1) + X(1) - modn = MOD(N,2) - IF ( modn==0 ) X(N) = X(N) + X(N) - CALL DFFTB(N,X,Xh) - DO k = 2 , ns2 + dimension x(1) , w(1) , Xh(1) + ns2 = (n+1)/2 + np2 = n + 2 + do i = 3 , n , 2 + xim1 = x(i-1) + x(i) + x(i) = x(i) - x(i-1) + x(i-1) = xim1 + enddo + x(1) = x(1) + x(1) + modn = mod(n,2) + if ( modn==0 ) x(n) = x(n) + x(n) + call dfftb(n,x,Xh) + do k = 2 , ns2 kc = np2 - k - Xh(k) = W(k-1)*X(kc) + W(kc-1)*X(k) - Xh(kc) = W(k-1)*X(k) - W(kc-1)*X(kc) - ENDDO - IF ( modn==0 ) X(ns2+1) = W(ns2)*(X(ns2+1)+X(ns2+1)) - DO k = 2 , ns2 + Xh(k) = w(k-1)*x(kc) + w(kc-1)*x(k) + Xh(kc) = w(k-1)*x(k) - w(kc-1)*x(kc) + enddo + if ( modn==0 ) x(ns2+1) = w(ns2)*(x(ns2+1)+x(ns2+1)) + do k = 2 , ns2 kc = np2 - k - X(k) = Xh(k) + Xh(kc) - X(kc) = Xh(k) - Xh(kc) - ENDDO - X(1) = X(1) + X(1) - END subroutine cosqb1 \ No newline at end of file + x(k) = Xh(k) + Xh(kc) + x(kc) = Xh(k) - Xh(kc) + enddo + x(1) = x(1) + x(1) + end subroutine cosqb1 \ No newline at end of file diff --git a/src/cosqf1.f90 b/src/cosqf1.f90 index 72bacc2..345452e 100644 --- a/src/cosqf1.f90 +++ b/src/cosqf1.f90 @@ -1,32 +1,32 @@ !*==COSQF1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE COSQF1(N,X,W,Xh) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine cosqf1(n,x,w,Xh) + use fftpack_kind + implicit none !*--COSQF1256 !*** Start of declarations inserted by SPAG - REAL FFTPACK_KIND , rk , W , X , Xh , xim1 - INTEGER i , k , kc , modn , N , np2 , ns2 + real fftpack_kind , rk , w , x , Xh , xim1 + integer i , k , kc , modn , n , np2 , ns2 !*** End of declarations inserted by SPAG - DIMENSION X(1) , W(1) , Xh(1) - ns2 = (N+1)/2 - np2 = N + 2 - DO k = 2 , ns2 + dimension x(1) , w(1) , Xh(1) + ns2 = (n+1)/2 + np2 = n + 2 + do k = 2 , ns2 kc = np2 - k - Xh(k) = X(k) + X(kc) - Xh(kc) = X(k) - X(kc) - ENDDO - modn = MOD(N,2) - IF ( modn==0 ) Xh(ns2+1) = X(ns2+1) + X(ns2+1) - DO k = 2 , ns2 + Xh(k) = x(k) + x(kc) + Xh(kc) = x(k) - x(kc) + enddo + modn = mod(n,2) + if ( modn==0 ) Xh(ns2+1) = x(ns2+1) + x(ns2+1) + do k = 2 , ns2 kc = np2 - k - X(k) = W(k-1)*Xh(kc) + W(kc-1)*Xh(k) - X(kc) = W(k-1)*Xh(k) - W(kc-1)*Xh(kc) - ENDDO - IF ( modn==0 ) X(ns2+1) = W(ns2)*Xh(ns2+1) - CALL DFFTF(N,X,Xh) - DO i = 3 , N , 2 - xim1 = X(i-1) - X(i) - X(i) = X(i-1) + X(i) - X(i-1) = xim1 - ENDDO - END subroutine cosqf1 \ No newline at end of file + x(k) = w(k-1)*Xh(kc) + w(kc-1)*Xh(k) + x(kc) = w(k-1)*Xh(k) - w(kc-1)*Xh(kc) + enddo + if ( modn==0 ) x(ns2+1) = w(ns2)*Xh(ns2+1) + call dfftf(n,x,Xh) + do i = 3 , n , 2 + xim1 = x(i-1) - x(i) + x(i) = x(i-1) + x(i) + x(i-1) = xim1 + enddo + end subroutine cosqf1 \ No newline at end of file diff --git a/src/dcosqb.f90 b/src/dcosqb.f90 index d1e9670..ade647f 100644 --- a/src/dcosqb.f90 +++ b/src/dcosqb.f90 @@ -1,23 +1,23 @@ !*==DCOSQB.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE DCOSQB(N,X,Wsave) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine dcosqb(n,x,Wsave) + use fftpack_kind + implicit none !*--DCOSQB288 !*** Start of declarations inserted by SPAG - REAL FFTPACK_KIND , rk , tsqrt2 , Wsave , X , x1 - INTEGER N + real fftpack_kind , rk , tsqrt2 , Wsave , x , x1 + integer n !*** End of declarations inserted by SPAG - DIMENSION X(*) , Wsave(*) - DATA tsqrt2/2.82842712474619009760D0/ - IF ( N<2 ) THEN - X(1) = 4.0D0*X(1) - RETURN - ELSEIF ( N==2 ) THEN - x1 = 4.0D0*(X(1)+X(2)) - X(2) = tsqrt2*(X(1)-X(2)) - X(1) = x1 - RETURN - ELSE - CALL COSQB1(N,X,Wsave,Wsave(N+1)) - ENDIF - END subroutine dcosqb \ No newline at end of file + dimension x(*) , Wsave(*) + data tsqrt2/2.82842712474619009760d0/ + if ( n<2 ) then + x(1) = 4.0d0*x(1) + return + elseif ( n==2 ) then + x1 = 4.0d0*(x(1)+x(2)) + x(2) = tsqrt2*(x(1)-x(2)) + x(1) = x1 + return + else + call cosqb1(n,x,Wsave,Wsave(n+1)) + endif + end subroutine dcosqb \ No newline at end of file diff --git a/src/dcosqf.f90 b/src/dcosqf.f90 index 1ee5fb9..004a713 100644 --- a/src/dcosqf.f90 +++ b/src/dcosqf.f90 @@ -1,22 +1,22 @@ !*==DCOSQF.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE DCOSQF(N,X,Wsave) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine dcosqf(n,x,Wsave) + use fftpack_kind + implicit none !*--DCOSQF311 !*** Start of declarations inserted by SPAG - REAL FFTPACK_KIND , rk , sqrt2 , tsqx , Wsave , X - INTEGER N + real fftpack_kind , rk , sqrt2 , tsqx , Wsave , x + integer n !*** End of declarations inserted by SPAG - DIMENSION X(*) , Wsave(*) - DATA sqrt2/1.41421356237309504880D0/ - IF ( N<2 ) THEN - ELSEIF ( N==2 ) THEN - tsqx = sqrt2*X(2) - X(2) = X(1) - tsqx - X(1) = X(1) + tsqx - ELSE - CALL COSQF1(N,X,Wsave,Wsave(N+1)) - GOTO 99999 - ENDIF - RETURN -99999 END subroutine dcosqf \ No newline at end of file + dimension x(*) , Wsave(*) + data sqrt2/1.41421356237309504880d0/ + if ( n<2 ) then + elseif ( n==2 ) then + tsqx = sqrt2*x(2) + x(2) = x(1) - tsqx + x(1) = x(1) + tsqx + else + call cosqf1(n,x,Wsave,Wsave(n+1)) + goto 99999 + endif + return +99999 end subroutine dcosqf \ No newline at end of file diff --git a/src/dcosqi.f90 b/src/dcosqi.f90 index 42b77c5..944f1e9 100644 --- a/src/dcosqi.f90 +++ b/src/dcosqi.f90 @@ -1,19 +1,19 @@ !*==DCOSQI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE DCOSQI(N,Wsave) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine dcosqi(n,Wsave) + use fftpack_kind + implicit none !*--DCOSQI333 !*** Start of declarations inserted by SPAG - REAL dt , FFTPACK_KIND , fk , pih , rk , Wsave - INTEGER k , N + real dt , fftpack_kind , fk , pih , rk , Wsave + integer k , n !*** End of declarations inserted by SPAG - DIMENSION Wsave(1) - DATA pih/1.57079632679489661923D0/ - dt = pih/REAL(N,rk) - fk = 0.0D0 - DO k = 1 , N - fk = fk + 1.0D0 - Wsave(k) = COS(fk*dt) - ENDDO - CALL DFFTI(N,Wsave(N+1)) - END subroutine dcosqi \ No newline at end of file + dimension Wsave(1) + data pih/1.57079632679489661923d0/ + dt = pih/real(n,rk) + fk = 0.0d0 + do k = 1 , n + fk = fk + 1.0d0 + Wsave(k) = cos(fk*dt) + enddo + call dffti(n,Wsave(n+1)) + end subroutine dcosqi \ No newline at end of file diff --git a/src/dcost.f90 b/src/dcost.f90 index 5d49a88..11f86a7 100644 --- a/src/dcost.f90 +++ b/src/dcost.f90 @@ -1,53 +1,53 @@ !*==DCOST.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE DCOST(N,X,Wsave) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine dcost(n,x,Wsave) + use fftpack_kind + implicit none !*--DCOST352 !*** Start of declarations inserted by SPAG - REAL c1 , FFTPACK_KIND , rk , t1 , t2 , tx2 , Wsave , X , x1h , & + real c1 , fftpack_kind , rk , t1 , t2 , tx2 , Wsave , x , x1h , & & x1p3 , xi , xim2 - INTEGER i , k , kc , modn , N , nm1 , np1 , ns2 + integer i , k , kc , modn , n , nm1 , np1 , ns2 !*** End of declarations inserted by SPAG - DIMENSION X(*) , Wsave(*) - nm1 = N - 1 - np1 = N + 1 - ns2 = N/2 - IF ( N<2 ) GOTO 99999 - IF ( N==2 ) THEN - x1h = X(1) + X(2) - X(2) = X(1) - X(2) - X(1) = x1h - RETURN - ELSEIF ( N>3 ) THEN - c1 = X(1) - X(N) - X(1) = X(1) + X(N) - DO k = 2 , ns2 + dimension x(*) , Wsave(*) + nm1 = n - 1 + np1 = n + 1 + ns2 = n/2 + if ( n<2 ) goto 99999 + if ( n==2 ) then + x1h = x(1) + x(2) + x(2) = x(1) - x(2) + x(1) = x1h + return + elseif ( n>3 ) then + c1 = x(1) - x(n) + x(1) = x(1) + x(n) + do k = 2 , ns2 kc = np1 - k - t1 = X(k) + X(kc) - t2 = X(k) - X(kc) + t1 = x(k) + x(kc) + t2 = x(k) - x(kc) c1 = c1 + Wsave(kc)*t2 t2 = Wsave(k)*t2 - X(k) = t1 - t2 - X(kc) = t1 + t2 - ENDDO - modn = MOD(N,2) - IF ( modn/=0 ) X(ns2+1) = X(ns2+1) + X(ns2+1) - CALL DFFTF(nm1,X,Wsave(N+1)) - xim2 = X(2) - X(2) = c1 - DO i = 4 , N , 2 - xi = X(i) - X(i) = X(i-2) - X(i-1) - X(i-1) = xim2 + x(k) = t1 - t2 + x(kc) = t1 + t2 + enddo + modn = mod(n,2) + if ( modn/=0 ) x(ns2+1) = x(ns2+1) + x(ns2+1) + call dfftf(nm1,x,Wsave(n+1)) + xim2 = x(2) + x(2) = c1 + do i = 4 , n , 2 + xi = x(i) + x(i) = x(i-2) - x(i-1) + x(i-1) = xim2 xim2 = xi - ENDDO - IF ( modn/=0 ) X(N) = xim2 - GOTO 99999 - ENDIF - x1p3 = X(1) + X(3) - tx2 = X(2) + X(2) - X(2) = X(1) - X(3) - X(1) = x1p3 + tx2 - X(3) = x1p3 - tx2 - RETURN -99999 END subroutine dcost \ No newline at end of file + enddo + if ( modn/=0 ) x(n) = xim2 + goto 99999 + endif + x1p3 = x(1) + x(3) + tx2 = x(2) + x(2) + x(2) = x(1) - x(3) + x(1) = x1p3 + tx2 + x(3) = x1p3 - tx2 + return +99999 end subroutine dcost \ No newline at end of file diff --git a/src/dcosti.f90 b/src/dcosti.f90 index 34fac58..e478243 100644 --- a/src/dcosti.f90 +++ b/src/dcosti.f90 @@ -1,25 +1,25 @@ !*==DCOSTI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE DCOSTI(N,Wsave) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine dcosti(n,Wsave) + use fftpack_kind + implicit none !*--DCOSTI405 !*** Start of declarations inserted by SPAG - REAL dt , FFTPACK_KIND , fk , pi , rk , Wsave - INTEGER k , kc , N , nm1 , np1 , ns2 + real dt , fftpack_kind , fk , pi , rk , Wsave + integer k , kc , n , nm1 , np1 , ns2 !*** End of declarations inserted by SPAG - DIMENSION Wsave(1) - DATA pi/3.14159265358979323846D0/ - IF ( N<=3 ) RETURN - nm1 = N - 1 - np1 = N + 1 - ns2 = N/2 - dt = pi/REAL(nm1,rk) - fk = 0.0D0 - DO k = 2 , ns2 + dimension Wsave(1) + data pi/3.14159265358979323846d0/ + if ( n<=3 ) return + nm1 = n - 1 + np1 = n + 1 + ns2 = n/2 + dt = pi/real(nm1,rk) + fk = 0.0d0 + do k = 2 , ns2 kc = np1 - k - fk = fk + 1.0D0 - Wsave(k) = 2.0D0*SIN(fk*dt) - Wsave(kc) = 2.0D0*COS(fk*dt) - ENDDO - CALL DFFTI(nm1,Wsave(N+1)) - END subroutine dcosti \ No newline at end of file + fk = fk + 1.0d0 + Wsave(k) = 2.0d0*sin(fk*dt) + Wsave(kc) = 2.0d0*cos(fk*dt) + enddo + call dffti(nm1,Wsave(n+1)) + end subroutine dcosti \ No newline at end of file diff --git a/src/dfftb.f90 b/src/dfftb.f90 index 5c1933a..f751011 100644 --- a/src/dfftb.f90 +++ b/src/dfftb.f90 @@ -1,13 +1,13 @@ !*==DFFTB.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE DFFTB(N,R,Wsave) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine dfftb(n,r,Wsave) + use fftpack_kind + implicit none !*--DFFTB430 !*** Start of declarations inserted by SPAG - REAL FFTPACK_KIND , R , rk , Wsave - INTEGER N + real fftpack_kind , r , rk , Wsave + integer n !*** End of declarations inserted by SPAG - DIMENSION R(1) , Wsave(1) - IF ( N==1 ) RETURN - CALL RFFTB1(N,R,Wsave,Wsave(N+1),Wsave(2*N+1)) - END subroutine dfftb \ No newline at end of file + dimension r(1) , Wsave(1) + if ( n==1 ) return + call rfftb1(n,r,Wsave,Wsave(n+1),Wsave(2*n+1)) + end subroutine dfftb \ No newline at end of file diff --git a/src/dfftf.f90 b/src/dfftf.f90 index 269bbce..4dc16be 100644 --- a/src/dfftf.f90 +++ b/src/dfftf.f90 @@ -1,13 +1,13 @@ !*==DFFTF.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE DFFTF(N,R,Wsave) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine dfftf(n,r,Wsave) + use fftpack_kind + implicit none !*--DFFTF443 !*** Start of declarations inserted by SPAG - REAL FFTPACK_KIND , R , rk , Wsave - INTEGER N + real fftpack_kind , r , rk , Wsave + integer n !*** End of declarations inserted by SPAG - DIMENSION R(1) , Wsave(1) - IF ( N==1 ) RETURN - CALL RFFTF1(N,R,Wsave,Wsave(N+1),Wsave(2*N+1)) - END subroutine dfftf \ No newline at end of file + dimension r(1) , Wsave(1) + if ( n==1 ) return + call rfftf1(n,r,Wsave,Wsave(n+1),Wsave(2*n+1)) + end subroutine dfftf \ No newline at end of file diff --git a/src/dffti.f90 b/src/dffti.f90 index 80c18b5..455aa00 100644 --- a/src/dffti.f90 +++ b/src/dffti.f90 @@ -1,13 +1,13 @@ !*==DFFTI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE DFFTI(N,Wsave) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine dffti(n,Wsave) + use fftpack_kind + implicit none !*--DFFTI456 !*** Start of declarations inserted by SPAG - REAL FFTPACK_KIND , rk , Wsave - INTEGER N + real fftpack_kind , rk , Wsave + integer n !*** End of declarations inserted by SPAG - DIMENSION Wsave(1) - IF ( N==1 ) RETURN - CALL RFFTI1(N,Wsave(N+1),Wsave(2*N+1)) - END subroutine dffti \ No newline at end of file + dimension Wsave(1) + if ( n==1 ) return + call rffti1(n,Wsave(n+1),Wsave(2*n+1)) + end subroutine dffti \ No newline at end of file diff --git a/src/dsinqb.f90 b/src/dsinqb.f90 index 1d60626..a6dec3f 100644 --- a/src/dsinqb.f90 +++ b/src/dsinqb.f90 @@ -1,27 +1,27 @@ !*==DSINQB.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE DSINQB(N,X,Wsave) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine dsinqb(n,x,Wsave) + use fftpack_kind + implicit none !*--DSINQB469 !*** Start of declarations inserted by SPAG - REAL FFTPACK_KIND , rk , Wsave , X , xhold - INTEGER k , kc , N , ns2 + real fftpack_kind , rk , Wsave , x , xhold + integer k , kc , n , ns2 !*** End of declarations inserted by SPAG - DIMENSION X(1) , Wsave(1) - IF ( N>1 ) THEN - ns2 = N/2 - DO k = 2 , N , 2 - X(k) = -X(k) - ENDDO - CALL DCOSQB(N,X,Wsave) - DO k = 1 , ns2 - kc = N - k - xhold = X(k) - X(k) = X(kc+1) - X(kc+1) = xhold - ENDDO - GOTO 99999 - ENDIF - X(1) = 4.0D0*X(1) - RETURN -99999 END subroutine dsinqb \ No newline at end of file + dimension x(1) , Wsave(1) + if ( n>1 ) then + ns2 = n/2 + do k = 2 , n , 2 + x(k) = -x(k) + enddo + call dcosqb(n,x,Wsave) + do k = 1 , ns2 + kc = n - k + xhold = x(k) + x(k) = x(kc+1) + x(kc+1) = xhold + enddo + goto 99999 + endif + x(1) = 4.0d0*x(1) + return +99999 end subroutine dsinqb \ No newline at end of file diff --git a/src/dsinqf.f90 b/src/dsinqf.f90 index 328f2ea..ae416fb 100644 --- a/src/dsinqf.f90 +++ b/src/dsinqf.f90 @@ -1,23 +1,23 @@ !*==DSINQF.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE DSINQF(N,X,Wsave) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine dsinqf(n,x,Wsave) + use fftpack_kind + implicit none !*--DSINQF496 !*** Start of declarations inserted by SPAG - REAL FFTPACK_KIND , rk , Wsave , X , xhold - INTEGER k , kc , N , ns2 + real fftpack_kind , rk , Wsave , x , xhold + integer k , kc , n , ns2 !*** End of declarations inserted by SPAG - DIMENSION X(1) , Wsave(1) - IF ( N==1 ) RETURN - ns2 = N/2 - DO k = 1 , ns2 - kc = N - k - xhold = X(k) - X(k) = X(kc+1) - X(kc+1) = xhold - ENDDO - CALL DCOSQF(N,X,Wsave) - DO k = 2 , N , 2 - X(k) = -X(k) - ENDDO - END subroutine dsinqf \ No newline at end of file + dimension x(1) , Wsave(1) + if ( n==1 ) return + ns2 = n/2 + do k = 1 , ns2 + kc = n - k + xhold = x(k) + x(k) = x(kc+1) + x(kc+1) = xhold + enddo + call dcosqf(n,x,Wsave) + do k = 2 , n , 2 + x(k) = -x(k) + enddo + end subroutine dsinqf \ No newline at end of file diff --git a/src/dsinqi.f90 b/src/dsinqi.f90 index 4b7d1a6..3319dc6 100644 --- a/src/dsinqi.f90 +++ b/src/dsinqi.f90 @@ -1,12 +1,12 @@ !*==DSINQI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE DSINQI(N,Wsave) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine dsinqi(n,Wsave) + use fftpack_kind + implicit none !*--DSINQI519 !*** Start of declarations inserted by SPAG - REAL FFTPACK_KIND , rk , Wsave - INTEGER N + real fftpack_kind , rk , Wsave + integer n !*** End of declarations inserted by SPAG - DIMENSION Wsave(1) - CALL DCOSQI(N,Wsave) - END subroutine dsinqi \ No newline at end of file + dimension Wsave(1) + call dcosqi(n,Wsave) + end subroutine dsinqi \ No newline at end of file diff --git a/src/dsint.f90 b/src/dsint.f90 index 6b02299..40bf2cc 100644 --- a/src/dsint.f90 +++ b/src/dsint.f90 @@ -1,16 +1,16 @@ !*==DSINT.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE DSINT(N,X,Wsave) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine dsint(n,x,Wsave) + use fftpack_kind + implicit none !*--DSINT531 !*** Start of declarations inserted by SPAG - REAL FFTPACK_KIND , rk , Wsave , X - INTEGER iw1 , iw2 , iw3 , N , np1 + real fftpack_kind , rk , Wsave , x + integer iw1 , iw2 , iw3 , n , np1 !*** End of declarations inserted by SPAG - DIMENSION X(1) , Wsave(1) - np1 = N + 1 - iw1 = N/2 + 1 + dimension x(1) , Wsave(1) + np1 = n + 1 + iw1 = n/2 + 1 iw2 = iw1 + np1 iw3 = iw2 + np1 - CALL SINT1(N,X,Wsave,Wsave(iw1),Wsave(iw2),Wsave(iw3)) - END subroutine dsint \ No newline at end of file + call sint1(n,x,Wsave,Wsave(iw1),Wsave(iw2),Wsave(iw3)) + end subroutine dsint \ No newline at end of file diff --git a/src/dsinti.f90 b/src/dsinti.f90 index fbb7878..17acc36 100644 --- a/src/dsinti.f90 +++ b/src/dsinti.f90 @@ -1,20 +1,20 @@ !*==DSINTI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE DSINTI(N,Wsave) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine dsinti(n,Wsave) + use fftpack_kind + implicit none !*--DSINTI547 !*** Start of declarations inserted by SPAG - REAL dt , FFTPACK_KIND , pi , rk , Wsave - INTEGER k , N , np1 , ns2 + real dt , fftpack_kind , pi , rk , Wsave + integer k , n , np1 , ns2 !*** End of declarations inserted by SPAG - DIMENSION Wsave(1) - DATA pi/3.14159265358979323846D0/ - IF ( N<=1 ) RETURN - ns2 = N/2 - np1 = N + 1 - dt = pi/REAL(np1,rk) - DO k = 1 , ns2 - Wsave(k) = 2.0D0*SIN(k*dt) - ENDDO - CALL DFFTI(np1,Wsave(ns2+1)) - END subroutine dsinti \ No newline at end of file + dimension Wsave(1) + data pi/3.14159265358979323846d0/ + if ( n<=1 ) return + ns2 = n/2 + np1 = n + 1 + dt = pi/real(np1,rk) + do k = 1 , ns2 + Wsave(k) = 2.0d0*sin(k*dt) + enddo + call dffti(np1,Wsave(ns2+1)) + end subroutine dsinti \ No newline at end of file diff --git a/src/dzfftb.f90 b/src/dzfftb.f90 index b8e5dc4..374227d 100644 --- a/src/dzfftb.f90 +++ b/src/dzfftb.f90 @@ -1,28 +1,28 @@ !*==DZFFTB.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE DZFFTB(N,R,Azero,A,B,Wsave) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine dzfftb(n,r,Azero,a,b,Wsave) + use fftpack_kind + implicit none !*--DZFFTB567 !*** Start of declarations inserted by SPAG - REAL A , Azero , B , FFTPACK_KIND , R , rk , Wsave - INTEGER i , N , ns2 + real a , Azero , b , fftpack_kind , r , rk , Wsave + integer i , n , ns2 !*** End of declarations inserted by SPAG - DIMENSION R(*) , A(*) , B(*) , Wsave(*) - IF ( N<2 ) THEN - R(1) = Azero - RETURN - ELSEIF ( N==2 ) THEN - R(1) = Azero + A(1) - R(2) = Azero - A(1) - RETURN - ELSE - ns2 = (N-1)/2 - DO i = 1 , ns2 - R(2*i) = 0.5D0*A(i) - R(2*i+1) = -0.5D0*B(i) - ENDDO - R(1) = Azero - IF ( MOD(N,2)==0 ) R(N) = A(ns2+1) - CALL DFFTB(N,R,Wsave(N+1)) - ENDIF - END subroutine dzfftb \ No newline at end of file + dimension r(*) , a(*) , b(*) , Wsave(*) + if ( n<2 ) then + r(1) = Azero + return + elseif ( n==2 ) then + r(1) = Azero + a(1) + r(2) = Azero - a(1) + return + else + ns2 = (n-1)/2 + do i = 1 , ns2 + r(2*i) = 0.5d0*a(i) + r(2*i+1) = -0.5d0*b(i) + enddo + r(1) = Azero + if ( mod(n,2)==0 ) r(n) = a(ns2+1) + call dfftb(n,r,Wsave(n+1)) + endif + end subroutine dzfftb \ No newline at end of file diff --git a/src/dzfftf.f90 b/src/dzfftf.f90 index eac2c86..14c1c5d 100644 --- a/src/dzfftf.f90 +++ b/src/dzfftf.f90 @@ -1,39 +1,39 @@ !*==DZFFTF.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE DZFFTF(N,R,Azero,A,B,Wsave) + subroutine dzfftf(n,r,Azero,a,b,Wsave) ! ! VERSION 3 JUNE 1979 ! - USE FFTPACK_KIND - IMPLICIT NONE + use fftpack_kind + implicit none !*--DZFFTF598 !*** Start of declarations inserted by SPAG - REAL A , Azero , B , cf , cfm , FFTPACK_KIND , R , rk , Wsave - INTEGER i , N , ns2 , ns2m + real a , Azero , b , cf , cfm , fftpack_kind , r , rk , Wsave + integer i , n , ns2 , ns2m !*** End of declarations inserted by SPAG - DIMENSION R(*) , A(*) , B(*) , Wsave(*) - IF ( N<2 ) THEN - Azero = R(1) - RETURN - ELSEIF ( N==2 ) THEN - Azero = 0.5D0*(R(1)+R(2)) - A(1) = 0.5D0*(R(1)-R(2)) - RETURN - ELSE - DO i = 1 , N - Wsave(i) = R(i) - ENDDO - CALL DFFTF(N,Wsave,Wsave(N+1)) - cf = 2.0D0/REAL(N,rk) + dimension r(*) , a(*) , b(*) , Wsave(*) + if ( n<2 ) then + Azero = r(1) + return + elseif ( n==2 ) then + Azero = 0.5d0*(r(1)+r(2)) + a(1) = 0.5d0*(r(1)-r(2)) + return + else + do i = 1 , n + Wsave(i) = r(i) + enddo + call dfftf(n,Wsave,Wsave(n+1)) + cf = 2.0d0/real(n,rk) cfm = -cf - Azero = 0.5D0*cf*Wsave(1) - ns2 = (N+1)/2 + Azero = 0.5d0*cf*Wsave(1) + ns2 = (n+1)/2 ns2m = ns2 - 1 - DO i = 1 , ns2m - A(i) = cf*Wsave(2*i) - B(i) = cfm*Wsave(2*i+1) - ENDDO - IF ( MOD(N,2)==1 ) RETURN - A(ns2) = 0.5D0*cf*Wsave(N) - B(ns2) = 0.0D0 - ENDIF - END subroutine dzfftf \ No newline at end of file + do i = 1 , ns2m + a(i) = cf*Wsave(2*i) + b(i) = cfm*Wsave(2*i+1) + enddo + if ( mod(n,2)==1 ) return + a(ns2) = 0.5d0*cf*Wsave(n) + b(ns2) = 0.0d0 + endif + end subroutine dzfftf \ No newline at end of file diff --git a/src/dzffti.f90 b/src/dzffti.f90 index 0f934b1..db904a6 100644 --- a/src/dzffti.f90 +++ b/src/dzffti.f90 @@ -1,13 +1,13 @@ !*==DZFFTI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE DZFFTI(N,Wsave) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine dzffti(n,Wsave) + use fftpack_kind + implicit none !*--DZFFTI634 !*** Start of declarations inserted by SPAG - REAL FFTPACK_KIND , rk , Wsave - INTEGER N + real fftpack_kind , rk , Wsave + integer n !*** End of declarations inserted by SPAG - DIMENSION Wsave(1) - IF ( N==1 ) RETURN - CALL EZFFT1(N,Wsave(2*N+1),Wsave(3*N+1)) - END subroutine dzffti \ No newline at end of file + dimension Wsave(1) + if ( n==1 ) return + call ezfft1(n,Wsave(2*n+1),Wsave(3*n+1)) + end subroutine dzffti \ No newline at end of file diff --git a/src/ezfft1.f90 b/src/ezfft1.f90 index 853f2ec..169818e 100644 --- a/src/ezfft1.f90 +++ b/src/ezfft1.f90 @@ -1,75 +1,75 @@ !*==EZFFT1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE EZFFT1(N,Wa,Ifac) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine ezfft1(n,Wa,Ifac) + use fftpack_kind + implicit none !*--EZFFT1647 !*** Start of declarations inserted by SPAG - REAL arg1 , argh , ch1 , ch1h , dch1 , dsh1 , FFTPACK_KIND , rk , & + real arg1 , argh , ch1 , ch1h , dch1 , dsh1 , fftpack_kind , rk , & & sh1 , tpi , Wa - INTEGER i , ib , ido , Ifac , ii , ip , ipm , is , j , k1 , l1 , & - & l2 , N , nf , nfm1 , nl , nq , nr , ntry , ntryh + integer i , ib , ido , Ifac , ii , ip , ipm , is , j , k1 , l1 , & + & l2 , n , nf , nfm1 , nl , nq , nr , ntry , ntryh !*** End of declarations inserted by SPAG - DIMENSION Wa(*) , Ifac(*) , ntryh(4) - DATA ntryh(1) , ntryh(2) , ntryh(3) , ntryh(4)/4 , 2 , 3 , 5/ , & - & tpi/6.28318530717958647692D0/ - nl = N + dimension Wa(*) , Ifac(*) , ntryh(4) + data ntryh(1) , ntryh(2) , ntryh(3) , ntryh(4)/4 , 2 , 3 , 5/ , & + & tpi/6.28318530717958647692d0/ + nl = n nf = 0 j = 0 100 j = j + 1 - IF ( j<=4 ) THEN + if ( j<=4 ) then ntry = ntryh(j) - ELSE + else ntry = ntry + 2 - ENDIF + endif 200 nq = nl/ntry nr = nl - ntry*nq - IF ( nr/=0 ) GOTO 100 + if ( nr/=0 ) goto 100 nf = nf + 1 Ifac(nf+2) = ntry nl = nq - IF ( ntry==2 ) THEN - IF ( nf/=1 ) THEN - DO i = 2 , nf + if ( ntry==2 ) then + if ( nf/=1 ) then + do i = 2 , nf ib = nf - i + 2 Ifac(ib+2) = Ifac(ib+1) - ENDDO + enddo Ifac(3) = 2 - ENDIF - ENDIF - IF ( nl/=1 ) GOTO 200 - Ifac(1) = N + endif + endif + if ( nl/=1 ) goto 200 + Ifac(1) = n Ifac(2) = nf - argh = tpi/REAL(N,rk) + argh = tpi/real(n,rk) is = 0 nfm1 = nf - 1 l1 = 1 - IF ( nfm1==0 ) RETURN - DO k1 = 1 , nfm1 + if ( nfm1==0 ) return + do k1 = 1 , nfm1 ip = Ifac(k1+2) l2 = l1*ip - ido = N/l2 + ido = n/l2 ipm = ip - 1 - arg1 = REAL(l1,rk)*argh - ch1 = 1.0D0 - sh1 = 0.0D0 - dch1 = COS(arg1) - dsh1 = SIN(arg1) - DO j = 1 , ipm + arg1 = real(l1,rk)*argh + ch1 = 1.0d0 + sh1 = 0.0d0 + dch1 = cos(arg1) + dsh1 = sin(arg1) + do j = 1 , ipm ch1h = dch1*ch1 - dsh1*sh1 sh1 = dch1*sh1 + dsh1*ch1 ch1 = ch1h i = is + 2 Wa(i-1) = ch1 Wa(i) = sh1 - IF ( ido>=5 ) THEN - DO ii = 5 , ido , 2 + if ( ido>=5 ) then + do ii = 5 , ido , 2 i = i + 2 Wa(i-1) = ch1*Wa(i-3) - sh1*Wa(i-2) Wa(i) = ch1*Wa(i-2) + sh1*Wa(i-3) - ENDDO - ENDIF + enddo + endif is = is + ido - ENDDO + enddo l1 = l2 - ENDDO - END subroutine ezfft1 \ No newline at end of file + enddo + end subroutine ezfft1 \ No newline at end of file diff --git a/src/passb.f90 b/src/passb.f90 index a7f005d..ebd147e 100644 --- a/src/passb.f90 +++ b/src/passb.f90 @@ -1,129 +1,129 @@ !*==PASSB.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE PASSB(Nac,Ido,Ip,L1,Idl1,Cc,C1,C2,Ch,Ch2,Wa) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine passb(Nac,Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) + use fftpack_kind + implicit none !*--PASSB722 !*** Start of declarations inserted by SPAG - REAL C1 , C2 , Cc , Ch , Ch2 , FFTPACK_KIND , rk , Wa , wai , war - INTEGER i , idij , idj , idl , Idl1 , idlj , Ido , idot , idp , & - & ik , inc , Ip , ipp2 , ipph , j , jc , k , l , L1 , lc - INTEGER Nac , nt + real c1 , c2 , Cc , Ch , Ch2 , fftpack_kind , rk , Wa , wai , war + integer i , idij , idj , idl , Idl1 , idlj , Ido , idot , idp , & + & ik , inc , Ip , ipp2 , ipph , j , jc , k , l , l1 , lc + integer Nac , nt !*** End of declarations inserted by SPAG - DIMENSION Ch(Ido,L1,Ip) , Cc(Ido,Ip,L1) , C1(Ido,L1,Ip) , Wa(1) , & - & C2(Idl1,Ip) , Ch2(Idl1,Ip) + dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , Wa(1) , & + & c2(Idl1,Ip) , Ch2(Idl1,Ip) idot = Ido/2 nt = Ip*Idl1 ipp2 = Ip + 2 ipph = (Ip+1)/2 idp = Ip*Ido ! - IF ( Idoidp ) idlj = idlj - idp + if ( idlj>idp ) idlj = idlj - idp war = Wa(idlj-1) wai = Wa(idlj) - DO ik = 1 , Idl1 - C2(ik,l) = C2(ik,l) + war*Ch2(ik,j) - C2(ik,lc) = C2(ik,lc) + wai*Ch2(ik,jc) - ENDDO - ENDDO - ENDDO - DO j = 2 , ipph - DO ik = 1 , Idl1 + do ik = 1 , Idl1 + c2(ik,l) = c2(ik,l) + war*Ch2(ik,j) + c2(ik,lc) = c2(ik,lc) + wai*Ch2(ik,jc) + enddo + enddo + enddo + do j = 2 , ipph + do ik = 1 , Idl1 Ch2(ik,1) = Ch2(ik,1) + Ch2(ik,j) - ENDDO - ENDDO - DO j = 2 , ipph + enddo + enddo + do j = 2 , ipph jc = ipp2 - j - DO ik = 2 , Idl1 , 2 - Ch2(ik-1,j) = C2(ik-1,j) - C2(ik,jc) - Ch2(ik-1,jc) = C2(ik-1,j) + C2(ik,jc) - Ch2(ik,j) = C2(ik,j) + C2(ik-1,jc) - Ch2(ik,jc) = C2(ik,j) - C2(ik-1,jc) - ENDDO - ENDDO + do ik = 2 , Idl1 , 2 + Ch2(ik-1,j) = c2(ik-1,j) - c2(ik,jc) + Ch2(ik-1,jc) = c2(ik-1,j) + c2(ik,jc) + Ch2(ik,j) = c2(ik,j) + c2(ik-1,jc) + Ch2(ik,jc) = c2(ik,j) - c2(ik-1,jc) + enddo + enddo Nac = 1 - IF ( Ido==2 ) RETURN + if ( Ido==2 ) return Nac = 0 - DO ik = 1 , Idl1 - C2(ik,1) = Ch2(ik,1) - ENDDO - DO j = 2 , Ip - DO k = 1 , L1 - C1(1,k,j) = Ch(1,k,j) - C1(2,k,j) = Ch(2,k,j) - ENDDO - ENDDO - IF ( idot>L1 ) THEN + do ik = 1 , Idl1 + c2(ik,1) = Ch2(ik,1) + enddo + do j = 2 , Ip + do k = 1 , l1 + c1(1,k,j) = Ch(1,k,j) + c1(2,k,j) = Ch(2,k,j) + enddo + enddo + if ( idot>l1 ) then idj = 2 - Ido - DO j = 2 , Ip + do j = 2 , Ip idj = idj + Ido - DO k = 1 , L1 + do k = 1 , l1 idij = idj - DO i = 4 , Ido , 2 + do i = 4 , Ido , 2 idij = idij + 2 - C1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & + c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & & *Ch(i,k,j) - C1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & + c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & & *Ch(i-1,k,j) - ENDDO - ENDDO - ENDDO - GOTO 99999 - ENDIF + enddo + enddo + enddo + goto 99999 + endif idij = 0 - DO j = 2 , Ip + do j = 2 , Ip idij = idij + 2 - DO i = 4 , Ido , 2 + do i = 4 , Ido , 2 idij = idij + 2 - DO k = 1 , L1 - C1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij)*Ch(i,k,j) - C1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij)*Ch(i-1,k,j) - ENDDO - ENDDO - ENDDO - RETURN -99999 END subroutine passb \ No newline at end of file + do k = 1 , l1 + c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij)*Ch(i,k,j) + c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij)*Ch(i-1,k,j) + enddo + enddo + enddo + return +99999 end subroutine passb \ No newline at end of file diff --git a/src/passb2.f90 b/src/passb2.f90 index af1cdbb..7e37c9c 100644 --- a/src/passb2.f90 +++ b/src/passb2.f90 @@ -1,31 +1,31 @@ !*==PASSB2.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE PASSB2(Ido,L1,Cc,Ch,Wa1) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine passb2(Ido,l1,Cc,Ch,Wa1) + use fftpack_kind + implicit none !*--PASSB2851 !*** Start of declarations inserted by SPAG - REAL Cc , Ch , FFTPACK_KIND , rk , ti2 , tr2 , Wa1 - INTEGER i , Ido , k , L1 + real Cc , Ch , fftpack_kind , rk , ti2 , tr2 , Wa1 + integer i , Ido , k , l1 !*** End of declarations inserted by SPAG - DIMENSION Cc(Ido,2,L1) , Ch(Ido,L1,2) , Wa1(1) - IF ( Ido>2 ) THEN - DO k = 1 , L1 - DO i = 2 , Ido , 2 + dimension Cc(Ido,2,l1) , Ch(Ido,l1,2) , Wa1(1) + if ( Ido>2 ) then + do k = 1 , l1 + do i = 2 , Ido , 2 Ch(i-1,k,1) = Cc(i-1,1,k) + Cc(i-1,2,k) tr2 = Cc(i-1,1,k) - Cc(i-1,2,k) Ch(i,k,1) = Cc(i,1,k) + Cc(i,2,k) ti2 = Cc(i,1,k) - Cc(i,2,k) Ch(i,k,2) = Wa1(i-1)*ti2 + Wa1(i)*tr2 Ch(i-1,k,2) = Wa1(i-1)*tr2 - Wa1(i)*ti2 - ENDDO - ENDDO - GOTO 99999 - ENDIF - DO k = 1 , L1 + enddo + enddo + goto 99999 + endif + do k = 1 , l1 Ch(1,k,1) = Cc(1,1,k) + Cc(1,2,k) Ch(1,k,2) = Cc(1,1,k) - Cc(1,2,k) Ch(2,k,1) = Cc(2,1,k) + Cc(2,2,k) Ch(2,k,2) = Cc(2,1,k) - Cc(2,2,k) - ENDDO - RETURN -99999 END subroutine passb2 \ No newline at end of file + enddo + return +99999 end subroutine passb2 \ No newline at end of file diff --git a/src/passb3.f90 b/src/passb3.f90 index 1c867be..5ce7855 100644 --- a/src/passb3.f90 +++ b/src/passb3.f90 @@ -1,19 +1,19 @@ !*==PASSB3.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE PASSB3(Ido,L1,Cc,Ch,Wa1,Wa2) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine passb3(Ido,l1,Cc,Ch,Wa1,Wa2) + use fftpack_kind + implicit none !*--PASSB3882 !*** Start of declarations inserted by SPAG - REAL Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , dr2 , dr3 , & - & FFTPACK_KIND , rk , taui , taur , ti2 , tr2 , Wa1 , Wa2 - INTEGER i , Ido , k , L1 + real Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , dr2 , dr3 , & + & fftpack_kind , rk , taui , taur , ti2 , tr2 , Wa1 , Wa2 + integer i , Ido , k , l1 !*** End of declarations inserted by SPAG - DIMENSION Cc(Ido,3,L1) , Ch(Ido,L1,3) , Wa1(1) , Wa2(1) + dimension Cc(Ido,3,l1) , Ch(Ido,l1,3) , Wa1(1) , Wa2(1) ! *** TAUI IS SQRT(3)/2 *** - DATA taur , taui/ - 0.5D0 , 0.86602540378443864676D0/ - IF ( Ido/=2 ) THEN - DO k = 1 , L1 - DO i = 2 , Ido , 2 + data taur , taui/ - 0.5d0 , 0.86602540378443864676d0/ + if ( Ido/=2 ) then + do k = 1 , l1 + do i = 2 , Ido , 2 tr2 = Cc(i-1,2,k) + Cc(i-1,3,k) cr2 = Cc(i-1,1,k) + taur*tr2 Ch(i-1,k,1) = Cc(i-1,1,k) + tr2 @@ -30,11 +30,11 @@ SUBROUTINE PASSB3(Ido,L1,Cc,Ch,Wa1,Wa2) Ch(i-1,k,2) = Wa1(i-1)*dr2 - Wa1(i)*di2 Ch(i,k,3) = Wa2(i-1)*di3 + Wa2(i)*dr3 Ch(i-1,k,3) = Wa2(i-1)*dr3 - Wa2(i)*di3 - ENDDO - ENDDO - GOTO 99999 - ENDIF - DO k = 1 , L1 + enddo + enddo + goto 99999 + endif + do k = 1 , l1 tr2 = Cc(1,2,k) + Cc(1,3,k) cr2 = Cc(1,1,k) + taur*tr2 Ch(1,k,1) = Cc(1,1,k) + tr2 @@ -47,6 +47,6 @@ SUBROUTINE PASSB3(Ido,L1,Cc,Ch,Wa1,Wa2) Ch(1,k,3) = cr2 + ci3 Ch(2,k,2) = ci2 + cr3 Ch(2,k,3) = ci2 - cr3 - ENDDO - RETURN -99999 END subroutine passb3 \ No newline at end of file + enddo + return +99999 end subroutine passb3 \ No newline at end of file diff --git a/src/passb4.f90 b/src/passb4.f90 index 451c280..410964a 100644 --- a/src/passb4.f90 +++ b/src/passb4.f90 @@ -1,19 +1,19 @@ !*==PASSB4.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE PASSB4(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine passb4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) + use fftpack_kind + implicit none !*--PASSB4934 !*** Start of declarations inserted by SPAG - REAL Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , FFTPACK_KIND , & + real Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , fftpack_kind , & & rk , ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3 , tr4 , Wa1 , & & Wa2 - REAL Wa3 - INTEGER i , Ido , k , L1 + real Wa3 + integer i , Ido , k , l1 !*** End of declarations inserted by SPAG - DIMENSION Cc(Ido,4,L1) , Ch(Ido,L1,4) , Wa1(1) , Wa2(1) , Wa3(1) - IF ( Ido/=2 ) THEN - DO k = 1 , L1 - DO i = 2 , Ido , 2 + dimension Cc(Ido,4,l1) , Ch(Ido,l1,4) , Wa1(1) , Wa2(1) , Wa3(1) + if ( Ido/=2 ) then + do k = 1 , l1 + do i = 2 , Ido , 2 ti1 = Cc(i,1,k) - Cc(i,3,k) ti2 = Cc(i,1,k) + Cc(i,3,k) ti3 = Cc(i,2,k) + Cc(i,4,k) @@ -36,11 +36,11 @@ SUBROUTINE PASSB4(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3) Ch(i,k,3) = Wa2(i-1)*ci3 + Wa2(i)*cr3 Ch(i-1,k,4) = Wa3(i-1)*cr4 - Wa3(i)*ci4 Ch(i,k,4) = Wa3(i-1)*ci4 + Wa3(i)*cr4 - ENDDO - ENDDO - GOTO 99999 - ENDIF - DO k = 1 , L1 + enddo + enddo + goto 99999 + endif + do k = 1 , l1 ti1 = Cc(2,1,k) - Cc(2,3,k) ti2 = Cc(2,1,k) + Cc(2,3,k) tr4 = Cc(2,4,k) - Cc(2,2,k) @@ -57,6 +57,6 @@ SUBROUTINE PASSB4(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3) Ch(1,k,4) = tr1 - tr4 Ch(2,k,2) = ti1 + ti4 Ch(2,k,4) = ti1 - ti4 - ENDDO - RETURN -99999 END subroutine passb4 \ No newline at end of file + enddo + return +99999 end subroutine passb4 \ No newline at end of file diff --git a/src/passb5.f90 b/src/passb5.f90 index 03db253..50fc0e7 100644 --- a/src/passb5.f90 +++ b/src/passb5.f90 @@ -1,26 +1,26 @@ !*==PASSB5.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE PASSB5(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine passb5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) + use fftpack_kind + implicit none !*--PASSB5996 !*** Start of declarations inserted by SPAG - REAL Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , cr4 , cr5 , & + real Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , cr4 , cr5 , & & di2 , di3 , di4 , di5 , dr2 , dr3 , dr4 , dr5 , & - & FFTPACK_KIND , rk - REAL ti11 , ti12 , ti2 , ti3 , ti4 , ti5 , tr11 , tr12 , tr2 , & + & fftpack_kind , rk + real ti11 , ti12 , ti2 , ti3 , ti4 , ti5 , tr11 , tr12 , tr2 , & & tr3 , tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 - INTEGER i , Ido , k , L1 + integer i , Ido , k , l1 !*** End of declarations inserted by SPAG - DIMENSION Cc(Ido,5,L1) , Ch(Ido,L1,5) , Wa1(1) , Wa2(1) , Wa3(1) ,& + dimension Cc(Ido,5,l1) , Ch(Ido,l1,5) , Wa1(1) , Wa2(1) , Wa3(1) ,& & Wa4(1) ! *** TR11=COS(2*PI/5), TI11=SIN(2*PI/5) ! *** TR12=COS(4*PI/5), TI12=SIN(4*PI/5) - DATA tr11 , ti11 , tr12 , ti12/0.3090169943749474241D0 , & - & 0.95105651629515357212D0 , -0.8090169943749474241D0 , & - & 0.58778525229247312917D0/ - IF ( Ido/=2 ) THEN - DO k = 1 , L1 - DO i = 2 , Ido , 2 + data tr11 , ti11 , tr12 , ti12/0.3090169943749474241d0 , & + & 0.95105651629515357212d0 , -0.8090169943749474241d0 , & + & 0.58778525229247312917d0/ + if ( Ido/=2 ) then + do k = 1 , l1 + do i = 2 , Ido , 2 ti5 = Cc(i,2,k) - Cc(i,5,k) ti2 = Cc(i,2,k) + Cc(i,5,k) ti4 = Cc(i,3,k) - Cc(i,4,k) @@ -55,11 +55,11 @@ SUBROUTINE PASSB5(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) Ch(i,k,4) = Wa3(i-1)*di4 + Wa3(i)*dr4 Ch(i-1,k,5) = Wa4(i-1)*dr5 - Wa4(i)*di5 Ch(i,k,5) = Wa4(i-1)*di5 + Wa4(i)*dr5 - ENDDO - ENDDO - GOTO 99999 - ENDIF - DO k = 1 , L1 + enddo + enddo + goto 99999 + endif + do k = 1 , l1 ti5 = Cc(2,2,k) - Cc(2,5,k) ti2 = Cc(2,2,k) + Cc(2,5,k) ti4 = Cc(2,3,k) - Cc(2,4,k) @@ -86,6 +86,6 @@ SUBROUTINE PASSB5(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) Ch(1,k,4) = cr3 + ci4 Ch(2,k,4) = ci3 - cr4 Ch(2,k,5) = ci2 - cr5 - ENDDO - RETURN -99999 END subroutine passb5 \ No newline at end of file + enddo + return +99999 end subroutine passb5 \ No newline at end of file diff --git a/src/passf.f90 b/src/passf.f90 index 823fbe1..8c91557 100644 --- a/src/passf.f90 +++ b/src/passf.f90 @@ -1,129 +1,129 @@ !*==PASSF.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE PASSF(Nac,Ido,Ip,L1,Idl1,Cc,C1,C2,Ch,Ch2,Wa) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine passf(Nac,Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) + use fftpack_kind + implicit none !*--PASSF1087 !*** Start of declarations inserted by SPAG - REAL C1 , C2 , Cc , Ch , Ch2 , FFTPACK_KIND , rk , Wa , wai , war - INTEGER i , idij , idj , idl , Idl1 , idlj , Ido , idot , idp , & - & ik , inc , Ip , ipp2 , ipph , j , jc , k , l , L1 , lc - INTEGER Nac , nt + real c1 , c2 , Cc , Ch , Ch2 , fftpack_kind , rk , Wa , wai , war + integer i , idij , idj , idl , Idl1 , idlj , Ido , idot , idp , & + & ik , inc , Ip , ipp2 , ipph , j , jc , k , l , l1 , lc + integer Nac , nt !*** End of declarations inserted by SPAG - DIMENSION Ch(Ido,L1,Ip) , Cc(Ido,Ip,L1) , C1(Ido,L1,Ip) , Wa(1) , & - & C2(Idl1,Ip) , Ch2(Idl1,Ip) + dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , Wa(1) , & + & c2(Idl1,Ip) , Ch2(Idl1,Ip) idot = Ido/2 nt = Ip*Idl1 ipp2 = Ip + 2 ipph = (Ip+1)/2 idp = Ip*Ido ! - IF ( Idoidp ) idlj = idlj - idp + if ( idlj>idp ) idlj = idlj - idp war = Wa(idlj-1) wai = Wa(idlj) - DO ik = 1 , Idl1 - C2(ik,l) = C2(ik,l) + war*Ch2(ik,j) - C2(ik,lc) = C2(ik,lc) - wai*Ch2(ik,jc) - ENDDO - ENDDO - ENDDO - DO j = 2 , ipph - DO ik = 1 , Idl1 + do ik = 1 , Idl1 + c2(ik,l) = c2(ik,l) + war*Ch2(ik,j) + c2(ik,lc) = c2(ik,lc) - wai*Ch2(ik,jc) + enddo + enddo + enddo + do j = 2 , ipph + do ik = 1 , Idl1 Ch2(ik,1) = Ch2(ik,1) + Ch2(ik,j) - ENDDO - ENDDO - DO j = 2 , ipph + enddo + enddo + do j = 2 , ipph jc = ipp2 - j - DO ik = 2 , Idl1 , 2 - Ch2(ik-1,j) = C2(ik-1,j) - C2(ik,jc) - Ch2(ik-1,jc) = C2(ik-1,j) + C2(ik,jc) - Ch2(ik,j) = C2(ik,j) + C2(ik-1,jc) - Ch2(ik,jc) = C2(ik,j) - C2(ik-1,jc) - ENDDO - ENDDO + do ik = 2 , Idl1 , 2 + Ch2(ik-1,j) = c2(ik-1,j) - c2(ik,jc) + Ch2(ik-1,jc) = c2(ik-1,j) + c2(ik,jc) + Ch2(ik,j) = c2(ik,j) + c2(ik-1,jc) + Ch2(ik,jc) = c2(ik,j) - c2(ik-1,jc) + enddo + enddo Nac = 1 - IF ( Ido==2 ) RETURN + if ( Ido==2 ) return Nac = 0 - DO ik = 1 , Idl1 - C2(ik,1) = Ch2(ik,1) - ENDDO - DO j = 2 , Ip - DO k = 1 , L1 - C1(1,k,j) = Ch(1,k,j) - C1(2,k,j) = Ch(2,k,j) - ENDDO - ENDDO - IF ( idot>L1 ) THEN + do ik = 1 , Idl1 + c2(ik,1) = Ch2(ik,1) + enddo + do j = 2 , Ip + do k = 1 , l1 + c1(1,k,j) = Ch(1,k,j) + c1(2,k,j) = Ch(2,k,j) + enddo + enddo + if ( idot>l1 ) then idj = 2 - Ido - DO j = 2 , Ip + do j = 2 , Ip idj = idj + Ido - DO k = 1 , L1 + do k = 1 , l1 idij = idj - DO i = 4 , Ido , 2 + do i = 4 , Ido , 2 idij = idij + 2 - C1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) + Wa(idij) & + c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) + Wa(idij) & & *Ch(i,k,j) - C1(i,k,j) = Wa(idij-1)*Ch(i,k,j) - Wa(idij) & + c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) - Wa(idij) & & *Ch(i-1,k,j) - ENDDO - ENDDO - ENDDO - GOTO 99999 - ENDIF + enddo + enddo + enddo + goto 99999 + endif idij = 0 - DO j = 2 , Ip + do j = 2 , Ip idij = idij + 2 - DO i = 4 , Ido , 2 + do i = 4 , Ido , 2 idij = idij + 2 - DO k = 1 , L1 - C1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) + Wa(idij)*Ch(i,k,j) - C1(i,k,j) = Wa(idij-1)*Ch(i,k,j) - Wa(idij)*Ch(i-1,k,j) - ENDDO - ENDDO - ENDDO - RETURN -99999 END subroutine passf \ No newline at end of file + do k = 1 , l1 + c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) + Wa(idij)*Ch(i,k,j) + c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) - Wa(idij)*Ch(i-1,k,j) + enddo + enddo + enddo + return +99999 end subroutine passf \ No newline at end of file diff --git a/src/passf2.f90 b/src/passf2.f90 index 8f496cf..c809b70 100644 --- a/src/passf2.f90 +++ b/src/passf2.f90 @@ -1,31 +1,31 @@ !*==PASSF2.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE PASSF2(Ido,L1,Cc,Ch,Wa1) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine passf2(Ido,l1,Cc,Ch,Wa1) + use fftpack_kind + implicit none !*--PASSF21216 !*** Start of declarations inserted by SPAG - REAL Cc , Ch , FFTPACK_KIND , rk , ti2 , tr2 , Wa1 - INTEGER i , Ido , k , L1 + real Cc , Ch , fftpack_kind , rk , ti2 , tr2 , Wa1 + integer i , Ido , k , l1 !*** End of declarations inserted by SPAG - DIMENSION Cc(Ido,2,L1) , Ch(Ido,L1,2) , Wa1(1) - IF ( Ido>2 ) THEN - DO k = 1 , L1 - DO i = 2 , Ido , 2 + dimension Cc(Ido,2,l1) , Ch(Ido,l1,2) , Wa1(1) + if ( Ido>2 ) then + do k = 1 , l1 + do i = 2 , Ido , 2 Ch(i-1,k,1) = Cc(i-1,1,k) + Cc(i-1,2,k) tr2 = Cc(i-1,1,k) - Cc(i-1,2,k) Ch(i,k,1) = Cc(i,1,k) + Cc(i,2,k) ti2 = Cc(i,1,k) - Cc(i,2,k) Ch(i,k,2) = Wa1(i-1)*ti2 - Wa1(i)*tr2 Ch(i-1,k,2) = Wa1(i-1)*tr2 + Wa1(i)*ti2 - ENDDO - ENDDO - GOTO 99999 - ENDIF - DO k = 1 , L1 + enddo + enddo + goto 99999 + endif + do k = 1 , l1 Ch(1,k,1) = Cc(1,1,k) + Cc(1,2,k) Ch(1,k,2) = Cc(1,1,k) - Cc(1,2,k) Ch(2,k,1) = Cc(2,1,k) + Cc(2,2,k) Ch(2,k,2) = Cc(2,1,k) - Cc(2,2,k) - ENDDO - RETURN -99999 END subroutine passf2 \ No newline at end of file + enddo + return +99999 end subroutine passf2 \ No newline at end of file diff --git a/src/passf3.f90 b/src/passf3.f90 index bf2659e..22db4a5 100644 --- a/src/passf3.f90 +++ b/src/passf3.f90 @@ -1,19 +1,19 @@ !*==PASSF3.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE PASSF3(Ido,L1,Cc,Ch,Wa1,Wa2) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine passf3(Ido,l1,Cc,Ch,Wa1,Wa2) + use fftpack_kind + implicit none !*--PASSF31247 !*** Start of declarations inserted by SPAG - REAL Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , dr2 , dr3 , & - & FFTPACK_KIND , rk , taui , taur , ti2 , tr2 , Wa1 , Wa2 - INTEGER i , Ido , k , L1 + real Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , dr2 , dr3 , & + & fftpack_kind , rk , taui , taur , ti2 , tr2 , Wa1 , Wa2 + integer i , Ido , k , l1 !*** End of declarations inserted by SPAG - DIMENSION Cc(Ido,3,L1) , Ch(Ido,L1,3) , Wa1(1) , Wa2(1) + dimension Cc(Ido,3,l1) , Ch(Ido,l1,3) , Wa1(1) , Wa2(1) ! *** TAUI IS -SQRT(3)/2 *** - DATA taur , taui/ - 0.5D0 , -0.86602540378443864676D0/ - IF ( Ido/=2 ) THEN - DO k = 1 , L1 - DO i = 2 , Ido , 2 + data taur , taui/ - 0.5d0 , -0.86602540378443864676d0/ + if ( Ido/=2 ) then + do k = 1 , l1 + do i = 2 , Ido , 2 tr2 = Cc(i-1,2,k) + Cc(i-1,3,k) cr2 = Cc(i-1,1,k) + taur*tr2 Ch(i-1,k,1) = Cc(i-1,1,k) + tr2 @@ -30,11 +30,11 @@ SUBROUTINE PASSF3(Ido,L1,Cc,Ch,Wa1,Wa2) Ch(i-1,k,2) = Wa1(i-1)*dr2 + Wa1(i)*di2 Ch(i,k,3) = Wa2(i-1)*di3 - Wa2(i)*dr3 Ch(i-1,k,3) = Wa2(i-1)*dr3 + Wa2(i)*di3 - ENDDO - ENDDO - GOTO 99999 - ENDIF - DO k = 1 , L1 + enddo + enddo + goto 99999 + endif + do k = 1 , l1 tr2 = Cc(1,2,k) + Cc(1,3,k) cr2 = Cc(1,1,k) + taur*tr2 Ch(1,k,1) = Cc(1,1,k) + tr2 @@ -47,6 +47,6 @@ SUBROUTINE PASSF3(Ido,L1,Cc,Ch,Wa1,Wa2) Ch(1,k,3) = cr2 + ci3 Ch(2,k,2) = ci2 + cr3 Ch(2,k,3) = ci2 - cr3 - ENDDO - RETURN -99999 END subroutine passf3 \ No newline at end of file + enddo + return +99999 end subroutine passf3 \ No newline at end of file diff --git a/src/passf4.f90 b/src/passf4.f90 index 9ca15b8..c4a825e 100644 --- a/src/passf4.f90 +++ b/src/passf4.f90 @@ -1,19 +1,19 @@ !*==PASSF4.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE PASSF4(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine passf4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) + use fftpack_kind + implicit none !*--PASSF41299 !*** Start of declarations inserted by SPAG - REAL Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , FFTPACK_KIND , & + real Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , fftpack_kind , & & rk , ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3 , tr4 , Wa1 , & & Wa2 - REAL Wa3 - INTEGER i , Ido , k , L1 + real Wa3 + integer i , Ido , k , l1 !*** End of declarations inserted by SPAG - DIMENSION Cc(Ido,4,L1) , Ch(Ido,L1,4) , Wa1(1) , Wa2(1) , Wa3(1) - IF ( Ido/=2 ) THEN - DO k = 1 , L1 - DO i = 2 , Ido , 2 + dimension Cc(Ido,4,l1) , Ch(Ido,l1,4) , Wa1(1) , Wa2(1) , Wa3(1) + if ( Ido/=2 ) then + do k = 1 , l1 + do i = 2 , Ido , 2 ti1 = Cc(i,1,k) - Cc(i,3,k) ti2 = Cc(i,1,k) + Cc(i,3,k) ti3 = Cc(i,2,k) + Cc(i,4,k) @@ -36,11 +36,11 @@ SUBROUTINE PASSF4(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3) Ch(i,k,3) = Wa2(i-1)*ci3 - Wa2(i)*cr3 Ch(i-1,k,4) = Wa3(i-1)*cr4 + Wa3(i)*ci4 Ch(i,k,4) = Wa3(i-1)*ci4 - Wa3(i)*cr4 - ENDDO - ENDDO - GOTO 99999 - ENDIF - DO k = 1 , L1 + enddo + enddo + goto 99999 + endif + do k = 1 , l1 ti1 = Cc(2,1,k) - Cc(2,3,k) ti2 = Cc(2,1,k) + Cc(2,3,k) tr4 = Cc(2,2,k) - Cc(2,4,k) @@ -57,6 +57,6 @@ SUBROUTINE PASSF4(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3) Ch(1,k,4) = tr1 - tr4 Ch(2,k,2) = ti1 + ti4 Ch(2,k,4) = ti1 - ti4 - ENDDO - RETURN -99999 END subroutine passf4 \ No newline at end of file + enddo + return +99999 end subroutine passf4 \ No newline at end of file diff --git a/src/passf5.f90 b/src/passf5.f90 index a45d0e0..fc4d73f 100644 --- a/src/passf5.f90 +++ b/src/passf5.f90 @@ -1,26 +1,26 @@ !*==PASSF5.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE PASSF5(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine passf5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) + use fftpack_kind + implicit none !*--PASSF51361 !*** Start of declarations inserted by SPAG - REAL Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , cr4 , cr5 , & + real Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , cr4 , cr5 , & & di2 , di3 , di4 , di5 , dr2 , dr3 , dr4 , dr5 , & - & FFTPACK_KIND , rk - REAL ti11 , ti12 , ti2 , ti3 , ti4 , ti5 , tr11 , tr12 , tr2 , & + & fftpack_kind , rk + real ti11 , ti12 , ti2 , ti3 , ti4 , ti5 , tr11 , tr12 , tr2 , & & tr3 , tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 - INTEGER i , Ido , k , L1 + integer i , Ido , k , l1 !*** End of declarations inserted by SPAG - DIMENSION Cc(Ido,5,L1) , Ch(Ido,L1,5) , Wa1(1) , Wa2(1) , Wa3(1) ,& + dimension Cc(Ido,5,l1) , Ch(Ido,l1,5) , Wa1(1) , Wa2(1) , Wa3(1) ,& & Wa4(1) ! *** TR11=COS(2*PI/5), TI11=-SIN(2*PI/5) ! *** TR12=-COS(4*PI/5), TI12=-SIN(4*PI/5) - DATA tr11 , ti11 , tr12 , ti12/0.3090169943749474241D0 , & - & -0.95105651629515357212D0 , -0.8090169943749474241D0 , & - & -0.58778525229247312917D0/ - IF ( Ido/=2 ) THEN - DO k = 1 , L1 - DO i = 2 , Ido , 2 + data tr11 , ti11 , tr12 , ti12/0.3090169943749474241d0 , & + & -0.95105651629515357212d0 , -0.8090169943749474241d0 , & + & -0.58778525229247312917d0/ + if ( Ido/=2 ) then + do k = 1 , l1 + do i = 2 , Ido , 2 ti5 = Cc(i,2,k) - Cc(i,5,k) ti2 = Cc(i,2,k) + Cc(i,5,k) ti4 = Cc(i,3,k) - Cc(i,4,k) @@ -55,11 +55,11 @@ SUBROUTINE PASSF5(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) Ch(i,k,4) = Wa3(i-1)*di4 - Wa3(i)*dr4 Ch(i-1,k,5) = Wa4(i-1)*dr5 + Wa4(i)*di5 Ch(i,k,5) = Wa4(i-1)*di5 - Wa4(i)*dr5 - ENDDO - ENDDO - GOTO 99999 - ENDIF - DO k = 1 , L1 + enddo + enddo + goto 99999 + endif + do k = 1 , l1 ti5 = Cc(2,2,k) - Cc(2,5,k) ti2 = Cc(2,2,k) + Cc(2,5,k) ti4 = Cc(2,3,k) - Cc(2,4,k) @@ -86,6 +86,6 @@ SUBROUTINE PASSF5(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) Ch(1,k,4) = cr3 + ci4 Ch(2,k,4) = ci3 - cr4 Ch(2,k,5) = ci2 - cr5 - ENDDO - RETURN -99999 END subroutine passf5 \ No newline at end of file + enddo + return +99999 end subroutine passf5 \ No newline at end of file diff --git a/src/radb2.f90 b/src/radb2.f90 index c26c7ad..94d9fa3 100644 --- a/src/radb2.f90 +++ b/src/radb2.f90 @@ -1,22 +1,22 @@ !*==RADB2.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE RADB2(Ido,L1,Cc,Ch,Wa1) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine radb2(Ido,l1,Cc,Ch,Wa1) + use fftpack_kind + implicit none !*--RADB21452 !*** Start of declarations inserted by SPAG - REAL Cc , Ch , FFTPACK_KIND , rk , ti2 , tr2 , Wa1 - INTEGER i , ic , Ido , idp2 , k , L1 + real Cc , Ch , fftpack_kind , rk , ti2 , tr2 , Wa1 + integer i , ic , Ido , idp2 , k , l1 !*** End of declarations inserted by SPAG - DIMENSION Cc(Ido,2,L1) , Ch(Ido,L1,2) , Wa1(1) - DO k = 1 , L1 + dimension Cc(Ido,2,l1) , Ch(Ido,l1,2) , Wa1(1) + do k = 1 , l1 Ch(1,k,1) = Cc(1,1,k) + Cc(Ido,2,k) Ch(1,k,2) = Cc(1,1,k) - Cc(Ido,2,k) - ENDDO - IF ( Ido<2 ) GOTO 99999 - IF ( Ido/=2 ) THEN + enddo + if ( Ido<2 ) goto 99999 + if ( Ido/=2 ) then idp2 = Ido + 2 - DO k = 1 , L1 - DO i = 3 , Ido , 2 + do k = 1 , l1 + do i = 3 , Ido , 2 ic = idp2 - i Ch(i-1,k,1) = Cc(i-1,1,k) + Cc(ic-1,2,k) tr2 = Cc(i-1,1,k) - Cc(ic-1,2,k) @@ -24,12 +24,12 @@ SUBROUTINE RADB2(Ido,L1,Cc,Ch,Wa1) ti2 = Cc(i,1,k) + Cc(ic,2,k) Ch(i-1,k,2) = Wa1(i-2)*tr2 - Wa1(i-1)*ti2 Ch(i,k,2) = Wa1(i-2)*ti2 + Wa1(i-1)*tr2 - ENDDO - ENDDO - IF ( MOD(Ido,2)==1 ) RETURN - ENDIF - DO k = 1 , L1 + enddo + enddo + if ( mod(Ido,2)==1 ) return + endif + do k = 1 , l1 Ch(Ido,k,1) = Cc(Ido,1,k) + Cc(Ido,1,k) Ch(Ido,k,2) = -(Cc(1,2,k)+Cc(1,2,k)) - ENDDO -99999 END subroutine radb2 \ No newline at end of file + enddo +99999 end subroutine radb2 \ No newline at end of file diff --git a/src/radb3.f90 b/src/radb3.f90 index 32e0b6b..b7c6944 100644 --- a/src/radb3.f90 +++ b/src/radb3.f90 @@ -1,28 +1,28 @@ !*==RADB3.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE RADB3(Ido,L1,Cc,Ch,Wa1,Wa2) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine radb3(Ido,l1,Cc,Ch,Wa1,Wa2) + use fftpack_kind + implicit none !*--RADB31487 !*** Start of declarations inserted by SPAG - REAL Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , dr2 , dr3 , & - & FFTPACK_KIND , rk , taui , taur , ti2 , tr2 , Wa1 , Wa2 - INTEGER i , ic , Ido , idp2 , k , L1 + real Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , dr2 , dr3 , & + & fftpack_kind , rk , taui , taur , ti2 , tr2 , Wa1 , Wa2 + integer i , ic , Ido , idp2 , k , l1 !*** End of declarations inserted by SPAG - DIMENSION Cc(Ido,3,L1) , Ch(Ido,L1,3) , Wa1(1) , Wa2(1) + dimension Cc(Ido,3,l1) , Ch(Ido,l1,3) , Wa1(1) , Wa2(1) ! *** TAUI IS SQRT(3)/2 *** - DATA taur , taui/ - 0.5D0 , 0.86602540378443864676D0/ - DO k = 1 , L1 + data taur , taui/ - 0.5d0 , 0.86602540378443864676d0/ + do k = 1 , l1 tr2 = Cc(Ido,2,k) + Cc(Ido,2,k) cr2 = Cc(1,1,k) + taur*tr2 Ch(1,k,1) = Cc(1,1,k) + tr2 ci3 = taui*(Cc(1,3,k)+Cc(1,3,k)) Ch(1,k,2) = cr2 - ci3 Ch(1,k,3) = cr2 + ci3 - ENDDO - IF ( Ido==1 ) RETURN + enddo + if ( Ido==1 ) return idp2 = Ido + 2 - DO k = 1 , L1 - DO i = 3 , Ido , 2 + do k = 1 , l1 + do i = 3 , Ido , 2 ic = idp2 - i tr2 = Cc(i-1,3,k) + Cc(ic-1,2,k) cr2 = Cc(i-1,1,k) + taur*tr2 @@ -40,6 +40,6 @@ SUBROUTINE RADB3(Ido,L1,Cc,Ch,Wa1,Wa2) Ch(i,k,2) = Wa1(i-2)*di2 + Wa1(i-1)*dr2 Ch(i-1,k,3) = Wa2(i-2)*dr3 - Wa2(i-1)*di3 Ch(i,k,3) = Wa2(i-2)*di3 + Wa2(i-1)*dr3 - ENDDO - ENDDO - END subroutine radb3 \ No newline at end of file + enddo + enddo + end subroutine radb3 \ No newline at end of file diff --git a/src/radb4.f90 b/src/radb4.f90 index 382a68a..85c76e3 100644 --- a/src/radb4.f90 +++ b/src/radb4.f90 @@ -1,18 +1,18 @@ !*==RADB4.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE RADB4(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine radb4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) + use fftpack_kind + implicit none !*--RADB41532 !*** Start of declarations inserted by SPAG - REAL Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , FFTPACK_KIND , & + real Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , fftpack_kind , & & rk , sqrt2 , ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3 , tr4 , & & Wa1 - REAL Wa2 , Wa3 - INTEGER i , ic , Ido , idp2 , k , L1 + real Wa2 , Wa3 + integer i , ic , Ido , idp2 , k , l1 !*** End of declarations inserted by SPAG - DIMENSION Cc(Ido,4,L1) , Ch(Ido,L1,4) , Wa1(1) , Wa2(1) , Wa3(1) - DATA sqrt2/1.41421356237309504880D0/ - DO k = 1 , L1 + dimension Cc(Ido,4,l1) , Ch(Ido,l1,4) , Wa1(1) , Wa2(1) , Wa3(1) + data sqrt2/1.41421356237309504880d0/ + do k = 1 , l1 tr1 = Cc(1,1,k) - Cc(Ido,4,k) tr2 = Cc(1,1,k) + Cc(Ido,4,k) tr3 = Cc(Ido,2,k) + Cc(Ido,2,k) @@ -21,12 +21,12 @@ SUBROUTINE RADB4(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3) Ch(1,k,2) = tr1 - tr4 Ch(1,k,3) = tr2 - tr3 Ch(1,k,4) = tr1 + tr4 - ENDDO - IF ( Ido<2 ) GOTO 99999 - IF ( Ido/=2 ) THEN + enddo + if ( Ido<2 ) goto 99999 + if ( Ido/=2 ) then idp2 = Ido + 2 - DO k = 1 , L1 - DO i = 3 , Ido , 2 + do k = 1 , l1 + do i = 3 , Ido , 2 ic = idp2 - i ti1 = Cc(i,1,k) + Cc(ic,4,k) ti2 = Cc(i,1,k) - Cc(ic,4,k) @@ -50,11 +50,11 @@ SUBROUTINE RADB4(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3) Ch(i,k,3) = Wa2(i-2)*ci3 + Wa2(i-1)*cr3 Ch(i-1,k,4) = Wa3(i-2)*cr4 - Wa3(i-1)*ci4 Ch(i,k,4) = Wa3(i-2)*ci4 + Wa3(i-1)*cr4 - ENDDO - ENDDO - IF ( MOD(Ido,2)==1 ) RETURN - ENDIF - DO k = 1 , L1 + enddo + enddo + if ( mod(Ido,2)==1 ) return + endif + do k = 1 , l1 ti1 = Cc(1,2,k) + Cc(1,4,k) ti2 = Cc(1,4,k) - Cc(1,2,k) tr1 = Cc(Ido,1,k) - Cc(Ido,3,k) @@ -63,5 +63,5 @@ SUBROUTINE RADB4(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3) Ch(Ido,k,2) = sqrt2*(tr1-ti1) Ch(Ido,k,3) = ti2 + ti2 Ch(Ido,k,4) = -sqrt2*(tr1+ti1) - ENDDO -99999 END subroutine radb4 \ No newline at end of file + enddo +99999 end subroutine radb4 \ No newline at end of file diff --git a/src/radb5.f90 b/src/radb5.f90 index c743183..6ae2a2b 100644 --- a/src/radb5.f90 +++ b/src/radb5.f90 @@ -1,24 +1,24 @@ !*==RADB5.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE RADB5(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine radb5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) + use fftpack_kind + implicit none !*--RADB51599 !*** Start of declarations inserted by SPAG - REAL Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , cr4 , cr5 , & + real Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , cr4 , cr5 , & & di2 , di3 , di4 , di5 , dr2 , dr3 , dr4 , dr5 , & - & FFTPACK_KIND , rk - REAL ti11 , ti12 , ti2 , ti3 , ti4 , ti5 , tr11 , tr12 , tr2 , & + & fftpack_kind , rk + real ti11 , ti12 , ti2 , ti3 , ti4 , ti5 , tr11 , tr12 , tr2 , & & tr3 , tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 - INTEGER i , ic , Ido , idp2 , k , L1 + integer i , ic , Ido , idp2 , k , l1 !*** End of declarations inserted by SPAG - DIMENSION Cc(Ido,5,L1) , Ch(Ido,L1,5) , Wa1(1) , Wa2(1) , Wa3(1) ,& + dimension Cc(Ido,5,l1) , Ch(Ido,l1,5) , Wa1(1) , Wa2(1) , Wa3(1) ,& & Wa4(1) ! *** TR11=COS(2*PI/5), TI11=SIN(2*PI/5) ! *** TR12=COS(4*PI/5), TI12=SIN(4*PI/5) - DATA tr11 , ti11 , tr12 , ti12/0.3090169943749474241D0 , & - & 0.95105651629515357212D0 , -0.8090169943749474241D0 , & - & 0.58778525229247312917D0/ - DO k = 1 , L1 + data tr11 , ti11 , tr12 , ti12/0.3090169943749474241d0 , & + & 0.95105651629515357212d0 , -0.8090169943749474241d0 , & + & 0.58778525229247312917d0/ + do k = 1 , l1 ti5 = Cc(1,3,k) + Cc(1,3,k) ti4 = Cc(1,5,k) + Cc(1,5,k) tr2 = Cc(Ido,2,k) + Cc(Ido,2,k) @@ -32,11 +32,11 @@ SUBROUTINE RADB5(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) Ch(1,k,3) = cr3 - ci4 Ch(1,k,4) = cr3 + ci4 Ch(1,k,5) = cr2 + ci5 - ENDDO - IF ( Ido==1 ) RETURN + enddo + if ( Ido==1 ) return idp2 = Ido + 2 - DO k = 1 , L1 - DO i = 3 , Ido , 2 + do k = 1 , l1 + do i = 3 , Ido , 2 ic = idp2 - i ti5 = Cc(i,3,k) + Cc(ic,2,k) ti2 = Cc(i,3,k) - Cc(ic,2,k) @@ -72,6 +72,6 @@ SUBROUTINE RADB5(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) Ch(i,k,4) = Wa3(i-2)*di4 + Wa3(i-1)*dr4 Ch(i-1,k,5) = Wa4(i-2)*dr5 - Wa4(i-1)*di5 Ch(i,k,5) = Wa4(i-2)*di5 + Wa4(i-1)*dr5 - ENDDO - ENDDO - END subroutine radb5 \ No newline at end of file + enddo + enddo + end subroutine radb5 \ No newline at end of file diff --git a/src/radbg.f90 b/src/radbg.f90 index 4f8f358..904514d 100644 --- a/src/radbg.f90 +++ b/src/radbg.f90 @@ -1,178 +1,178 @@ !*==RADBG.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE RADBG(Ido,Ip,L1,Idl1,Cc,C1,C2,Ch,Ch2,Wa) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine radbg(Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) + use fftpack_kind + implicit none !*--RADBG1676 !*** Start of declarations inserted by SPAG - REAL ai1 , ai2 , ar1 , ar1h , ar2 , ar2h , arg , C1 , C2 , Cc , & - & Ch , Ch2 , dc2 , dcp , ds2 , dsp , FFTPACK_KIND , rk , tpi , & + real ai1 , ai2 , ar1 , ar1h , ar2 , ar2h , arg , c1 , c2 , Cc , & + & Ch , Ch2 , dc2 , dcp , ds2 , dsp , fftpack_kind , rk , tpi , & & Wa - INTEGER i , ic , idij , Idl1 , Ido , idp2 , ik , Ip , ipp2 , & - & ipph , is , j , j2 , jc , k , l , L1 , lc , nbd + integer i , ic , idij , Idl1 , Ido , idp2 , ik , Ip , ipp2 , & + & ipph , is , j , j2 , jc , k , l , l1 , lc , nbd !*** End of declarations inserted by SPAG - DIMENSION Ch(Ido,L1,Ip) , Cc(Ido,Ip,L1) , C1(Ido,L1,Ip) , & - & C2(Idl1,Ip) , Ch2(Idl1,Ip) , Wa(1) - DATA tpi/6.28318530717958647692D0/ - arg = tpi/REAL(Ip,rk) - dcp = COS(arg) - dsp = SIN(arg) + dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , & + & c2(Idl1,Ip) , Ch2(Idl1,Ip) , Wa(1) + data tpi/6.28318530717958647692d0/ + arg = tpi/real(Ip,rk) + dcp = cos(arg) + dsp = sin(arg) idp2 = Ido + 2 nbd = (Ido-1)/2 ipp2 = Ip + 2 ipph = (Ip+1)/2 - IF ( IdoL1 ) THEN + do k = 1 , l1 + do i = 3 , Ido , 2 + Ch(i-1,k,j) = c1(i-1,k,j) - c1(i,k,jc) + Ch(i-1,k,jc) = c1(i-1,k,j) + c1(i,k,jc) + Ch(i,k,j) = c1(i,k,j) + c1(i-1,k,jc) + Ch(i,k,jc) = c1(i,k,j) - c1(i-1,k,jc) + enddo + enddo + enddo + endif + endif + if ( Ido==1 ) return + do ik = 1 , Idl1 + c2(ik,1) = Ch2(ik,1) + enddo + do j = 2 , Ip + do k = 1 , l1 + c1(1,k,j) = Ch(1,k,j) + enddo + enddo + if ( nbd>l1 ) then is = -Ido - DO j = 2 , Ip + do j = 2 , Ip is = is + Ido - DO k = 1 , L1 + do k = 1 , l1 idij = is - DO i = 3 , Ido , 2 + do i = 3 , Ido , 2 idij = idij + 2 - C1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & + c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & & *Ch(i,k,j) - C1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & + c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & & *Ch(i-1,k,j) - ENDDO - ENDDO - ENDDO - ELSE + enddo + enddo + enddo + else is = -Ido - DO j = 2 , Ip + do j = 2 , Ip is = is + Ido idij = is - DO i = 3 , Ido , 2 + do i = 3 , Ido , 2 idij = idij + 2 - DO k = 1 , L1 - C1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & + do k = 1 , l1 + c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & & *Ch(i,k,j) - C1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & + c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & & *Ch(i-1,k,j) - ENDDO - ENDDO - ENDDO - ENDIF - END subroutine radbg \ No newline at end of file + enddo + enddo + enddo + endif + end subroutine radbg \ No newline at end of file diff --git a/src/radf2.f90 b/src/radf2.f90 index f0666e3..2484926 100644 --- a/src/radf2.f90 +++ b/src/radf2.f90 @@ -1,22 +1,22 @@ !*==RADF2.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE RADF2(Ido,L1,Cc,Ch,Wa1) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine radf2(Ido,l1,Cc,Ch,Wa1) + use fftpack_kind + implicit none !*--RADF21854 !*** Start of declarations inserted by SPAG - REAL Cc , Ch , FFTPACK_KIND , rk , ti2 , tr2 , Wa1 - INTEGER i , ic , Ido , idp2 , k , L1 + real Cc , Ch , fftpack_kind , rk , ti2 , tr2 , Wa1 + integer i , ic , Ido , idp2 , k , l1 !*** End of declarations inserted by SPAG - DIMENSION Ch(Ido,2,L1) , Cc(Ido,L1,2) , Wa1(1) - DO k = 1 , L1 + dimension Ch(Ido,2,l1) , Cc(Ido,l1,2) , Wa1(1) + do k = 1 , l1 Ch(1,1,k) = Cc(1,k,1) + Cc(1,k,2) Ch(Ido,2,k) = Cc(1,k,1) - Cc(1,k,2) - ENDDO - IF ( Ido<2 ) GOTO 99999 - IF ( Ido/=2 ) THEN + enddo + if ( Ido<2 ) goto 99999 + if ( Ido/=2 ) then idp2 = Ido + 2 - DO k = 1 , L1 - DO i = 3 , Ido , 2 + do k = 1 , l1 + do i = 3 , Ido , 2 ic = idp2 - i tr2 = Wa1(i-2)*Cc(i-1,k,2) + Wa1(i-1)*Cc(i,k,2) ti2 = Wa1(i-2)*Cc(i,k,2) - Wa1(i-1)*Cc(i-1,k,2) @@ -24,12 +24,12 @@ SUBROUTINE RADF2(Ido,L1,Cc,Ch,Wa1) Ch(ic,2,k) = ti2 - Cc(i,k,1) Ch(i-1,1,k) = Cc(i-1,k,1) + tr2 Ch(ic-1,2,k) = Cc(i-1,k,1) - tr2 - ENDDO - ENDDO - IF ( MOD(Ido,2)==1 ) RETURN - ENDIF - DO k = 1 , L1 + enddo + enddo + if ( mod(Ido,2)==1 ) return + endif + do k = 1 , l1 Ch(1,2,k) = -Cc(Ido,k,2) Ch(Ido,1,k) = Cc(Ido,k,1) - ENDDO -99999 END subroutine radf2 \ No newline at end of file + enddo +99999 end subroutine radf2 \ No newline at end of file diff --git a/src/radf3.f90 b/src/radf3.f90 index 746ae36..e0e527d 100644 --- a/src/radf3.f90 +++ b/src/radf3.f90 @@ -1,26 +1,26 @@ !*==RADF3.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE RADF3(Ido,L1,Cc,Ch,Wa1,Wa2) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine radf3(Ido,l1,Cc,Ch,Wa1,Wa2) + use fftpack_kind + implicit none !*--RADF31889 !*** Start of declarations inserted by SPAG - REAL Cc , Ch , ci2 , cr2 , di2 , di3 , dr2 , dr3 , FFTPACK_KIND , & + real Cc , Ch , ci2 , cr2 , di2 , di3 , dr2 , dr3 , fftpack_kind , & & rk , taui , taur , ti2 , ti3 , tr2 , tr3 , Wa1 , Wa2 - INTEGER i , ic , Ido , idp2 , k , L1 + integer i , ic , Ido , idp2 , k , l1 !*** End of declarations inserted by SPAG - DIMENSION Ch(Ido,3,L1) , Cc(Ido,L1,3) , Wa1(1) , Wa2(1) + dimension Ch(Ido,3,l1) , Cc(Ido,l1,3) , Wa1(1) , Wa2(1) ! *** TAUI IS -SQRT(3)/2 *** - DATA taur , taui/ - 0.5D0 , 0.86602540378443864676D0/ - DO k = 1 , L1 + data taur , taui/ - 0.5d0 , 0.86602540378443864676d0/ + do k = 1 , l1 cr2 = Cc(1,k,2) + Cc(1,k,3) Ch(1,1,k) = Cc(1,k,1) + cr2 Ch(1,3,k) = taui*(Cc(1,k,3)-Cc(1,k,2)) Ch(Ido,2,k) = Cc(1,k,1) + taur*cr2 - ENDDO - IF ( Ido==1 ) RETURN + enddo + if ( Ido==1 ) return idp2 = Ido + 2 - DO k = 1 , L1 - DO i = 3 , Ido , 2 + do k = 1 , l1 + do i = 3 , Ido , 2 ic = idp2 - i dr2 = Wa1(i-2)*Cc(i-1,k,2) + Wa1(i-1)*Cc(i,k,2) di2 = Wa1(i-2)*Cc(i,k,2) - Wa1(i-1)*Cc(i-1,k,2) @@ -38,6 +38,6 @@ SUBROUTINE RADF3(Ido,L1,Cc,Ch,Wa1,Wa2) Ch(ic-1,2,k) = tr2 - tr3 Ch(i,3,k) = ti2 + ti3 Ch(ic,2,k) = ti3 - ti2 - ENDDO - ENDDO - END subroutine radf3 \ No newline at end of file + enddo + enddo + end subroutine radf3 \ No newline at end of file diff --git a/src/radf4.f90 b/src/radf4.f90 index 468ba9a..f9cbeb6 100644 --- a/src/radf4.f90 +++ b/src/radf4.f90 @@ -1,30 +1,30 @@ !*==RADF4.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE RADF4(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine radf4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) + use fftpack_kind + implicit none !*--RADF41932 !*** Start of declarations inserted by SPAG - REAL Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , FFTPACK_KIND , & + real Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , fftpack_kind , & & hsqt2 , rk , ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3 , tr4 , & & Wa1 - REAL Wa2 , Wa3 - INTEGER i , ic , Ido , idp2 , k , L1 + real Wa2 , Wa3 + integer i , ic , Ido , idp2 , k , l1 !*** End of declarations inserted by SPAG - DIMENSION Cc(Ido,L1,4) , Ch(Ido,4,L1) , Wa1(1) , Wa2(1) , Wa3(1) - DATA hsqt2/0.70710678118654752440D0/ - DO k = 1 , L1 + dimension Cc(Ido,l1,4) , Ch(Ido,4,l1) , Wa1(1) , Wa2(1) , Wa3(1) + data hsqt2/0.70710678118654752440d0/ + do k = 1 , l1 tr1 = Cc(1,k,2) + Cc(1,k,4) tr2 = Cc(1,k,1) + Cc(1,k,3) Ch(1,1,k) = tr1 + tr2 Ch(Ido,4,k) = tr2 - tr1 Ch(Ido,2,k) = Cc(1,k,1) - Cc(1,k,3) Ch(1,3,k) = Cc(1,k,4) - Cc(1,k,2) - ENDDO - IF ( Ido<2 ) GOTO 99999 - IF ( Ido/=2 ) THEN + enddo + if ( Ido<2 ) goto 99999 + if ( Ido/=2 ) then idp2 = Ido + 2 - DO k = 1 , L1 - DO i = 3 , Ido , 2 + do k = 1 , l1 + do i = 3 , Ido , 2 ic = idp2 - i cr2 = Wa1(i-2)*Cc(i-1,k,2) + Wa1(i-1)*Cc(i,k,2) ci2 = Wa1(i-2)*Cc(i,k,2) - Wa1(i-1)*Cc(i-1,k,2) @@ -48,16 +48,16 @@ SUBROUTINE RADF4(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3) Ch(ic-1,2,k) = tr3 - ti4 Ch(i,3,k) = tr4 + ti3 Ch(ic,2,k) = tr4 - ti3 - ENDDO - ENDDO - IF ( MOD(Ido,2)==1 ) RETURN - ENDIF - DO k = 1 , L1 + enddo + enddo + if ( mod(Ido,2)==1 ) return + endif + do k = 1 , l1 ti1 = -hsqt2*(Cc(Ido,k,2)+Cc(Ido,k,4)) tr1 = hsqt2*(Cc(Ido,k,2)-Cc(Ido,k,4)) Ch(Ido,1,k) = tr1 + Cc(Ido,k,1) Ch(Ido,3,k) = Cc(Ido,k,1) - tr1 Ch(1,2,k) = ti1 - Cc(Ido,k,3) Ch(1,4,k) = ti1 + Cc(Ido,k,3) - ENDDO -99999 END subroutine radf4 \ No newline at end of file + enddo +99999 end subroutine radf4 \ No newline at end of file diff --git a/src/radf5.f90 b/src/radf5.f90 index ad08267..e816123 100644 --- a/src/radf5.f90 +++ b/src/radf5.f90 @@ -1,22 +1,22 @@ !*==RADF5.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE RADF5(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine radf5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) + use fftpack_kind + implicit none !*--RADF51995 !*** Start of declarations inserted by SPAG - REAL Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , cr4 , cr5 , & + real Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , cr4 , cr5 , & & di2 , di3 , di4 , di5 , dr2 , dr3 , dr4 , dr5 , & - & FFTPACK_KIND , rk - REAL ti11 , ti12 , ti2 , ti3 , ti4 , ti5 , tr11 , tr12 , tr2 , & + & fftpack_kind , rk + real ti11 , ti12 , ti2 , ti3 , ti4 , ti5 , tr11 , tr12 , tr2 , & & tr3 , tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 - INTEGER i , ic , Ido , idp2 , k , L1 + integer i , ic , Ido , idp2 , k , l1 !*** End of declarations inserted by SPAG - DIMENSION Cc(Ido,L1,5) , Ch(Ido,5,L1) , Wa1(1) , Wa2(1) , Wa3(1) ,& + dimension Cc(Ido,l1,5) , Ch(Ido,5,l1) , Wa1(1) , Wa2(1) , Wa3(1) ,& & Wa4(1) - DATA tr11 , ti11 , tr12 , ti12/0.3090169943749474241D0 , & - & 0.95105651629515357212D0 , -0.8090169943749474241D0 , & - & 0.58778525229247312917D0/ - DO k = 1 , L1 + data tr11 , ti11 , tr12 , ti12/0.3090169943749474241d0 , & + & 0.95105651629515357212d0 , -0.8090169943749474241d0 , & + & 0.58778525229247312917d0/ + do k = 1 , l1 cr2 = Cc(1,k,5) + Cc(1,k,2) ci5 = Cc(1,k,5) - Cc(1,k,2) cr3 = Cc(1,k,4) + Cc(1,k,3) @@ -26,11 +26,11 @@ SUBROUTINE RADF5(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) Ch(1,3,k) = ti11*ci5 + ti12*ci4 Ch(Ido,4,k) = Cc(1,k,1) + tr12*cr2 + tr11*cr3 Ch(1,5,k) = ti12*ci5 - ti11*ci4 - ENDDO - IF ( Ido==1 ) RETURN + enddo + if ( Ido==1 ) return idp2 = Ido + 2 - DO k = 1 , L1 - DO i = 3 , Ido , 2 + do k = 1 , l1 + do i = 3 , Ido , 2 ic = idp2 - i dr2 = Wa1(i-2)*Cc(i-1,k,2) + Wa1(i-1)*Cc(i,k,2) di2 = Wa1(i-2)*Cc(i,k,2) - Wa1(i-1)*Cc(i-1,k,2) @@ -66,6 +66,6 @@ SUBROUTINE RADF5(Ido,L1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) Ch(ic-1,4,k) = tr3 - tr4 Ch(i,5,k) = ti3 + ti4 Ch(ic,4,k) = ti4 - ti3 - ENDDO - ENDDO - END subroutine radf5 \ No newline at end of file + enddo + enddo + end subroutine radf5 \ No newline at end of file diff --git a/src/radfg.f90 b/src/radfg.f90 index cb855dc..0079f1b 100644 --- a/src/radfg.f90 +++ b/src/radfg.f90 @@ -1,185 +1,185 @@ !*==RADFG.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 - SUBROUTINE RADFG(Ido,Ip,L1,Idl1,Cc,C1,C2,Ch,Ch2,Wa) - USE FFTPACK_KIND - IMPLICIT NONE + subroutine radfg(Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) + use fftpack_kind + implicit none !*--RADFG2066 !*** Start of declarations inserted by SPAG - REAL ai1 , ai2 , ar1 , ar1h , ar2 , ar2h , arg , C1 , C2 , Cc , & - & Ch , Ch2 , dc2 , dcp , ds2 , dsp , FFTPACK_KIND , rk , tpi , & + real ai1 , ai2 , ar1 , ar1h , ar2 , ar2h , arg , c1 , c2 , Cc , & + & Ch , Ch2 , dc2 , dcp , ds2 , dsp , fftpack_kind , rk , tpi , & & Wa - INTEGER i , ic , idij , Idl1 , Ido , idp2 , ik , Ip , ipp2 , & - & ipph , is , j , j2 , jc , k , l , L1 , lc , nbd + integer i , ic , idij , Idl1 , Ido , idp2 , ik , Ip , ipp2 , & + & ipph , is , j , j2 , jc , k , l , l1 , lc , nbd !*** End of declarations inserted by SPAG - DIMENSION Ch(Ido,L1,Ip) , Cc(Ido,Ip,L1) , C1(Ido,L1,Ip) , & - & C2(Idl1,Ip) , Ch2(Idl1,Ip) , Wa(1) - DATA tpi/6.28318530717958647692D0/ - arg = tpi/REAL(Ip,rk) - dcp = COS(arg) - dsp = SIN(arg) + dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , & + & c2(Idl1,Ip) , Ch2(Idl1,Ip) , Wa(1) + data tpi/6.28318530717958647692d0/ + arg = tpi/real(Ip,rk) + dcp = cos(arg) + dsp = sin(arg) ipph = (Ip+1)/2 ipp2 = Ip + 2 idp2 = Ido + 2 nbd = (Ido-1)/2 - IF ( Ido==1 ) THEN - DO ik = 1 , Idl1 - C2(ik,1) = Ch2(ik,1) - ENDDO - ELSE - DO ik = 1 , Idl1 - Ch2(ik,1) = C2(ik,1) - ENDDO - DO j = 2 , Ip - DO k = 1 , L1 - Ch(1,k,j) = C1(1,k,j) - ENDDO - ENDDO - IF ( nbd>L1 ) THEN + if ( Ido==1 ) then + do ik = 1 , Idl1 + c2(ik,1) = Ch2(ik,1) + enddo + else + do ik = 1 , Idl1 + Ch2(ik,1) = c2(ik,1) + enddo + do j = 2 , Ip + do k = 1 , l1 + Ch(1,k,j) = c1(1,k,j) + enddo + enddo + if ( nbd>l1 ) then is = -Ido - DO j = 2 , Ip + do j = 2 , Ip is = is + Ido - DO k = 1 , L1 + do k = 1 , l1 idij = is - DO i = 3 , Ido , 2 + do i = 3 , Ido , 2 idij = idij + 2 - Ch(i-1,k,j) = Wa(idij-1)*C1(i-1,k,j) + Wa(idij) & - & *C1(i,k,j) - Ch(i,k,j) = Wa(idij-1)*C1(i,k,j) - Wa(idij) & - & *C1(i-1,k,j) - ENDDO - ENDDO - ENDDO - ELSE + Ch(i-1,k,j) = Wa(idij-1)*c1(i-1,k,j) + Wa(idij) & + & *c1(i,k,j) + Ch(i,k,j) = Wa(idij-1)*c1(i,k,j) - Wa(idij) & + & *c1(i-1,k,j) + enddo + enddo + enddo + else is = -Ido - DO j = 2 , Ip + do j = 2 , Ip is = is + Ido idij = is - DO i = 3 , Ido , 2 + do i = 3 , Ido , 2 idij = idij + 2 - DO k = 1 , L1 - Ch(i-1,k,j) = Wa(idij-1)*C1(i-1,k,j) + Wa(idij) & - & *C1(i,k,j) - Ch(i,k,j) = Wa(idij-1)*C1(i,k,j) - Wa(idij) & - & *C1(i-1,k,j) - ENDDO - ENDDO - ENDDO - ENDIF - IF ( nbd Date: Tue, 14 Sep 2021 13:32:00 -0500 Subject: [PATCH 06/10] manual cleanups. added back rk module --- src/cfftb1.f90 | 10 ++---- src/cfftf1.f90 | 10 ++---- src/cffti1.f90 | 29 +++++++--------- src/cosqb1.f90 | 10 ++---- src/cosqf1.f90 | 10 ++---- src/dcosqb.f90 | 14 +++----- src/dcosqf.f90 | 15 +++----- src/dcosqi.f90 | 18 ++++------ src/dcost.f90 | 17 ++++----- src/dcosti.f90 | 22 +++++------- src/dfftb.f90 | 10 ++---- src/dfftf.f90 | 10 ++---- src/dffti.f90 | 10 ++---- src/dsinqb.f90 | 16 ++++----- src/dsinqf.f90 | 10 ++---- src/dsinqi.f90 | 10 ++---- src/dsint.f90 | 10 ++---- src/dsinti.f90 | 16 ++++----- src/dzfftb.f90 | 12 +++---- src/dzfftf.f90 | 22 +++++------- src/dzffti.f90 | 10 ++---- src/ezfft1.f90 | 26 ++++++-------- src/passb.f90 | 24 ++++++------- src/passb2.f90 | 29 +++++++--------- src/passb3.f90 | 51 +++++++++++++-------------- src/passb4.f90 | 58 ++++++++++++++----------------- src/passb5.f90 | 93 ++++++++++++++++++++++++-------------------------- src/passf.f90 | 45 +++++++++++------------- src/passf2.f90 | 29 +++++++--------- src/passf3.f90 | 51 +++++++++++++-------------- src/passf4.f90 | 58 ++++++++++++++----------------- src/passf5.f90 | 93 ++++++++++++++++++++++++-------------------------- src/radb2.f90 | 14 +++----- src/radb3.f90 | 16 ++++----- src/radb4.f90 | 21 +++++------- src/radb5.f90 | 30 +++++++--------- src/radbg.f90 | 42 +++++++++++------------ src/radf2.f90 | 14 +++----- src/radf3.f90 | 17 ++++----- src/radf4.f90 | 21 +++++------- src/radf5.f90 | 28 +++++++-------- src/radfg.f90 | 71 ++++++++++++++++++-------------------- src/rfftb1.f90 | 10 ++---- src/rfftf1.f90 | 10 ++---- src/rffti1.f90 | 25 ++++++-------- src/rk.f90 | 4 +++ src/sint1.f90 | 16 ++++----- src/zfftb.f90 | 10 ++---- src/zfftf.f90 | 10 ++---- src/zffti.f90 | 10 ++---- 50 files changed, 505 insertions(+), 712 deletions(-) create mode 100644 src/rk.f90 diff --git a/src/cfftb1.f90 b/src/cfftb1.f90 index efc29bc..43f5b54 100644 --- a/src/cfftb1.f90 +++ b/src/cfftb1.f90 @@ -1,13 +1,9 @@ -!*==CFFTB1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine cfftb1(n,c,Ch,Wa,Ifac) use fftpack_kind implicit none -!*--CFFTB15 -!*** Start of declarations inserted by SPAG - real c , Ch , fftpack_kind , rk , Wa - integer i , idl1 , ido , idot , Ifac , ip , iw , ix2 , ix3 , ix4 ,& - & k1 , l1 , l2 , n , n2 , na , nac , nf -!*** End of declarations inserted by SPAG + real(rk) :: c , Ch , Wa + integer :: i , idl1 , ido , idot , Ifac , ip , iw , ix2 , ix3 , ix4, & + k1 , l1 , l2 , n , n2 , na , nac , nf dimension Ch(*) , c(*) , Wa(*) , Ifac(*) nf = Ifac(2) na = 0 diff --git a/src/cfftf1.f90 b/src/cfftf1.f90 index 39ffbb8..0139f39 100644 --- a/src/cfftf1.f90 +++ b/src/cfftf1.f90 @@ -1,13 +1,9 @@ -!*==CFFTF1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine cfftf1(n,c,Ch,Wa,Ifac) use fftpack_kind implicit none -!*--CFFTF177 -!*** Start of declarations inserted by SPAG - real c , Ch , fftpack_kind , rk , Wa - integer i , idl1 , ido , idot , Ifac , ip , iw , ix2 , ix3 , ix4 ,& - & k1 , l1 , l2 , n , n2 , na , nac , nf -!*** End of declarations inserted by SPAG + real(rk) :: c , Ch , Wa + integer :: i , idl1 , ido , idot , Ifac , ip , iw , ix2 , ix3 , ix4, & + k1 , l1 , l2 , n , n2 , na , nac , nf dimension Ch(*) , c(*) , Wa(*) , Ifac(*) nf = Ifac(2) na = 0 diff --git a/src/cffti1.f90 b/src/cffti1.f90 index 4b0cd0c..1335697 100644 --- a/src/cffti1.f90 +++ b/src/cffti1.f90 @@ -1,16 +1,12 @@ -!*==CFFTI1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine cffti1(n,Wa,Ifac) use fftpack_kind implicit none -!*--CFFTI1149 -!*** Start of declarations inserted by SPAG - real arg , argh , argld , fftpack_kind , fi , rk , tpi , Wa - integer i , i1 , ib , ido , idot , Ifac , ii , ip , ipm , j , k1 ,& - & l1 , l2 , ld , n , nf , nl , nq , nr , ntry - integer ntryh -!*** End of declarations inserted by SPAG - dimension Wa(*) , Ifac(*) , ntryh(4) - data ntryh(1) , ntryh(2) , ntryh(3) , ntryh(4)/3 , 4 , 2 , 5/ + real(rk) :: arg , argh , argld , fi , Wa + integer :: i , i1 , ib , ido , idot , Ifac , ii , ip , ipm , j , k1, & + l1 , l2 , ld , n , nf , nl , nq , nr , ntry + dimension Wa(*) , Ifac(*) + integer,dimension(4),parameter :: ntryh = [3 , 4 , 2 , 5] + real(rk),parameter :: tpi = 2.0_rk * acos(-1.0_rk) ! 2 * pi nl = n nf = 0 j = 0 @@ -38,8 +34,7 @@ subroutine cffti1(n,Wa,Ifac) if ( nl/=1 ) goto 200 Ifac(1) = n Ifac(2) = nf - tpi = 6.28318530717958647692d0 - argh = tpi/real(n,rk) + argh = tpi/real(n, rk) i = 2 l1 = 1 do k1 = 1 , nf @@ -51,14 +46,14 @@ subroutine cffti1(n,Wa,Ifac) ipm = ip - 1 do j = 1 , ipm i1 = i - Wa(i-1) = 1.0d0 - Wa(i) = 0.0d0 + Wa(i-1) = 1.0_rk + Wa(i) = 0.0_rk ld = ld + l1 - fi = 0.0d0 - argld = real(ld,rk)*argh + fi = 0.0_rk + argld = real(ld, rk)*argh do ii = 4 , idot , 2 i = i + 2 - fi = fi + 1.d0 + fi = fi + 1.0_rk arg = fi*argld Wa(i-1) = cos(arg) Wa(i) = sin(arg) diff --git a/src/cosqb1.f90 b/src/cosqb1.f90 index e50108c..11d7f4a 100644 --- a/src/cosqb1.f90 +++ b/src/cosqb1.f90 @@ -1,13 +1,9 @@ -!*==COSQB1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine cosqb1(n,x,w,Xh) use fftpack_kind implicit none -!*--COSQB1222 -!*** Start of declarations inserted by SPAG - real fftpack_kind , rk , w , x , Xh , xim1 - integer i , k , kc , modn , n , np2 , ns2 -!*** End of declarations inserted by SPAG - dimension x(1) , w(1) , Xh(1) + integer :: i , k , kc , modn , n , np2 , ns2 + real(rk) :: w , x , Xh , xim1 + dimension x(*) , w(*) , Xh(*) ns2 = (n+1)/2 np2 = n + 2 do i = 3 , n , 2 diff --git a/src/cosqf1.f90 b/src/cosqf1.f90 index 345452e..8ef39f4 100644 --- a/src/cosqf1.f90 +++ b/src/cosqf1.f90 @@ -1,13 +1,9 @@ -!*==COSQF1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine cosqf1(n,x,w,Xh) use fftpack_kind implicit none -!*--COSQF1256 -!*** Start of declarations inserted by SPAG - real fftpack_kind , rk , w , x , Xh , xim1 - integer i , k , kc , modn , n , np2 , ns2 -!*** End of declarations inserted by SPAG - dimension x(1) , w(1) , Xh(1) + integer :: i , k , kc , modn , n , np2 , ns2 + real(rk) :: w , x , Xh , xim1 + dimension x(*) , w(*) , Xh(*) ns2 = (n+1)/2 np2 = n + 2 do k = 2 , ns2 diff --git a/src/dcosqb.f90 b/src/dcosqb.f90 index ade647f..1ab8de7 100644 --- a/src/dcosqb.f90 +++ b/src/dcosqb.f90 @@ -1,19 +1,15 @@ -!*==DCOSQB.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine dcosqb(n,x,Wsave) use fftpack_kind implicit none -!*--DCOSQB288 -!*** Start of declarations inserted by SPAG - real fftpack_kind , rk , tsqrt2 , Wsave , x , x1 - integer n -!*** End of declarations inserted by SPAG + integer :: n + real(rk) :: Wsave , x , x1 dimension x(*) , Wsave(*) - data tsqrt2/2.82842712474619009760d0/ + real(rk),parameter :: tsqrt2 = 2.0_rk * sqrt(2.0_rk) if ( n<2 ) then - x(1) = 4.0d0*x(1) + x(1) = 4.0_rk*x(1) return elseif ( n==2 ) then - x1 = 4.0d0*(x(1)+x(2)) + x1 = 4.0_rk*(x(1)+x(2)) x(2) = tsqrt2*(x(1)-x(2)) x(1) = x1 return diff --git a/src/dcosqf.f90 b/src/dcosqf.f90 index 004a713..27f4ceb 100644 --- a/src/dcosqf.f90 +++ b/src/dcosqf.f90 @@ -1,22 +1,17 @@ -!*==DCOSQF.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine dcosqf(n,x,Wsave) use fftpack_kind implicit none -!*--DCOSQF311 -!*** Start of declarations inserted by SPAG - real fftpack_kind , rk , sqrt2 , tsqx , Wsave , x - integer n -!*** End of declarations inserted by SPAG + integer :: n + real(rk) :: tsqx , Wsave , x dimension x(*) , Wsave(*) - data sqrt2/1.41421356237309504880d0/ + real(rk),parameter :: sqrt2 = sqrt(2.0_rk) if ( n<2 ) then + return elseif ( n==2 ) then tsqx = sqrt2*x(2) x(2) = x(1) - tsqx x(1) = x(1) + tsqx else call cosqf1(n,x,Wsave,Wsave(n+1)) - goto 99999 endif - return -99999 end subroutine dcosqf \ No newline at end of file + end subroutine dcosqf \ No newline at end of file diff --git a/src/dcosqi.f90 b/src/dcosqi.f90 index 944f1e9..1faf8d0 100644 --- a/src/dcosqi.f90 +++ b/src/dcosqi.f90 @@ -1,18 +1,14 @@ -!*==DCOSQI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine dcosqi(n,Wsave) use fftpack_kind implicit none -!*--DCOSQI333 -!*** Start of declarations inserted by SPAG - real dt , fftpack_kind , fk , pih , rk , Wsave - integer k , n -!*** End of declarations inserted by SPAG - dimension Wsave(1) - data pih/1.57079632679489661923d0/ - dt = pih/real(n,rk) - fk = 0.0d0 + real(rk) :: dt , fk , Wsave + integer :: k , n + dimension Wsave(*) + real(rk),parameter :: pih = acos(-1.0_rk) / 2.0_rk ! pi / 2 + dt = pih/real(n, rk) + fk = 0.0_rk do k = 1 , n - fk = fk + 1.0d0 + fk = fk + 1.0_rk Wsave(k) = cos(fk*dt) enddo call dffti(n,Wsave(n+1)) diff --git a/src/dcost.f90 b/src/dcost.f90 index 11f86a7..fdc431d 100644 --- a/src/dcost.f90 +++ b/src/dcost.f90 @@ -1,18 +1,14 @@ -!*==DCOST.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine dcost(n,x,Wsave) use fftpack_kind implicit none -!*--DCOST352 -!*** Start of declarations inserted by SPAG - real c1 , fftpack_kind , rk , t1 , t2 , tx2 , Wsave , x , x1h , & - & x1p3 , xi , xim2 - integer i , k , kc , modn , n , nm1 , np1 , ns2 -!*** End of declarations inserted by SPAG + real(rk) :: c1 , t1 , t2 , tx2 , Wsave , x , x1h , x1p3 , & + xi , xim2 + integer :: i , k , kc , modn , n , nm1 , np1 , ns2 dimension x(*) , Wsave(*) nm1 = n - 1 np1 = n + 1 ns2 = n/2 - if ( n<2 ) goto 99999 + if ( n<2 ) return if ( n==2 ) then x1h = x(1) + x(2) x(2) = x(1) - x(2) @@ -42,12 +38,11 @@ subroutine dcost(n,x,Wsave) xim2 = xi enddo if ( modn/=0 ) x(n) = xim2 - goto 99999 + return endif x1p3 = x(1) + x(3) tx2 = x(2) + x(2) x(2) = x(1) - x(3) x(1) = x1p3 + tx2 x(3) = x1p3 - tx2 - return -99999 end subroutine dcost \ No newline at end of file + end subroutine dcost \ No newline at end of file diff --git a/src/dcosti.f90 b/src/dcosti.f90 index e478243..ed4fc1d 100644 --- a/src/dcosti.f90 +++ b/src/dcosti.f90 @@ -1,25 +1,21 @@ -!*==DCOSTI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine dcosti(n,Wsave) use fftpack_kind implicit none -!*--DCOSTI405 -!*** Start of declarations inserted by SPAG - real dt , fftpack_kind , fk , pi , rk , Wsave - integer k , kc , n , nm1 , np1 , ns2 -!*** End of declarations inserted by SPAG - dimension Wsave(1) - data pi/3.14159265358979323846d0/ + real(rk) :: dt , fk , Wsave + integer :: k , kc , n , nm1 , np1 , ns2 + dimension Wsave(*) + real(rk),parameter :: pi = acos(-1.0_rk) if ( n<=3 ) return nm1 = n - 1 np1 = n + 1 ns2 = n/2 - dt = pi/real(nm1,rk) - fk = 0.0d0 + dt = pi/real(nm1, rk) + fk = 0.0_rk do k = 2 , ns2 kc = np1 - k - fk = fk + 1.0d0 - Wsave(k) = 2.0d0*sin(fk*dt) - Wsave(kc) = 2.0d0*cos(fk*dt) + fk = fk + 1.0_rk + Wsave(k) = 2.0_rk*sin(fk*dt) + Wsave(kc) = 2.0_rk*cos(fk*dt) enddo call dffti(nm1,Wsave(n+1)) end subroutine dcosti \ No newline at end of file diff --git a/src/dfftb.f90 b/src/dfftb.f90 index f751011..20167d8 100644 --- a/src/dfftb.f90 +++ b/src/dfftb.f90 @@ -1,13 +1,9 @@ -!*==DFFTB.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine dfftb(n,r,Wsave) use fftpack_kind implicit none -!*--DFFTB430 -!*** Start of declarations inserted by SPAG - real fftpack_kind , r , rk , Wsave - integer n -!*** End of declarations inserted by SPAG - dimension r(1) , Wsave(1) + integer :: n + real(rk) :: r , Wsave + dimension r(1) , Wsave(*) if ( n==1 ) return call rfftb1(n,r,Wsave,Wsave(n+1),Wsave(2*n+1)) end subroutine dfftb \ No newline at end of file diff --git a/src/dfftf.f90 b/src/dfftf.f90 index 4dc16be..e52a2d0 100644 --- a/src/dfftf.f90 +++ b/src/dfftf.f90 @@ -1,13 +1,9 @@ -!*==DFFTF.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine dfftf(n,r,Wsave) use fftpack_kind implicit none -!*--DFFTF443 -!*** Start of declarations inserted by SPAG - real fftpack_kind , r , rk , Wsave - integer n -!*** End of declarations inserted by SPAG - dimension r(1) , Wsave(1) + integer :: n + real(rk) :: r , Wsave + dimension r(1) , Wsave(*) if ( n==1 ) return call rfftf1(n,r,Wsave,Wsave(n+1),Wsave(2*n+1)) end subroutine dfftf \ No newline at end of file diff --git a/src/dffti.f90 b/src/dffti.f90 index 455aa00..d9f07db 100644 --- a/src/dffti.f90 +++ b/src/dffti.f90 @@ -1,13 +1,9 @@ -!*==DFFTI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine dffti(n,Wsave) use fftpack_kind implicit none -!*--DFFTI456 -!*** Start of declarations inserted by SPAG - real fftpack_kind , rk , Wsave - integer n -!*** End of declarations inserted by SPAG - dimension Wsave(1) + integer :: n + real(rk) :: Wsave + dimension Wsave(*) if ( n==1 ) return call rffti1(n,Wsave(n+1),Wsave(2*n+1)) end subroutine dffti \ No newline at end of file diff --git a/src/dsinqb.f90 b/src/dsinqb.f90 index a6dec3f..1832e6b 100644 --- a/src/dsinqb.f90 +++ b/src/dsinqb.f90 @@ -1,13 +1,9 @@ -!*==DSINQB.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine dsinqb(n,x,Wsave) use fftpack_kind implicit none -!*--DSINQB469 -!*** Start of declarations inserted by SPAG - real fftpack_kind , rk , Wsave , x , xhold - integer k , kc , n , ns2 -!*** End of declarations inserted by SPAG - dimension x(1) , Wsave(1) + integer :: k , kc , n , ns2 + real(rk) :: Wsave , x , xhold + dimension x(*) , Wsave(*) if ( n>1 ) then ns2 = n/2 do k = 2 , n , 2 @@ -20,8 +16,8 @@ subroutine dsinqb(n,x,Wsave) x(k) = x(kc+1) x(kc+1) = xhold enddo - goto 99999 + return endif - x(1) = 4.0d0*x(1) + x(1) = 4.0_rk*x(1) return -99999 end subroutine dsinqb \ No newline at end of file + end subroutine dsinqb \ No newline at end of file diff --git a/src/dsinqf.f90 b/src/dsinqf.f90 index ae416fb..66e7312 100644 --- a/src/dsinqf.f90 +++ b/src/dsinqf.f90 @@ -1,13 +1,9 @@ -!*==DSINQF.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine dsinqf(n,x,Wsave) use fftpack_kind implicit none -!*--DSINQF496 -!*** Start of declarations inserted by SPAG - real fftpack_kind , rk , Wsave , x , xhold - integer k , kc , n , ns2 -!*** End of declarations inserted by SPAG - dimension x(1) , Wsave(1) + integer :: k , kc , n , ns2 + real(rk) :: Wsave , x , xhold + dimension x(*) , Wsave(*) if ( n==1 ) return ns2 = n/2 do k = 1 , ns2 diff --git a/src/dsinqi.f90 b/src/dsinqi.f90 index 3319dc6..d95e2db 100644 --- a/src/dsinqi.f90 +++ b/src/dsinqi.f90 @@ -1,12 +1,8 @@ -!*==DSINQI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine dsinqi(n,Wsave) use fftpack_kind implicit none -!*--DSINQI519 -!*** Start of declarations inserted by SPAG - real fftpack_kind , rk , Wsave - integer n -!*** End of declarations inserted by SPAG - dimension Wsave(1) + integer :: n + real(rk) :: Wsave + dimension Wsave(*) call dcosqi(n,Wsave) end subroutine dsinqi \ No newline at end of file diff --git a/src/dsint.f90 b/src/dsint.f90 index 40bf2cc..8c97f2f 100644 --- a/src/dsint.f90 +++ b/src/dsint.f90 @@ -1,13 +1,9 @@ -!*==DSINT.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine dsint(n,x,Wsave) use fftpack_kind implicit none -!*--DSINT531 -!*** Start of declarations inserted by SPAG - real fftpack_kind , rk , Wsave , x - integer iw1 , iw2 , iw3 , n , np1 -!*** End of declarations inserted by SPAG - dimension x(1) , Wsave(1) + integer :: iw1 , iw2 , iw3 , n , np1 + real(rk) :: Wsave , x + dimension x(*) , Wsave(*) np1 = n + 1 iw1 = n/2 + 1 iw2 = iw1 + np1 diff --git a/src/dsinti.f90 b/src/dsinti.f90 index 17acc36..2069076 100644 --- a/src/dsinti.f90 +++ b/src/dsinti.f90 @@ -1,20 +1,16 @@ -!*==DSINTI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine dsinti(n,Wsave) use fftpack_kind implicit none -!*--DSINTI547 -!*** Start of declarations inserted by SPAG - real dt , fftpack_kind , pi , rk , Wsave - integer k , n , np1 , ns2 -!*** End of declarations inserted by SPAG - dimension Wsave(1) - data pi/3.14159265358979323846d0/ + real(rk) :: dt , Wsave + integer :: k , n , np1 , ns2 + dimension Wsave(*) + real(rk),parameter :: pi = acos(-1.0_rk) if ( n<=1 ) return ns2 = n/2 np1 = n + 1 - dt = pi/real(np1,rk) + dt = pi/real(np1, rk) do k = 1 , ns2 - Wsave(k) = 2.0d0*sin(k*dt) + Wsave(k) = 2.0_rk*sin(k*dt) enddo call dffti(np1,Wsave(ns2+1)) end subroutine dsinti \ No newline at end of file diff --git a/src/dzfftb.f90 b/src/dzfftb.f90 index 374227d..e02dcc1 100644 --- a/src/dzfftb.f90 +++ b/src/dzfftb.f90 @@ -1,12 +1,8 @@ -!*==DZFFTB.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine dzfftb(n,r,Azero,a,b,Wsave) use fftpack_kind implicit none -!*--DZFFTB567 -!*** Start of declarations inserted by SPAG - real a , Azero , b , fftpack_kind , r , rk , Wsave - integer i , n , ns2 -!*** End of declarations inserted by SPAG + real(rk) :: a , Azero , b , r , Wsave + integer :: i , n , ns2 dimension r(*) , a(*) , b(*) , Wsave(*) if ( n<2 ) then r(1) = Azero @@ -18,8 +14,8 @@ subroutine dzfftb(n,r,Azero,a,b,Wsave) else ns2 = (n-1)/2 do i = 1 , ns2 - r(2*i) = 0.5d0*a(i) - r(2*i+1) = -0.5d0*b(i) + r(2*i) = 0.5_rk*a(i) + r(2*i+1) = -0.5_rk*b(i) enddo r(1) = Azero if ( mod(n,2)==0 ) r(n) = a(ns2+1) diff --git a/src/dzfftf.f90 b/src/dzfftf.f90 index 14c1c5d..d122b9b 100644 --- a/src/dzfftf.f90 +++ b/src/dzfftf.f90 @@ -1,31 +1,27 @@ -!*==DZFFTF.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine dzfftf(n,r,Azero,a,b,Wsave) ! -! VERSION 3 JUNE 1979 +! VERSION 3 JUNE 1979 ! use fftpack_kind implicit none -!*--DZFFTF598 -!*** Start of declarations inserted by SPAG - real a , Azero , b , cf , cfm , fftpack_kind , r , rk , Wsave - integer i , n , ns2 , ns2m -!*** End of declarations inserted by SPAG + real(rk) :: a , Azero , b , cf , cfm , r , Wsave + integer :: i , n , ns2 , ns2m dimension r(*) , a(*) , b(*) , Wsave(*) if ( n<2 ) then Azero = r(1) return elseif ( n==2 ) then - Azero = 0.5d0*(r(1)+r(2)) - a(1) = 0.5d0*(r(1)-r(2)) + Azero = 0.5_rk*(r(1)+r(2)) + a(1) = 0.5_rk*(r(1)-r(2)) return else do i = 1 , n Wsave(i) = r(i) enddo call dfftf(n,Wsave,Wsave(n+1)) - cf = 2.0d0/real(n,rk) + cf = 2.0_rk/real(n, rk) cfm = -cf - Azero = 0.5d0*cf*Wsave(1) + Azero = 0.5_rk*cf*Wsave(1) ns2 = (n+1)/2 ns2m = ns2 - 1 do i = 1 , ns2m @@ -33,7 +29,7 @@ subroutine dzfftf(n,r,Azero,a,b,Wsave) b(i) = cfm*Wsave(2*i+1) enddo if ( mod(n,2)==1 ) return - a(ns2) = 0.5d0*cf*Wsave(n) - b(ns2) = 0.0d0 + a(ns2) = 0.5_rk*cf*Wsave(n) + b(ns2) = 0.0_rk endif end subroutine dzfftf \ No newline at end of file diff --git a/src/dzffti.f90 b/src/dzffti.f90 index db904a6..8b51821 100644 --- a/src/dzffti.f90 +++ b/src/dzffti.f90 @@ -1,13 +1,9 @@ -!*==DZFFTI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine dzffti(n,Wsave) use fftpack_kind implicit none -!*--DZFFTI634 -!*** Start of declarations inserted by SPAG - real fftpack_kind , rk , Wsave - integer n -!*** End of declarations inserted by SPAG - dimension Wsave(1) + integer :: n + real(rk) :: Wsave + dimension Wsave(*) if ( n==1 ) return call ezfft1(n,Wsave(2*n+1),Wsave(3*n+1)) end subroutine dzffti \ No newline at end of file diff --git a/src/ezfft1.f90 b/src/ezfft1.f90 index 169818e..45e1c7d 100644 --- a/src/ezfft1.f90 +++ b/src/ezfft1.f90 @@ -1,17 +1,13 @@ -!*==EZFFT1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine ezfft1(n,Wa,Ifac) use fftpack_kind implicit none -!*--EZFFT1647 -!*** Start of declarations inserted by SPAG - real arg1 , argh , ch1 , ch1h , dch1 , dsh1 , fftpack_kind , rk , & - & sh1 , tpi , Wa - integer i , ib , ido , Ifac , ii , ip , ipm , is , j , k1 , l1 , & - & l2 , n , nf , nfm1 , nl , nq , nr , ntry , ntryh -!*** End of declarations inserted by SPAG - dimension Wa(*) , Ifac(*) , ntryh(4) - data ntryh(1) , ntryh(2) , ntryh(3) , ntryh(4)/4 , 2 , 3 , 5/ , & - & tpi/6.28318530717958647692d0/ + real(rk) :: arg1 , argh , ch1 , ch1h , dch1 , dsh1 , sh1 , & + Wa + integer :: i , ib , ido , Ifac , ii , ip , ipm , is , j , k1 , l1 , & + l2 , n , nf , nfm1 , nl , nq , nr , ntry + dimension Wa(*) , Ifac(*) + integer,dimension(4),parameter :: ntryh = [4 , 2 , 3 , 5] + real(rk),parameter :: tpi = 2.0_rk * acos(-1.0_rk) ! 2 * pi nl = n nf = 0 j = 0 @@ -39,7 +35,7 @@ subroutine ezfft1(n,Wa,Ifac) if ( nl/=1 ) goto 200 Ifac(1) = n Ifac(2) = nf - argh = tpi/real(n,rk) + argh = tpi/real(n, rk) is = 0 nfm1 = nf - 1 l1 = 1 @@ -49,9 +45,9 @@ subroutine ezfft1(n,Wa,Ifac) l2 = l1*ip ido = n/l2 ipm = ip - 1 - arg1 = real(l1,rk)*argh - ch1 = 1.0d0 - sh1 = 0.0d0 + arg1 = real(l1, rk)*argh + ch1 = 1.0_rk + sh1 = 0.0_rk dch1 = cos(arg1) dsh1 = sin(arg1) do j = 1 , ipm diff --git a/src/passb.f90 b/src/passb.f90 index ebd147e..12c3928 100644 --- a/src/passb.f90 +++ b/src/passb.f90 @@ -1,16 +1,12 @@ -!*==PASSB.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine passb(Nac,Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) use fftpack_kind implicit none -!*--PASSB722 -!*** Start of declarations inserted by SPAG - real c1 , c2 , Cc , Ch , Ch2 , fftpack_kind , rk , Wa , wai , war - integer i , idij , idj , idl , Idl1 , idlj , Ido , idot , idp , & - & ik , inc , Ip , ipp2 , ipph , j , jc , k , l , l1 , lc - integer Nac , nt -!*** End of declarations inserted by SPAG - dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , Wa(1) , & - & c2(Idl1,Ip) , Ch2(Idl1,Ip) + real(rk) :: c1 , c2 , Cc , Ch , Ch2 , Wa , wai , war + integer :: i , idij , idj , idl , Idl1 , idlj , Ido , idot , idp , & + ik , inc , Ip , ipp2 , ipph , j , jc , k , l , l1 , lc + integer :: Nac , nt + dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , Wa(*) , & + c2(Idl1,Ip) , Ch2(Idl1,Ip) idot = Ido/2 nt = Ip*Idl1 ipp2 = Ip + 2 @@ -106,13 +102,13 @@ subroutine passb(Nac,Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) do i = 4 , Ido , 2 idij = idij + 2 c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & - & *Ch(i,k,j) + *Ch(i,k,j) c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & - & *Ch(i-1,k,j) + *Ch(i-1,k,j) enddo enddo enddo - goto 99999 + return endif idij = 0 do j = 2 , Ip @@ -126,4 +122,4 @@ subroutine passb(Nac,Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) enddo enddo return -99999 end subroutine passb \ No newline at end of file + end subroutine passb \ No newline at end of file diff --git a/src/passb2.f90 b/src/passb2.f90 index 7e37c9c..f75bf41 100644 --- a/src/passb2.f90 +++ b/src/passb2.f90 @@ -1,13 +1,9 @@ -!*==PASSB2.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine passb2(Ido,l1,Cc,Ch,Wa1) use fftpack_kind implicit none -!*--PASSB2851 -!*** Start of declarations inserted by SPAG - real Cc , Ch , fftpack_kind , rk , ti2 , tr2 , Wa1 - integer i , Ido , k , l1 -!*** End of declarations inserted by SPAG - dimension Cc(Ido,2,l1) , Ch(Ido,l1,2) , Wa1(1) + real(rk) :: Cc , Ch , ti2 , tr2 , Wa1 + integer :: i , Ido , k , l1 + dimension Cc(Ido,2,l1) , Ch(Ido,l1,2) , Wa1(*) if ( Ido>2 ) then do k = 1 , l1 do i = 2 , Ido , 2 @@ -19,13 +15,12 @@ subroutine passb2(Ido,l1,Cc,Ch,Wa1) Ch(i-1,k,2) = Wa1(i-1)*tr2 - Wa1(i)*ti2 enddo enddo - goto 99999 - endif - do k = 1 , l1 - Ch(1,k,1) = Cc(1,1,k) + Cc(1,2,k) - Ch(1,k,2) = Cc(1,1,k) - Cc(1,2,k) - Ch(2,k,1) = Cc(2,1,k) + Cc(2,2,k) - Ch(2,k,2) = Cc(2,1,k) - Cc(2,2,k) - enddo - return -99999 end subroutine passb2 \ No newline at end of file + else + do k = 1 , l1 + Ch(1,k,1) = Cc(1,1,k) + Cc(1,2,k) + Ch(1,k,2) = Cc(1,1,k) - Cc(1,2,k) + Ch(2,k,1) = Cc(2,1,k) + Cc(2,2,k) + Ch(2,k,2) = Cc(2,1,k) - Cc(2,2,k) + enddo + end if + end subroutine passb2 \ No newline at end of file diff --git a/src/passb3.f90 b/src/passb3.f90 index 5ce7855..0161f73 100644 --- a/src/passb3.f90 +++ b/src/passb3.f90 @@ -1,16 +1,12 @@ -!*==PASSB3.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine passb3(Ido,l1,Cc,Ch,Wa1,Wa2) use fftpack_kind implicit none -!*--PASSB3882 -!*** Start of declarations inserted by SPAG - real Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , dr2 , dr3 , & - & fftpack_kind , rk , taui , taur , ti2 , tr2 , Wa1 , Wa2 - integer i , Ido , k , l1 -!*** End of declarations inserted by SPAG - dimension Cc(Ido,3,l1) , Ch(Ido,l1,3) , Wa1(1) , Wa2(1) -! *** TAUI IS SQRT(3)/2 *** - data taur , taui/ - 0.5d0 , 0.86602540378443864676d0/ + real(rk) :: Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , & + dr2 , dr3 , ti2 , tr2 , Wa1 , Wa2 + integer :: i , Ido , k , l1 + dimension Cc(Ido,3,l1) , Ch(Ido,l1,3) , Wa1(*) , Wa2(*) + real(rk),parameter :: taur = -0.5_rk + real(rk),parameter :: taui = sqrt(3.0_rk) / 2.0_rk if ( Ido/=2 ) then do k = 1 , l1 do i = 2 , Ido , 2 @@ -32,21 +28,20 @@ subroutine passb3(Ido,l1,Cc,Ch,Wa1,Wa2) Ch(i-1,k,3) = Wa2(i-1)*dr3 - Wa2(i)*di3 enddo enddo - goto 99999 - endif - do k = 1 , l1 - tr2 = Cc(1,2,k) + Cc(1,3,k) - cr2 = Cc(1,1,k) + taur*tr2 - Ch(1,k,1) = Cc(1,1,k) + tr2 - ti2 = Cc(2,2,k) + Cc(2,3,k) - ci2 = Cc(2,1,k) + taur*ti2 - Ch(2,k,1) = Cc(2,1,k) + ti2 - cr3 = taui*(Cc(1,2,k)-Cc(1,3,k)) - ci3 = taui*(Cc(2,2,k)-Cc(2,3,k)) - Ch(1,k,2) = cr2 - ci3 - Ch(1,k,3) = cr2 + ci3 - Ch(2,k,2) = ci2 + cr3 - Ch(2,k,3) = ci2 - cr3 - enddo - return -99999 end subroutine passb3 \ No newline at end of file + else + do k = 1 , l1 + tr2 = Cc(1,2,k) + Cc(1,3,k) + cr2 = Cc(1,1,k) + taur*tr2 + Ch(1,k,1) = Cc(1,1,k) + tr2 + ti2 = Cc(2,2,k) + Cc(2,3,k) + ci2 = Cc(2,1,k) + taur*ti2 + Ch(2,k,1) = Cc(2,1,k) + ti2 + cr3 = taui*(Cc(1,2,k)-Cc(1,3,k)) + ci3 = taui*(Cc(2,2,k)-Cc(2,3,k)) + Ch(1,k,2) = cr2 - ci3 + Ch(1,k,3) = cr2 + ci3 + Ch(2,k,2) = ci2 + cr3 + Ch(2,k,3) = ci2 - cr3 + enddo + end if + end subroutine passb3 \ No newline at end of file diff --git a/src/passb4.f90 b/src/passb4.f90 index 410964a..0c78a1d 100644 --- a/src/passb4.f90 +++ b/src/passb4.f90 @@ -1,16 +1,11 @@ -!*==PASSB4.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine passb4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) use fftpack_kind implicit none -!*--PASSB4934 -!*** Start of declarations inserted by SPAG - real Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , fftpack_kind , & - & rk , ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3 , tr4 , Wa1 , & - & Wa2 - real Wa3 - integer i , Ido , k , l1 -!*** End of declarations inserted by SPAG - dimension Cc(Ido,4,l1) , Ch(Ido,l1,4) , Wa1(1) , Wa2(1) , Wa3(1) + real(rk) :: Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , & + & ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3 , tr4 , & + & Wa1 , Wa2 , Wa3 + integer :: i , Ido , k , l1 + dimension Cc(Ido,4,l1) , Ch(Ido,l1,4) , Wa1(*) , Wa2(*) , Wa3(*) if ( Ido/=2 ) then do k = 1 , l1 do i = 2 , Ido , 2 @@ -38,25 +33,24 @@ subroutine passb4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) Ch(i,k,4) = Wa3(i-1)*ci4 + Wa3(i)*cr4 enddo enddo - goto 99999 - endif - do k = 1 , l1 - ti1 = Cc(2,1,k) - Cc(2,3,k) - ti2 = Cc(2,1,k) + Cc(2,3,k) - tr4 = Cc(2,4,k) - Cc(2,2,k) - ti3 = Cc(2,2,k) + Cc(2,4,k) - tr1 = Cc(1,1,k) - Cc(1,3,k) - tr2 = Cc(1,1,k) + Cc(1,3,k) - ti4 = Cc(1,2,k) - Cc(1,4,k) - tr3 = Cc(1,2,k) + Cc(1,4,k) - Ch(1,k,1) = tr2 + tr3 - Ch(1,k,3) = tr2 - tr3 - Ch(2,k,1) = ti2 + ti3 - Ch(2,k,3) = ti2 - ti3 - Ch(1,k,2) = tr1 + tr4 - Ch(1,k,4) = tr1 - tr4 - Ch(2,k,2) = ti1 + ti4 - Ch(2,k,4) = ti1 - ti4 - enddo - return -99999 end subroutine passb4 \ No newline at end of file + else + do k = 1 , l1 + ti1 = Cc(2,1,k) - Cc(2,3,k) + ti2 = Cc(2,1,k) + Cc(2,3,k) + tr4 = Cc(2,4,k) - Cc(2,2,k) + ti3 = Cc(2,2,k) + Cc(2,4,k) + tr1 = Cc(1,1,k) - Cc(1,3,k) + tr2 = Cc(1,1,k) + Cc(1,3,k) + ti4 = Cc(1,2,k) - Cc(1,4,k) + tr3 = Cc(1,2,k) + Cc(1,4,k) + Ch(1,k,1) = tr2 + tr3 + Ch(1,k,3) = tr2 - tr3 + Ch(2,k,1) = ti2 + ti3 + Ch(2,k,3) = ti2 - ti3 + Ch(1,k,2) = tr1 + tr4 + Ch(1,k,4) = tr1 - tr4 + Ch(2,k,2) = ti1 + ti4 + Ch(2,k,4) = ti1 - ti4 + enddo + end if + end subroutine passb4 \ No newline at end of file diff --git a/src/passb5.f90 b/src/passb5.f90 index 50fc0e7..c696810 100644 --- a/src/passb5.f90 +++ b/src/passb5.f90 @@ -1,23 +1,19 @@ -!*==PASSB5.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine passb5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) use fftpack_kind implicit none -!*--PASSB5996 -!*** Start of declarations inserted by SPAG - real Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , cr4 , cr5 , & - & di2 , di3 , di4 , di5 , dr2 , dr3 , dr4 , dr5 , & - & fftpack_kind , rk - real ti11 , ti12 , ti2 , ti3 , ti4 , ti5 , tr11 , tr12 , tr2 , & - & tr3 , tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 - integer i , Ido , k , l1 -!*** End of declarations inserted by SPAG - dimension Cc(Ido,5,l1) , Ch(Ido,l1,5) , Wa1(1) , Wa2(1) , Wa3(1) ,& - & Wa4(1) -! *** TR11=COS(2*PI/5), TI11=SIN(2*PI/5) -! *** TR12=COS(4*PI/5), TI12=SIN(4*PI/5) - data tr11 , ti11 , tr12 , ti12/0.3090169943749474241d0 , & - & 0.95105651629515357212d0 , -0.8090169943749474241d0 , & - & 0.58778525229247312917d0/ + real(rk) :: Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , & + cr4 , cr5 , di2 , di3 , di4 , di5 , dr2 , dr3 , & + dr4 , dr5 + real(rk) :: ti2 , ti3 , ti4 , ti5 , tr2 , tr3, & + tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 + integer :: i , Ido , k , l1 + dimension Cc(Ido,5,l1) , Ch(Ido,l1,5) , Wa1(*) , Wa2(*) , Wa3(*), & + Wa4(1) + real(rk),parameter :: pi = acos(-1.0_rk) + real(rk),parameter :: tr11 = cos(2.0_rk * pi / 5.0_rk) + real(rk),parameter :: ti11 = sin(2.0_rk * pi / 5.0_rk) + real(rk),parameter :: tr12 = cos(4.0_rk * pi / 5.0_rk) + real(rk),parameter :: ti12 = sin(4.0_rk * pi / 5.0_rk) if ( Ido/=2 ) then do k = 1 , l1 do i = 2 , Ido , 2 @@ -57,35 +53,34 @@ subroutine passb5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) Ch(i,k,5) = Wa4(i-1)*di5 + Wa4(i)*dr5 enddo enddo - goto 99999 - endif - do k = 1 , l1 - ti5 = Cc(2,2,k) - Cc(2,5,k) - ti2 = Cc(2,2,k) + Cc(2,5,k) - ti4 = Cc(2,3,k) - Cc(2,4,k) - ti3 = Cc(2,3,k) + Cc(2,4,k) - tr5 = Cc(1,2,k) - Cc(1,5,k) - tr2 = Cc(1,2,k) + Cc(1,5,k) - tr4 = Cc(1,3,k) - Cc(1,4,k) - tr3 = Cc(1,3,k) + Cc(1,4,k) - Ch(1,k,1) = Cc(1,1,k) + tr2 + tr3 - Ch(2,k,1) = Cc(2,1,k) + ti2 + ti3 - cr2 = Cc(1,1,k) + tr11*tr2 + tr12*tr3 - ci2 = Cc(2,1,k) + tr11*ti2 + tr12*ti3 - cr3 = Cc(1,1,k) + tr12*tr2 + tr11*tr3 - ci3 = Cc(2,1,k) + tr12*ti2 + tr11*ti3 - cr5 = ti11*tr5 + ti12*tr4 - ci5 = ti11*ti5 + ti12*ti4 - cr4 = ti12*tr5 - ti11*tr4 - ci4 = ti12*ti5 - ti11*ti4 - Ch(1,k,2) = cr2 - ci5 - Ch(1,k,5) = cr2 + ci5 - Ch(2,k,2) = ci2 + cr5 - Ch(2,k,3) = ci3 + cr4 - Ch(1,k,3) = cr3 - ci4 - Ch(1,k,4) = cr3 + ci4 - Ch(2,k,4) = ci3 - cr4 - Ch(2,k,5) = ci2 - cr5 - enddo - return -99999 end subroutine passb5 \ No newline at end of file + else + do k = 1 , l1 + ti5 = Cc(2,2,k) - Cc(2,5,k) + ti2 = Cc(2,2,k) + Cc(2,5,k) + ti4 = Cc(2,3,k) - Cc(2,4,k) + ti3 = Cc(2,3,k) + Cc(2,4,k) + tr5 = Cc(1,2,k) - Cc(1,5,k) + tr2 = Cc(1,2,k) + Cc(1,5,k) + tr4 = Cc(1,3,k) - Cc(1,4,k) + tr3 = Cc(1,3,k) + Cc(1,4,k) + Ch(1,k,1) = Cc(1,1,k) + tr2 + tr3 + Ch(2,k,1) = Cc(2,1,k) + ti2 + ti3 + cr2 = Cc(1,1,k) + tr11*tr2 + tr12*tr3 + ci2 = Cc(2,1,k) + tr11*ti2 + tr12*ti3 + cr3 = Cc(1,1,k) + tr12*tr2 + tr11*tr3 + ci3 = Cc(2,1,k) + tr12*ti2 + tr11*ti3 + cr5 = ti11*tr5 + ti12*tr4 + ci5 = ti11*ti5 + ti12*ti4 + cr4 = ti12*tr5 - ti11*tr4 + ci4 = ti12*ti5 - ti11*ti4 + Ch(1,k,2) = cr2 - ci5 + Ch(1,k,5) = cr2 + ci5 + Ch(2,k,2) = ci2 + cr5 + Ch(2,k,3) = ci3 + cr4 + Ch(1,k,3) = cr3 - ci4 + Ch(1,k,4) = cr3 + ci4 + Ch(2,k,4) = ci3 - cr4 + Ch(2,k,5) = ci2 - cr5 + enddo + end if + end subroutine passb5 \ No newline at end of file diff --git a/src/passf.f90 b/src/passf.f90 index 8c91557..ebf9278 100644 --- a/src/passf.f90 +++ b/src/passf.f90 @@ -1,15 +1,11 @@ -!*==PASSF.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine passf(Nac,Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) use fftpack_kind implicit none -!*--PASSF1087 -!*** Start of declarations inserted by SPAG - real c1 , c2 , Cc , Ch , Ch2 , fftpack_kind , rk , Wa , wai , war - integer i , idij , idj , idl , Idl1 , idlj , Ido , idot , idp , & - & ik , inc , Ip , ipp2 , ipph , j , jc , k , l , l1 , lc - integer Nac , nt -!*** End of declarations inserted by SPAG - dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , Wa(1) , & + real(rk) :: c1 , c2 , Cc , Ch , Ch2 , Wa , wai , war + integer :: i , idij , idj , idl , Idl1 , idlj , Ido , idot , idp , & + ik , inc , Ip , ipp2 , ipph , j , jc , k , l , l1 , lc + integer :: Nac , nt + dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , Wa(*) , & & c2(Idl1,Ip) , Ch2(Idl1,Ip) idot = Ido/2 nt = Ip*Idl1 @@ -105,25 +101,24 @@ subroutine passf(Nac,Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) idij = idj do i = 4 , Ido , 2 idij = idij + 2 - c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) + Wa(idij) & - & *Ch(i,k,j) - c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) - Wa(idij) & - & *Ch(i-1,k,j) + c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) + Wa(idij) & + *Ch(i,k,j) + c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) - Wa(idij) & + *Ch(i-1,k,j) enddo enddo enddo - goto 99999 - endif - idij = 0 - do j = 2 , Ip - idij = idij + 2 - do i = 4 , Ido , 2 + else + idij = 0 + do j = 2 , Ip idij = idij + 2 - do k = 1 , l1 - c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) + Wa(idij)*Ch(i,k,j) - c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) - Wa(idij)*Ch(i-1,k,j) + do i = 4 , Ido , 2 + idij = idij + 2 + do k = 1 , l1 + c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) + Wa(idij)*Ch(i,k,j) + c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) - Wa(idij)*Ch(i-1,k,j) + enddo enddo enddo - enddo - return -99999 end subroutine passf \ No newline at end of file + end if + end subroutine passf \ No newline at end of file diff --git a/src/passf2.f90 b/src/passf2.f90 index c809b70..4c9f17c 100644 --- a/src/passf2.f90 +++ b/src/passf2.f90 @@ -1,13 +1,9 @@ -!*==PASSF2.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine passf2(Ido,l1,Cc,Ch,Wa1) use fftpack_kind implicit none -!*--PASSF21216 -!*** Start of declarations inserted by SPAG - real Cc , Ch , fftpack_kind , rk , ti2 , tr2 , Wa1 - integer i , Ido , k , l1 -!*** End of declarations inserted by SPAG - dimension Cc(Ido,2,l1) , Ch(Ido,l1,2) , Wa1(1) + real(rk) :: Cc , Ch , ti2 , tr2 , Wa1 + integer :: i , Ido , k , l1 + dimension Cc(Ido,2,l1) , Ch(Ido,l1,2) , Wa1(*) if ( Ido>2 ) then do k = 1 , l1 do i = 2 , Ido , 2 @@ -19,13 +15,12 @@ subroutine passf2(Ido,l1,Cc,Ch,Wa1) Ch(i-1,k,2) = Wa1(i-1)*tr2 + Wa1(i)*ti2 enddo enddo - goto 99999 - endif - do k = 1 , l1 - Ch(1,k,1) = Cc(1,1,k) + Cc(1,2,k) - Ch(1,k,2) = Cc(1,1,k) - Cc(1,2,k) - Ch(2,k,1) = Cc(2,1,k) + Cc(2,2,k) - Ch(2,k,2) = Cc(2,1,k) - Cc(2,2,k) - enddo - return -99999 end subroutine passf2 \ No newline at end of file + else + do k = 1 , l1 + Ch(1,k,1) = Cc(1,1,k) + Cc(1,2,k) + Ch(1,k,2) = Cc(1,1,k) - Cc(1,2,k) + Ch(2,k,1) = Cc(2,1,k) + Cc(2,2,k) + Ch(2,k,2) = Cc(2,1,k) - Cc(2,2,k) + enddo + end if + end subroutine passf2 \ No newline at end of file diff --git a/src/passf3.f90 b/src/passf3.f90 index 22db4a5..165b286 100644 --- a/src/passf3.f90 +++ b/src/passf3.f90 @@ -1,16 +1,12 @@ -!*==PASSF3.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine passf3(Ido,l1,Cc,Ch,Wa1,Wa2) use fftpack_kind implicit none -!*--PASSF31247 -!*** Start of declarations inserted by SPAG - real Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , dr2 , dr3 , & - & fftpack_kind , rk , taui , taur , ti2 , tr2 , Wa1 , Wa2 - integer i , Ido , k , l1 -!*** End of declarations inserted by SPAG - dimension Cc(Ido,3,l1) , Ch(Ido,l1,3) , Wa1(1) , Wa2(1) -! *** TAUI IS -SQRT(3)/2 *** - data taur , taui/ - 0.5d0 , -0.86602540378443864676d0/ + real(rk) :: Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , & + & dr2 , dr3 , ti2 , tr2 , Wa1 , Wa2 + integer :: i , Ido , k , l1 + dimension Cc(Ido,3,l1) , Ch(Ido,l1,3) , Wa1(*) , Wa2(*) + real(rk),parameter :: taur = -0.5_rk + real(rk),parameter :: taui = -sqrt(3.0_rk) / 2.0_rk if ( Ido/=2 ) then do k = 1 , l1 do i = 2 , Ido , 2 @@ -32,21 +28,20 @@ subroutine passf3(Ido,l1,Cc,Ch,Wa1,Wa2) Ch(i-1,k,3) = Wa2(i-1)*dr3 + Wa2(i)*di3 enddo enddo - goto 99999 - endif - do k = 1 , l1 - tr2 = Cc(1,2,k) + Cc(1,3,k) - cr2 = Cc(1,1,k) + taur*tr2 - Ch(1,k,1) = Cc(1,1,k) + tr2 - ti2 = Cc(2,2,k) + Cc(2,3,k) - ci2 = Cc(2,1,k) + taur*ti2 - Ch(2,k,1) = Cc(2,1,k) + ti2 - cr3 = taui*(Cc(1,2,k)-Cc(1,3,k)) - ci3 = taui*(Cc(2,2,k)-Cc(2,3,k)) - Ch(1,k,2) = cr2 - ci3 - Ch(1,k,3) = cr2 + ci3 - Ch(2,k,2) = ci2 + cr3 - Ch(2,k,3) = ci2 - cr3 - enddo - return -99999 end subroutine passf3 \ No newline at end of file + else + do k = 1 , l1 + tr2 = Cc(1,2,k) + Cc(1,3,k) + cr2 = Cc(1,1,k) + taur*tr2 + Ch(1,k,1) = Cc(1,1,k) + tr2 + ti2 = Cc(2,2,k) + Cc(2,3,k) + ci2 = Cc(2,1,k) + taur*ti2 + Ch(2,k,1) = Cc(2,1,k) + ti2 + cr3 = taui*(Cc(1,2,k)-Cc(1,3,k)) + ci3 = taui*(Cc(2,2,k)-Cc(2,3,k)) + Ch(1,k,2) = cr2 - ci3 + Ch(1,k,3) = cr2 + ci3 + Ch(2,k,2) = ci2 + cr3 + Ch(2,k,3) = ci2 - cr3 + enddo + end if + end subroutine passf3 \ No newline at end of file diff --git a/src/passf4.f90 b/src/passf4.f90 index c4a825e..110dea8 100644 --- a/src/passf4.f90 +++ b/src/passf4.f90 @@ -1,16 +1,11 @@ -!*==PASSF4.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine passf4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) use fftpack_kind implicit none -!*--PASSF41299 -!*** Start of declarations inserted by SPAG - real Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , fftpack_kind , & - & rk , ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3 , tr4 , Wa1 , & - & Wa2 - real Wa3 - integer i , Ido , k , l1 -!*** End of declarations inserted by SPAG - dimension Cc(Ido,4,l1) , Ch(Ido,l1,4) , Wa1(1) , Wa2(1) , Wa3(1) + real(rk) :: Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , & + & ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3 , tr4 , & + & Wa1 , Wa2 , Wa3 + integer :: i , Ido , k , l1 + dimension Cc(Ido,4,l1) , Ch(Ido,l1,4) , Wa1(*) , Wa2(*) , Wa3(*) if ( Ido/=2 ) then do k = 1 , l1 do i = 2 , Ido , 2 @@ -38,25 +33,24 @@ subroutine passf4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) Ch(i,k,4) = Wa3(i-1)*ci4 - Wa3(i)*cr4 enddo enddo - goto 99999 - endif - do k = 1 , l1 - ti1 = Cc(2,1,k) - Cc(2,3,k) - ti2 = Cc(2,1,k) + Cc(2,3,k) - tr4 = Cc(2,2,k) - Cc(2,4,k) - ti3 = Cc(2,2,k) + Cc(2,4,k) - tr1 = Cc(1,1,k) - Cc(1,3,k) - tr2 = Cc(1,1,k) + Cc(1,3,k) - ti4 = Cc(1,4,k) - Cc(1,2,k) - tr3 = Cc(1,2,k) + Cc(1,4,k) - Ch(1,k,1) = tr2 + tr3 - Ch(1,k,3) = tr2 - tr3 - Ch(2,k,1) = ti2 + ti3 - Ch(2,k,3) = ti2 - ti3 - Ch(1,k,2) = tr1 + tr4 - Ch(1,k,4) = tr1 - tr4 - Ch(2,k,2) = ti1 + ti4 - Ch(2,k,4) = ti1 - ti4 - enddo - return -99999 end subroutine passf4 \ No newline at end of file + else + do k = 1 , l1 + ti1 = Cc(2,1,k) - Cc(2,3,k) + ti2 = Cc(2,1,k) + Cc(2,3,k) + tr4 = Cc(2,2,k) - Cc(2,4,k) + ti3 = Cc(2,2,k) + Cc(2,4,k) + tr1 = Cc(1,1,k) - Cc(1,3,k) + tr2 = Cc(1,1,k) + Cc(1,3,k) + ti4 = Cc(1,4,k) - Cc(1,2,k) + tr3 = Cc(1,2,k) + Cc(1,4,k) + Ch(1,k,1) = tr2 + tr3 + Ch(1,k,3) = tr2 - tr3 + Ch(2,k,1) = ti2 + ti3 + Ch(2,k,3) = ti2 - ti3 + Ch(1,k,2) = tr1 + tr4 + Ch(1,k,4) = tr1 - tr4 + Ch(2,k,2) = ti1 + ti4 + Ch(2,k,4) = ti1 - ti4 + enddo + end if + end subroutine passf4 \ No newline at end of file diff --git a/src/passf5.f90 b/src/passf5.f90 index fc4d73f..e9b41ba 100644 --- a/src/passf5.f90 +++ b/src/passf5.f90 @@ -1,23 +1,19 @@ -!*==PASSF5.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine passf5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) use fftpack_kind implicit none -!*--PASSF51361 -!*** Start of declarations inserted by SPAG - real Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , cr4 , cr5 , & - & di2 , di3 , di4 , di5 , dr2 , dr3 , dr4 , dr5 , & - & fftpack_kind , rk - real ti11 , ti12 , ti2 , ti3 , ti4 , ti5 , tr11 , tr12 , tr2 , & - & tr3 , tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 - integer i , Ido , k , l1 -!*** End of declarations inserted by SPAG - dimension Cc(Ido,5,l1) , Ch(Ido,l1,5) , Wa1(1) , Wa2(1) , Wa3(1) ,& - & Wa4(1) -! *** TR11=COS(2*PI/5), TI11=-SIN(2*PI/5) -! *** TR12=-COS(4*PI/5), TI12=-SIN(4*PI/5) - data tr11 , ti11 , tr12 , ti12/0.3090169943749474241d0 , & - & -0.95105651629515357212d0 , -0.8090169943749474241d0 , & - & -0.58778525229247312917d0/ + real(rk) :: Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , & + cr4 , cr5 , di2 , di3 , di4 , di5 , dr2 , dr3 , & + dr4 , dr5 + real(rk) :: ti2 , ti3 , ti4 , ti5 , tr2 , tr3, & + tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 + integer :: i , Ido , k , l1 + dimension Cc(Ido,5,l1) , Ch(Ido,l1,5) , Wa1(*) , Wa2(*) , Wa3(*), & + Wa4(1) + real(rk),parameter :: pi = acos(-1.0_rk) + real(rk),parameter :: tr11 = cos(2.0_rk * pi / 5.0_rk) + real(rk),parameter :: ti11 = -sin(2.0_rk * pi / 5.0_rk) + real(rk),parameter :: tr12 = -cos(4.0_rk * pi / 5.0_rk) + real(rk),parameter :: ti12 = -sin(4.0_rk * pi / 5.0_rk) if ( Ido/=2 ) then do k = 1 , l1 do i = 2 , Ido , 2 @@ -57,35 +53,34 @@ subroutine passf5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) Ch(i,k,5) = Wa4(i-1)*di5 - Wa4(i)*dr5 enddo enddo - goto 99999 - endif - do k = 1 , l1 - ti5 = Cc(2,2,k) - Cc(2,5,k) - ti2 = Cc(2,2,k) + Cc(2,5,k) - ti4 = Cc(2,3,k) - Cc(2,4,k) - ti3 = Cc(2,3,k) + Cc(2,4,k) - tr5 = Cc(1,2,k) - Cc(1,5,k) - tr2 = Cc(1,2,k) + Cc(1,5,k) - tr4 = Cc(1,3,k) - Cc(1,4,k) - tr3 = Cc(1,3,k) + Cc(1,4,k) - Ch(1,k,1) = Cc(1,1,k) + tr2 + tr3 - Ch(2,k,1) = Cc(2,1,k) + ti2 + ti3 - cr2 = Cc(1,1,k) + tr11*tr2 + tr12*tr3 - ci2 = Cc(2,1,k) + tr11*ti2 + tr12*ti3 - cr3 = Cc(1,1,k) + tr12*tr2 + tr11*tr3 - ci3 = Cc(2,1,k) + tr12*ti2 + tr11*ti3 - cr5 = ti11*tr5 + ti12*tr4 - ci5 = ti11*ti5 + ti12*ti4 - cr4 = ti12*tr5 - ti11*tr4 - ci4 = ti12*ti5 - ti11*ti4 - Ch(1,k,2) = cr2 - ci5 - Ch(1,k,5) = cr2 + ci5 - Ch(2,k,2) = ci2 + cr5 - Ch(2,k,3) = ci3 + cr4 - Ch(1,k,3) = cr3 - ci4 - Ch(1,k,4) = cr3 + ci4 - Ch(2,k,4) = ci3 - cr4 - Ch(2,k,5) = ci2 - cr5 - enddo - return -99999 end subroutine passf5 \ No newline at end of file + else + do k = 1 , l1 + ti5 = Cc(2,2,k) - Cc(2,5,k) + ti2 = Cc(2,2,k) + Cc(2,5,k) + ti4 = Cc(2,3,k) - Cc(2,4,k) + ti3 = Cc(2,3,k) + Cc(2,4,k) + tr5 = Cc(1,2,k) - Cc(1,5,k) + tr2 = Cc(1,2,k) + Cc(1,5,k) + tr4 = Cc(1,3,k) - Cc(1,4,k) + tr3 = Cc(1,3,k) + Cc(1,4,k) + Ch(1,k,1) = Cc(1,1,k) + tr2 + tr3 + Ch(2,k,1) = Cc(2,1,k) + ti2 + ti3 + cr2 = Cc(1,1,k) + tr11*tr2 + tr12*tr3 + ci2 = Cc(2,1,k) + tr11*ti2 + tr12*ti3 + cr3 = Cc(1,1,k) + tr12*tr2 + tr11*tr3 + ci3 = Cc(2,1,k) + tr12*ti2 + tr11*ti3 + cr5 = ti11*tr5 + ti12*tr4 + ci5 = ti11*ti5 + ti12*ti4 + cr4 = ti12*tr5 - ti11*tr4 + ci4 = ti12*ti5 - ti11*ti4 + Ch(1,k,2) = cr2 - ci5 + Ch(1,k,5) = cr2 + ci5 + Ch(2,k,2) = ci2 + cr5 + Ch(2,k,3) = ci3 + cr4 + Ch(1,k,3) = cr3 - ci4 + Ch(1,k,4) = cr3 + ci4 + Ch(2,k,4) = ci3 - cr4 + Ch(2,k,5) = ci2 - cr5 + enddo + end if + end subroutine passf5 \ No newline at end of file diff --git a/src/radb2.f90 b/src/radb2.f90 index 94d9fa3..b37708a 100644 --- a/src/radb2.f90 +++ b/src/radb2.f90 @@ -1,18 +1,14 @@ -!*==RADB2.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine radb2(Ido,l1,Cc,Ch,Wa1) use fftpack_kind implicit none -!*--RADB21452 -!*** Start of declarations inserted by SPAG - real Cc , Ch , fftpack_kind , rk , ti2 , tr2 , Wa1 - integer i , ic , Ido , idp2 , k , l1 -!*** End of declarations inserted by SPAG - dimension Cc(Ido,2,l1) , Ch(Ido,l1,2) , Wa1(1) + real(rk) :: Cc , Ch , ti2 , tr2 , Wa1 + integer :: i , ic , Ido , idp2 , k , l1 + dimension Cc(Ido,2,l1) , Ch(Ido,l1,2) , Wa1(*) do k = 1 , l1 Ch(1,k,1) = Cc(1,1,k) + Cc(Ido,2,k) Ch(1,k,2) = Cc(1,1,k) - Cc(Ido,2,k) enddo - if ( Ido<2 ) goto 99999 + if ( Ido<2 ) return if ( Ido/=2 ) then idp2 = Ido + 2 do k = 1 , l1 @@ -32,4 +28,4 @@ subroutine radb2(Ido,l1,Cc,Ch,Wa1) Ch(Ido,k,1) = Cc(Ido,1,k) + Cc(Ido,1,k) Ch(Ido,k,2) = -(Cc(1,2,k)+Cc(1,2,k)) enddo -99999 end subroutine radb2 \ No newline at end of file + end subroutine radb2 \ No newline at end of file diff --git a/src/radb3.f90 b/src/radb3.f90 index b7c6944..f2c3e23 100644 --- a/src/radb3.f90 +++ b/src/radb3.f90 @@ -1,16 +1,12 @@ -!*==RADB3.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine radb3(Ido,l1,Cc,Ch,Wa1,Wa2) use fftpack_kind implicit none -!*--RADB31487 -!*** Start of declarations inserted by SPAG - real Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , dr2 , dr3 , & - & fftpack_kind , rk , taui , taur , ti2 , tr2 , Wa1 , Wa2 - integer i , ic , Ido , idp2 , k , l1 -!*** End of declarations inserted by SPAG - dimension Cc(Ido,3,l1) , Ch(Ido,l1,3) , Wa1(1) , Wa2(1) -! *** TAUI IS SQRT(3)/2 *** - data taur , taui/ - 0.5d0 , 0.86602540378443864676d0/ + real(rk) :: Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , & + dr2 , dr3 , ti2 , tr2 , Wa1 , Wa2 + integer :: i , ic , Ido , idp2 , k , l1 + dimension Cc(Ido,3,l1) , Ch(Ido,l1,3) , Wa1(*) , Wa2(*) + real(rk),parameter :: taur = - 0.5_rk + real(rk),parameter :: taui = sqrt(3.0_rk) / 2.0_rk do k = 1 , l1 tr2 = Cc(Ido,2,k) + Cc(Ido,2,k) cr2 = Cc(1,1,k) + taur*tr2 diff --git a/src/radb4.f90 b/src/radb4.f90 index 85c76e3..e6fadf5 100644 --- a/src/radb4.f90 +++ b/src/radb4.f90 @@ -1,17 +1,12 @@ -!*==RADB4.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine radb4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) use fftpack_kind implicit none -!*--RADB41532 -!*** Start of declarations inserted by SPAG - real Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , fftpack_kind , & - & rk , sqrt2 , ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3 , tr4 , & - & Wa1 - real Wa2 , Wa3 - integer i , ic , Ido , idp2 , k , l1 -!*** End of declarations inserted by SPAG - dimension Cc(Ido,4,l1) , Ch(Ido,l1,4) , Wa1(1) , Wa2(1) , Wa3(1) - data sqrt2/1.41421356237309504880d0/ + real(rk) :: Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , & + ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3, & + tr4 , Wa1 , Wa2 , Wa3 + integer :: i , ic , Ido , idp2 , k , l1 + dimension Cc(Ido,4,l1) , Ch(Ido,l1,4) , Wa1(*) , Wa2(*) , Wa3(*) + real(rk),parameter :: sqrt2 = sqrt(2.0_rk) do k = 1 , l1 tr1 = Cc(1,1,k) - Cc(Ido,4,k) tr2 = Cc(1,1,k) + Cc(Ido,4,k) @@ -22,7 +17,7 @@ subroutine radb4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) Ch(1,k,3) = tr2 - tr3 Ch(1,k,4) = tr1 + tr4 enddo - if ( Ido<2 ) goto 99999 + if ( Ido<2 ) return if ( Ido/=2 ) then idp2 = Ido + 2 do k = 1 , l1 @@ -64,4 +59,4 @@ subroutine radb4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) Ch(Ido,k,3) = ti2 + ti2 Ch(Ido,k,4) = -sqrt2*(tr1+ti1) enddo -99999 end subroutine radb4 \ No newline at end of file + end subroutine radb4 \ No newline at end of file diff --git a/src/radb5.f90 b/src/radb5.f90 index 6ae2a2b..7907828 100644 --- a/src/radb5.f90 +++ b/src/radb5.f90 @@ -1,23 +1,19 @@ -!*==RADB5.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine radb5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) use fftpack_kind implicit none -!*--RADB51599 -!*** Start of declarations inserted by SPAG - real Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , cr4 , cr5 , & - & di2 , di3 , di4 , di5 , dr2 , dr3 , dr4 , dr5 , & - & fftpack_kind , rk - real ti11 , ti12 , ti2 , ti3 , ti4 , ti5 , tr11 , tr12 , tr2 , & - & tr3 , tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 - integer i , ic , Ido , idp2 , k , l1 -!*** End of declarations inserted by SPAG - dimension Cc(Ido,5,l1) , Ch(Ido,l1,5) , Wa1(1) , Wa2(1) , Wa3(1) ,& - & Wa4(1) -! *** TR11=COS(2*PI/5), TI11=SIN(2*PI/5) -! *** TR12=COS(4*PI/5), TI12=SIN(4*PI/5) - data tr11 , ti11 , tr12 , ti12/0.3090169943749474241d0 , & - & 0.95105651629515357212d0 , -0.8090169943749474241d0 , & - & 0.58778525229247312917d0/ + real(rk) :: Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , & + cr4 , cr5 , di2 , di3 , di4 , di5 , dr2 , dr3 , & + dr4 , dr5 + real(rk) :: ti2 , ti3 , ti4 , ti5 , tr2 , tr3, & + tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 + integer :: i , ic , Ido , idp2 , k , l1 + dimension Cc(Ido,5,l1) , Ch(Ido,l1,5) , Wa1(*) , Wa2(*) , Wa3(*), & + Wa4(1) + real(rk),parameter :: pi = acos(-1.0_rk) + real(rk),parameter :: tr11 = cos(2.0_rk * pi / 5.0_rk) + real(rk),parameter :: ti11 = sin(2.0_rk * pi / 5.0_rk) + real(rk),parameter :: tr12 = cos(4.0_rk * pi / 5.0_rk) + real(rk),parameter :: ti12 = sin(4.0_rk * pi / 5.0_rk) do k = 1 , l1 ti5 = Cc(1,3,k) + Cc(1,3,k) ti4 = Cc(1,5,k) + Cc(1,5,k) diff --git a/src/radbg.f90 b/src/radbg.f90 index 904514d..78f3cdf 100644 --- a/src/radbg.f90 +++ b/src/radbg.f90 @@ -1,19 +1,15 @@ -!*==RADBG.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine radbg(Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) use fftpack_kind implicit none -!*--RADBG1676 -!*** Start of declarations inserted by SPAG - real ai1 , ai2 , ar1 , ar1h , ar2 , ar2h , arg , c1 , c2 , Cc , & - & Ch , Ch2 , dc2 , dcp , ds2 , dsp , fftpack_kind , rk , tpi , & - & Wa - integer i , ic , idij , Idl1 , Ido , idp2 , ik , Ip , ipp2 , & - & ipph , is , j , j2 , jc , k , l , l1 , lc , nbd -!*** End of declarations inserted by SPAG - dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , & - & c2(Idl1,Ip) , Ch2(Idl1,Ip) , Wa(1) - data tpi/6.28318530717958647692d0/ - arg = tpi/real(Ip,rk) + real(rk) :: ai1 , ai2 , ar1 , ar1h , ar2 , ar2h , arg , c1 , & + c2 , Cc , Ch , Ch2 , dc2 , dcp , ds2 , dsp , & + Wa + integer :: i , ic , idij , Idl1 , Ido , idp2 , ik , Ip , ipp2 , & + ipph , is , j , j2 , jc , k , l , l1 , lc , nbd + dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , & + c2(Idl1,Ip) , Ch2(Idl1,Ip) , Wa(*) + real(rk),parameter :: tpi = acos(-1.0_rk) / 2.0_rk ! 2 * pi + arg = tpi/real(Ip, rk) dcp = cos(arg) dsp = sin(arg) idp2 = Ido + 2 @@ -70,8 +66,8 @@ subroutine radbg(Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) enddo endif endif - ar1 = 1.0d0 - ai1 = 0.0d0 + ar1 = 1.0_rk + ai1 = 0.0_rk do l = 2 , ipph lc = ipp2 - l ar1h = dcp*ar1 - dsp*ai1 @@ -152,10 +148,10 @@ subroutine radbg(Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) idij = is do i = 3 , Ido , 2 idij = idij + 2 - c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & - & *Ch(i,k,j) - c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & - & *Ch(i-1,k,j) + c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & + *Ch(i,k,j) + c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & + *Ch(i-1,k,j) enddo enddo enddo @@ -167,10 +163,10 @@ subroutine radbg(Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) do i = 3 , Ido , 2 idij = idij + 2 do k = 1 , l1 - c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & - & *Ch(i,k,j) - c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & - & *Ch(i-1,k,j) + c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & + *Ch(i,k,j) + c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & + *Ch(i-1,k,j) enddo enddo enddo diff --git a/src/radf2.f90 b/src/radf2.f90 index 2484926..51a6fc4 100644 --- a/src/radf2.f90 +++ b/src/radf2.f90 @@ -1,18 +1,14 @@ -!*==RADF2.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine radf2(Ido,l1,Cc,Ch,Wa1) use fftpack_kind implicit none -!*--RADF21854 -!*** Start of declarations inserted by SPAG - real Cc , Ch , fftpack_kind , rk , ti2 , tr2 , Wa1 - integer i , ic , Ido , idp2 , k , l1 -!*** End of declarations inserted by SPAG - dimension Ch(Ido,2,l1) , Cc(Ido,l1,2) , Wa1(1) + real(rk) :: Cc , Ch , ti2 , tr2 , Wa1 + integer :: i , ic , Ido , idp2 , k , l1 + dimension Ch(Ido,2,l1) , Cc(Ido,l1,2) , Wa1(*) do k = 1 , l1 Ch(1,1,k) = Cc(1,k,1) + Cc(1,k,2) Ch(Ido,2,k) = Cc(1,k,1) - Cc(1,k,2) enddo - if ( Ido<2 ) goto 99999 + if ( Ido<2 ) return if ( Ido/=2 ) then idp2 = Ido + 2 do k = 1 , l1 @@ -32,4 +28,4 @@ subroutine radf2(Ido,l1,Cc,Ch,Wa1) Ch(1,2,k) = -Cc(Ido,k,2) Ch(Ido,1,k) = Cc(Ido,k,1) enddo -99999 end subroutine radf2 \ No newline at end of file + end subroutine radf2 \ No newline at end of file diff --git a/src/radf3.f90 b/src/radf3.f90 index e0e527d..472489a 100644 --- a/src/radf3.f90 +++ b/src/radf3.f90 @@ -1,16 +1,13 @@ -!*==RADF3.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine radf3(Ido,l1,Cc,Ch,Wa1,Wa2) use fftpack_kind implicit none -!*--RADF31889 -!*** Start of declarations inserted by SPAG - real Cc , Ch , ci2 , cr2 , di2 , di3 , dr2 , dr3 , fftpack_kind , & - & rk , taui , taur , ti2 , ti3 , tr2 , tr3 , Wa1 , Wa2 - integer i , ic , Ido , idp2 , k , l1 -!*** End of declarations inserted by SPAG - dimension Ch(Ido,3,l1) , Cc(Ido,l1,3) , Wa1(1) , Wa2(1) -! *** TAUI IS -SQRT(3)/2 *** - data taur , taui/ - 0.5d0 , 0.86602540378443864676d0/ + real(rk) :: Cc , Ch , ci2 , cr2 , di2 , di3 , dr2 , dr3 , & + ti2 , ti3 , tr2 , tr3 , Wa1 , Wa2 + integer :: i , ic , Ido , idp2 , k , l1 + dimension Ch(Ido,3,l1) , Cc(Ido,l1,3) , Wa1(*) , Wa2(*) + real(rk),parameter :: taur = -0.5_rk + ! note: original comment said this was -SQRT(3)/2 but value was 0.86602540378443864676d0 + real(rk),parameter :: taui = sqrt(3.0_rk) / 2.0_rk do k = 1 , l1 cr2 = Cc(1,k,2) + Cc(1,k,3) Ch(1,1,k) = Cc(1,k,1) + cr2 diff --git a/src/radf4.f90 b/src/radf4.f90 index f9cbeb6..c0b62bb 100644 --- a/src/radf4.f90 +++ b/src/radf4.f90 @@ -1,17 +1,12 @@ -!*==RADF4.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine radf4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) use fftpack_kind implicit none -!*--RADF41932 -!*** Start of declarations inserted by SPAG - real Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , fftpack_kind , & - & hsqt2 , rk , ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3 , tr4 , & - & Wa1 - real Wa2 , Wa3 - integer i , ic , Ido , idp2 , k , l1 -!*** End of declarations inserted by SPAG - dimension Cc(Ido,l1,4) , Ch(Ido,4,l1) , Wa1(1) , Wa2(1) , Wa3(1) - data hsqt2/0.70710678118654752440d0/ + real(rk) :: Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , & + ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3, & + tr4 , Wa1 , Wa2 , Wa3 + integer :: i , ic , Ido , idp2 , k , l1 + dimension Cc(Ido,l1,4) , Ch(Ido,4,l1) , Wa1(*) , Wa2(*) , Wa3(*) + real(rk),parameter :: hsqt2 = sqrt(2.0_rk) / 2.0_rk do k = 1 , l1 tr1 = Cc(1,k,2) + Cc(1,k,4) tr2 = Cc(1,k,1) + Cc(1,k,3) @@ -20,7 +15,7 @@ subroutine radf4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) Ch(Ido,2,k) = Cc(1,k,1) - Cc(1,k,3) Ch(1,3,k) = Cc(1,k,4) - Cc(1,k,2) enddo - if ( Ido<2 ) goto 99999 + if ( Ido<2 ) return if ( Ido/=2 ) then idp2 = Ido + 2 do k = 1 , l1 @@ -60,4 +55,4 @@ subroutine radf4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) Ch(1,2,k) = ti1 - Cc(Ido,k,3) Ch(1,4,k) = ti1 + Cc(Ido,k,3) enddo -99999 end subroutine radf4 \ No newline at end of file + end subroutine radf4 \ No newline at end of file diff --git a/src/radf5.f90 b/src/radf5.f90 index e816123..56df255 100644 --- a/src/radf5.f90 +++ b/src/radf5.f90 @@ -1,21 +1,19 @@ -!*==RADF5.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine radf5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) use fftpack_kind implicit none -!*--RADF51995 -!*** Start of declarations inserted by SPAG - real Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , cr4 , cr5 , & - & di2 , di3 , di4 , di5 , dr2 , dr3 , dr4 , dr5 , & - & fftpack_kind , rk - real ti11 , ti12 , ti2 , ti3 , ti4 , ti5 , tr11 , tr12 , tr2 , & - & tr3 , tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 - integer i , ic , Ido , idp2 , k , l1 -!*** End of declarations inserted by SPAG - dimension Cc(Ido,l1,5) , Ch(Ido,5,l1) , Wa1(1) , Wa2(1) , Wa3(1) ,& - & Wa4(1) - data tr11 , ti11 , tr12 , ti12/0.3090169943749474241d0 , & - & 0.95105651629515357212d0 , -0.8090169943749474241d0 , & - & 0.58778525229247312917d0/ + real(rk) :: Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , & + cr4 , cr5 , di2 , di3 , di4 , di5 , dr2 , dr3 , & + dr4 , dr5 + real(rk) :: ti2 , ti3 , ti4 , ti5 , tr2 , tr3, & + tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 + integer :: i , ic , Ido , idp2 , k , l1 + dimension Cc(Ido,l1,5) , Ch(Ido,5,l1) , Wa1(*) , Wa2(*) , Wa3(*), & + Wa4(1) + real(rk),parameter :: pi = acos(-1.0_rk) + real(rk),parameter :: tr11 = cos(2.0_rk * pi / 5.0_rk) + real(rk),parameter :: ti11 = sin(2.0_rk * pi / 5.0_rk) + real(rk),parameter :: tr12 = cos(4.0_rk * pi / 5.0_rk) + real(rk),parameter :: ti12 = sin(4.0_rk * pi / 5.0_rk) do k = 1 , l1 cr2 = Cc(1,k,5) + Cc(1,k,2) ci5 = Cc(1,k,5) - Cc(1,k,2) diff --git a/src/radfg.f90 b/src/radfg.f90 index 0079f1b..589a466 100644 --- a/src/radfg.f90 +++ b/src/radfg.f90 @@ -1,19 +1,15 @@ -!*==RADFG.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine radfg(Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) use fftpack_kind implicit none -!*--RADFG2066 -!*** Start of declarations inserted by SPAG - real ai1 , ai2 , ar1 , ar1h , ar2 , ar2h , arg , c1 , c2 , Cc , & - & Ch , Ch2 , dc2 , dcp , ds2 , dsp , fftpack_kind , rk , tpi , & - & Wa - integer i , ic , idij , Idl1 , Ido , idp2 , ik , Ip , ipp2 , & - & ipph , is , j , j2 , jc , k , l , l1 , lc , nbd -!*** End of declarations inserted by SPAG - dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , & - & c2(Idl1,Ip) , Ch2(Idl1,Ip) , Wa(1) - data tpi/6.28318530717958647692d0/ - arg = tpi/real(Ip,rk) + real(rk) :: ai1 , ai2 , ar1 , ar1h , ar2 , ar2h , arg , c1 , & + c2 , Cc , Ch , Ch2 , dc2 , dcp , ds2 , dsp , & + Wa + integer :: i , ic , idij , Idl1 , Ido , idp2 , ik , Ip , ipp2 , & + ipph , is , j , j2 , jc , k , l , l1 , lc , nbd + dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , & + c2(Idl1,Ip) , Ch2(Idl1,Ip) , Wa(*) + real(rk),parameter :: tpi = 2.0_rk * acos(-1.0_rk) ! 2 * pi + arg = tpi/real(Ip, rk) dcp = cos(arg) dsp = sin(arg) ipph = (Ip+1)/2 @@ -41,10 +37,10 @@ subroutine radfg(Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) idij = is do i = 3 , Ido , 2 idij = idij + 2 - Ch(i-1,k,j) = Wa(idij-1)*c1(i-1,k,j) + Wa(idij) & - & *c1(i,k,j) - Ch(i,k,j) = Wa(idij-1)*c1(i,k,j) - Wa(idij) & - & *c1(i-1,k,j) + Ch(i-1,k,j) = Wa(idij-1)*c1(i-1,k,j) + Wa(idij) & + *c1(i,k,j) + Ch(i,k,j) = Wa(idij-1)*c1(i,k,j) - Wa(idij) & + *c1(i-1,k,j) enddo enddo enddo @@ -56,10 +52,10 @@ subroutine radfg(Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) do i = 3 , Ido , 2 idij = idij + 2 do k = 1 , l1 - Ch(i-1,k,j) = Wa(idij-1)*c1(i-1,k,j) + Wa(idij) & - & *c1(i,k,j) - Ch(i,k,j) = Wa(idij-1)*c1(i,k,j) - Wa(idij) & - & *c1(i-1,k,j) + Ch(i-1,k,j) = Wa(idij-1)*c1(i-1,k,j) + Wa(idij) & + *c1(i,k,j) + Ch(i,k,j) = Wa(idij-1)*c1(i,k,j) - Wa(idij) & + *c1(i-1,k,j) enddo enddo enddo @@ -98,8 +94,8 @@ subroutine radfg(Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) enddo enddo ! - ar1 = 1.0d0 - ai1 = 0.0d0 + ar1 = 1.0_rk + ai1 = 0.0_rk do l = 2 , ipph lc = ipp2 - l ar1h = dcp*ar1 - dsp*ai1 @@ -166,20 +162,19 @@ subroutine radfg(Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) enddo enddo enddo - goto 99999 - endif - do j = 2 , ipph - jc = ipp2 - j - j2 = j + j - do k = 1 , l1 - do i = 3 , Ido , 2 - ic = idp2 - i - Cc(i-1,j2-1,k) = Ch(i-1,k,j) + Ch(i-1,k,jc) - Cc(ic-1,j2-2,k) = Ch(i-1,k,j) - Ch(i-1,k,jc) - Cc(i,j2-1,k) = Ch(i,k,j) + Ch(i,k,jc) - Cc(ic,j2-2,k) = Ch(i,k,jc) - Ch(i,k,j) + else + do j = 2 , ipph + jc = ipp2 - j + j2 = j + j + do k = 1 , l1 + do i = 3 , Ido , 2 + ic = idp2 - i + Cc(i-1,j2-1,k) = Ch(i-1,k,j) + Ch(i-1,k,jc) + Cc(ic-1,j2-2,k) = Ch(i-1,k,j) - Ch(i-1,k,jc) + Cc(i,j2-1,k) = Ch(i,k,j) + Ch(i,k,jc) + Cc(ic,j2-2,k) = Ch(i,k,jc) - Ch(i,k,j) + enddo enddo enddo - enddo - return -99999 end subroutine radfg \ No newline at end of file + end if + end subroutine radfg \ No newline at end of file diff --git a/src/rfftb1.f90 b/src/rfftb1.f90 index cd764d9..019791e 100644 --- a/src/rfftb1.f90 +++ b/src/rfftb1.f90 @@ -1,13 +1,9 @@ -!*==RFFTB1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine rfftb1(n,c,Ch,Wa,Ifac) use fftpack_kind implicit none -!*--RFFTB12251 -!*** Start of declarations inserted by SPAG - real c , Ch , fftpack_kind , rk , Wa - integer i , idl1 , ido , Ifac , ip , iw , ix2 , ix3 , ix4 , k1 , & - & l1 , l2 , n , na , nf -!*** End of declarations inserted by SPAG + real(rk) :: c , Ch , Wa + integer :: i , idl1 , ido , Ifac , ip , iw , ix2 , ix3 , ix4 , k1 , & + l1 , l2 , n , na , nf dimension Ch(*) , c(*) , Wa(*) , Ifac(*) nf = Ifac(2) na = 0 diff --git a/src/rfftf1.f90 b/src/rfftf1.f90 index 62cd297..acbde50 100644 --- a/src/rfftf1.f90 +++ b/src/rfftf1.f90 @@ -1,13 +1,9 @@ -!*==RFFTF1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine rfftf1(n,c,Ch,Wa,Ifac) use fftpack_kind implicit none -!*--RFFTF12321 -!*** Start of declarations inserted by SPAG - real c , Ch , fftpack_kind , rk , Wa - integer i , idl1 , ido , Ifac , ip , iw , ix2 , ix3 , ix4 , k1 , & - & kh , l1 , l2 , n , na , nf -!*** End of declarations inserted by SPAG + real(rk) :: c , Ch , Wa + integer :: i , idl1 , ido , Ifac , ip , iw , ix2 , ix3 , ix4 , k1 , & + kh , l1 , l2 , n , na , nf dimension Ch(*) , c(*) , Wa(*) , Ifac(*) nf = Ifac(2) na = 1 diff --git a/src/rffti1.f90 b/src/rffti1.f90 index 5125d77..167eb5d 100644 --- a/src/rffti1.f90 +++ b/src/rffti1.f90 @@ -1,16 +1,12 @@ -!*==RFFTI1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine rffti1(n,Wa,Ifac) use fftpack_kind implicit none -!*--RFFTI12391 -!*** Start of declarations inserted by SPAG - real arg , argh , argld , fftpack_kind , fi , rk , tpi , Wa - integer i , ib , ido , Ifac , ii , ip , ipm , is , j , k1 , l1 , & - & l2 , ld , n , nf , nfm1 , nl , nq , nr , ntry - integer ntryh -!*** End of declarations inserted by SPAG - dimension Wa(*) , Ifac(*) , ntryh(4) - data ntryh(1) , ntryh(2) , ntryh(3) , ntryh(4)/4 , 2 , 3 , 5/ + real(rk) :: arg , argh , argld , fi , Wa + integer :: i , ib , ido , Ifac , ii , ip , ipm , is , j , k1 , l1 , & + l2 , ld , n , nf , nfm1 , nl , nq , nr , ntry + dimension Wa(*) , Ifac(*) + integer,dimension(4),parameter :: ntryh = [4 , 2 , 3 , 5] + real(rk),parameter :: tpi = 2.0_rk * acos(-1.0_rk) ! 2 * pi nl = n nf = 0 j = 0 @@ -38,8 +34,7 @@ subroutine rffti1(n,Wa,Ifac) if ( nl/=1 ) goto 200 Ifac(1) = n Ifac(2) = nf - tpi = 6.28318530717958647692d0 - argh = tpi/real(n,rk) + argh = tpi/real(n, rk) is = 0 nfm1 = nf - 1 l1 = 1 @@ -53,11 +48,11 @@ subroutine rffti1(n,Wa,Ifac) do j = 1 , ipm ld = ld + l1 i = is - argld = real(ld,rk)*argh - fi = 0.0d0 + argld = real(ld, rk)*argh + fi = 0.0_rk do ii = 3 , ido , 2 i = i + 2 - fi = fi + 1.0d0 + fi = fi + 1.0_rk arg = fi*argld Wa(i-1) = cos(arg) Wa(i) = sin(arg) diff --git a/src/rk.f90 b/src/rk.f90 new file mode 100644 index 0000000..663df9c --- /dev/null +++ b/src/rk.f90 @@ -0,0 +1,4 @@ + module fftpack_kind + implicit none + integer,parameter :: rk = kind(1.0d0) + end module fftpack_kind diff --git a/src/sint1.f90 b/src/sint1.f90 index 0cfa621..09cad5d 100644 --- a/src/sint1.f90 +++ b/src/sint1.f90 @@ -1,14 +1,10 @@ -!*==SINT1.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine sint1(n,War,Was,Xh,x,Ifac) use fftpack_kind implicit none -!*--SINT12466 -!*** Start of declarations inserted by SPAG - integer i , Ifac , k , kc , modn , n , np1 , ns2 - real sqrt3 , t1 , t2 , War , Was , x , Xh , xhold -!*** End of declarations inserted by SPAG + integer :: i , Ifac , k , kc , modn , n , np1 , ns2 + real(rk) :: t1 , t2 , War , Was , x , Xh , xhold dimension War(*) , Was(*) , x(*) , Xh(*) , Ifac(*) - data sqrt3/1.73205080756887729352d0/ + real(rk),parameter :: sqrt3 = sqrt(3.0_rk) do i = 1 , n Xh(i) = War(i) War(i) = x(i) @@ -22,7 +18,7 @@ subroutine sint1(n,War,Was,Xh,x,Ifac) else np1 = n + 1 ns2 = n/2 - x(1) = 0.0d0 + x(1) = 0.0_rk do k = 1 , ns2 kc = np1 - k t1 = Xh(k) - Xh(kc) @@ -31,9 +27,9 @@ subroutine sint1(n,War,Was,Xh,x,Ifac) x(kc+1) = t2 - t1 enddo modn = mod(n,2) - if ( modn/=0 ) x(ns2+2) = 4.0d0*Xh(ns2+1) + if ( modn/=0 ) x(ns2+2) = 4.0_rk*Xh(ns2+1) call rfftf1(np1,x,Xh,War,Ifac) - Xh(1) = 0.5d0*x(1) + Xh(1) = 0.5_rk*x(1) do i = 3 , n , 2 Xh(i-1) = -x(i) Xh(i) = Xh(i-2) + x(i-1) diff --git a/src/zfftb.f90 b/src/zfftb.f90 index 16b2b48..a0e80f4 100644 --- a/src/zfftb.f90 +++ b/src/zfftb.f90 @@ -1,13 +1,9 @@ -!*==ZFFTB.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine zfftb(n,c,Wsave) use fftpack_kind implicit none -!*--ZFFTB2513 -!*** Start of declarations inserted by SPAG - real c , Wsave - integer iw1 , iw2 , n -!*** End of declarations inserted by SPAG - dimension c(1) , Wsave(1) + real(rk) :: c , Wsave + integer :: iw1 , iw2 , n + dimension c(1) , Wsave(*) if ( n==1 ) return iw1 = n + n + 1 iw2 = iw1 + n + n diff --git a/src/zfftf.f90 b/src/zfftf.f90 index b1d77f9..8fa2791 100644 --- a/src/zfftf.f90 +++ b/src/zfftf.f90 @@ -1,13 +1,9 @@ -!*==ZFFTF.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine zfftf(n,c,Wsave) use fftpack_kind implicit none -!*--ZFFTF2528 -!*** Start of declarations inserted by SPAG - real c , Wsave - integer iw1 , iw2 , n -!*** End of declarations inserted by SPAG - dimension c(1) , Wsave(1) + real(rk) :: c , Wsave + integer :: iw1 , iw2 , n + dimension c(1) , Wsave(*) if ( n==1 ) return iw1 = n + n + 1 iw2 = iw1 + n + n diff --git a/src/zffti.f90 b/src/zffti.f90 index 0ed33fc..5cc7cca 100644 --- a/src/zffti.f90 +++ b/src/zffti.f90 @@ -1,13 +1,9 @@ -!*==ZFFTI.spg processed by SPAG 6.72Dc at 19:17 on 14 Sep 2021 subroutine zffti(n,Wsave) use fftpack_kind implicit none -!*--ZFFTI2543 -!*** Start of declarations inserted by SPAG - integer iw1 , iw2 , n - real Wsave -!*** End of declarations inserted by SPAG - dimension Wsave(1) + integer :: iw1 , iw2 , n + real(rk) :: Wsave + dimension Wsave(*) if ( n==1 ) return iw1 = n + n + 1 iw2 = iw1 + n + n From 0418b0dfbc4a25509dd1a03a6cf0ac34c5218bc6 Mon Sep 17 00:00:00 2001 From: zoziha Date: Wed, 15 Sep 2021 08:57:17 +0800 Subject: [PATCH 07/10] {x}(1) -> {x}(*), where {x} = r, c, Wa4. --- src/dfftb.f90 | 2 +- src/dfftf.f90 | 2 +- src/passb5.f90 | 2 +- src/passf5.f90 | 2 +- src/radb5.f90 | 2 +- src/radf5.f90 | 2 +- src/zfftb.f90 | 2 +- src/zfftf.f90 | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/dfftb.f90 b/src/dfftb.f90 index 20167d8..045edc1 100644 --- a/src/dfftb.f90 +++ b/src/dfftb.f90 @@ -3,7 +3,7 @@ subroutine dfftb(n,r,Wsave) implicit none integer :: n real(rk) :: r , Wsave - dimension r(1) , Wsave(*) + dimension r(*) , Wsave(*) if ( n==1 ) return call rfftb1(n,r,Wsave,Wsave(n+1),Wsave(2*n+1)) end subroutine dfftb \ No newline at end of file diff --git a/src/dfftf.f90 b/src/dfftf.f90 index e52a2d0..d23437e 100644 --- a/src/dfftf.f90 +++ b/src/dfftf.f90 @@ -3,7 +3,7 @@ subroutine dfftf(n,r,Wsave) implicit none integer :: n real(rk) :: r , Wsave - dimension r(1) , Wsave(*) + dimension r(*) , Wsave(*) if ( n==1 ) return call rfftf1(n,r,Wsave,Wsave(n+1),Wsave(2*n+1)) end subroutine dfftf \ No newline at end of file diff --git a/src/passb5.f90 b/src/passb5.f90 index c696810..acdfbfe 100644 --- a/src/passb5.f90 +++ b/src/passb5.f90 @@ -8,7 +8,7 @@ subroutine passb5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 integer :: i , Ido , k , l1 dimension Cc(Ido,5,l1) , Ch(Ido,l1,5) , Wa1(*) , Wa2(*) , Wa3(*), & - Wa4(1) + Wa4(*) real(rk),parameter :: pi = acos(-1.0_rk) real(rk),parameter :: tr11 = cos(2.0_rk * pi / 5.0_rk) real(rk),parameter :: ti11 = sin(2.0_rk * pi / 5.0_rk) diff --git a/src/passf5.f90 b/src/passf5.f90 index e9b41ba..ad16bc4 100644 --- a/src/passf5.f90 +++ b/src/passf5.f90 @@ -8,7 +8,7 @@ subroutine passf5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 integer :: i , Ido , k , l1 dimension Cc(Ido,5,l1) , Ch(Ido,l1,5) , Wa1(*) , Wa2(*) , Wa3(*), & - Wa4(1) + Wa4(*) real(rk),parameter :: pi = acos(-1.0_rk) real(rk),parameter :: tr11 = cos(2.0_rk * pi / 5.0_rk) real(rk),parameter :: ti11 = -sin(2.0_rk * pi / 5.0_rk) diff --git a/src/radb5.f90 b/src/radb5.f90 index 7907828..e90a4d8 100644 --- a/src/radb5.f90 +++ b/src/radb5.f90 @@ -8,7 +8,7 @@ subroutine radb5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 integer :: i , ic , Ido , idp2 , k , l1 dimension Cc(Ido,5,l1) , Ch(Ido,l1,5) , Wa1(*) , Wa2(*) , Wa3(*), & - Wa4(1) + Wa4(*) real(rk),parameter :: pi = acos(-1.0_rk) real(rk),parameter :: tr11 = cos(2.0_rk * pi / 5.0_rk) real(rk),parameter :: ti11 = sin(2.0_rk * pi / 5.0_rk) diff --git a/src/radf5.f90 b/src/radf5.f90 index 56df255..5fbcb11 100644 --- a/src/radf5.f90 +++ b/src/radf5.f90 @@ -8,7 +8,7 @@ subroutine radf5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 integer :: i , ic , Ido , idp2 , k , l1 dimension Cc(Ido,l1,5) , Ch(Ido,5,l1) , Wa1(*) , Wa2(*) , Wa3(*), & - Wa4(1) + Wa4(*) real(rk),parameter :: pi = acos(-1.0_rk) real(rk),parameter :: tr11 = cos(2.0_rk * pi / 5.0_rk) real(rk),parameter :: ti11 = sin(2.0_rk * pi / 5.0_rk) diff --git a/src/zfftb.f90 b/src/zfftb.f90 index a0e80f4..792526e 100644 --- a/src/zfftb.f90 +++ b/src/zfftb.f90 @@ -3,7 +3,7 @@ subroutine zfftb(n,c,Wsave) implicit none real(rk) :: c , Wsave integer :: iw1 , iw2 , n - dimension c(1) , Wsave(*) + dimension c(*) , Wsave(*) if ( n==1 ) return iw1 = n + n + 1 iw2 = iw1 + n + n diff --git a/src/zfftf.f90 b/src/zfftf.f90 index 8fa2791..1403702 100644 --- a/src/zfftf.f90 +++ b/src/zfftf.f90 @@ -3,7 +3,7 @@ subroutine zfftf(n,c,Wsave) implicit none real(rk) :: c , Wsave integer :: iw1 , iw2 , n - dimension c(1) , Wsave(*) + dimension c(*) , Wsave(*) if ( n==1 ) return iw1 = n + n + 1 iw2 = iw1 + n + n From 124ab4eeda51fae24ab0495379f1303cdd5cceba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C4=8Cert=C3=ADk?= Date: Tue, 14 Sep 2021 21:50:58 -0600 Subject: [PATCH 08/10] Fix a bug for 2*pi --- src/radbg.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/radbg.f90 b/src/radbg.f90 index 78f3cdf..55a6af4 100644 --- a/src/radbg.f90 +++ b/src/radbg.f90 @@ -8,7 +8,7 @@ subroutine radbg(Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) ipph , is , j , j2 , jc , k , l , l1 , lc , nbd dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , & c2(Idl1,Ip) , Ch2(Idl1,Ip) , Wa(*) - real(rk),parameter :: tpi = acos(-1.0_rk) / 2.0_rk ! 2 * pi + real(rk),parameter :: tpi = 2*acos(-1.0_rk) ! 2 * pi arg = tpi/real(Ip, rk) dcp = cos(arg) dsp = sin(arg) From db5967d42a86ad1b18befb25b8f2af337207cf69 Mon Sep 17 00:00:00 2001 From: zoziha Date: Mon, 13 Dec 2021 14:51:49 +0800 Subject: [PATCH 09/10] Update src/passf5.f90 Fix `tr12` value. --- src/passf5.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/passf5.f90 b/src/passf5.f90 index ad16bc4..6c29b44 100644 --- a/src/passf5.f90 +++ b/src/passf5.f90 @@ -12,7 +12,7 @@ subroutine passf5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) real(rk),parameter :: pi = acos(-1.0_rk) real(rk),parameter :: tr11 = cos(2.0_rk * pi / 5.0_rk) real(rk),parameter :: ti11 = -sin(2.0_rk * pi / 5.0_rk) - real(rk),parameter :: tr12 = -cos(4.0_rk * pi / 5.0_rk) + real(rk),parameter :: tr12 = cos(4.0_rk * pi / 5.0_rk) real(rk),parameter :: ti12 = -sin(4.0_rk * pi / 5.0_rk) if ( Ido/=2 ) then do k = 1 , l1 From 5601a66e02c97c4e4eadcaff3260f9c92dbdde54 Mon Sep 17 00:00:00 2001 From: zoziha Date: Thu, 27 Jan 2022 18:06:49 +0800 Subject: [PATCH 10/10] Fix Makefile & replace dp with rk. --- README.md | 8 +- example/bench1.f90 | 10 +-- src/Makefile | 171 +++++++++++++++++++++++------------- src/fftpack.f90 | 22 ++--- src/fftpack_dct.f90 | 12 +-- test/Makefile | 4 +- test/test_fftpack_dcosq.f90 | 2 +- test/test_fftpack_dcost.f90 | 12 +-- test/test_fftpack_dct.f90 | 30 +++---- 9 files changed, 162 insertions(+), 109 deletions(-) diff --git a/README.md b/README.md index ec1486b..91845e2 100644 --- a/README.md +++ b/README.md @@ -12,12 +12,12 @@ cd fftpack ``` ### Build with [fortran-lang/fpm](https://github.com/fortran-lang/fpm) -Fortran Package Manager (fpm) is a great package manager and build system for Fortran. +Fortran Package Manager (fpm) is a package manager and build system for Fortran. You can build using provided `fpm.toml`: ```bash -fpm build --flag "-O2" -fpm test --flag "-O2" --list -fpm test --flag "-O2" +fpm build +fpm test --list +fpm test ``` To use `fftpack` within your `fpm` project, add the following to your `fpm.toml` file: ```toml diff --git a/example/bench1.f90 b/example/bench1.f90 index af9c7f9..c46496d 100644 --- a/example/bench1.f90 +++ b/example/bench1.f90 @@ -1,10 +1,10 @@ program bench1 use fftpack, only: zffti, zfftf, zfftb +use fftpack_kind, only: rk implicit none -integer, parameter :: dp = kind(0.d0) -complex(dp), allocatable :: z(:) -real(dp), allocatable :: w(:), x(:) -real(dp) :: err, time_init, time_forward, time_backward, t1, t2 +complex(rk), allocatable :: z(:) +real(rk), allocatable :: w(:), x(:) +real(rk) :: err, time_init, time_forward, time_backward, t1, t2 integer :: N N = 1024*1014*16 @@ -32,7 +32,7 @@ program bench1 time_backward = t2-t1 print *, "Done" -err = maxval(abs(x-real(z/N,dp))) +err = maxval(abs(x-real(z/N,rk))) print * print *, "Error: ", err print *, "Init time: ", time_init diff --git a/src/Makefile b/src/Makefile index 2a9f61f..7b868a6 100644 --- a/src/Makefile +++ b/src/Makefile @@ -1,53 +1,53 @@ SRCF = \ - zfftb.f\ - cfftb1.f\ - zfftf.f\ - cfftf1.f\ - zffti.f\ - cffti1.f\ - dcosqb.f\ - cosqb1.f\ - dcosqf.f\ - cosqf1.f\ - dcosqi.f\ - dcost.f\ - dcosti.f\ - ezfft1.f\ - dzfftb.f\ - dzfftf.f\ - dzffti.f\ - passb.f\ - passb2.f\ - passb3.f\ - passb4.f\ - passb5.f\ - passf.f\ - passf2.f\ - passf3.f\ - passf4.f\ - passf5.f\ - radb2.f\ - radb3.f\ - radb4.f\ - radb5.f\ - radbg.f\ - radf2.f\ - radf3.f\ - radf4.f\ - radf5.f\ - radfg.f\ - dfftb.f\ - rfftb1.f\ - dfftf.f\ - rfftf1.f\ - dffti.f\ - rffti1.f\ - dsinqb.f\ - dsinqf.f\ - dsinqi.f\ - dsint.f\ - sint1.f\ - dsinti.f + zfftb.f90\ + cfftb1.f90\ + zfftf.f90\ + cfftf1.f90\ + zffti.f90\ + cffti1.f90\ + dcosqb.f90\ + cosqb1.f90\ + dcosqf.f90\ + cosqf1.f90\ + dcosqi.f90\ + dcost.f90\ + dcosti.f90\ + ezfft1.f90\ + dzfftb.f90\ + dzfftf.f90\ + dzffti.f90\ + passb.f90\ + passb2.f90\ + passb3.f90\ + passb4.f90\ + passb5.f90\ + passf.f90\ + passf2.f90\ + passf3.f90\ + passf4.f90\ + passf5.f90\ + radb2.f90\ + radb3.f90\ + radb4.f90\ + radb5.f90\ + radbg.f90\ + radf2.f90\ + radf3.f90\ + radf4.f90\ + radf5.f90\ + radfg.f90\ + dfftb.f90\ + rfftb1.f90\ + dfftf.f90\ + rfftf1.f90\ + dffti.f90\ + rffti1.f90\ + dsinqb.f90\ + dsinqf.f90\ + dsinqi.f90\ + dsint.f90\ + sint1.f90\ + dsinti.f90 SRCF90 = \ fftpack.f90\ @@ -59,9 +59,10 @@ SRCF90 = \ fftpack_ifftshift.f90\ fftpack_qct.f90\ fftpack_iqct.f90\ - fftpack_dct.f90 + fftpack_dct.f90\ + rk.f90 -OBJF := $(SRCF:.f=.o) +OBJF := $(SRCF:.f90=.o) OBJF90 := $(SRCF90:.f90=.o) lib$(LIB).a: $(OBJF) $(OBJF90) @@ -76,12 +77,62 @@ clean: %.o: %.f90 $(FC) $(FFLAGS) -c $< -fftpack_fft.o: fftpack.o -fftpack_ifft.o: fftpack.o -fftpack_rfft.o: fftpack.o -fftpack_irfft.o: fftpack.o -fftpack_qct.o: fftpack.o -fftpack_iqct.o: fftpack.o -fftpack_dct.o: fftpack.o -fftpack_fftshift.o: fftpack.o -fftpack_ifftshift.o: fftpack.o \ No newline at end of file +fftpack_fft.o: fftpack.o rk.o +fftpack_ifft.o: fftpack.o rk.o +fftpack_rfft.o: fftpack.o rk.o +fftpack_irfft.o: fftpack.o rk.o +fftpack_qct.o: fftpack.o rk.o +fftpack_iqct.o: fftpack.o rk.o +fftpack_dct.o: fftpack.o rk.o +fftpack_fftshift.o: fftpack.o rk.o +fftpack_ifftshift.o: fftpack.o rk.o + +zfftb.f90: rk.o +cfftb1.f90: rk.o +zfftf.f90: rk.o +cfftf1.f90: rk.o +zffti.f90: rk.o +cffti1.f90: rk.o +dcosqb.f90: rk.o +cosqb1.f90: rk.o +dcosqf.f90: rk.o +cosqf1.f90: rk.o +dcosqi.f90: rk.o +dcost.f90: rk.o +dcosti.f90: rk.o +ezfft1.f90: rk.o +dzfftb.f90: rk.o +dzfftf.f90: rk.o +dzffti.f90: rk.o +passb.f90: rk.o +passb2.f90: rk.o +passb3.f90: rk.o +passb4.f90: rk.o +passb5.f90: rk.o +passf.f90: rk.o +passf2.f90: rk.o +passf3.f90: rk.o +passf4.f90: rk.o +passf5.f90: rk.o +radb2.f90: rk.o +radb3.f90: rk.o +radb4.f90: rk.o +radb5.f90: rk.o +radbg.f90: rk.o +radf2.f90: rk.o +radf3.f90: rk.o +radf4.f90: rk.o +radf5.f90: rk.o +radfg.f90: rk.o +dfftb.f90: rk.o +rfftb1.f90: rk.o +dfftf.f90: rk.o +rfftf1.f90: rk.o +dffti.f90: rk.o +rffti1.f90: rk.o +dsinqb.f90: rk.o +dsinqf.f90: rk.o +dsinqi.f90: rk.o +dsint.f90: rk.o +sint1.f90: rk.o +dsinti.f90: rk.o diff --git a/src/fftpack.f90 b/src/fftpack.f90 index 9527acc..b6b9659 100644 --- a/src/fftpack.f90 +++ b/src/fftpack.f90 @@ -18,6 +18,8 @@ module fftpack public :: dcosti, dcost public :: dct, idct + + public :: rk interface @@ -157,9 +159,9 @@ end subroutine dcosqb !> !> Initialize `dcost`. ([Specification](../page/specs/fftpack.html#dcosti)) pure subroutine dcosti(n, wsave) - import dp + import rk integer, intent(in) :: n - real(kind=dp), intent(out) :: wsave(*) + real(kind=rk), intent(out) :: wsave(*) end subroutine dcosti !> Version: experimental @@ -167,10 +169,10 @@ end subroutine dcosti !> Discrete fourier cosine transform of an even sequence. !> ([Specification](../page/specs/fftpack.html#dcost)) pure subroutine dcost(n, x, wsave) - import dp + import rk integer, intent(in) :: n - real(kind=dp), intent(inout) :: x(*) - real(kind=dp), intent(in) :: wsave(*) + real(kind=rk), intent(inout) :: x(*) + real(kind=rk), intent(in) :: wsave(*) end subroutine dcost end interface @@ -252,11 +254,11 @@ end function iqct_rk !> Discrete fourier cosine (forward) transform of an even sequence. !> ([Specification](../page/specs/fftpack.html#dct)) interface dct - pure module function dct_dp(x, n) result(result) - real(kind=dp), intent(in) :: x(:) + pure module function dct_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n - real(kind=dp), allocatable :: result(:) - end function dct_dp + real(kind=rk), allocatable :: result(:) + end function dct_rk end interface dct !> Version: experimental @@ -264,7 +266,7 @@ end function dct_dp !> Discrete fourier cosine (backward) transform of an even sequence. !> ([Specification](../page/specs/fftpack.html#idct)) interface idct - module procedure :: dct_dp + module procedure :: dct_rk end interface idct !> Version: experimental diff --git a/src/fftpack_dct.f90 b/src/fftpack_dct.f90 index 85f3539..88a46d9 100644 --- a/src/fftpack_dct.f90 +++ b/src/fftpack_dct.f90 @@ -3,20 +3,20 @@ contains !> Discrete fourier cosine transform of an even sequence. - pure module function dct_dp(x, n) result(result) - real(kind=dp), intent(in) :: x(:) + pure module function dct_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) integer, intent(in), optional :: n - real(kind=dp), allocatable :: result(:) + real(kind=rk), allocatable :: result(:) integer :: lenseq, lensav, i - real(kind=dp), allocatable :: wsave(:) + real(kind=rk), allocatable :: wsave(:) if (present(n)) then lenseq = n if (lenseq <= size(x)) then result = x(:lenseq) else if (lenseq > size(x)) then - result = [x, (0.0_dp, i=1, lenseq - size(x))] + result = [x, (0.0_rk, i=1, lenseq - size(x))] end if else lenseq = size(x) @@ -31,6 +31,6 @@ pure module function dct_dp(x, n) result(result) !> Discrete fourier cosine transformation call dcost(lenseq, result, wsave) - end function dct_dp + end function dct_rk end submodule fftpack_dct diff --git a/test/Makefile b/test/Makefile index 57a618a..b47eb19 100644 --- a/test/Makefile +++ b/test/Makefile @@ -13,7 +13,7 @@ all: tstfft \ fftpack_dct # Orginal test -tstfft: tstfft.o +tstfft: tstfft.f $(FC) $(FFLAGS) $< -L../src -l$(LIB) -I../src -o $@.x time ./tstfft.x @@ -68,4 +68,4 @@ fftpack_ifftshift: test_fftpack_ifftshift.f90 ./fftpack_ifftshift.x clean: - rm -f -r *.o *.x \ No newline at end of file + rm -f -r *.o *.x diff --git a/test/test_fftpack_dcosq.f90 b/test/test_fftpack_dcosq.f90 index 9d990db..ee8a703 100644 --- a/test/test_fftpack_dcosq.f90 +++ b/test/test_fftpack_dcosq.f90 @@ -13,7 +13,7 @@ end subroutine check subroutine test_fftpack_dcosq_real use fftpack, only: dcosqi, dcosqf, dcosqb - use fftpack_kind + use fftpack_kind real(kind=rk) :: w(3*4 + 15) real(kind=rk) :: x(4) = [1, 2, 3, 4] real(kind=rk) :: eps = 1.0e-10_rk diff --git a/test/test_fftpack_dcost.f90 b/test/test_fftpack_dcost.f90 index ef978ea..d9cdcfc 100644 --- a/test/test_fftpack_dcost.f90 +++ b/test/test_fftpack_dcost.f90 @@ -13,17 +13,17 @@ end subroutine check subroutine test_fftpack_dcost_real use fftpack, only: dcosti, dcost - use iso_fortran_env, only: dp => real64 - real(kind=dp) :: w(3*4 + 15) - real(kind=dp) :: x(4) = [1, 2, 3, 4] - real(kind=dp) :: eps = 1.0e-10_dp + use fftpack_kind + real(kind=rk) :: w(3*4 + 15) + real(kind=rk) :: x(4) = [1, 2, 3, 4] + real(kind=rk) :: eps = 1.0e-10_rk call dcosti(4, w) call dcost(4, x, w) - call check(all(x == [real(kind=dp) :: 15, -4, 0, -1.0000000000000009_dp]), msg="`dcosti` failed.") + call check(all(x == [real(kind=rk) :: 15, -4, 0, -1.0000000000000009_rk]), msg="`dcosti` failed.") call dcost(4, x, w) - call check(all(x/(2.0_dp*(4.0_dp - 1.0_dp)) == [real(kind=dp) :: 1, 2, 3, 4]), msg="`dcost` failed.") + call check(all(x/(2.0_rk*(4.0_rk - 1.0_rk)) == [real(kind=rk) :: 1, 2, 3, 4]), msg="`dcost` failed.") end subroutine test_fftpack_dcost_real diff --git a/test/test_fftpack_dct.f90 b/test/test_fftpack_dct.f90 index ef1c6f8..f2a2307 100644 --- a/test/test_fftpack_dct.f90 +++ b/test/test_fftpack_dct.f90 @@ -14,29 +14,29 @@ end subroutine check subroutine test_fftpack_dct use fftpack, only: dct - use iso_fortran_env, only: dp => real64 + use fftpack_kind - real(kind=dp) :: x(3) = [9, -9, 3] + real(kind=rk) :: x(3) = [9, -9, 3] - call check(all(dct(x, 2) == [real(kind=dp) :: 0, 18]), msg="`dct(x, 2)` failed.") + call check(all(dct(x, 2) == [real(kind=rk) :: 0, 18]), msg="`dct(x, 2)` failed.") call check(all(dct(x, 3) == dct(x)), msg="`dct(x, 3)` failed.") - call check(all(dct(x, 4) == [real(kind=dp) :: -3, -3.0000000000000036_dp, 15, 33]), msg="`dct(x, 4)` failed.") + call check(all(dct(x, 4) == [real(kind=rk) :: -3, -3.0000000000000036_rk, 15, 33]), msg="`dct(x, 4)` failed.") end subroutine test_fftpack_dct subroutine test_fftpack_idct use fftpack, only: dct, idct - use iso_fortran_env, only: dp => real64 - real(kind=dp) :: eps = 1.0e-10_dp - real(kind=dp) :: x(4) = [1, 2, 3, 4] - - call check(all(idct(dct(x))/(2.0_dp*(4.0_dp - 1.0_dp)) == [real(kind=dp) :: 1, 2, 3, 4]), & - msg="`idct(dct(x))/(2.0_dp*(4.0_dp-1.0_dp))` failed.") - call check(all(idct(dct(x), 2)/(2.0_dp*(2.0_dp - 1.0_dp)) == [real(kind=dp) :: 5.5, 9.5]), & - msg="`idct(dct(x), 2)/(2.0_dp*(2.0_dp-1.0_dp))` failed.") - call check(all(idct(dct(x, 2), 4)/(2.0_dp*(4.0_dp - 1.0_dp)) == & - [0.16666666666666666_dp, 0.33333333333333331_dp, 0.66666666666666663_dp, 0.83333333333333315_dp]), & - msg="`idct(dct(x, 2), 4)/(2.0_dp*(4.0_dp-1.0_dp))` failed.") + use iso_fortran_env, only: rk => real64 + real(kind=rk) :: eps = 1.0e-10_rk + real(kind=rk) :: x(4) = [1, 2, 3, 4] + + call check(all(idct(dct(x))/(2.0_rk*(4.0_rk - 1.0_rk)) == [real(kind=rk) :: 1, 2, 3, 4]), & + msg="`idct(dct(x))/(2.0_rk*(4.0_rk-1.0_rk))` failed.") + call check(all(idct(dct(x), 2)/(2.0_rk*(2.0_rk - 1.0_rk)) == [real(kind=rk) :: 5.5, 9.5]), & + msg="`idct(dct(x), 2)/(2.0_rk*(2.0_rk-1.0_rk))` failed.") + call check(all(idct(dct(x, 2), 4)/(2.0_rk*(4.0_rk - 1.0_rk)) == & + [0.16666666666666666_rk, 0.33333333333333331_rk, 0.66666666666666663_rk, 0.83333333333333315_rk]), & + msg="`idct(dct(x, 2), 4)/(2.0_rk*(4.0_rk-1.0_rk))` failed.") end subroutine test_fftpack_idct