From 2edada5c11af0bf1ea7d8afe374feaf67b4e217d Mon Sep 17 00:00:00 2001 From: zoziha <zuo.zhihua@qq.com> Date: Thu, 17 Feb 2022 11:15:54 +0800 Subject: [PATCH] Use testdrive for unit tests --- fpm.toml | 76 ++---------------------- test/Makefile | 102 +++++++++++++------------------- test/test_fftpack.f90 | 34 +++++++++++ test/test_fftpack_dcosq.f90 | 30 ---------- test/test_fftpack_dcost.f90 | 30 ---------- test/test_fftpack_dct.f90 | 83 +++++++++++++++++--------- test/test_fftpack_dfft.f90 | 34 ----------- test/test_fftpack_dzfft.f90 | 35 ----------- test/test_fftpack_fft.f90 | 84 +++++++++++++++++++------- test/test_fftpack_fftshift.f90 | 43 -------------- test/test_fftpack_ifft.f90 | 30 ---------- test/test_fftpack_ifftshift.f90 | 45 -------------- test/test_fftpack_iqct.f90 | 31 ---------- test/test_fftpack_irfft.f90 | 30 ---------- test/test_fftpack_qct.f90 | 86 ++++++++++++++++++++------- test/test_fftpack_rfft.f90 | 100 ++++++++++++++++++++++++------- test/test_fftpack_utils.f90 | 82 +++++++++++++++++++++++++ test/test_fftpack_zfft.f90 | 35 ----------- 18 files changed, 428 insertions(+), 562 deletions(-) create mode 100644 test/test_fftpack.f90 delete mode 100644 test/test_fftpack_dcosq.f90 delete mode 100644 test/test_fftpack_dcost.f90 delete mode 100644 test/test_fftpack_dfft.f90 delete mode 100644 test/test_fftpack_dzfft.f90 delete mode 100644 test/test_fftpack_fftshift.f90 delete mode 100644 test/test_fftpack_ifft.f90 delete mode 100644 test/test_fftpack_ifftshift.f90 delete mode 100644 test/test_fftpack_iqct.f90 delete mode 100644 test/test_fftpack_irfft.f90 create mode 100644 test/test_fftpack_utils.f90 delete mode 100644 test/test_fftpack_zfft.f90 diff --git a/fpm.toml b/fpm.toml index 1ecbc3f..7610390 100644 --- a/fpm.toml +++ b/fpm.toml @@ -13,7 +13,10 @@ keywords = ["netlib", "fftpack", "fft"] [build] auto-executables = false auto-tests = false -auto-examples = true +auto-examples = false + +[dev-dependencies] +test-drive = { git = "https://github.com/fortran-lang/test-drive", tag = "v0.4.0" } # Original test [[test]] @@ -21,74 +24,7 @@ name = "tstfft" source-dir = "test" main = "tstfft.f" -# `fftpack` fft routines -[[test]] -name = "fftpack_zfft" -source-dir = "test" -main = "test_fftpack_zfft.f90" - -[[test]] -name = "fftpack_fft" -source-dir = "test" -main = "test_fftpack_fft.f90" - -[[test]] -name = "fftpack_ifft" -source-dir = "test" -main = "test_fftpack_ifft.f90" - -[[test]] -name = "fftpack_dfft" -source-dir = "test" -main = "test_fftpack_dfft.f90" - -[[test]] -name = "fftpack_rfft" -source-dir = "test" -main = "test_fftpack_rfft.f90" - -[[test]] -name = "fftpack_irfft" -source-dir = "test" -main = "test_fftpack_irfft.f90" - -[[test]] -name = "fftpack_dzfft" -source-dir = "test" -main = "test_fftpack_dzfft.f90" - -[[test]] -name = "fftpack_dcosq" -source-dir = "test" -main = "test_fftpack_dcosq.f90" - -[[test]] -name = "fftpack_qct" -source-dir = "test" -main = "test_fftpack_qct.f90" - -[[test]] -name = "fftpack_iqct" -source-dir = "test" -main = "test_fftpack_iqct.f90" - -[[test]] -name = "fftpack_dcost" -source-dir = "test" -main = "test_fftpack_dcost.f90" - -[[test]] -name = "fftpack_dct" -source-dir = "test" -main = "test_fftpack_dct.f90" - -# `fftpack` utility routines -[[test]] -name = "fftpack_fftshift" -source-dir = "test" -main = "test_fftpack_fftshift.f90" - [[test]] -name = "fftpack_ifftshift" +name = "test_fftpack" source-dir = "test" -main = "test_fftpack_ifftshift.f90" +main = "test_fftpack.f90" diff --git a/test/Makefile b/test/Makefile index b47eb19..cabb8a3 100644 --- a/test/Makefile +++ b/test/Makefile @@ -1,16 +1,19 @@ +FETCH = curl -L + +SRC = \ + test_fftpack_fft.f90 \ + test_fftpack_rfft.f90 \ + test_fftpack_qct.f90 \ + test_fftpack_dct.f90 \ + test_fftpack_utils.f90 \ + test_fftpack.f90 \ + testdrive.F90 + +OBJ = $(SRC:.f90=.o) +OBJ := $(OBJ:.F90=.o) + all: tstfft \ - fftpack_fft \ - fftpack_ifft \ - fftpack_rfft \ - fftpack_irfft \ - fftpack_fftshift \ - fftpack_ifftshift \ - fftpack_dzfft \ - fftpack_dcosq \ - fftpack_qct \ - fftpack_iqct \ - fftpack_dcost \ - fftpack_dct + test_fftpack # Orginal test tstfft: tstfft.f @@ -18,54 +21,31 @@ tstfft: tstfft.f time ./tstfft.x # `fftpack` fft routines -fftpack_fft: test_fftpack_fft.f90 - $(FC) $(FFLAGS) $< -L../src -l$(LIB) -I../src -o $@.x - ./fftpack_fft.x - -fftpack_ifft: test_fftpack_ifft.f90 - $(FC) $(FFLAGS) $< -L../src -l$(LIB) -I../src -o $@.x - ./fftpack_ifft.x - -fftpack_rfft: test_fftpack_rfft.f90 - $(FC) $(FFLAGS) $< -L../src -l$(LIB) -I../src -o $@.x - ./fftpack_rfft.x - -fftpack_irfft: test_fftpack_irfft.f90 - $(FC) $(FFLAGS) $< -L../src -l$(LIB) -I../src -o $@.x - ./fftpack_irfft.x - -fftpack_dzfft: test_fftpack_dzfft.f90 - $(FC) $(FFLAGS) $< -L../src -l$(LIB) -I../src -o $@.x - ./fftpack_dzfft.x - -fftpack_dcosq: test_fftpack_dcosq.f90 - $(FC) $(FFLAGS) $< -L../src -l$(LIB) -I../src -o $@.x - ./fftpack_dcosq.x - -fftpack_qct: test_fftpack_qct.f90 - $(FC) $(FFLAGS) $< -L../src -l$(LIB) -I../src -o $@.x - ./fftpack_qct.x - -fftpack_iqct: test_fftpack_iqct.f90 - $(FC) $(FFLAGS) $< -L../src -l$(LIB) -I../src -o $@.x - ./fftpack_iqct.x - -fftpack_dcost: test_fftpack_dcost.f90 - $(FC) $(FFLAGS) $< -L../src -l$(LIB) -I../src -o $@.x - ./fftpack_dcost.x - -fftpack_dct: test_fftpack_dct.f90 - $(FC) $(FFLAGS) $< -L../src -l$(LIB) -I../src -o $@.x - ./fftpack_dct.x - -# `fftpack` utility routines -fftpack_fftshift: test_fftpack_fftshift.f90 - $(FC) $(FFLAGS) $< -L../src -l$(LIB) -I../src -o $@.x - ./fftpack_fftshift.x - -fftpack_ifftshift: test_fftpack_ifftshift.f90 - $(FC) $(FFLAGS) $< -L../src -l$(LIB) -I../src -o $@.x - ./fftpack_ifftshift.x +test_fftpack: $(OBJ) + $(FC) $(FFLAGS) $(OBJ) -L../src -l$(LIB) -I../src -o $@.x + ./test_fftpack.x + +testdrive.F90: + $(FETCH) https://github.com/fortran-lang/test-drive/raw/v0.4.0/src/testdrive.F90 > $@ + +%.o: %.F90 + $(FC) $(FFLAGS) -c $< + +%.o: %.f90 + $(FC) $(FFLAGS) -I../src -c $< + +test_fftpack.o: test_fftpack_fft.o \ + test_fftpack_rfft.o \ + test_fftpack_qct.o \ + test_fftpack_dct.o \ + test_fftpack_utils.o \ + testdrive.o + +test_fftpack_fft.o: testdrive.o +test_fftpack_rfft.o: testdrive.o +test_fftpack_qct.o: testdrive.o +test_fftpack_dct.o: testdrive.o +test_fftpack_utils.o: testdrive.o clean: - rm -f -r *.o *.x + rm -f -r *.o *.mod *.smod *.x testdrive.F90 diff --git a/test/test_fftpack.f90 b/test/test_fftpack.f90 new file mode 100644 index 0000000..3396421 --- /dev/null +++ b/test/test_fftpack.f90 @@ -0,0 +1,34 @@ +program test_fftpack + use, intrinsic :: iso_fortran_env, only: error_unit + use testdrive, only: run_testsuite, new_testsuite, testsuite_type + use test_fftpack_fft, only: collect_fft + use test_fftpack_rfft, only: collect_rfft + use test_fftpack_qct, only: collect_qct + use test_fftpack_dct, only: collect_dct + use test_fftpack_utils, only: collect_utils + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("fft", collect_fft), & + new_testsuite("rfft", collect_rfft), & + new_testsuite("qct", collect_qct), & + new_testsuite("dct", collect_dct), & + new_testsuite("utils", collect_utils) & + ] + + do is = 1, size(testsuites) + write (error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write (error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if + +end program test_fftpack diff --git a/test/test_fftpack_dcosq.f90 b/test/test_fftpack_dcosq.f90 deleted file mode 100644 index ee8a703..0000000 --- a/test/test_fftpack_dcosq.f90 +++ /dev/null @@ -1,30 +0,0 @@ -program tester - - call test_fftpack_dcosq_real - print *, "All tests in `test_fftpack_dcosq` passed." - -contains - - subroutine check(condition, msg) - logical, intent(in) :: condition - character(*), intent(in) :: msg - if (.not. condition) error stop msg - end subroutine check - - subroutine test_fftpack_dcosq_real - 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_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_rk*4.0_rk) - [real(kind=rk) :: 1, 2, 3, 4])) < eps, msg="`dcosqb` failed.") - - end subroutine test_fftpack_dcosq_real - -end program tester diff --git a/test/test_fftpack_dcost.f90 b/test/test_fftpack_dcost.f90 deleted file mode 100644 index d9cdcfc..0000000 --- a/test/test_fftpack_dcost.f90 +++ /dev/null @@ -1,30 +0,0 @@ -program tester - - call test_fftpack_dcost_real - print *, "All tests in `test_fftpack_dcost` passed." - -contains - - subroutine check(condition, msg) - logical, intent(in) :: condition - character(*), intent(in) :: msg - if (.not. condition) error stop msg - end subroutine check - - subroutine test_fftpack_dcost_real - use fftpack, only: dcosti, dcost - 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=rk) :: 15, -4, 0, -1.0000000000000009_rk]), msg="`dcosti` failed.") - - call dcost(4, x, w) - 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 - -end program tester diff --git a/test/test_fftpack_dct.f90 b/test/test_fftpack_dct.f90 index f2a2307..e435923 100644 --- a/test/test_fftpack_dct.f90 +++ b/test/test_fftpack_dct.f90 @@ -1,43 +1,70 @@ -program tester +module test_fftpack_dct - call test_fftpack_dct() - call test_fftpack_idct() - print *, "All tests in `test_fftpack_dct` passed." + use fftpack, only: rk, dcosti, dcost, dct, idct + use testdrive, only: new_unittest, unittest_type, error_type, check + implicit none + private + + public :: collect_dct contains - subroutine check(condition, msg) - logical, intent(in) :: condition - character(*), intent(in) :: msg - if (.not. condition) error stop msg - end subroutine check + !> Collect all exported unit tests + subroutine collect_dct(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("classic-dct-API", test_classic_dct), & + new_unittest("modernized-dct-API", test_modernized_dct), & + new_unittest("modernized-idct-API", test_modernized_idct) & + ] + + end subroutine collect_dct + + subroutine test_classic_dct(error) + type(error_type), allocatable, intent(out) :: error + 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(error, all(x == [real(kind=rk) :: 15, -4, 0, -1.0000000000000009_rk]), "`dcosti` failed.") + if (allocated(error)) return + + call dcost(4, x, w) + call check(error, all(x/(2.0_rk*(4.0_rk - 1.0_rk)) == [real(kind=rk) :: 1, 2, 3, 4]), "`dcost` failed.") - subroutine test_fftpack_dct - use fftpack, only: dct - use fftpack_kind + end subroutine test_classic_dct + subroutine test_modernized_dct(error) + type(error_type), allocatable, intent(out) :: error real(kind=rk) :: x(3) = [9, -9, 3] - 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=rk) :: -3, -3.0000000000000036_rk, 15, 33]), msg="`dct(x, 4)` failed.") + call check(error, all(dct(x, 2) == [real(kind=rk) :: 0, 18]), "`dct(x, 2)` failed.") + if (allocated(error)) return + call check(error, all(dct(x, 3) == dct(x)), "`dct(x, 3)` failed.") + if (allocated(error)) return + call check(error, all(dct(x, 4) == [real(kind=rk) :: -3, -3.0000000000000036_rk, 15, 33]), "`dct(x, 4)` failed.") - end subroutine test_fftpack_dct + end subroutine test_modernized_dct - subroutine test_fftpack_idct - use fftpack, only: dct, idct - use iso_fortran_env, only: rk => real64 + subroutine test_modernized_idct(error) + type(error_type), allocatable, intent(out) :: error 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.") + call check(error, all(idct(dct(x))/(2.0_rk*(4.0_rk - 1.0_rk)) == [real(kind=rk) :: 1, 2, 3, 4]), & + "`idct(dct(x))/(2.0_rk*(4.0_rk-1.0_rk))` failed.") + if (allocated(error)) return + call check(error, all(idct(dct(x), 2)/(2.0_rk*(2.0_rk - 1.0_rk)) == [real(kind=rk) :: 5.5, 9.5]), & + "`idct(dct(x), 2)/(2.0_rk*(2.0_rk-1.0_rk))` failed.") + if (allocated(error)) return + call check(error, 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]), & + "`idct(dct(x, 2), 4)/(2.0_rk*(4.0_rk-1.0_rk))` failed.") - end subroutine test_fftpack_idct + end subroutine test_modernized_idct -end program tester +end module test_fftpack_dct diff --git a/test/test_fftpack_dfft.f90 b/test/test_fftpack_dfft.f90 deleted file mode 100644 index bbad26a..0000000 --- a/test/test_fftpack_dfft.f90 +++ /dev/null @@ -1,34 +0,0 @@ -program tester - - call test_fftpack_dfft() - print *, "All tests in `test_fftpack_dfft` passed." - -contains - - subroutine check(condition, msg) - logical, intent(in) :: condition - character(*), intent(in) :: msg - if (.not. condition) error stop msg - end subroutine check - - subroutine test_fftpack_dfft() - use fftpack, only: dffti, dfftf, dfftb - use fftpack_kind - - 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=rk) :: 10, -2, 2, -2]), & - msg="`dfftf` failed.") - - call dfftb(4, x, w) - call check(all(x/4.0_rk == [real(kind=rk) :: 1, 2, 3, 4]), & - msg="`dfftb` failed.") - - end subroutine test_fftpack_dfft - -end program tester diff --git a/test/test_fftpack_dzfft.f90 b/test/test_fftpack_dzfft.f90 deleted file mode 100644 index 31f3ebc..0000000 --- a/test/test_fftpack_dzfft.f90 +++ /dev/null @@ -1,35 +0,0 @@ -program tester - - call test_fftpack_dzfft - print *, "All tests in `test_fftpack_dzfft` passed." - -contains - - subroutine check(condition, msg) - logical, intent(in) :: condition - character(*), intent(in) :: msg - if (.not. condition) error stop msg - end subroutine check - - subroutine test_fftpack_dzfft - use fftpack, only: dzffti, dzfftf, dzfftb - use fftpack_kind - - 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_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=rk) :: 1, 2, 3, 4]), msg="all(x = [real(kind=rk) :: 1, 2, 3, 4]) failed.") - - end subroutine test_fftpack_dzfft - -end program tester - diff --git a/test/test_fftpack_fft.f90 b/test/test_fftpack_fft.f90 index 1770065..9db72fc 100644 --- a/test/test_fftpack_fft.f90 +++ b/test/test_fftpack_fft.f90 @@ -1,30 +1,74 @@ -program tester +module test_fftpack_fft - call test_fftpack_fft() - print *, "All tests in `test_fftpack_fft` passed." + use fftpack, only: rk, zffti, zfftf, zfftb, fft, ifft + use testdrive, only: new_unittest, unittest_type, error_type, check + implicit none + private + + public :: collect_fft contains - subroutine check(condition, msg) - logical, intent(in) :: condition - character(*), intent(in) :: msg - if (.not. condition) error stop msg - end subroutine check + !> Collect all exported unit tests + subroutine collect_fft(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) - subroutine test_fftpack_fft - use fftpack, only: fft - use fftpack_kind - real(kind=rk) :: eps = 1.0e-10_rk + testsuite = [ & + new_unittest("classic-fft-API", test_classic_fft), & + new_unittest("modernized-fft-API", test_modernized_fft), & + new_unittest("modernized-ifft-API", test_modernized_ifft) & + ] + + end subroutine collect_fft + + subroutine test_classic_fft(error) + type(error_type), allocatable, intent(out) :: error + 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(error, all(x == [complex(kind=rk) ::(10, 0), (-2, 2), (-2, 0), (-2, -2)]), & + "`zfftf` failed.") + if (allocated(error)) return + call zfftb(4, x, w) + call check(error, all(x/4.0_rk == [complex(kind=rk) ::(1, 0), (2, 0), (3, 0), (4, 0)]), & + "`zfftb` failed.") + end subroutine test_classic_fft + + subroutine test_modernized_fft(error) + type(error_type), allocatable, intent(out) :: error + real(kind=rk) :: eps = 1.0e-10_rk complex(kind=rk) :: x(3) = [1.0_rk, 2.0_rk, 3.0_rk] - 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_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.") + call check(error, sum(abs(fft(x, 2) - [(3.0_rk, 0.0_rk), (-1.0_rk, 0.0_rk)])) < eps, & + "`fft(x, 2)` failed.") + if (allocated(error)) return + call check(error, sum(abs(fft(x, 3) - fft(x))) < eps, & + "`fft(x, 3)` failed.") + if (allocated(error)) return + call check(error, 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, & + "`fft(x, 4)` failed.") + + end subroutine test_modernized_fft + + subroutine test_modernized_ifft(error) + type(error_type), allocatable, intent(out) :: error + real(kind=rk) :: eps = 1.0e-10_rk + complex(kind=rk) :: x(4) = [1, 2, 3, 4] + + call check(error, sum(abs(ifft(fft(x))/4.0_rk - [complex(kind=rk) :: 1, 2, 3, 4])) < eps, & + "`ifft(fft(x))/4.0_rk` failed.") + if (allocated(error)) return + call check(error, sum(abs(ifft(fft(x), 2) - [complex(kind=rk) ::(8, 2), (12, -2)])) < eps, & + "`ifft(fft(x), 2)` failed.") + if (allocated(error)) return + call check(error, sum(abs(ifft(fft(x, 2), 4) - [complex(kind=rk) ::(2, 0), (3, -1), (4, 0), (3, 1)])) < eps, & + "`ifft(fft(x, 2), 4)` failed.") - end subroutine test_fftpack_fft + end subroutine test_modernized_ifft + -end program tester +end module test_fftpack_fft diff --git a/test/test_fftpack_fftshift.f90 b/test/test_fftpack_fftshift.f90 deleted file mode 100644 index 2b90b3c..0000000 --- a/test/test_fftpack_fftshift.f90 +++ /dev/null @@ -1,43 +0,0 @@ -program tester - - call test_fftpack_fftshift_complex - call test_fftpack_fftshift_real - print *, "All tests in `test_fftpack_fftshift` passed." - -contains - - subroutine check(condition, msg) - logical, intent(in) :: condition - character(*), intent(in) :: msg - if (.not. condition) error stop msg - end subroutine check - - subroutine test_fftpack_fftshift_complex - use fftpack, only: fftshift - use fftpack_kind - - 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=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 - use fftpack_kind - - 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=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 - -end program tester diff --git a/test/test_fftpack_ifft.f90 b/test/test_fftpack_ifft.f90 deleted file mode 100644 index d7c7f73..0000000 --- a/test/test_fftpack_ifft.f90 +++ /dev/null @@ -1,30 +0,0 @@ -program tester - - call test_fftpack_ifft() - print *, "All tests in `test_fftpack_ifft` passed." - -contains - - subroutine check(condition, msg) - logical, intent(in) :: condition - character(*), intent(in) :: msg - if (.not. condition) error stop msg - end subroutine check - - subroutine test_fftpack_ifft - use fftpack, only: fft, ifft - use fftpack_kind - real(kind=rk) :: eps = 1.0e-10_rk - - complex(kind=rk) :: x(4) = [1, 2, 3, 4] - - 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=rk) ::(2, 0), (3, -1), (4, 0), (3, 1)])) < eps, & - msg="`ifft(fft(x, 2), 4)` failed.") - - end subroutine test_fftpack_ifft - -end program tester diff --git a/test/test_fftpack_ifftshift.f90 b/test/test_fftpack_ifftshift.f90 deleted file mode 100644 index 88f56ed..0000000 --- a/test/test_fftpack_ifftshift.f90 +++ /dev/null @@ -1,45 +0,0 @@ -program tester - - call test_fftpack_ifftshift_complex - call test_fftpack_ifftshift_real - print *, "All tests in `test_fftpack_ifftshift` passed." - -contains - - subroutine check(condition, msg) - logical, intent(in) :: condition - character(*), intent(in) :: msg - if (.not. condition) error stop msg - end subroutine check - - subroutine test_fftpack_ifftshift_complex - use fftpack, only: ifftshift - use fftpack_kind - integer :: i - - 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=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 - use fftpack_kind - integer :: i - - 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=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 - -end program tester diff --git a/test/test_fftpack_iqct.f90 b/test/test_fftpack_iqct.f90 deleted file mode 100644 index 62f535b..0000000 --- a/test/test_fftpack_iqct.f90 +++ /dev/null @@ -1,31 +0,0 @@ -program tester - - call test_fftpack_iqct() - print *, "All tests in `test_fftpack_iqct` passed." - -contains - - subroutine check(condition, msg) - logical, intent(in) :: condition - character(*), intent(in) :: msg - if (.not. condition) error stop msg - end subroutine check - - subroutine test_fftpack_iqct - 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 - -end program tester diff --git a/test/test_fftpack_irfft.f90 b/test/test_fftpack_irfft.f90 deleted file mode 100644 index 0c7e970..0000000 --- a/test/test_fftpack_irfft.f90 +++ /dev/null @@ -1,30 +0,0 @@ -program tester - - call test_fftpack_irfft() - print *, "All tests in `test_fftpack_irfft` passed." - -contains - - subroutine check(condition, msg) - logical, intent(in) :: condition - character(*), intent(in) :: msg - if (.not. condition) error stop msg - end subroutine check - - subroutine test_fftpack_irfft - use fftpack, only: rfft, irfft - use fftpack_kind - real(kind=rk) :: eps = 1.0e-10_rk - - real(kind=rk) :: x(4) = [1, 2, 3, 4] - - 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=rk) :: 1, 3, 5, 3])) < eps, & - msg="`irfft(rfft(x, 2), 4)` failed.") - - end subroutine test_fftpack_irfft - -end program tester diff --git a/test/test_fftpack_qct.f90 b/test/test_fftpack_qct.f90 index 850d989..ed56b58 100644 --- a/test/test_fftpack_qct.f90 +++ b/test/test_fftpack_qct.f90 @@ -1,31 +1,77 @@ -program tester +module test_fftpack_qct - call test_fftpack_qct() - print *, "All tests in `test_fftpack_qct` passed." + use fftpack, only: rk, dcosqi, dcosqf, dcosqb, qct, iqct + use testdrive, only: new_unittest, unittest_type, error_type, check + implicit none + private + + public :: collect_qct contains - subroutine check(condition, msg) - logical, intent(in) :: condition - character(*), intent(in) :: msg - if (.not. condition) error stop msg - end subroutine check + !> Collect all exported unit tests + subroutine collect_qct(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("classic-qct-API", test_classic_qct), & + new_unittest("modernized-qct-API", test_modernized_qct), & + new_unittest("modernized-iqct-API", test_modernized_iqct) & + ] + + end subroutine collect_qct - subroutine test_fftpack_qct - use fftpack, only: qct - use fftpack_kind + subroutine test_classic_qct(error) + type(error_type), allocatable, intent(out) :: error + 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(error, sum(abs(x - [11.999626276085150_rk, -9.1029432177492193_rk, & + 2.6176618435106480_rk, -1.5143449018465791_rk])) < eps, & + "`dcosqf` failed.") + if (allocated(error)) return + call dcosqb(4, x, w) + call check(error, sum(abs(x/(4.0_rk*4.0_rk) - [real(kind=rk) :: 1, 2, 3, 4])) < eps, & + "`dcosqb` failed.") + + end subroutine test_classic_qct + + subroutine test_modernized_qct(error) + type(error_type), allocatable, intent(out) :: error + real(kind=rk) :: eps = 1.0e-10_rk real(kind=rk) :: x(3) = [9, -9, 3] - 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_rk, -2.1309424696909023_rk, & - 11.645661095452331_rk, 29.872472272322447_rk])) < eps, & - msg="`qct(x, 4)` failed.") + call check(error, sum(abs(qct(x, 2) - [-3.7279220613578570_rk, 21.727922061357859_rk])) < eps, & + "`qct(x, 2)` failed.") + if (allocated(error)) return + call check(error, sum(abs(qct(x, 3) - qct(x))) < eps, & + "`qct(x,3)` failed.") + if (allocated(error)) return + call check(error, sum(abs(qct(x, 4) - [-3.3871908980838743_rk, -2.1309424696909023_rk, & + 11.645661095452331_rk, 29.872472272322447_rk])) < eps, & + "`qct(x, 4)` failed.") + + end subroutine test_modernized_qct + + subroutine test_modernized_iqct(error) + type(error_type), allocatable, intent(out) :: error + real(kind=rk) :: eps = 1.0e-10_rk + real(kind=rk) :: x(4) = [1, 2, 3, 4] + + call check(error, sum(abs(iqct(qct(x))/(4.0_rk*4.0_rk) - [real(kind=rk) :: 1, 2, 3, 4])) < eps, & + "`iqct(qct(x)/(4.0_rk*4.0_rk)` failed.") + if (allocated(error)) return + call check(error, sum(abs(iqct(qct(x), 2)/(4.0_rk*2.0_rk) - [1.4483415291679655_rk, 7.4608849947753271_rk])) < eps, & + "`iqct(qct(x), 2)/(4.0_rk*2.0_rk)` failed.") + if (allocated(error)) return + call check(error, 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, & + "`iqct(qct(x, 2), 4)/(4.0_rk*4.0_rk)` failed.") - end subroutine test_fftpack_qct + end subroutine test_modernized_iqct -end program tester +end module test_fftpack_qct diff --git a/test/test_fftpack_rfft.f90 b/test/test_fftpack_rfft.f90 index cf37192..6b7cc15 100644 --- a/test/test_fftpack_rfft.f90 +++ b/test/test_fftpack_rfft.f90 @@ -1,30 +1,90 @@ -program tester +module test_fftpack_rfft - call test_fftpack_rfft() - print *, "All tests in `test_fftpack_rfft` passed." + use fftpack, only: rk, dffti, dfftf, dfftb, rfft, irfft + use fftpack, only: dzffti, dzfftf, dzfftb + use testdrive, only: new_unittest, unittest_type, error_type, check + implicit none + private + + public :: collect_rfft contains - subroutine check(condition, msg) - logical, intent(in) :: condition - character(*), intent(in) :: msg - if (.not. condition) error stop msg - end subroutine check + !> Collect all exported unit tests + subroutine collect_rfft(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) - subroutine test_fftpack_rfft - use fftpack, only: rfft - use fftpack_kind - real(kind=rk) :: eps = 1.0e-10_rk + testsuite = [ & + new_unittest("classic-rfft-API", test_classic_rfft), & + new_unittest("modernized-rfft-API", test_modernized_rfft), & + new_unittest("modernized-irfft-API", test_modernized_irfft) & + ] + + end subroutine collect_rfft + + subroutine test_classic_rfft(error) + type(error_type), allocatable, intent(out) :: error + real(kind=rk) :: x(4) = [1, 2, 3, 4] + real(kind=rk) :: w(31) + real(kind=rk) :: azero, a(4/2), b(4/2) + + call dffti(4, w) + call dfftf(4, x, w) + call check(error, all(x == [real(kind=rk) :: 10, -2, 2, -2]), & + "`dfftf` failed.") + if (allocated(error)) return + call dfftb(4, x, w) + call check(error, all(x/4.0_rk == [real(kind=rk) :: 1, 2, 3, 4]), & + "`dfftb` failed.") + if (allocated(error)) return + + x = [1, 2, 3, 4] + call dzffti(4, w) + call dzfftf(4, x, azero, a, b, w) + call check(error, azero == 2.5_rk, "dzfftf: azero == 2.5_rk failed.") + if (allocated(error)) return + call check(error, all(a == [-1.0_rk, -0.5_rk]), "dzfftf: all(a == [-1.0, -0.5]) failed.") + if (allocated(error)) return + call check(error, all(b == [-1.0_rk, 0.0_rk]), "dzfftf: all(b == [-1.0, 0.0]) failed.") + if (allocated(error)) return + + call dzfftb(4, x, azero, a, b, w) + call check(error, all(x == [real(kind=rk) :: 1, 2, 3, 4]), & + "dzfftb: all(x = [real(kind=rk) :: 1, 2, 3, 4]) failed.") + end subroutine test_classic_rfft + + subroutine test_modernized_rfft(error) + type(error_type), allocatable, intent(out) :: error + real(kind=rk) :: eps = 1.0e-10_rk real(kind=rk) :: x(3) = [9, -9, 3] - 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=rk) :: 3, 6, 9, 21])) < eps, & - msg="`rfft(x, 4)` failed.") + call check(error, sum(abs(rfft(x, 2) - [real(kind=rk) :: 0, 18])) < eps, & + "`rfft(x, 2)` failed.") + if (allocated(error)) return + call check(error, sum(abs(rfft(x, 3) - rfft(x))) < eps, & + "`rfft(x, 3)` failed.") + if (allocated(error)) return + call check(error, sum(abs(rfft(x, 4) - [real(kind=rk) :: 3, 6, 9, 21])) < eps, & + "`rfft(x, 4)` failed.") + + end subroutine test_modernized_rfft + + subroutine test_modernized_irfft(error) + type(error_type), allocatable, intent(out) :: error + real(kind=rk) :: eps = 1.0e-10_rk + real(kind=rk) :: x(4) = [1, 2, 3, 4] + + call check(error, sum(abs(irfft(rfft(x))/4.0_rk - [real(kind=rk) :: 1, 2, 3, 4])) < eps, & + "`irfft(rfft(x))/4.0_rk` failed.") + if (allocated(error)) return + call check(error, sum(abs(irfft(rfft(x), 2) - [real(kind=rk) :: 8, 12])) < eps, & + "`irfft(rfft(x), 2)` failed.") + if (allocated(error)) return + call check(error, sum(abs(irfft(rfft(x, 2), 4) - [real(kind=rk) :: 1, 3, 5, 3])) < eps, & + "`irfft(rfft(x, 2), 4)` failed.") - end subroutine test_fftpack_rfft + end subroutine test_modernized_irfft -end program tester +end module test_fftpack_rfft diff --git a/test/test_fftpack_utils.f90 b/test/test_fftpack_utils.f90 new file mode 100644 index 0000000..6c5cdb3 --- /dev/null +++ b/test/test_fftpack_utils.f90 @@ -0,0 +1,82 @@ +module test_fftpack_utils + + use fftpack, only: rk, fftshift, ifftshift + use testdrive, only: new_unittest, unittest_type, error_type, check + implicit none + private + + public :: collect_utils + +contains + + !> Collect all exported unit tests + subroutine collect_utils(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("fftshift_complex", test_fftshift_complex), & + new_unittest("fftshift_real", test_fftshift_real), & + new_unittest("ifftshift_complex", test_fftshift_complex), & + new_unittest("ifftshift_real", test_fftshift_real) & + ] + + end subroutine collect_utils + + subroutine test_fftshift_complex(error) + type(error_type), allocatable, intent(out) :: error + complex(kind=rk) :: xeven(4) = [1, 2, 3, 4] + complex(kind=rk) :: xodd(5) = [1, 2, 3, 4, 5] + + call check(error, all(fftshift(xeven) == [complex(kind=rk) :: 3, 4, 1, 2]), & + "all(fftshift(xeven) == [complex(kind=rk) :: 3, 4, 1, 2]) failed.") + if (allocated(error)) return + call check(error, all(fftshift(xodd) == [complex(kind=rk) :: 4, 5, 1, 2, 3]), & + "all(fftshift(xodd) == [complex(kind=rk) :: 4, 5, 1, 2, 3]) failed.") + + end subroutine test_fftshift_complex + + subroutine test_fftshift_real(error) + type(error_type), allocatable, intent(out) :: error + real(kind=rk) :: xeven(4) = [1, 2, 3, 4] + real(kind=rk) :: xodd(5) = [1, 2, 3, 4, 5] + + call check(error, all(fftshift(xeven) == [real(kind=rk) :: 3, 4, 1, 2]), & + "all(fftshift(xeven) == [real(kind=rk) :: 3, 4, 1, 2]) failed.") + if (allocated(error)) return + call check(error, all(fftshift(xodd) == [real(kind=rk) :: 4, 5, 1, 2, 3]), & + "all(fftshift(xodd) == [real(kind=rk) :: 4, 5, 1, 2, 3]) failed.") + + end subroutine test_fftshift_real + + subroutine test_ifftshift_complex(error) + type(error_type), allocatable, intent(out) :: error + integer :: i + + complex(kind=rk) :: xeven(4) = [3, 4, 1, 2] + complex(kind=rk) :: xodd(5) = [4, 5, 1, 2, 3] + + call check(error, all(ifftshift(xeven) == [complex(kind=rk) ::(i, i=1, 4)]), & + "all(ifftshift(xeven) == [complex(kind=rk) ::(i, i=1, 4)]) failed.") + if (allocated(error)) return + call check(error, all(ifftshift(xodd) == [complex(kind=rk) ::(i, i=1, 5)]), & + "all(ifftshift(xodd) == [complex(kind=rk) ::(i, i=1, 5)]) failed.") + + end subroutine test_ifftshift_complex + + subroutine test_ifftshift_real(error) + type(error_type), allocatable, intent(out) :: error + integer :: i + + real(kind=rk) :: xeven(4) = [3, 4, 1, 2] + real(kind=rk) :: xodd(5) = [4, 5, 1, 2, 3] + + call check(error, all(ifftshift(xeven) == [real(kind=rk) ::(i, i=1, 4)]), & + "all(ifftshift(xeven) == [real(kind=rk) ::(i, i=1, 4)]) failed.") + if (allocated(error)) return + call check(error, all(ifftshift(xodd) == [real(kind=rk) ::(i, i=1, 5)]), & + "all(ifftshift(xodd) == [real(kind=rk) ::(i, i=1, 5)]) failed.") + + end subroutine test_ifftshift_real + +end module test_fftpack_utils diff --git a/test/test_fftpack_zfft.f90 b/test/test_fftpack_zfft.f90 deleted file mode 100644 index b45ab3b..0000000 --- a/test/test_fftpack_zfft.f90 +++ /dev/null @@ -1,35 +0,0 @@ -program tester - - call test_fftpack_zfft() - print *, "All tests in `test_fftpack_zfft` passed." - -contains - - subroutine check(condition, msg) - logical, intent(in) :: condition - character(*), intent(in) :: msg - if (.not. condition) error stop msg - end subroutine check - - subroutine test_fftpack_zfft() - use fftpack_kind - - 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=rk) ::(10, 0), (-2, 2), (-2, 0), (-2, -2)]), & - msg="`zfftf` failed.") - - call zfftb(4, x, w) - 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 - -end program tester