From f08ef22a16eafe7823415b00779fd36554935aff Mon Sep 17 00:00:00 2001 From: zoziha Date: Mon, 20 Jun 2022 08:43:53 +0800 Subject: [PATCH] Add array checking support for `check` --- src/testdrive.F90 | 238 ++++++ test/CMakeLists.txt | 1 + test/main.f90 | 2 + test/meson.build | 1 + test/test_check_array.F90 | 1481 +++++++++++++++++++++++++++++++++++++ 5 files changed, 1723 insertions(+) create mode 100644 test/test_check_array.F90 diff --git a/src/testdrive.F90 b/src/testdrive.F90 index 0ac587e..e55a522 100644 --- a/src/testdrive.F90 +++ b/src/testdrive.F90 @@ -212,6 +212,8 @@ module testdrive module procedure :: check_int_i8 module procedure :: check_bool module procedure :: check_string + module procedure :: check_single_array + module procedure :: check_double_array end interface check @@ -1969,4 +1971,240 @@ end function is_nan_qp #endif + subroutine error_wrap(error, more) + !> Error handling + type(error_type), intent(inout) :: error + !> Error message + character(len=*), intent(in) :: more + + character(len=*), parameter :: skip = new_line("a") // repeat(" ", 11) + + error%message = error%message // skip // more + + end subroutine error_wrap + + + subroutine check_single_array(error, array, message, more) + + !> Error handing + type(error_type), allocatable, intent(out) :: error + + !> The array to be checked + class(*), intent(in), target :: array(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + integer :: i + class(*), pointer :: item(:) ! @note gfortran <=10 does not support syntax: associate(item => array(i)) + + item => array + do i = 1, size(array) + select type (item) + type is (integer) + call check(error, item(i), message, more) + type is (logical) + call check(error, item(i), message, more) + type is (real(sp)) + call check(error, item(i), message, more) + type is (real(dp)) + call check(error, item(i), message, more) + type is (complex(sp)) + call check(error, item(i), message, more) + type is (complex(dp)) + call check(error, item(i), message, more) +#if WITH_XDP + type is (real(xdp)) + call check(error, item(i), message, more) + type is (complex(xdp)) + call check(error, item(i), message, more) +#endif +#if WITH_QP + type is (real(qp)) + call check(error, item(i), message, more) + type is (complex(qp)) + call check(error, item(i), message, more) +#endif + end select + if (allocated(error)) then + call error_wrap(error, "Array check failed at element index "//trim(ch(i))) + return + end if + end do + + end subroutine check_single_array + + + subroutine check_double_array(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found values + class(*), intent(in), target :: actual(:) + + !> Expected values + class(*), intent(in), target :: expected(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + class(*), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + integer :: i + class(*), pointer :: item1(:), item2(:) + + item1 => actual + item2 => expected + do i = 1, size(expected) + select type (item1) + type is (integer(i1)) + select type (item2) + type is (integer(i1)) + call check(error, item1(i), item2(i), message, more) + end select + type is (integer(i2)) + select type (item2) + type is (integer(i2)) + call check(error, item1(i), item2(i), message, more) + end select + type is (integer(i4)) + select type (item2) + type is (integer(i4)) + call check(error, item1(i), item2(i), message, more) + end select + type is (integer(i8)) + select type (item2) + type is (integer(i8)) + call check(error, item1(i), item2(i), message, more) + end select + type is (logical) + select type (item2) + type is (logical) + call check(error, item1(i), item2(i), message, more) + end select + type is (character(*)) + select type (item2) + type is (character(*)) + call check(error, item1(i), item2(i), message, more) + end select + type is (real(sp)) + select type (item2) + type is (real(sp)) + if (present(thr)) then + select type (thr) + type is (real(sp)) + call check(error, item1(i), item2(i), message, more, thr, rel) + end select + else + call check(error, item1(i), item2(i), message, more, rel=rel) + end if + end select + type is (real(dp)) + select type (item2) + type is (real(dp)) + if (present(thr)) then + select type (thr) + type is (real(dp)) + call check(error, item1(i), item2(i), message, more, thr, rel) + end select + else + call check(error, item1(i), item2(i), message, more, rel=rel) + end if + end select + type is (complex(sp)) + select type (item2) + type is (complex(sp)) + if (present(thr)) then + select type (thr) + type is (real(sp)) + call check(error, item1(i), item2(i), message, more, thr, rel) + end select + else + call check(error, item1(i), item2(i), message, more, rel=rel) + end if + end select + type is (complex(dp)) + select type (item2) + type is (complex(dp)) + if (present(thr)) then + select type (thr) + type is (real(dp)) + call check(error, item1(i), item2(i), message, more, thr, rel) + end select + else + call check(error, item1(i), item2(i), message, more, rel=rel) + end if + end select +#if WITH_XDP + type is (real(xdp)) + select type (item2) + type is (real(xdp)) + if (present(thr)) then + select type (thr) + type is (real(xdp)) + call check(error, item1(i), item2(i), message, more, thr, rel) + end select + else + call check(error, item1(i), item2(i), message, more, rel=rel) + end if + end select + type is (complex(xdp)) + select type (item2) + type is (complex(xdp)) + if (present(thr)) then + select type (thr) + type is (real(xdp)) + call check(error, item1(i), item2(i), message, more, thr, rel) + end select + else + call check(error, item1(i), item2(i), message, more, rel=rel) + end if + end select +#endif +#if WITH_QP + type is (real(qp)) + select type (item2) + type is (real(qp)) + if (present(thr)) then + select type (thr) + type is (real(qp)) + call check(error, item1(i), item2(i), message, more, thr, rel) + end select + else + call check(error, item1(i), item2(i), message, more, rel=rel) + end if + end select + type is (complex(qp)) + select type (item2) + type is (complex(qp)) + if (present(thr)) then + select type (thr) + type is (real(qp)) + call check(error, item1(i), item2(i), message, more, thr, rel) + end select + else + call check(error, item1(i), item2(i), message, more, rel=rel) + end if + end select +#endif + end select + if (allocated(error)) then + call error_wrap(error, "Array check failed at element index "//trim(ch(i))) + return + end if + end do + + end subroutine check_double_array + end module testdrive diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 0c98279..7acafe1 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -15,6 +15,7 @@ set( tests "check" + "check_array" "select" ) set( diff --git a/test/main.f90 b/test/main.f90 index a155118..b26f89f 100644 --- a/test/main.f90 +++ b/test/main.f90 @@ -17,6 +17,7 @@ program tester use testdrive, only : run_testsuite, new_testsuite, testsuite_type, & & select_suite, run_selected, get_argument use test_check, only : collect_check + use test_check_array, only: collect_check_array use test_select, only : collect_select implicit none integer :: stat, is @@ -28,6 +29,7 @@ program tester testsuites = [ & new_testsuite("check", collect_check), & + new_testsuite("check-array", collect_check_array), & new_testsuite("select", collect_select) & ] diff --git a/test/meson.build b/test/meson.build index ae2956b..0fdd3a2 100644 --- a/test/meson.build +++ b/test/meson.build @@ -13,6 +13,7 @@ tests = [ 'check', + 'check_array', 'select', ] diff --git a/test/test_check_array.F90 b/test/test_check_array.F90 new file mode 100644 index 0000000..654a47b --- /dev/null +++ b/test/test_check_array.F90 @@ -0,0 +1,1481 @@ +! This file is part of test-drive. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!# Enable support for quadruple precision +#ifndef WITH_QP +#define WITH_QP 0 +#endif + +!# Enable support for extended double precision +#ifndef WITH_XDP +#define WITH_XDP 0 +#endif + +module test_check_array + use, intrinsic :: ieee_arithmetic, only : ieee_value, ieee_quiet_nan + use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test + implicit none + private + + public :: collect_check_array + + + !> Single precision real numbers + integer, parameter :: sp = selected_real_kind(6) + + !> Double precision real numbers + integer, parameter :: dp = selected_real_kind(15) + +#if WITH_XDP + !> Extended double precision real numbers + integer, parameter :: xdp = selected_real_kind(18) +#endif + +#if WITH_QP + !> Quadruple precision real numbers + integer, parameter :: qp = selected_real_kind(33) +#endif + + !> Char length for integers + integer, parameter :: i1 = selected_int_kind(2) + + !> Short length for integers + integer, parameter :: i2 = selected_int_kind(4) + + !> Length of default integers + integer, parameter :: i4 = selected_int_kind(9) + + !> Long length for integers + integer, parameter :: i8 = selected_int_kind(18) + +contains + + + !> Collect all exported unit tests + subroutine collect_check_array(testsuite) + + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("success", test_success), & + new_unittest("failure", test_failure, should_fail=.true.), & + new_unittest("failure-message", test_failure_message, should_fail=.true.), & + new_unittest("failure-with-more", test_failure_with_more, should_fail=.true.), & + new_unittest("expression", test_expression), & + new_unittest("expression-fail", test_expression_fail, should_fail=.true.), & + new_unittest("expression-message", test_expression_message, should_fail=.true.), & + new_unittest("expression-with-more", test_expression_with_more, should_fail=.true.), & + new_unittest("real-single-abs", test_rsp_abs), & + new_unittest("real-single-rel", test_rsp_rel), & + new_unittest("real-single-nan", test_rsp_nan, should_fail=.true.), & + new_unittest("real-single-abs-fail", test_rsp_abs_fail, should_fail=.true.), & + new_unittest("real-single-rel-fail", test_rsp_rel_fail, should_fail=.true.), & + new_unittest("real-single-abs-message", test_rsp_abs_message, should_fail=.true.), & + new_unittest("real-single-nan-message", test_rsp_nan_message, should_fail=.true.), & + new_unittest("real-double-abs", test_rdp_abs), & + new_unittest("real-double-rel", test_rdp_rel), & + new_unittest("real-double-nan", test_rdp_nan, should_fail=.true.), & + new_unittest("real-double-abs-fail", test_rdp_abs_fail, should_fail=.true.), & + new_unittest("real-double-rel-fail", test_rdp_rel_fail, should_fail=.true.), & + new_unittest("real-double-abs-message", test_rdp_abs_message, should_fail=.true.), & + new_unittest("real-double-nan-message", test_rdp_nan_message, should_fail=.true.), & + new_unittest("real-xdouble-abs", test_rxdp_abs), & + new_unittest("real-xdouble-rel", test_rxdp_rel), & + new_unittest("real-xdouble-nan", test_rxdp_nan, should_fail=.true.), & + new_unittest("real-xdouble-abs-fail", test_rxdp_abs_fail, should_fail=.true.), & + new_unittest("real-xdouble-rel-fail", test_rxdp_rel_fail, should_fail=.true.), & + new_unittest("real-xdouble-abs-message", test_rxdp_abs_message, should_fail=.true.), & + new_unittest("real-xdouble-nan-message", test_rxdp_nan_message, should_fail=.true.), & + new_unittest("real-quadruple-abs", test_rqp_abs), & + new_unittest("real-quadruple-rel", test_rqp_rel), & + new_unittest("real-quadruple-nan", test_rqp_nan, should_fail=.true.), & + new_unittest("real-quadruple-abs-fail", test_rqp_abs_fail, should_fail=.true.), & + new_unittest("real-quadruple-rel-fail", test_rqp_rel_fail, should_fail=.true.), & + new_unittest("real-quadruple-abs-message", test_rqp_abs_message, should_fail=.true.), & + new_unittest("real-quadruple-nan-message", test_rqp_nan_message, should_fail=.true.), & + new_unittest("complex-single-abs", test_csp_abs), & + new_unittest("complex-single-rel", test_csp_rel), & + new_unittest("complex-single-nan", test_csp_nan, should_fail=.true.), & + new_unittest("complex-single-abs-fail", test_csp_abs_fail, should_fail=.true.), & + new_unittest("complex-single-rel-fail", test_csp_rel_fail, should_fail=.true.), & + new_unittest("complex-single-abs-message", test_csp_abs_message, should_fail=.true.), & + new_unittest("complex-single-nan-message", test_csp_nan_message, should_fail=.true.), & + new_unittest("complex-double-abs", test_cdp_abs), & + new_unittest("complex-double-rel", test_cdp_rel), & + new_unittest("complex-double-nan", test_cdp_nan, should_fail=.true.), & + new_unittest("complex-double-abs-fail", test_cdp_abs_fail, should_fail=.true.), & + new_unittest("complex-double-rel-fail", test_cdp_rel_fail, should_fail=.true.), & + new_unittest("complex-double-abs-message", test_cdp_abs_message, should_fail=.true.), & + new_unittest("complex-double-nan-message", test_cdp_nan_message, should_fail=.true.), & + new_unittest("complex-xdouble-abs", test_cxdp_abs), & + new_unittest("complex-xdouble-rel", test_cxdp_rel), & + new_unittest("complex-xdouble-nan", test_cxdp_nan, should_fail=.true.), & + new_unittest("complex-xdouble-abs-fail", test_cxdp_abs_fail, should_fail=.true.), & + new_unittest("complex-xdouble-rel-fail", test_cxdp_rel_fail, should_fail=.true.), & + new_unittest("complex-xdouble-abs-message", test_cxdp_abs_message, should_fail=.true.), & + new_unittest("complex-xdouble-nan-message", test_cxdp_nan_message, should_fail=.true.), & + new_unittest("complex-quadruple-abs", test_cqp_abs), & + new_unittest("complex-quadruple-rel", test_cqp_rel), & + new_unittest("complex-quadruple-nan", test_cqp_nan, should_fail=.true.), & + new_unittest("complex-quadruple-abs-fail", test_cqp_abs_fail, should_fail=.true.), & + new_unittest("complex-quadruple-rel-fail", test_cqp_rel_fail, should_fail=.true.), & + new_unittest("complex-quadruple-abs-message", test_cqp_abs_message, should_fail=.true.), & + new_unittest("complex-quadruple-nan-message", test_cqp_nan_message, should_fail=.true.), & + new_unittest("integer-char", test_i1), & + new_unittest("integer-char-fail", test_i1_fail, should_fail=.true.), & + new_unittest("integer-char-message", test_i1_message, should_fail=.true.), & + new_unittest("integer-char-with-more", test_i1_with_more, should_fail=.true.), & + new_unittest("integer-short", test_i2), & + new_unittest("integer-short-fail", test_i2_fail, should_fail=.true.), & + new_unittest("integer-short-message", test_i2_message, should_fail=.true.), & + new_unittest("integer-short-with-more", test_i2_with_more, should_fail=.true.), & + new_unittest("integer-default", test_i4), & + new_unittest("integer-default-fail", test_i4_fail, should_fail=.true.), & + new_unittest("integer-default-message", test_i4_message, should_fail=.true.), & + new_unittest("integer-default-with-more", test_i4_with_more, should_fail=.true.), & + new_unittest("integer-long", test_i8), & + new_unittest("integer-long-fail", test_i8_fail, should_fail=.true.), & + new_unittest("integer-long-message", test_i8_message, should_fail=.true.), & + new_unittest("integer-long-with-more", test_i8_with_more, should_fail=.true.), & + new_unittest("logical-default-true", test_l4_true), & + new_unittest("logical-default-false", test_l4_false), & + new_unittest("logical-default-fail", test_l4_fail, should_fail=.true.), & + new_unittest("logical-default-message", test_l4_message, should_fail=.true.), & + new_unittest("logical-default-with-more", test_l4_with_more, should_fail=.true.), & + new_unittest("character", test_char), & + new_unittest("character-fail", test_char_fail, should_fail=.true.), & + new_unittest("character-message", test_char_message, should_fail=.true.), & + new_unittest("character-with-more", test_char_with_more, should_fail=.true.) & + ] + + end subroutine collect_check_array + + + subroutine test_success(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [0, 0]) + if (allocated(error)) return + + end subroutine test_success + + + subroutine test_failure(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [7, 0]) + if (allocated(error)) return + + end subroutine test_failure + + + subroutine test_failure_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [7, 7], "Custom message describing the error") + + end subroutine test_failure_message + + + subroutine test_failure_with_more(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [7, 7], more="with an additional descriptive message here") + + end subroutine test_failure_with_more + + + subroutine test_expression(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.true., .true.], "Expression failed") + + end subroutine test_expression + + + subroutine test_expression_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.false., .false.], "Expression failed") + + end subroutine test_expression_fail + + + subroutine test_expression_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.false., .true.], 'Expression with message failed') + + end subroutine test_expression_message + + + subroutine test_expression_with_more(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.false., .true.], more='Expression with more failed') + + end subroutine test_expression_with_more + + + subroutine test_rsp_abs(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val(2) + + val = 3.3_sp + + call check(error, val, [3.3_sp, 3.3_sp], thr=sqrt(epsilon(val))) + + end subroutine test_rsp_abs + + + subroutine test_rsp_nan(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val(2) + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, [3.3_sp, 3.3_sp], rel=.true.) + + end subroutine test_rsp_nan + + + subroutine test_rsp_rel(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val(2) + + val = 3.3_sp + + call check(error, val, [3.3_sp, 3.3_sp], rel=.true.) + + end subroutine test_rsp_rel + + + subroutine test_rsp_abs_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val(2) + + val = 1.0_sp + + call check(error, val, [2.0_sp, 2.0_sp]) + + end subroutine test_rsp_abs_fail + + + subroutine test_rsp_rel_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val(2) + + val = 1.0_sp + + call check(error, val, [1.5_sp, 1.5_sp], rel=.true.) + + end subroutine test_rsp_rel_fail + + + subroutine test_rsp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val(2) + + val = 1.0_sp + + call check(error, val, [1.5_sp, 1.5_sp], message="Actual value is not 1.5") + + end subroutine test_rsp_abs_message + + + subroutine test_rsp_nan_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val(2) + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, message="Actual value is not a number") + + end subroutine test_rsp_nan_message + + + subroutine test_rdp_abs(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val(2) + + val = 3.3_dp + + call check(error, val, [3.3_dp, 3.3_dp], thr=sqrt(epsilon(val))) + + end subroutine test_rdp_abs + + + subroutine test_rdp_rel(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val(2) + + val = 3.3_dp + + call check(error, val, [3.3_dp, 3.3_dp], rel=.true.) + + end subroutine test_rdp_rel + + + subroutine test_rdp_nan(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val(2) + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, [3.3_dp, 3.3_dp], rel=.true.) + + end subroutine test_rdp_nan + + + subroutine test_rdp_abs_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val(2) + + val = 1.0_dp + + call check(error, val, [2.0_dp, 2.0_dp]) + + end subroutine test_rdp_abs_fail + + + subroutine test_rdp_rel_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val(2) + + val = 1.0_dp + + call check(error, val, [1.5_dp, 1.5_dp], rel=.true.) + + end subroutine test_rdp_rel_fail + + + subroutine test_rdp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val(2) + + val = 1.0_dp + + call check(error, val, [1.5_dp, 1.0_dp], message="Actual value is not 1.5") + + end subroutine test_rdp_abs_message + + + subroutine test_rdp_nan_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val(2) + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, message="Actual value is not a number") + + end subroutine test_rdp_nan_message + + + subroutine test_rxdp_abs(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + real(xdp) :: val(2) + + val = 3.3_xdp + + call check(error, val, [3.3_xdp, 3.3_xdp], thr=sqrt(epsilon(val))) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_rxdp_abs + + + subroutine test_rxdp_rel(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + real(xdp) :: val(2) + + val = 3.3_xdp + + call check(error, val, [3.3_xdp, 3.3_xdp], rel=.true.) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_rxdp_rel + + + subroutine test_rxdp_nan(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + real(xdp) :: val(2) + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, [3.3_xdp, 3.3_xdp], rel=.true.) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_rxdp_nan + + + subroutine test_rxdp_abs_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + real(xdp) :: val(2) + + val = 1.0_xdp + + call check(error, val, [2.0_xdp, 2.0_xdp]) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_rxdp_abs_fail + + + subroutine test_rxdp_rel_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + real(xdp) :: val(2) + + val = 1.0_xdp + + call check(error, val, [1.5_xdp, 1.5_xdp], rel=.true.) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_rxdp_rel_fail + + + subroutine test_rxdp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + real(xdp) :: val(2) + + val = 1.0_xdp + + call check(error, val, [1.5_xdp, 1.5_xdp], message="Actual value is not 1.5") +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_rxdp_abs_message + + + subroutine test_rxdp_nan_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + real(xdp) :: val(2) + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, message="Actual value is not a number") +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_rxdp_nan_message + + + subroutine test_rqp_abs(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + real(qp) :: val(2) + + val = 3.3_qp + + call check(error, val, [3.3_qp, 3.3_qp], thr=sqrt(epsilon(val))) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_rqp_abs + + + subroutine test_rqp_rel(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + real(qp) :: val(2) + + val = 3.3_qp + + call check(error, val, [3.3_qp, 3.3_qp], rel=.true.) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_rqp_rel + + + subroutine test_rqp_nan(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + real(qp) :: val(2) + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, [3.3_qp, 3.3_qp], rel=.true.) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_rqp_nan + + + subroutine test_rqp_abs_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + real(qp) :: val(2) + + val = 1.0_qp + + call check(error, val, [2.0_qp, 2.0_qp]) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_rqp_abs_fail + + + subroutine test_rqp_rel_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + real(qp) :: val(2) + + val = 1.0_qp + + call check(error, val, [1.5_qp, 1.5_qp], rel=.true.) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_rqp_rel_fail + + + subroutine test_rqp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + real(qp) :: val(2) + + val = 1.0_qp + + call check(error, val, [1.5_qp, 1.5_qp], message="Actual value is not 1.5") +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_rqp_abs_message + + + subroutine test_rqp_nan_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + real(qp) :: val(2) + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, message="Actual value is not a number") +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_rqp_nan_message + + + subroutine test_csp_abs(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: val(2) + + val = cmplx(3.3_sp, 1.0_sp, sp) + + call check(error, val, [cmplx(3.3_sp, 1.0_sp, sp), cmplx(3.3_sp, 1.0_sp, sp)], thr=sqrt(epsilon(abs(val)))) + + end subroutine test_csp_abs + + + subroutine test_csp_nan(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: val(2) + + val = cmplx(ieee_value(0.0_sp, ieee_quiet_nan), & + & ieee_value(0.0_sp, ieee_quiet_nan), sp) + + call check(error, val, [cmplx(3.3_sp, 1.0_sp, sp), cmplx(3.3_sp, 1.0_sp, sp)], rel=.true.) + + end subroutine test_csp_nan + + + subroutine test_csp_rel(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: val(2) + + val = cmplx(3.3_sp, 1.0_sp, sp) + + call check(error, val, [cmplx(3.3_sp, 1.0_sp, sp), cmplx(3.3_sp, 1.0_sp, sp)], rel=.true.) + + end subroutine test_csp_rel + + + subroutine test_csp_abs_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: val(2) + + val = cmplx(1.0_sp, 2.0_sp, sp) + + call check(error, val, [cmplx(2.0_sp, 1.0_sp, sp), cmplx(3.3_sp, 1.0_sp, sp)]) + + end subroutine test_csp_abs_fail + + + subroutine test_csp_rel_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: val(2) + + val = cmplx(1.0_sp, 1.5_sp, sp) + + call check(error, val, [cmplx(1.5_sp, 1.0_sp, sp), cmplx(3.3_sp, 1.0_sp, sp)], rel=.true.) + + end subroutine test_csp_rel_fail + + + subroutine test_csp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: val(2) + + val = cmplx(1.0_sp, 1.5_sp, sp) + + call check(error, val, [cmplx(1.5_sp, 1.0_sp, sp), cmplx(3.3_sp, 1.0_sp, sp)], & + message="Actual value is not 1.5+1.0i") + + end subroutine test_csp_abs_message + + + subroutine test_csp_nan_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: val(2) + + val = cmplx(ieee_value(0.0_sp, ieee_quiet_nan), 0.0_sp, sp) + + call check(error, val, message="Actual value is not a number") + + end subroutine test_csp_nan_message + + + subroutine test_cdp_abs(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(dp) :: val(2) + + val = cmplx(3.3_dp, 1.0_dp, dp) + + call check(error, val, [cmplx(3.3_dp, 1.0_dp, dp), cmplx(3.3_dp, 1.0_dp, dp)], & + thr=sqrt(epsilon(real(val)))) + + end subroutine test_cdp_abs + + + subroutine test_cdp_rel(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(dp) :: val(2) + + val = cmplx(3.3_dp, 1.0_dp, dp) + + call check(error, val, [cmplx(3.3_dp, 1.0_dp, dp), cmplx(3.3_dp, 1.0_dp, dp)], rel=.true.) + + end subroutine test_cdp_rel + + + subroutine test_cdp_nan(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(dp) :: val(2) + + val = cmplx(ieee_value(0.0_dp, ieee_quiet_nan), 0.0_dp, dp) + + call check(error, val, [cmplx(3.3_dp, 1.0_dp, dp), cmplx(3.3_dp, 1.0_dp, dp)], rel=.true.) + + end subroutine test_cdp_nan + + + subroutine test_cdp_abs_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(dp) :: val(2) + + val = cmplx(1.0_dp, 2.0_dp, dp) + + call check(error, val, [cmplx(2.0_dp, 1.0_dp, dp), cmplx(3.3_dp, 1.0_dp, dp)]) + + end subroutine test_cdp_abs_fail + + + subroutine test_cdp_rel_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(dp) :: val(2) + + val = cmplx(1.0_dp, 1.5_dp, dp) + + call check(error, val, [cmplx(1.5_dp, 1.0_dp, dp), cmplx(3.3_dp, 1.0_dp, dp)], rel=.true.) + + end subroutine test_cdp_rel_fail + + + subroutine test_cdp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(dp) :: val(2) + + val = cmplx(1.0_dp, 1.5_dp, dp) + + call check(error, val, [cmplx(1.5_dp, 1.0_dp, dp), cmplx(3.3_dp, 1.0_dp, dp)], & + message="Actual value is not 1.5+1.0i") + + end subroutine test_cdp_abs_message + + + subroutine test_cdp_nan_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(dp) :: val(2) + + val = cmplx(ieee_value(0.0_dp, ieee_quiet_nan), 0.0_dp, dp) + + call check(error, val, message="Actual value is not a number") + + end subroutine test_cdp_nan_message + + + subroutine test_cxdp_abs(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + complex(xdp) :: val(2) + + val = cmplx(3.3_xdp, 1.0_xdp, xdp) + + call check(error, val, [cmplx(3.3_xdp, 1.0_xdp, xdp), cmplx(3.3_xdp, 1.0_xdp, xdp)], & + thr=sqrt(epsilon(real(val)))) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_cxdp_abs + + + subroutine test_cxdp_rel(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + complex(xdp) :: val(2) + + val = cmplx(3.3_xdp, 1.0_xdp, xdp) + + call check(error, val, [cmplx(3.3_xdp, 1.0_xdp, xdp), cmplx(3.3_xdp, 1.0_xdp, xdp)], rel=.true.) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_cxdp_rel + + + subroutine test_cxdp_nan(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + complex(xdp) :: val(2) + + val = cmplx(ieee_value(0.0_xdp, ieee_quiet_nan), 0.0_xdp, xdp) + + call check(error, val, [cmplx(3.3_xdp, 1.0_xdp, xdp), cmplx(3.3_xdp, 1.0_xdp, xdp)], rel=.true.) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_cxdp_nan + + + subroutine test_cxdp_abs_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + complex(xdp) :: val(2) + + val = cmplx(1.0_xdp, 2.0_xdp, xdp) + + call check(error, val, [cmplx(2.0_xdp, 1.0_xdp, xdp), cmplx(3.3_xdp, 1.0_xdp, xdp)]) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_cxdp_abs_fail + + + subroutine test_cxdp_rel_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + complex(xdp) :: val(2) + + val = cmplx(1.0_xdp, 1.5_xdp, xdp) + + call check(error, val, [cmplx(1.5_xdp, 1.0_xdp, xdp), cmplx(3.3_xdp, 1.0_xdp, xdp)], rel=.true.) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_cxdp_rel_fail + + + subroutine test_cxdp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + complex(xdp) :: val(2) + + val = cmplx(1.0_xdp, 1.5_xdp, xdp) + + call check(error, val, [cmplx(1.5_xdp, 1.0_xdp, xdp), cmplx(3.3_xdp, 1.0_xdp, xdp)], & + message="Actual value is not 1.5+1.0i") +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_cxdp_abs_message + + + subroutine test_cxdp_nan_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + complex(xdp) :: val(2) + + val = cmplx(ieee_value(0.0_xdp, ieee_quiet_nan), 0.0_xdp, xdp) + + call check(error, val, message="Actual value is not a number") +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_cxdp_nan_message + + + subroutine test_cqp_abs(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + complex(qp) :: val(2) + + val = cmplx(3.3_qp, 1.0_qp, qp) + + call check(error, val, [cmplx(3.3_qp, 1.0_qp, qp), cmplx(3.3_qp, 1.0_qp, qp)], & + thr=sqrt(epsilon(real(val)))) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_cqp_abs + + + subroutine test_cqp_rel(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + complex(qp) :: val(2) + + val = cmplx(3.3_qp, 1.0_qp, qp) + + call check(error, val, [cmplx(3.3_qp, 1.0_qp, qp), cmplx(3.3_qp, 1.0_qp, qp)], rel=.true.) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_cqp_rel + + + subroutine test_cqp_nan(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + complex(qp) :: val(2) + + val = cmplx(ieee_value(0.0_qp, ieee_quiet_nan), 0.0_qp, qp) + + call check(error, val, [cmplx(3.3_qp, 1.0_qp, qp), cmplx(3.3_qp, 1.0_qp, qp)], rel=.true.) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_cqp_nan + + + subroutine test_cqp_abs_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + complex(qp) :: val(2) + + val = cmplx(1.0_qp, 2.0_qp, qp) + + call check(error, val, [cmplx(2.0_qp, 1.0_qp, qp), cmplx(3.3_qp, 1.0_qp, qp)]) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_cqp_abs_fail + + + subroutine test_cqp_rel_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + complex(qp) :: val(2) + + val = cmplx(1.0_qp, 1.5_qp, qp) + + call check(error, val, [cmplx(1.5_qp, 1.0_qp, qp), cmplx(1.5_qp, 1.0_qp, qp)], rel=.true.) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_cqp_rel_fail + + + subroutine test_cqp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + complex(qp) :: val(2) + + val = cmplx(1.0_qp, 1.5_qp, qp) + + call check(error, val, [cmplx(1.5_qp, 1.0_qp, qp), cmplx(1.5_qp, 1.0_qp, qp)], & + message="Actual value is not 1.5+1.0i") +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_cqp_abs_message + + + subroutine test_cqp_nan_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + complex(qp) :: val(2) + + val = cmplx(ieee_value(0.0_qp, ieee_quiet_nan), 0.0_qp, qp) + + call check(error, val, message="Actual value is not a number") +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_cqp_nan_message + + + subroutine test_i1(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i1) :: val(2) + + val = 3_i1 + + call check(error, val, [3_i1, 3_i1]) + + end subroutine test_i1 + + + subroutine test_i1_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i1) :: val(2) + + val = 3_i1 + + call check(error, val, [-4_i1, -4_i1]) + + end subroutine test_i1_fail + + + subroutine test_i1_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i1) :: val(2) + + val = -3_i1 + + call check(error, val, [7_i1, 7_i1], "Actual value is not seven") + + end subroutine test_i1_message + + + subroutine test_i1_with_more(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i1) :: val(2) + + val = 0_i1 + + call check(error, val, [3_i1, 3_i1], more="with an additional descriptive message here") + + end subroutine test_i1_with_more + + + subroutine test_i2(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i2) :: val(2) + + val = 3_i2 + + call check(error, val, [3_i2, 3_i2]) + + end subroutine test_i2 + + + subroutine test_i2_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i2) :: val(2) + + val = 3_i2 + + call check(error, val, [-4_i2, -4_i2]) + + end subroutine test_i2_fail + + + subroutine test_i2_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i2) :: val(2) + + val = -3_i2 + + call check(error, val, [7_i2, 7_i2], "Actual value is not seven") + + end subroutine test_i2_message + + + subroutine test_i2_with_more(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i2) :: val(2) + + val = 0_i2 + + call check(error, val, [3_i2, 3_i2], more="with an additional descriptive message here") + + end subroutine test_i2_with_more + + + subroutine test_i4(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i4) :: val(2) + + val = 3_i4 + + call check(error, val, [3_i4, 3_i4]) + + end subroutine test_i4 + + + subroutine test_i4_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i4) :: val(2) + + val = 3_i4 + + call check(error, val, [-4_i4, -4_i4]) + + end subroutine test_i4_fail + + + subroutine test_i4_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i4) :: val(2) + + val = -3_i4 + + call check(error, val, [7_i4, 7_i4], "Actual value is not seven") + + end subroutine test_i4_message + + + subroutine test_i4_with_more(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i4) :: val(2) + + val = 0_i4 + + call check(error, val, [3_i4, 3_i4], more="with an additional descriptive message here") + + end subroutine test_i4_with_more + + + subroutine test_i8(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i8) :: val(2) + + val = 3_i8 + + call check(error, val, [3_i8, 3_i8]) + + end subroutine test_i8 + + + subroutine test_i8_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i8) :: val(2) + + val = 3_i8 + + call check(error, val, [-4_i8, -4_i8]) + + end subroutine test_i8_fail + + + subroutine test_i8_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i8) :: val(2) + + val = -3_i8 + + call check(error, val, [7_i8, 7_i8], "Actual value is not seven") + + end subroutine test_i8_message + + + subroutine test_i8_with_more(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i8) :: val(2) + + val = 0_i8 + + call check(error, val, [3_i8, 3_i8], more="with an additional descriptive message here") + + end subroutine test_i8_with_more + + + subroutine test_l4_true(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.true., .true.], [.true., .true.]) + + end subroutine test_l4_true + + + subroutine test_l4_false(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.false., .false.], [.false., .false.]) + + end subroutine test_l4_false + + + subroutine test_l4_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.true.], [.false.]) + + end subroutine test_l4_fail + + + subroutine test_l4_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.false.], [.true.], "Logical value is not true") + + end subroutine test_l4_message + + + subroutine test_l4_with_more(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.true.], [.false.], more="with an additional descriptive message") + + end subroutine test_l4_with_more + + + subroutine test_char(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=:), allocatable :: val(:) + + val = ["positive"] + + call check(error, val, ["positive"]) + + end subroutine test_char + + + subroutine test_char_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=:), allocatable :: val(:) + + val = ["positive"] + + call check(error, val, ["negative"]) + + end subroutine test_char_fail + + + subroutine test_char_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=:), allocatable :: val(:) + + val = ["positive"] + + call check(error, val, ["negative"], "Character string should be negative") + + end subroutine test_char_message + + + subroutine test_char_with_more(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=:), allocatable :: val(:) + + val = ["positive"] + + call check(error, val, ["negative"], more="with an additional descriptive message") + + end subroutine test_char_with_more + + +end module test_check_array