diff --git a/src/Makefile b/src/Makefile index 7b868a6..df591a2 100644 --- a/src/Makefile +++ b/src/Makefile @@ -60,7 +60,7 @@ SRCF90 = \ fftpack_qct.f90\ fftpack_iqct.f90\ fftpack_dct.f90\ - rk.f90 + rk.F90 OBJF := $(SRCF:.f90=.o) OBJF90 := $(SRCF90:.f90=.o) @@ -74,6 +74,9 @@ shared: $(OBJ) clean: rm -f -r *.o *.a *.so *.mod *.smod +%.o: %.F90 + $(FC) $(FFLAGS) -c $< + %.o: %.f90 $(FC) $(FFLAGS) -c $< diff --git a/src/rk.F90 b/src/rk.F90 new file mode 100644 index 0000000..686efc2 --- /dev/null +++ b/src/rk.F90 @@ -0,0 +1,16 @@ +!> fftpack kind +module fftpack_kind + implicit none + + !> fftpack real kind +#if defined(fftpack_sp) + integer, parameter :: rk = selected_real_kind(6) +#elif defined(fftpack_xdp) + integer, parameter :: rk = selected_real_kind(18) +#elif defined(fftpack_qp) + integer, parameter :: rk = selected_real_kind(33) +#else + integer, parameter :: rk = selected_real_kind(15) +#endif + +end module fftpack_kind diff --git a/src/rk.f90 b/src/rk.f90 deleted file mode 100644 index 663df9c..0000000 --- a/src/rk.f90 +++ /dev/null @@ -1,4 +0,0 @@ - module fftpack_kind - implicit none - integer,parameter :: rk = kind(1.0d0) - end module fftpack_kind diff --git a/test/Makefile b/test/Makefile index cabb8a3..51dac52 100644 --- a/test/Makefile +++ b/test/Makefile @@ -29,7 +29,7 @@ testdrive.F90: $(FETCH) https://github.com/fortran-lang/test-drive/raw/v0.4.0/src/testdrive.F90 > $@ %.o: %.F90 - $(FC) $(FFLAGS) -c $< + $(FC) $(FFLAGS) -I../src -c $< %.o: %.f90 $(FC) $(FFLAGS) -I../src -c $< diff --git a/test/test_fftpack_dct.f90 b/test/test_fftpack_dct.F90 similarity index 68% rename from test/test_fftpack_dct.f90 rename to test/test_fftpack_dct.F90 index e435923..838e44a 100644 --- a/test/test_fftpack_dct.f90 +++ b/test/test_fftpack_dct.F90 @@ -7,6 +7,12 @@ module test_fftpack_dct public :: collect_dct +#if defined(fftpack_sp) + real(kind=rk) :: eps = 1.0e-5_rk +#else + real(kind=rk) :: eps = 1.0e-10_rk +#endif + contains !> Collect all exported unit tests @@ -26,15 +32,16 @@ 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.") + call check(error, sum(abs(x - [real(kind=rk) :: 15, -4, 0, -1.0000000000000009_rk])) < eps, & + "`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.") + call check(error, sum(abs(x/(2.0_rk*(4.0_rk - 1.0_rk)) - & + [real(kind=rk) :: 1, 2, 3, 4])) < eps, "`dcost` failed.") end subroutine test_classic_dct @@ -46,23 +53,25 @@ subroutine test_modernized_dct(error) 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.") + call check(error, sum(abs(dct(x, 4) - [real(kind=rk) :: -3, -3.0000000000000036_rk, 15, 33])) & + < eps, "`dct(x, 4)` failed.") end subroutine test_modernized_dct 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(error, all(idct(dct(x))/(2.0_rk*(4.0_rk - 1.0_rk)) == [real(kind=rk) :: 1, 2, 3, 4]), & + call check(error, sum(abs(idct(dct(x))/(2.0_rk*(4.0_rk - 1.0_rk)) - & + [real(kind=rk) :: 1, 2, 3, 4])) < eps, & "`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]), & + call check(error, sum(abs(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])) < eps, & "`idct(dct(x, 2), 4)/(2.0_rk*(4.0_rk-1.0_rk))` failed.") end subroutine test_modernized_idct diff --git a/test/test_fftpack_qct.f90 b/test/test_fftpack_qct.F90 similarity index 96% rename from test/test_fftpack_qct.f90 rename to test/test_fftpack_qct.F90 index ed56b58..8d0851a 100644 --- a/test/test_fftpack_qct.f90 +++ b/test/test_fftpack_qct.F90 @@ -7,6 +7,12 @@ module test_fftpack_qct public :: collect_qct +#if defined(fftpack_sp) + real(kind=rk) :: eps = 1.0e-5_rk +#else + real(kind=rk) :: eps = 1.0e-10_rk +#endif + contains !> Collect all exported unit tests @@ -26,7 +32,6 @@ 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) @@ -42,7 +47,6 @@ 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(error, sum(abs(qct(x, 2) - [-3.7279220613578570_rk, 21.727922061357859_rk])) < eps, & @@ -59,7 +63,6 @@ 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, &