From b76e540bba4363bc838930e2882758e01eb42257 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 18 May 2024 09:08:16 +0200 Subject: [PATCH 01/10] Fixes for extended and quad precision checking. Add CI cheks with fpm --- .github/workflows/fpm-deployment.yml | 5 +- src/stdlib_specialfunctions_gamma.fypp | 71 ++- test/math/test_meshgrid.fypp | 2 +- test/math/test_stdlib_math.fypp | 12 +- test/quadrature/test_simps.fypp | 554 +++--------------- .../test_specialfunctions_gamma.fypp | 15 +- test/stats/test_mean.fypp | 27 +- test/stats/test_median.fypp | 16 +- 8 files changed, 173 insertions(+), 529 deletions(-) diff --git a/.github/workflows/fpm-deployment.yml b/.github/workflows/fpm-deployment.yml index 2e4a3203c..9c4314e35 100644 --- a/.github/workflows/fpm-deployment.yml +++ b/.github/workflows/fpm-deployment.yml @@ -35,8 +35,11 @@ jobs: with: fpm-version: 'v0.10.0' - - run: | + - run: | # Just for deployment: create stdlib-fpm folder python config/fypp_deployment.py --deploy_stdlib_fpm + + - run: | # Use fpm gnu ci to check xdp and qp + python config/fypp_deployment.py --with_xdp --with_qp fpm test --profile release # Update and deploy the f90 files generated by github-ci to the `stdlib-fpm` branch. diff --git a/src/stdlib_specialfunctions_gamma.fypp b/src/stdlib_specialfunctions_gamma.fypp index 2307a6660..e208ccad3 100644 --- a/src/stdlib_specialfunctions_gamma.fypp +++ b/src/stdlib_specialfunctions_gamma.fypp @@ -1,7 +1,6 @@ -#:set WITH_QP = False -#:set WITH_XDP = False #:include "common.fypp" -#:set CI_KINDS_TYPES = INT_KINDS_TYPES + CMPLX_KINDS_TYPES +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES[0:2] +#:set CI_KINDS_TYPES = INT_KINDS_TYPES + CMPLX_KINDS_TYPES[0:2] module stdlib_specialfunctions_gamma use iso_fortran_env, only : qp => real128 use stdlib_kinds, only : sp, dp, int8, int16, int32, int64 @@ -15,7 +14,7 @@ module stdlib_specialfunctions_gamma integer(int32), parameter :: max_fact_int32 = 13_int32 integer(int64), parameter :: max_fact_int64 = 21_int64 - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES ${t1}$, parameter :: tol_${k1}$ = epsilon(1.0_${k1}$) #:endfor real(qp), parameter :: tol_qp = epsilon(1.0_qp) @@ -63,12 +62,12 @@ module stdlib_specialfunctions_gamma !! Lower incomplete gamma function !! #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES module procedure ingamma_low_${t1[0]}$${k1}$${k2}$ #:endfor #:endfor - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES module procedure ingamma_low_${t1[0]}$${k1}$ #:endfor end interface lower_incomplete_gamma @@ -79,12 +78,12 @@ module stdlib_specialfunctions_gamma !! Logarithm of lower incomplete gamma function !! #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES module procedure l_ingamma_low_${t1[0]}$${k1}$${k2}$ #:endfor #:endfor - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES module procedure l_ingamma_low_${t1[0]}$${k1}$ #:endfor end interface log_lower_incomplete_gamma @@ -95,12 +94,12 @@ module stdlib_specialfunctions_gamma !! Upper incomplete gamma function !! #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES module procedure ingamma_up_${t1[0]}$${k1}$${k2}$ #:endfor #:endfor - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES module procedure ingamma_up_${t1[0]}$${k1}$ #:endfor end interface upper_incomplete_gamma @@ -111,12 +110,12 @@ module stdlib_specialfunctions_gamma !! Logarithm of upper incomplete gamma function !! #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES module procedure l_ingamma_up_${t1[0]}$${k1}$${k2}$ #:endfor #:endfor - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES module procedure l_ingamma_up_${t1[0]}$${k1}$ #:endfor end interface log_upper_incomplete_gamma @@ -127,12 +126,12 @@ module stdlib_specialfunctions_gamma !! Regularized (normalized) lower incomplete gamma function, P !! #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES module procedure regamma_p_${t1[0]}$${k1}$${k2}$ #:endfor #:endfor - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES module procedure regamma_p_${t1[0]}$${k1}$ #:endfor end interface regularized_gamma_p @@ -143,12 +142,12 @@ module stdlib_specialfunctions_gamma !! Regularized (normalized) upper incomplete gamma function, Q !! #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES module procedure regamma_q_${t1[0]}$${k1}$${k2}$ #:endfor #:endfor - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES module procedure regamma_q_${t1[0]}$${k1}$ #:endfor end interface regularized_gamma_q @@ -159,12 +158,12 @@ module stdlib_specialfunctions_gamma ! Incomplete gamma G function. ! Internal use only ! - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES module procedure gpx_${t1[0]}$${k1}$ !for real p and x #:endfor #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES module procedure gpx_${t1[0]}$${k1}$${k2}$ !for integer p and real x #:endfor #:endfor @@ -177,7 +176,7 @@ module stdlib_specialfunctions_gamma ! Internal use only ! #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES module procedure l_gamma_${t1[0]}$${k1}$${k2}$ #:endfor #:endfor @@ -218,7 +217,7 @@ contains - #:for k1, t1 in CMPLX_KINDS_TYPES + #:for k1, t1 in CMPLX_KINDS_TYPES[0:2] #:if k1 == "sp" #:set k2 = "dp" #:elif k1 == "dp" @@ -373,7 +372,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES impure elemental function l_gamma_${t1[0]}$${k1}$${k2}$(z, x) result(res) ! @@ -414,7 +413,7 @@ contains - #:for k1, t1 in CMPLX_KINDS_TYPES + #:for k1, t1 in CMPLX_KINDS_TYPES[0:2] #:if k1 == "sp" #:set k2 = "dp" #:elif k1 == "dp" @@ -556,7 +555,7 @@ contains - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES #:if k1 == "sp" #:set k2 = "dp" #:elif k1 == "dp" @@ -702,7 +701,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES impure elemental function gpx_${t1[0]}$${k1}$${k2}$(p, x) result(res) ! ! Approximation of incomplete gamma G function with integer argument p. @@ -841,7 +840,7 @@ contains - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES impure elemental function ingamma_low_${t1[0]}$${k1}$(p, x) result(res) ! ! Approximation of lower incomplete gamma function with real p. @@ -878,7 +877,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES impure elemental function ingamma_low_${t1[0]}$${k1}$${k2}$(p, x) & result(res) ! @@ -918,7 +917,7 @@ contains - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES impure elemental function l_ingamma_low_${t1[0]}$${k1}$(p, x) result(res) ${t1}$, intent(in) :: p, x @@ -955,7 +954,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES impure elemental function l_ingamma_low_${t1[0]}$${k1}$${k2}$(p, x) & result(res) @@ -987,7 +986,7 @@ contains - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES impure elemental function ingamma_up_${t1[0]}$${k1}$(p, x) result(res) ! ! Approximation of upper incomplete gamma function with real p. @@ -1025,7 +1024,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES impure elemental function ingamma_up_${t1[0]}$${k1}$${k2}$(p, x) & result(res) ! @@ -1067,7 +1066,7 @@ contains - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES impure elemental function l_ingamma_up_${t1[0]}$${k1}$(p, x) result(res) ${t1}$, intent(in) :: p, x @@ -1105,7 +1104,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES impure elemental function l_ingamma_up_${t1[0]}$${k1}$${k2}$(p, x) & result(res) @@ -1146,7 +1145,7 @@ contains - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES impure elemental function regamma_p_${t1[0]}$${k1}$(p, x) result(res) ! ! Approximation of regularized incomplete gamma function P(p,x) for real p @@ -1181,7 +1180,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES impure elemental function regamma_p_${t1[0]}$${k1}$${k2}$(p, x) result(res) ! ! Approximation of regularized incomplete gamma function P(p,x) for integer p @@ -1217,7 +1216,7 @@ contains - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES impure elemental function regamma_q_${t1[0]}$${k1}$(p, x) result(res) ! ! Approximation of regularized incomplete gamma function Q(p,x) for real p @@ -1252,7 +1251,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES impure elemental function regamma_q_${t1[0]}$${k1}$${k2}$(p, x) result(res) ! ! Approximation of regularized incomplet gamma function Q(p,x) for integer p diff --git a/test/math/test_meshgrid.fypp b/test/math/test_meshgrid.fypp index b61b956b7..fea181185 100644 --- a/test/math/test_meshgrid.fypp +++ b/test/math/test_meshgrid.fypp @@ -79,7 +79,7 @@ contains ${"".join(f"xm{j}," for j in range(1, rank + 1)).removesuffix(",")}$ & ${OPTIONAL_PART_IN_SIGNATURE(INDEXING)}$ ) #:for j in range(1, rank + 1) - call check(error, maxval(abs(xm${j}$ - xm${j}$_exact)), ZERO) + call check(error, maxval(abs(xm${j}$ - xm${j}$_exact)) == ZERO) if (allocated(error)) return #:endfor end subroutine test_${RName}$ diff --git a/test/math/test_stdlib_math.fypp b/test/math/test_stdlib_math.fypp index 9b02f5fbe..e686ce912 100644 --- a/test/math/test_stdlib_math.fypp +++ b/test/math/test_stdlib_math.fypp @@ -170,9 +170,9 @@ contains type(error_type), allocatable, intent(out) :: error ! type: real(sp), kind: sp ! valid test case - call check(error, clip(3.025_sp, -5.77_sp, 3.025_sp), 3.025_sp) + call check(error, clip(3.025_sp, -5.77_sp, 3.025_sp) == 3.025_sp) if (allocated(error)) return - call check(error, clip(0.0_sp, -1578.025_sp, -59.68_sp), -59.68_sp) + call check(error, clip(0.0_sp, -1578.025_sp, -59.68_sp) == -59.68_sp) if (allocated(error)) return end subroutine test_clip_rsp @@ -215,9 +215,9 @@ contains #:if WITH_QP ! type: real(qp), kind: qp ! valid test case - call check(error, clip(3.025_qp, -5.77_qp, 3.025_qp), 3.025_qp) + call check(error, clip(3.025_qp, -5.77_qp, 3.025_qp) == 3.025_qp) if (allocated(error)) return - call check(error, clip(-55891546.2_qp, -8958133457.23_qp, -689712245.23_qp), -689712245.23_qp) + call check(error, clip(-55891546.2_qp, -8958133457.23_qp, -689712245.23_qp) == -689712245.23_qp) if (allocated(error)) return #:else call skip_test(error, "Quadruple precision is not enabled") @@ -230,9 +230,9 @@ contains type(error_type), allocatable, intent(out) :: error #:if WITH_QP ! invalid test case - call check(error, clip(3.025_qp, 3.025_qp, -5.77_qp), 3.025_qp) + call check(error, clip(3.025_qp, 3.025_qp, -5.77_qp) == 3.025_qp) if (allocated(error)) return - call check(error, clip(-55891546.2_qp, -689712245.23_qp, -8958133457.23_qp), -689712245.23_qp) + call check(error, clip(-55891546.2_qp, -689712245.23_qp, -8958133457.23_qp) == 689712245.23_qp) if (allocated(error)) return #:else call skip_test(error, "Quadruple precision is not enabled") diff --git a/test/quadrature/test_simps.fypp b/test/quadrature/test_simps.fypp index 26814c1c1..411d5f55a 100644 --- a/test/quadrature/test_simps.fypp +++ b/test/quadrature/test_simps.fypp @@ -7,15 +7,9 @@ module test_simps implicit none - real(sp), parameter :: tol_sp = 1000 * epsilon(1.0_sp) - real(dp), parameter :: tol_dp = 1000 * epsilon(1.0_dp) -#:if WITH_XDP - real(xdp), parameter :: tol_xdp = 1000 * epsilon(1.0_xdp) -#:endif -#:if WITH_QP - real(qp), parameter :: tol_qp = 1000 * epsilon(1.0_qp) -#:endif - + #:for k1, t1 in REAL_KINDS_TYPES + ${t1}$, parameter :: tol_${k1}$ = 1000 * epsilon(1.0_${k1}$) + #:endfor contains @@ -25,135 +19,70 @@ contains type(unittest_type), allocatable, intent(out) :: testsuite(:) testsuite = [ & - new_unittest("simps_sp", test_simps_sp), & - new_unittest("simps_dp", test_simps_dp), & - new_unittest("simps_qp", test_simps_qp), & - new_unittest("simps_weights_sp", test_simps_weights_sp), & - new_unittest("simps_weights_dp", test_simps_weights_dp), & - new_unittest("simps_weights_qp", test_simps_weights_qp), & - new_unittest("simps_zero_sp", test_simps_zero_sp), & - new_unittest("simps_zero_dp", test_simps_zero_dp), & - new_unittest("simps_zero_qp", test_simps_zero_qp), & - new_unittest("simps_even_sp", test_simps_even_sp), & - new_unittest("simps_even_dp", test_simps_even_dp), & - new_unittest("simps_even_qp", test_simps_even_qp), & - new_unittest("simps_weights_even_sp", test_simps_weights_even_sp), & - new_unittest("simps_weights_even_dp", test_simps_weights_even_dp), & - new_unittest("simps_weights_even_qp", test_simps_weights_even_qp), & - new_unittest("simps_six_sp", test_simps_six_sp), & - new_unittest("simps_six_dp", test_simps_six_dp), & - new_unittest("simps_six_qp", test_simps_six_qp) & + new_unittest("simps_sp", test_simps_sp) & + #:for k1, t1 in REAL_KINDS_TYPES[1:] + , new_unittest("simps_${k1}$", test_simps_${k1}$) & + #:endfor + #:for k1, t1 in REAL_KINDS_TYPES + , new_unittest("simps_weights_${k1}$", test_simps_weights_${k1}$) & + #:endfor + #:for k1, t1 in REAL_KINDS_TYPES + , new_unittest("simps_zero_${k1}$", test_simps_zero_${k1}$) & + #:endfor + #:for k1, t1 in REAL_KINDS_TYPES + , new_unittest("simps_even_${k1}$", test_simps_even_${k1}$) & + #:endfor + #:for k1, t1 in REAL_KINDS_TYPES + , new_unittest("simps_weights_even_${k1}$", test_simps_weights_even_${k1}$) & + #:endfor + #:for k1, t1 in REAL_KINDS_TYPES + , new_unittest("simps_six_${k1}$", test_simps_six_${k1}$) & + #:endfor ] end subroutine collect_simps - subroutine test_simps_sp(error) + #:for k1, t1 in REAL_KINDS_TYPES + subroutine test_simps_${k1}$(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer, parameter :: n = 13 - real(sp), dimension(n) :: y - real(sp), dimension(n) :: x - real(sp) :: val - real(sp) :: ans + ${t1}$ :: y(n) + ${t1}$ :: x(n) + ${t1}$ :: val + ${t1}$ :: ans integer :: i y = [(real(i-1, sp)**2, i = 1, n)] - val = simps(y, 1.0_sp) - ans = 576.0_sp - call check(error, val, ans, thr=tol_sp) - if (allocated(error)) return - - val = simps(y, 0.5_sp) - ans = 288.0_sp - call check(error, val, ans, thr=tol_sp) - if (allocated(error)) return - - x = [(0.25_sp*(i-1), i = 1, n)] - val = simps(y, x) - ans = 144.0_sp - call check(error, val, ans, thr=tol_sp) - end subroutine test_simps_sp - - - subroutine test_simps_dp(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - integer, parameter :: n = 13 - real(dp), dimension(n) :: y - real(dp), dimension(n) :: x - real(dp) :: val - real(dp) :: ans - integer :: i - - - y = [(real(i-1, dp)**2, i = 1, n)] - - val = simps(y, 1.0_dp) - ans = 576.0_dp - call check(error, val, ans, thr=tol_dp) - if (allocated(error)) return - - val = simps(y, 0.5_dp) - ans = 288.0_dp - call check(error, val, ans, thr=tol_dp) - if (allocated(error)) return - - x = [(0.25_dp*(i-1), i = 1, n)] - val = simps(y, x) - ans = 144.0_dp - call check(error, val, ans, thr=tol_dp) - end subroutine test_simps_dp - - - subroutine test_simps_qp(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - -#:if WITH_QP - integer, parameter :: n = 13 - real(qp), dimension(n) :: y - real(qp), dimension(n) :: x - real(qp) :: val - real(qp) :: ans - integer :: i - - - y = [(real(i-1, qp)**2, i = 1, n)] - - val = simps(y, 1.0_qp) - ans = 576.0_qp - call check(error, val, ans, thr=tol_qp) + val = simps(y, 1.0_${k1}$) + ans = 576.0_${k1}$ + call check(error, abs(val - ans) < tol_${k1}$) if (allocated(error)) return - val = simps(y, 0.5_qp) - ans = 288.0_qp - call check(error, val, ans, thr=tol_qp) + val = simps(y, 0.5_${k1}$) + ans = 288.0_${k1}$ + call check(error, abs(val - ans) < tol_${k1}$) if (allocated(error)) return - x = [(0.25_qp*(i-1), i = 1, n)] + x = [(0.25_${k1}$*(i-1), i = 1, n)] val = simps(y, x) - ans = 144.0_qp - call check(error, val, ans, thr=tol_qp) -#:else - call skip_test(error, "Quadruple precision is not enabled") -#:endif - end subroutine test_simps_qp - + ans = 144.0_${k1}$ + call check(error, abs(val - ans) < tol_${k1}$) + end subroutine test_simps_${k1}$ - subroutine test_simps_weights_sp(error) + subroutine test_simps_weights_${k1}$(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer, parameter :: n = 17 - real(sp), dimension(n) :: y - real(sp), dimension(n) :: x - real(sp), dimension(n) :: w + ${t1}$ :: y(n) + ${t1}$ :: x(n) + ${t1}$ :: w(n) integer :: i - real(sp) :: val - real(sp) :: ans + ${t1}$ :: val + ${t1}$ :: ans y = [(real(i-1, sp), i = 1, n)] @@ -162,233 +91,71 @@ contains w = simps_weights(x) val = sum(w*y) ans = simps(y, x) - call check(error, val, ans, thr=tol_sp) - end subroutine test_simps_weights_sp - - - subroutine test_simps_weights_dp(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - integer, parameter :: n = 17 - real(dp), dimension(n) :: y - real(dp), dimension(n) :: x - real(dp), dimension(n) :: w - integer :: i - real(dp) :: val - real(dp) :: ans - - - y = [(real(i-1, dp), i = 1, n)] - - x = y - w = simps_weights(x) - val = sum(w*y) - ans = simps(y, x) - call check(error, val, ans, thr=tol_dp) - end subroutine test_simps_weights_dp - - - subroutine test_simps_weights_qp(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - -#:if WITH_QP - integer, parameter :: n = 17 - real(qp), dimension(n) :: y - real(qp), dimension(n) :: x - real(qp), dimension(n) :: w - integer :: i - real(qp) :: val - real(qp) :: ans - - - y = [(real(i-1, qp), i = 1, n)] - - x = y - w = simps_weights(x) - val = sum(w*y) - ans = simps(y, x) - call check(error, val, ans, thr=tol_qp) -#:else - call skip_test(error, "Quadruple precision is not enabled") -#:endif - end subroutine test_simps_weights_qp - - - subroutine test_simps_zero_sp(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - real(sp), dimension(0) :: a - - - call check(error, abs(simps(a, 1.0_sp)) < epsilon(0.0_sp)) - if (allocated(error)) return - call check(error, abs(simps([1.0_sp], 1.0_sp)) < epsilon(0.0_sp)) - if (allocated(error)) return - call check(error, abs(simps(a, a)) < epsilon(0.0_sp)) - if (allocated(error)) return - call check(error, abs(simps([1.0_sp], [1.0_sp])) < epsilon(0.0_sp)) - end subroutine test_simps_zero_sp - - - subroutine test_simps_zero_dp(error) + call check(error, abs(val - ans) < tol_${k1}$) + end subroutine test_simps_weights_${k1}$ + + subroutine test_simps_zero_${k1}$(error) !> Error handling type(error_type), allocatable, intent(out) :: error - real(dp), dimension(0) :: a + ${t1}$, dimension(0) :: a - call check(error, abs(simps(a, 1.0_dp)) < epsilon(0.0_dp)) + call check(error, abs(simps(a, 1.0_${k1}$)) < epsilon(0.0_${k1}$)) if (allocated(error)) return - call check(error, abs(simps([1.0_dp], 1.0_dp)) < epsilon(0.0_dp)) - if (allocated(error)) return - call check(error, abs(simps(a, a)) < epsilon(0.0_dp)) - if (allocated(error)) return - call check(error, abs(simps([1.0_dp], [1.0_dp])) < epsilon(0.0_dp)) - end subroutine test_simps_zero_dp - - - subroutine test_simps_zero_qp(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - -#:if WITH_QP - real(qp), dimension(0) :: a - - - call check(error, abs(simps(a, 1.0_qp)) < epsilon(0.0_qp)) - if (allocated(error)) return - call check(error, abs(simps([1.0_qp], 1.0_qp)) < epsilon(0.0_qp)) - if (allocated(error)) return - call check(error, abs(simps(a, a)) < epsilon(0.0_qp)) - if (allocated(error)) return - call check(error, abs(simps([1.0_qp], [1.0_qp])) < epsilon(0.0_qp)) -#:else - call skip_test(error, "Quadruple precision is not enabled") -#:endif - end subroutine test_simps_zero_qp - - - subroutine test_simps_even_sp(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - integer, parameter :: n = 11 - real(sp), dimension(n) :: y - real(sp), dimension(n) :: x - real(sp) :: val - real(sp) :: ans - integer :: i - integer :: even - - - y = [(3.0_sp*real(i-1, sp)**2, i = 1, n)] - - do even = -1, 1 - - val = simps(y, 1.0_sp) - ans = 1000.0_sp - call check(error, val, ans, thr=tol_sp) - if (allocated(error)) return - - val = simps(y, 0.5_sp) - ans = 500.0_sp - call check(error, val, ans, thr=tol_sp) - if (allocated(error)) return - - x = [(0.25_sp*(i-1), i = 1, n)] - val = simps(y, x) - ans = 250.0_sp - call check(error, val, ans, thr=tol_sp) - if (allocated(error)) return - end do - end subroutine test_simps_even_sp - - - subroutine test_simps_even_dp(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - integer, parameter :: n = 11 - real(dp), dimension(n) :: y - real(dp), dimension(n) :: x - real(dp) :: val - real(dp) :: ans - integer :: i - - - y = [(3.0_dp*real(i-1, dp)**2, i = 1, n)] - - val = simps(y, 1.0_dp) - ans = 1000.0_dp - call check(error, val, ans, thr=tol_dp) + call check(error, abs(simps([1.0_${k1}$], 1.0_${k1}$)) < epsilon(0.0_${k1}$)) if (allocated(error)) return - - val = simps(y, 0.5_dp) - ans = 500.0_dp - call check(error, val, ans, thr=tol_dp) + call check(error, abs(simps(a, a)) < epsilon(0.0_${k1}$)) if (allocated(error)) return + call check(error, abs(simps([1.0_${k1}$], [1.0_${k1}$])) < epsilon(0.0_${k1}$)) + end subroutine test_simps_zero_${k1}$ - x = [(0.25_dp*(i-1), i = 1, n)] - val = simps(y, x) - ans = 250.0_dp - call check(error, val, ans, thr=tol_dp) - end subroutine test_simps_even_dp - - - subroutine test_simps_even_qp(error) + subroutine test_simps_even_${k1}$(error) !> Error handling type(error_type), allocatable, intent(out) :: error -#:if WITH_QP integer, parameter :: n = 11 - real(qp), dimension(n) :: y - real(qp), dimension(n) :: x - real(qp) :: val - real(qp) :: ans + ${t1}$ :: y(n) + ${t1}$ :: x(n) + ${t1}$ :: val + ${t1}$ :: ans integer :: i integer :: even - y = [(3.0_qp*real(i-1, qp)**2, i = 1, n)] + y = [(3.0_${k1}$*real(i-1, sp)**2, i = 1, n)] do even = -1, 1 - val = simps(y, 1.0_qp) - ans = 1000.0_qp - call check(error, val, ans, thr=tol_qp) + val = simps(y, 1.0_${k1}$) + ans = 1000.0_${k1}$ + call check(error, abs(val - ans) < tol_${k1}$) if (allocated(error)) return - val = simps(y, 0.5_qp) - ans = 500.0_qp - call check(error, val, ans, thr=tol_qp) + val = simps(y, 0.5_${k1}$) + ans = 500.0_${k1}$ + call check(error, abs(val - ans) < tol_${k1}$) if (allocated(error)) return - x = [(0.25_qp*(i-1), i = 1, n)] + x = [(0.25_${k1}$*(i-1), i = 1, n)] val = simps(y, x) - ans = 250.0_qp - call check(error, val, ans, thr=tol_qp) + ans = 250.0_${k1}$ + call check(error, abs(val - ans) < tol_${k1}$) if (allocated(error)) return end do -#:else - call skip_test(error, "Quadruple precision is not enabled") -#:endif - end subroutine test_simps_even_qp - + end subroutine test_simps_even_${k1}$ - subroutine test_simps_weights_even_sp(error) + subroutine test_simps_weights_even_${k1}$(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer, parameter :: n = 16 - real(sp), dimension(n) :: y - real(sp), dimension(n) :: x - real(sp), dimension(n) :: w + ${t1}$ :: y(n) + ${t1}$ :: x(n) + ${t1}$ :: w(n) integer :: i - real(sp) :: val - real(sp) :: ans + ${t1}$ :: val + ${t1}$ :: ans integer :: even @@ -399,176 +166,47 @@ contains w = simps_weights(x) val = sum(w*y) ans = simps(y, x) - call check(error, val, ans, thr=tol_sp) - if (allocated(error)) return - end do - end subroutine test_simps_weights_even_sp - - - subroutine test_simps_weights_even_dp(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - integer, parameter :: n = 16 - real(dp), dimension(n) :: y - real(dp), dimension(n) :: x - real(dp), dimension(n) :: w - integer :: i - real(dp) :: val - real(dp) :: ans - integer :: even - - - y = [(real(i-1, dp), i = 1, n)] - x = y - - do even = -1, 1 - w = simps_weights(x) - val = sum(w*y) - ans = simps(y, x) - call check(error, val, ans, thr=tol_dp) - if (allocated(error)) return - end do - end subroutine test_simps_weights_even_dp - - - subroutine test_simps_weights_even_qp(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - -#:if WITH_QP - integer, parameter :: n = 16 - real(qp), dimension(n) :: y - real(qp), dimension(n) :: x - real(qp), dimension(n) :: w - integer :: i - real(qp) :: val - real(qp) :: ans - integer :: even - - - y = [(real(i-1, qp), i = 1, n)] - - x = y - - do even = -1, 1 - w = simps_weights(x) - val = sum(w*y) - ans = simps(y, x) - call check(error, val, ans, thr=tol_qp) - if (allocated(error)) return - end do -#:else - call skip_test(error, "Quadruple precision is not enabled") -#:endif - end subroutine test_simps_weights_even_qp - - - subroutine test_simps_six_sp(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - integer, parameter :: n = 6 - real(sp), dimension(n) :: y - real(sp), dimension(n) :: x - real(sp) :: val - real(sp) :: ans - integer :: i - integer :: even - - - y = [(3.0_sp*real(i-1, sp)**2, i = 1, n)] - - do even = -1, 1 - - val = simps(y, 1.0_sp) - ans = 125.0_sp - call check(error, val, ans, thr=tol_sp) - if (allocated(error)) return - - val = simps(y, 0.5_sp) - ans = 62.5_sp - call check(error, val, ans, thr=tol_sp) - if (allocated(error)) return - - x = [(0.25_sp*(i-1), i = 1, n)] - val = simps(y, x) - ans = 31.25_sp - call check(error, val, ans, thr=tol_sp) + call check(error, abs(val - ans) < tol_${k1}$) if (allocated(error)) return end do - end subroutine test_simps_six_sp - - - subroutine test_simps_six_dp(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - integer, parameter :: n = 6 - real(dp), dimension(n) :: y - real(dp), dimension(n) :: x - real(dp) :: val - real(dp) :: ans - integer :: i - - - y = [(3.0_dp*real(i-1, dp)**2, i = 1, n)] - - val = simps(y, 1.0_dp) - ans = 125.0_dp - call check(error, val, ans, thr=tol_dp) - if (allocated(error)) return - - val = simps(y, 0.5_dp) - ans = 62.5_dp - call check(error, val, ans, thr=tol_dp) - if (allocated(error)) return - - x = [(0.25_dp*(i-1), i = 1, n)] - val = simps(y, x) - ans = 31.25_dp - call check(error, val, ans, thr=tol_dp) - end subroutine test_simps_six_dp - + end subroutine test_simps_weights_even_${k1}$ - subroutine test_simps_six_qp(error) + subroutine test_simps_six_${k1}$(error) !> Error handling type(error_type), allocatable, intent(out) :: error -#:if WITH_QP integer, parameter :: n = 6 - real(qp), dimension(n) :: y - real(qp), dimension(n) :: x - real(qp) :: val - real(qp) :: ans + ${t1}$ :: y(n) + ${t1}$ :: x(n) + ${t1}$ :: val + ${t1}$ :: ans integer :: i integer :: even - y = [(3.0_qp*real(i-1, qp)**2, i = 1, n)] + y = [(3.0_${k1}$*real(i-1, sp)**2, i = 1, n)] do even = -1, 1 - val = simps(y, 1.0_qp) - ans = 125.0_qp - call check(error, val, ans, thr=tol_qp) + val = simps(y, 1.0_${k1}$) + ans = 125.0_${k1}$ + call check(error, abs(val - ans) < tol_${k1}$) if (allocated(error)) return - val = simps(y, 0.5_qp) - ans = 62.5_qp - call check(error, val, ans, thr=tol_qp) + val = simps(y, 0.5_${k1}$) + ans = 62.5_${k1}$ + call check(error, abs(val - ans) < tol_${k1}$) if (allocated(error)) return - x = [(0.25_qp*(i-1), i = 1, n)] + x = [(0.25_${k1}$*(i-1), i = 1, n)] val = simps(y, x) - ans = 31.25_qp - call check(error, val, ans, thr=tol_qp) + ans = 31.25_${k1}$ + call check(error, abs(val - ans) < tol_${k1}$) if (allocated(error)) return end do -#:else - call skip_test(error, "Quadruple precision is not enabled") -#:endif - end subroutine test_simps_six_qp + end subroutine test_simps_six_${k1}$ + + #:endfor end module diff --git a/test/specialfunctions/test_specialfunctions_gamma.fypp b/test/specialfunctions/test_specialfunctions_gamma.fypp index a5853df1f..e0fc12fba 100644 --- a/test/specialfunctions/test_specialfunctions_gamma.fypp +++ b/test/specialfunctions/test_specialfunctions_gamma.fypp @@ -1,7 +1,6 @@ -#:set WITH_QP = False -#:set WITH_XDP = False #:include "common.fypp" -#:set CI_KINDS_TYPES = INT_KINDS_TYPES + CMPLX_KINDS_TYPES +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES[0:2] +#:set CI_KINDS_TYPES = INT_KINDS_TYPES + CMPLX_KINDS_TYPES[0:2] module test_specialfunctions_gamma use testdrive, only : new_unittest, unittest_type, error_type, check use stdlib_kinds, only: sp, dp, int8, int16, int32, int64 @@ -18,7 +17,7 @@ module test_specialfunctions_gamma public :: collect_specialfunctions_gamma - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES ${t1}$, parameter :: tol_${k1}$ = 1000 * epsilon(1.0_${k1}$) #:endfor @@ -46,7 +45,7 @@ contains #:endfor #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES , new_unittest("lower_incomplete_gamma_${t1[0]}$${k1}$${k2}$", & test_lincgamma_${t1[0]}$${k1}$${k2}$) & , new_unittest("log_lower_incomplete_gamma_${t1[0]}$${k1}$${k2}$", & @@ -62,7 +61,7 @@ contains #:endfor #:endfor - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES , new_unittest("lower_incomplete_gamma_${t1[0]}$${k1}$", & test_lincgamma_${t1[0]}$${k1}$) & , new_unittest("log_lower_incomplete_gamma_${t1[0]}$${k1}$", & @@ -268,7 +267,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES + #:for k2, t2 in RC_KINDS_TYPES subroutine test_lincgamma_${t1[0]}$${k1}$${k2}$(error) type(error_type), allocatable, intent(out) :: error @@ -417,7 +416,7 @@ contains - #:for k1, t1 in REAL_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES subroutine test_lincgamma_${t1[0]}$${k1}$(error) type(error_type), allocatable, intent(out) :: error diff --git a/test/stats/test_mean.fypp b/test/stats/test_mean.fypp index ffa40bb05..7512f0081 100644 --- a/test/stats/test_mean.fypp +++ b/test/stats/test_mean.fypp @@ -173,9 +173,10 @@ contains type(error_type), allocatable, intent(out) :: error #:for rank in range(1, NRANK+1) - call check(error, mean(d${rank}$_${k1}$), sum(d${rank}$_${k1}$)/real(size(d${rank}$_${k1}$), ${k1}$)& - , 'mean(d${rank}$_${k1}$): uncorrect answer'& - , thr = ${k1}$tol) + call check(error, abs(mean(d${rank}$_${k1}$) - & + sum(d${rank}$_${k1}$)/real(size(d${rank}$_${k1}$), ${k1}$)) & + < ${k1}$tol & + , 'mean(d${rank}$_${k1}$): uncorrect answer') if (allocated(error)) return #:endfor end subroutine @@ -236,10 +237,11 @@ contains type(error_type), allocatable, intent(out) :: error #:for rank in range(1, NRANK+1) - call check(error, mean(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0)& - , sum(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0)/real(count(d${rank}$_${k1}$ > 0), ${k1}$)& + call check(error, abs( mean(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0) & + - sum(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0)/real(count(d${rank}$_${k1}$ > 0), ${k1}$))& + < ${k1}$tol & , 'mean(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0): uncorrect answer'& - , thr = ${k1}$tol) + ) if (allocated(error)) return #:endfor end subroutine @@ -274,9 +276,11 @@ contains type(error_type), allocatable, intent(out) :: error #:for rank in range(1, NRANK+1) - call check(error, mean(d${rank}$_c${k1}$), sum(d${rank}$_c${k1}$)/real(size(d${rank}$_c${k1}$), ${k1}$)& + call check(error, abs( mean(d${rank}$_c${k1}$) - & + sum(d${rank}$_c${k1}$)/real(size(d${rank}$_c${k1}$), ${k1}$) )& + < ${k1}$tol & , 'mean(d${rank}$_c${k1}$): uncorrect answer'& - , thr = ${k1}$tol) + ) if (allocated(error)) return #:endfor end subroutine @@ -337,10 +341,11 @@ contains type(error_type), allocatable, intent(out) :: error #:for rank in range(1, NRANK+1) - call check(error, mean(d${rank}$_c${k1}$, d${rank}$_c${k1}$%re > 0)& - , sum(d${rank}$_c${k1}$, d${rank}$_c${k1}$%re > 0)/real(count(d${rank}$_c${k1}$%re > 0), ${k1}$)& + call check(error, abs(mean(d${rank}$_c${k1}$, d${rank}$_c${k1}$%re > 0) - & + sum(d${rank}$_c${k1}$, d${rank}$_c${k1}$%re > 0)/real(count(d${rank}$_c${k1}$%re > 0), ${k1}$))& + < ${k1}$tol & , 'mean(d${rank}$_c${k1}$, d${rank}$_c${k1}$%re > 0): uncorrect answer'& - , thr = ${k1}$tol) + ) if (allocated(error)) return #:endfor end subroutine diff --git a/test/stats/test_median.fypp b/test/stats/test_median.fypp index 22d19785d..7cf0ef474 100644 --- a/test/stats/test_median.fypp +++ b/test/stats/test_median.fypp @@ -330,9 +330,9 @@ contains if (allocated(error)) return #:for rank in range(1, NRANK + 1) - call check(error, median(d${rank}$_${k1}$), 1.5_${k1}$& + call check(error, abs( median(d${rank}$_${k1}$) - 1.5_${k1}$)<${k1}$tol& , 'median(d${rank}$_${k1}$): uncorrect answer'& - , thr = ${k1}$tol) + ) if (allocated(error)) return #:endfor end subroutine @@ -341,19 +341,19 @@ contains !> Error handling type(error_type), allocatable, intent(out) :: error - call check(error, median(d1odd_${k1}$), 2._${k1}$& + call check(error, abs(median(d1odd_${k1}$) - 2._${k1}$)<${k1}$tol& , 'median(d1odd_${k1}$): uncorrect answer'& - , thr = ${k1}$tol) + ) if (allocated(error)) return - call check(error, median(d2odd_${k1}$), 1._${k1}$& + call check(error, abs(median(d2odd_${k1}$)-1._${k1}$)<${k1}$tol& , 'median(d2odd_${k1}$): uncorrect answer'& - , thr = ${k1}$tol) + ) if (allocated(error)) return - call check(error, median(d2odd_${k1}$), 1._${k1}$& + call check(error, abs(median(d2odd_${k1}$)-1._${k1}$)<${k1}$tol& , 'median(d2odd_${k1}$): uncorrect answer'& - , thr = ${k1}$tol) + ) if (allocated(error)) return end subroutine From 61ca3efc2527811d9e297ef79ba8a51f52700dd9 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 18 May 2024 09:57:59 +0200 Subject: [PATCH 02/10] lost sign --- test/math/test_stdlib_math.fypp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/math/test_stdlib_math.fypp b/test/math/test_stdlib_math.fypp index e686ce912..1c50e4284 100644 --- a/test/math/test_stdlib_math.fypp +++ b/test/math/test_stdlib_math.fypp @@ -232,7 +232,7 @@ contains ! invalid test case call check(error, clip(3.025_qp, 3.025_qp, -5.77_qp) == 3.025_qp) if (allocated(error)) return - call check(error, clip(-55891546.2_qp, -689712245.23_qp, -8958133457.23_qp) == 689712245.23_qp) + call check(error, clip(-55891546.2_qp, -689712245.23_qp, -8958133457.23_qp) == -689712245.23_qp) if (allocated(error)) return #:else call skip_test(error, "Quadruple precision is not enabled") From 575cccd1ccebc1cca08feb62d0ea88ca3603bfc1 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 18 May 2024 17:38:57 +0200 Subject: [PATCH 03/10] change name of local fypp macro real kinds list --- src/stdlib_specialfunctions_gamma.fypp | 64 +++++++++---------- .../test_specialfunctions_gamma.fypp | 12 ++-- 2 files changed, 38 insertions(+), 38 deletions(-) diff --git a/src/stdlib_specialfunctions_gamma.fypp b/src/stdlib_specialfunctions_gamma.fypp index e208ccad3..724261f3b 100644 --- a/src/stdlib_specialfunctions_gamma.fypp +++ b/src/stdlib_specialfunctions_gamma.fypp @@ -1,5 +1,5 @@ #:include "common.fypp" -#:set RC_KINDS_TYPES = REAL_KINDS_TYPES[0:2] +#:set R_KINDS_TYPES = REAL_KINDS_TYPES[0:2] #:set CI_KINDS_TYPES = INT_KINDS_TYPES + CMPLX_KINDS_TYPES[0:2] module stdlib_specialfunctions_gamma use iso_fortran_env, only : qp => real128 @@ -14,7 +14,7 @@ module stdlib_specialfunctions_gamma integer(int32), parameter :: max_fact_int32 = 13_int32 integer(int64), parameter :: max_fact_int64 = 21_int64 - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES ${t1}$, parameter :: tol_${k1}$ = epsilon(1.0_${k1}$) #:endfor real(qp), parameter :: tol_qp = epsilon(1.0_qp) @@ -62,12 +62,12 @@ module stdlib_specialfunctions_gamma !! Lower incomplete gamma function !! #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES module procedure ingamma_low_${t1[0]}$${k1}$${k2}$ #:endfor #:endfor - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES module procedure ingamma_low_${t1[0]}$${k1}$ #:endfor end interface lower_incomplete_gamma @@ -78,12 +78,12 @@ module stdlib_specialfunctions_gamma !! Logarithm of lower incomplete gamma function !! #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES module procedure l_ingamma_low_${t1[0]}$${k1}$${k2}$ #:endfor #:endfor - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES module procedure l_ingamma_low_${t1[0]}$${k1}$ #:endfor end interface log_lower_incomplete_gamma @@ -94,12 +94,12 @@ module stdlib_specialfunctions_gamma !! Upper incomplete gamma function !! #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES module procedure ingamma_up_${t1[0]}$${k1}$${k2}$ #:endfor #:endfor - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES module procedure ingamma_up_${t1[0]}$${k1}$ #:endfor end interface upper_incomplete_gamma @@ -110,12 +110,12 @@ module stdlib_specialfunctions_gamma !! Logarithm of upper incomplete gamma function !! #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES module procedure l_ingamma_up_${t1[0]}$${k1}$${k2}$ #:endfor #:endfor - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES module procedure l_ingamma_up_${t1[0]}$${k1}$ #:endfor end interface log_upper_incomplete_gamma @@ -126,12 +126,12 @@ module stdlib_specialfunctions_gamma !! Regularized (normalized) lower incomplete gamma function, P !! #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES module procedure regamma_p_${t1[0]}$${k1}$${k2}$ #:endfor #:endfor - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES module procedure regamma_p_${t1[0]}$${k1}$ #:endfor end interface regularized_gamma_p @@ -142,12 +142,12 @@ module stdlib_specialfunctions_gamma !! Regularized (normalized) upper incomplete gamma function, Q !! #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES module procedure regamma_q_${t1[0]}$${k1}$${k2}$ #:endfor #:endfor - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES module procedure regamma_q_${t1[0]}$${k1}$ #:endfor end interface regularized_gamma_q @@ -158,12 +158,12 @@ module stdlib_specialfunctions_gamma ! Incomplete gamma G function. ! Internal use only ! - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES module procedure gpx_${t1[0]}$${k1}$ !for real p and x #:endfor #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES module procedure gpx_${t1[0]}$${k1}$${k2}$ !for integer p and real x #:endfor #:endfor @@ -176,7 +176,7 @@ module stdlib_specialfunctions_gamma ! Internal use only ! #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES module procedure l_gamma_${t1[0]}$${k1}$${k2}$ #:endfor #:endfor @@ -372,7 +372,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES impure elemental function l_gamma_${t1[0]}$${k1}$${k2}$(z, x) result(res) ! @@ -555,7 +555,7 @@ contains - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES #:if k1 == "sp" #:set k2 = "dp" #:elif k1 == "dp" @@ -701,7 +701,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES impure elemental function gpx_${t1[0]}$${k1}$${k2}$(p, x) result(res) ! ! Approximation of incomplete gamma G function with integer argument p. @@ -840,7 +840,7 @@ contains - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES impure elemental function ingamma_low_${t1[0]}$${k1}$(p, x) result(res) ! ! Approximation of lower incomplete gamma function with real p. @@ -877,7 +877,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES impure elemental function ingamma_low_${t1[0]}$${k1}$${k2}$(p, x) & result(res) ! @@ -917,7 +917,7 @@ contains - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES impure elemental function l_ingamma_low_${t1[0]}$${k1}$(p, x) result(res) ${t1}$, intent(in) :: p, x @@ -954,7 +954,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES impure elemental function l_ingamma_low_${t1[0]}$${k1}$${k2}$(p, x) & result(res) @@ -986,7 +986,7 @@ contains - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES impure elemental function ingamma_up_${t1[0]}$${k1}$(p, x) result(res) ! ! Approximation of upper incomplete gamma function with real p. @@ -1024,7 +1024,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES impure elemental function ingamma_up_${t1[0]}$${k1}$${k2}$(p, x) & result(res) ! @@ -1066,7 +1066,7 @@ contains - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES impure elemental function l_ingamma_up_${t1[0]}$${k1}$(p, x) result(res) ${t1}$, intent(in) :: p, x @@ -1104,7 +1104,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES impure elemental function l_ingamma_up_${t1[0]}$${k1}$${k2}$(p, x) & result(res) @@ -1145,7 +1145,7 @@ contains - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES impure elemental function regamma_p_${t1[0]}$${k1}$(p, x) result(res) ! ! Approximation of regularized incomplete gamma function P(p,x) for real p @@ -1180,7 +1180,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES impure elemental function regamma_p_${t1[0]}$${k1}$${k2}$(p, x) result(res) ! ! Approximation of regularized incomplete gamma function P(p,x) for integer p @@ -1216,7 +1216,7 @@ contains - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES impure elemental function regamma_q_${t1[0]}$${k1}$(p, x) result(res) ! ! Approximation of regularized incomplete gamma function Q(p,x) for real p @@ -1251,7 +1251,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES impure elemental function regamma_q_${t1[0]}$${k1}$${k2}$(p, x) result(res) ! ! Approximation of regularized incomplet gamma function Q(p,x) for integer p diff --git a/test/specialfunctions/test_specialfunctions_gamma.fypp b/test/specialfunctions/test_specialfunctions_gamma.fypp index e0fc12fba..47988eedc 100644 --- a/test/specialfunctions/test_specialfunctions_gamma.fypp +++ b/test/specialfunctions/test_specialfunctions_gamma.fypp @@ -1,5 +1,5 @@ #:include "common.fypp" -#:set RC_KINDS_TYPES = REAL_KINDS_TYPES[0:2] +#:set R_KINDS_TYPES = REAL_KINDS_TYPES[0:2] #:set CI_KINDS_TYPES = INT_KINDS_TYPES + CMPLX_KINDS_TYPES[0:2] module test_specialfunctions_gamma use testdrive, only : new_unittest, unittest_type, error_type, check @@ -17,7 +17,7 @@ module test_specialfunctions_gamma public :: collect_specialfunctions_gamma - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES ${t1}$, parameter :: tol_${k1}$ = 1000 * epsilon(1.0_${k1}$) #:endfor @@ -45,7 +45,7 @@ contains #:endfor #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES , new_unittest("lower_incomplete_gamma_${t1[0]}$${k1}$${k2}$", & test_lincgamma_${t1[0]}$${k1}$${k2}$) & , new_unittest("log_lower_incomplete_gamma_${t1[0]}$${k1}$${k2}$", & @@ -61,7 +61,7 @@ contains #:endfor #:endfor - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES , new_unittest("lower_incomplete_gamma_${t1[0]}$${k1}$", & test_lincgamma_${t1[0]}$${k1}$) & , new_unittest("log_lower_incomplete_gamma_${t1[0]}$${k1}$", & @@ -267,7 +267,7 @@ contains #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in RC_KINDS_TYPES + #:for k2, t2 in R_KINDS_TYPES subroutine test_lincgamma_${t1[0]}$${k1}$${k2}$(error) type(error_type), allocatable, intent(out) :: error @@ -416,7 +416,7 @@ contains - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in R_KINDS_TYPES subroutine test_lincgamma_${t1[0]}$${k1}$(error) type(error_type), allocatable, intent(out) :: error From 7c90998012cda3aab2b2224b8de921b492ac57b2 Mon Sep 17 00:00:00 2001 From: jalvesz Date: Sat, 18 May 2024 17:52:44 +0200 Subject: [PATCH 04/10] extract desired kinds for local limited preprocessing --- src/stdlib_specialfunctions_gamma.fypp | 5 +++-- test/specialfunctions/test_specialfunctions_gamma.fypp | 8 +++----- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/src/stdlib_specialfunctions_gamma.fypp b/src/stdlib_specialfunctions_gamma.fypp index 724261f3b..6f49360f1 100644 --- a/src/stdlib_specialfunctions_gamma.fypp +++ b/src/stdlib_specialfunctions_gamma.fypp @@ -1,6 +1,7 @@ #:include "common.fypp" -#:set R_KINDS_TYPES = REAL_KINDS_TYPES[0:2] -#:set CI_KINDS_TYPES = INT_KINDS_TYPES + CMPLX_KINDS_TYPES[0:2] +#:set R_KINDS_TYPES = [KT for KT in REAL_KINDS_TYPES if KT[0] in ["sp","dp"]] +#:set C_KINDS_TYPES = [KT for KT in CMPLX_KINDS_TYPES if KT[0] in ["sp","dp"]] +#:set CI_KINDS_TYPES = INT_KINDS_TYPES + C_KINDS_TYPES module stdlib_specialfunctions_gamma use iso_fortran_env, only : qp => real128 use stdlib_kinds, only : sp, dp, int8, int16, int32, int64 diff --git a/test/specialfunctions/test_specialfunctions_gamma.fypp b/test/specialfunctions/test_specialfunctions_gamma.fypp index 47988eedc..62ee4c1f9 100644 --- a/test/specialfunctions/test_specialfunctions_gamma.fypp +++ b/test/specialfunctions/test_specialfunctions_gamma.fypp @@ -1,6 +1,7 @@ #:include "common.fypp" -#:set R_KINDS_TYPES = REAL_KINDS_TYPES[0:2] -#:set CI_KINDS_TYPES = INT_KINDS_TYPES + CMPLX_KINDS_TYPES[0:2] +#:set R_KINDS_TYPES = [KT for KT in REAL_KINDS_TYPES if KT[0] in ["sp","dp"]] +#:set C_KINDS_TYPES = [KT for KT in CMPLX_KINDS_TYPES if KT[0] in ["sp","dp"]] +#:set CI_KINDS_TYPES = INT_KINDS_TYPES + C_KINDS_TYPES module test_specialfunctions_gamma use testdrive, only : new_unittest, unittest_type, error_type, check use stdlib_kinds, only: sp, dp, int8, int16, int32, int64 @@ -21,9 +22,6 @@ module test_specialfunctions_gamma ${t1}$, parameter :: tol_${k1}$ = 1000 * epsilon(1.0_${k1}$) #:endfor - - - contains subroutine collect_specialfunctions_gamma(testsuite) From 4999f9a2e838eb8abb897bfdb52d16b5d3fa544a Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Sat, 1 Jun 2024 17:21:39 +0200 Subject: [PATCH 05/10] Update src/stdlib_specialfunctions_gamma.fypp Co-authored-by: Jeremie Vandenplas --- src/stdlib_specialfunctions_gamma.fypp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/stdlib_specialfunctions_gamma.fypp b/src/stdlib_specialfunctions_gamma.fypp index 6f49360f1..3fb8147d0 100644 --- a/src/stdlib_specialfunctions_gamma.fypp +++ b/src/stdlib_specialfunctions_gamma.fypp @@ -218,7 +218,7 @@ contains - #:for k1, t1 in CMPLX_KINDS_TYPES[0:2] + #:for k1, t1 in C_KINDS_TYPES #:if k1 == "sp" #:set k2 = "dp" #:elif k1 == "dp" From f64357a1ba3ecf7bf1b45eb9667a07c21d49f95c Mon Sep 17 00:00:00 2001 From: jalvesz <102541118+jalvesz@users.noreply.github.com> Date: Sat, 1 Jun 2024 17:21:54 +0200 Subject: [PATCH 06/10] Update src/stdlib_specialfunctions_gamma.fypp Co-authored-by: Jeremie Vandenplas --- src/stdlib_specialfunctions_gamma.fypp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/stdlib_specialfunctions_gamma.fypp b/src/stdlib_specialfunctions_gamma.fypp index 3fb8147d0..e91f14954 100644 --- a/src/stdlib_specialfunctions_gamma.fypp +++ b/src/stdlib_specialfunctions_gamma.fypp @@ -414,7 +414,7 @@ contains - #:for k1, t1 in CMPLX_KINDS_TYPES[0:2] + #:for k1, t1 in C_KINDS_TYPES #:if k1 == "sp" #:set k2 = "dp" #:elif k1 == "dp" From 2078cbb2738f7c5afc6c13d0b7ea00cf5bb87c6e Mon Sep 17 00:00:00 2001 From: Jose Alves Date: Mon, 3 Jun 2024 00:48:38 +0200 Subject: [PATCH 07/10] test passing xdp and qp c-preprocessing flags with fpm --- .github/workflows/fpm-deployment.yml | 2 +- test/math/test_meshgrid.fypp | 2 +- test/math/test_stdlib_math.fypp | 12 ++++++------ 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/.github/workflows/fpm-deployment.yml b/.github/workflows/fpm-deployment.yml index 9c4314e35..19cf58d8b 100644 --- a/.github/workflows/fpm-deployment.yml +++ b/.github/workflows/fpm-deployment.yml @@ -40,7 +40,7 @@ jobs: - run: | # Use fpm gnu ci to check xdp and qp python config/fypp_deployment.py --with_xdp --with_qp - fpm test --profile release + fpm test --profile release --flag '-DWITH_XDP -DWITH_QP' # Update and deploy the f90 files generated by github-ci to the `stdlib-fpm` branch. - name: Deploy 🚀 diff --git a/test/math/test_meshgrid.fypp b/test/math/test_meshgrid.fypp index fea181185..b61b956b7 100644 --- a/test/math/test_meshgrid.fypp +++ b/test/math/test_meshgrid.fypp @@ -79,7 +79,7 @@ contains ${"".join(f"xm{j}," for j in range(1, rank + 1)).removesuffix(",")}$ & ${OPTIONAL_PART_IN_SIGNATURE(INDEXING)}$ ) #:for j in range(1, rank + 1) - call check(error, maxval(abs(xm${j}$ - xm${j}$_exact)) == ZERO) + call check(error, maxval(abs(xm${j}$ - xm${j}$_exact)), ZERO) if (allocated(error)) return #:endfor end subroutine test_${RName}$ diff --git a/test/math/test_stdlib_math.fypp b/test/math/test_stdlib_math.fypp index 1c50e4284..9b02f5fbe 100644 --- a/test/math/test_stdlib_math.fypp +++ b/test/math/test_stdlib_math.fypp @@ -170,9 +170,9 @@ contains type(error_type), allocatable, intent(out) :: error ! type: real(sp), kind: sp ! valid test case - call check(error, clip(3.025_sp, -5.77_sp, 3.025_sp) == 3.025_sp) + call check(error, clip(3.025_sp, -5.77_sp, 3.025_sp), 3.025_sp) if (allocated(error)) return - call check(error, clip(0.0_sp, -1578.025_sp, -59.68_sp) == -59.68_sp) + call check(error, clip(0.0_sp, -1578.025_sp, -59.68_sp), -59.68_sp) if (allocated(error)) return end subroutine test_clip_rsp @@ -215,9 +215,9 @@ contains #:if WITH_QP ! type: real(qp), kind: qp ! valid test case - call check(error, clip(3.025_qp, -5.77_qp, 3.025_qp) == 3.025_qp) + call check(error, clip(3.025_qp, -5.77_qp, 3.025_qp), 3.025_qp) if (allocated(error)) return - call check(error, clip(-55891546.2_qp, -8958133457.23_qp, -689712245.23_qp) == -689712245.23_qp) + call check(error, clip(-55891546.2_qp, -8958133457.23_qp, -689712245.23_qp), -689712245.23_qp) if (allocated(error)) return #:else call skip_test(error, "Quadruple precision is not enabled") @@ -230,9 +230,9 @@ contains type(error_type), allocatable, intent(out) :: error #:if WITH_QP ! invalid test case - call check(error, clip(3.025_qp, 3.025_qp, -5.77_qp) == 3.025_qp) + call check(error, clip(3.025_qp, 3.025_qp, -5.77_qp), 3.025_qp) if (allocated(error)) return - call check(error, clip(-55891546.2_qp, -689712245.23_qp, -8958133457.23_qp) == -689712245.23_qp) + call check(error, clip(-55891546.2_qp, -689712245.23_qp, -8958133457.23_qp), -689712245.23_qp) if (allocated(error)) return #:else call skip_test(error, "Quadruple precision is not enabled") From efc86d81c6bbe508be00447787bd85ea17218f8c Mon Sep 17 00:00:00 2001 From: Jose Alves Date: Mon, 3 Jun 2024 09:36:39 +0200 Subject: [PATCH 08/10] revert tests changes --- test/stats/test_mean.fypp | 27 +++++++++++---------------- test/stats/test_median.fypp | 16 ++++++++-------- 2 files changed, 19 insertions(+), 24 deletions(-) diff --git a/test/stats/test_mean.fypp b/test/stats/test_mean.fypp index 7512f0081..ffa40bb05 100644 --- a/test/stats/test_mean.fypp +++ b/test/stats/test_mean.fypp @@ -173,10 +173,9 @@ contains type(error_type), allocatable, intent(out) :: error #:for rank in range(1, NRANK+1) - call check(error, abs(mean(d${rank}$_${k1}$) - & - sum(d${rank}$_${k1}$)/real(size(d${rank}$_${k1}$), ${k1}$)) & - < ${k1}$tol & - , 'mean(d${rank}$_${k1}$): uncorrect answer') + call check(error, mean(d${rank}$_${k1}$), sum(d${rank}$_${k1}$)/real(size(d${rank}$_${k1}$), ${k1}$)& + , 'mean(d${rank}$_${k1}$): uncorrect answer'& + , thr = ${k1}$tol) if (allocated(error)) return #:endfor end subroutine @@ -237,11 +236,10 @@ contains type(error_type), allocatable, intent(out) :: error #:for rank in range(1, NRANK+1) - call check(error, abs( mean(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0) & - - sum(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0)/real(count(d${rank}$_${k1}$ > 0), ${k1}$))& - < ${k1}$tol & + call check(error, mean(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0)& + , sum(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0)/real(count(d${rank}$_${k1}$ > 0), ${k1}$)& , 'mean(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0): uncorrect answer'& - ) + , thr = ${k1}$tol) if (allocated(error)) return #:endfor end subroutine @@ -276,11 +274,9 @@ contains type(error_type), allocatable, intent(out) :: error #:for rank in range(1, NRANK+1) - call check(error, abs( mean(d${rank}$_c${k1}$) - & - sum(d${rank}$_c${k1}$)/real(size(d${rank}$_c${k1}$), ${k1}$) )& - < ${k1}$tol & + call check(error, mean(d${rank}$_c${k1}$), sum(d${rank}$_c${k1}$)/real(size(d${rank}$_c${k1}$), ${k1}$)& , 'mean(d${rank}$_c${k1}$): uncorrect answer'& - ) + , thr = ${k1}$tol) if (allocated(error)) return #:endfor end subroutine @@ -341,11 +337,10 @@ contains type(error_type), allocatable, intent(out) :: error #:for rank in range(1, NRANK+1) - call check(error, abs(mean(d${rank}$_c${k1}$, d${rank}$_c${k1}$%re > 0) - & - sum(d${rank}$_c${k1}$, d${rank}$_c${k1}$%re > 0)/real(count(d${rank}$_c${k1}$%re > 0), ${k1}$))& - < ${k1}$tol & + call check(error, mean(d${rank}$_c${k1}$, d${rank}$_c${k1}$%re > 0)& + , sum(d${rank}$_c${k1}$, d${rank}$_c${k1}$%re > 0)/real(count(d${rank}$_c${k1}$%re > 0), ${k1}$)& , 'mean(d${rank}$_c${k1}$, d${rank}$_c${k1}$%re > 0): uncorrect answer'& - ) + , thr = ${k1}$tol) if (allocated(error)) return #:endfor end subroutine diff --git a/test/stats/test_median.fypp b/test/stats/test_median.fypp index 7cf0ef474..22d19785d 100644 --- a/test/stats/test_median.fypp +++ b/test/stats/test_median.fypp @@ -330,9 +330,9 @@ contains if (allocated(error)) return #:for rank in range(1, NRANK + 1) - call check(error, abs( median(d${rank}$_${k1}$) - 1.5_${k1}$)<${k1}$tol& + call check(error, median(d${rank}$_${k1}$), 1.5_${k1}$& , 'median(d${rank}$_${k1}$): uncorrect answer'& - ) + , thr = ${k1}$tol) if (allocated(error)) return #:endfor end subroutine @@ -341,19 +341,19 @@ contains !> Error handling type(error_type), allocatable, intent(out) :: error - call check(error, abs(median(d1odd_${k1}$) - 2._${k1}$)<${k1}$tol& + call check(error, median(d1odd_${k1}$), 2._${k1}$& , 'median(d1odd_${k1}$): uncorrect answer'& - ) + , thr = ${k1}$tol) if (allocated(error)) return - call check(error, abs(median(d2odd_${k1}$)-1._${k1}$)<${k1}$tol& + call check(error, median(d2odd_${k1}$), 1._${k1}$& , 'median(d2odd_${k1}$): uncorrect answer'& - ) + , thr = ${k1}$tol) if (allocated(error)) return - call check(error, abs(median(d2odd_${k1}$)-1._${k1}$)<${k1}$tol& + call check(error, median(d2odd_${k1}$), 1._${k1}$& , 'median(d2odd_${k1}$): uncorrect answer'& - ) + , thr = ${k1}$tol) if (allocated(error)) return end subroutine From 23934fce5201b56cc42f7ea77a15ce508cd403be Mon Sep 17 00:00:00 2001 From: Jose Alves Date: Mon, 3 Jun 2024 09:52:58 +0200 Subject: [PATCH 09/10] revert use of check --- test/quadrature/test_simps.fypp | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/test/quadrature/test_simps.fypp b/test/quadrature/test_simps.fypp index 411d5f55a..bf845b87a 100644 --- a/test/quadrature/test_simps.fypp +++ b/test/quadrature/test_simps.fypp @@ -58,18 +58,18 @@ contains val = simps(y, 1.0_${k1}$) ans = 576.0_${k1}$ - call check(error, abs(val - ans) < tol_${k1}$) + call check(error, val, ans, thr=tol_${k1}$) if (allocated(error)) return val = simps(y, 0.5_${k1}$) ans = 288.0_${k1}$ - call check(error, abs(val - ans) < tol_${k1}$) + call check(error, val, ans, thr=tol_${k1}$) if (allocated(error)) return x = [(0.25_${k1}$*(i-1), i = 1, n)] val = simps(y, x) ans = 144.0_${k1}$ - call check(error, abs(val - ans) < tol_${k1}$) + call check(error, val, ans, thr=tol_${k1}$) end subroutine test_simps_${k1}$ subroutine test_simps_weights_${k1}$(error) @@ -91,7 +91,7 @@ contains w = simps_weights(x) val = sum(w*y) ans = simps(y, x) - call check(error, abs(val - ans) < tol_${k1}$) + call check(error, val, ans, thr=tol_${k1}$) end subroutine test_simps_weights_${k1}$ subroutine test_simps_zero_${k1}$(error) @@ -129,18 +129,18 @@ contains val = simps(y, 1.0_${k1}$) ans = 1000.0_${k1}$ - call check(error, abs(val - ans) < tol_${k1}$) + call check(error, val, ans, thr=tol_${k1}$) if (allocated(error)) return val = simps(y, 0.5_${k1}$) ans = 500.0_${k1}$ - call check(error, abs(val - ans) < tol_${k1}$) + call check(error, val, ans, thr=tol_${k1}$) if (allocated(error)) return x = [(0.25_${k1}$*(i-1), i = 1, n)] val = simps(y, x) ans = 250.0_${k1}$ - call check(error, abs(val - ans) < tol_${k1}$) + call check(error, val, ans, thr=tol_${k1}$) if (allocated(error)) return end do end subroutine test_simps_even_${k1}$ @@ -166,7 +166,7 @@ contains w = simps_weights(x) val = sum(w*y) ans = simps(y, x) - call check(error, abs(val - ans) < tol_${k1}$) + call check(error, val, ans, thr=tol_${k1}$) if (allocated(error)) return end do end subroutine test_simps_weights_even_${k1}$ @@ -190,18 +190,18 @@ contains val = simps(y, 1.0_${k1}$) ans = 125.0_${k1}$ - call check(error, abs(val - ans) < tol_${k1}$) + call check(error, val, ans, thr=tol_${k1}$) if (allocated(error)) return val = simps(y, 0.5_${k1}$) ans = 62.5_${k1}$ - call check(error, abs(val - ans) < tol_${k1}$) + call check(error, val, ans, thr=tol_${k1}$) if (allocated(error)) return x = [(0.25_${k1}$*(i-1), i = 1, n)] val = simps(y, x) ans = 31.25_${k1}$ - call check(error, abs(val - ans) < tol_${k1}$) + call check(error, val, ans, thr=tol_${k1}$) if (allocated(error)) return end do end subroutine test_simps_six_${k1}$ From 1e9b47033f5b4ec519783f457f6c186cfd7a84d8 Mon Sep 17 00:00:00 2001 From: Jose Alves Date: Mon, 10 Jun 2024 09:01:26 +0200 Subject: [PATCH 10/10] set the first test in the table with the 0th index of real_kinds --- test/quadrature/test_simps.fypp | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test/quadrature/test_simps.fypp b/test/quadrature/test_simps.fypp index bf845b87a..cb6272612 100644 --- a/test/quadrature/test_simps.fypp +++ b/test/quadrature/test_simps.fypp @@ -19,7 +19,9 @@ contains type(unittest_type), allocatable, intent(out) :: testsuite(:) testsuite = [ & - new_unittest("simps_sp", test_simps_sp) & + #:for k1, t1 in REAL_KINDS_TYPES[0:1] # set the first test independently to initialize the table + new_unittest("simps_${k1}$", test_simps_sp) & + #:endfor #:for k1, t1 in REAL_KINDS_TYPES[1:] , new_unittest("simps_${k1}$", test_simps_${k1}$) & #:endfor