diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index f12fafb..40086fe 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -47,12 +47,6 @@ jobs: compiler: gnu version: 10 - - os: macos-latest - build: meson - build-type: debug - compiler: gnu - version: 5 - - os: macos-latest build: cmake build-type: debug diff --git a/CMakeLists.txt b/CMakeLists.txt index c614408..4505b4b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -56,6 +56,12 @@ target_include_directories( $ $ ) +target_compile_definitions( + "${PROJECT_NAME}-lib" + PRIVATE + "WITH_QP=$" + "WITH_XDP=$" +) # Export targets for other projects add_library("${PROJECT_NAME}" INTERFACE) diff --git a/config/CMakeLists.txt b/config/CMakeLists.txt index 5185952..c9b2d9c 100644 --- a/config/CMakeLists.txt +++ b/config/CMakeLists.txt @@ -32,6 +32,18 @@ if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) ) endif() +include(CheckFortranSourceRuns) +check_fortran_source_runs( + "if (selected_real_kind(33) == -1) stop 1; end" + WITH_QP +) +set(WITH_QP ${WITH_QP} PARENT_SCOPE) +check_fortran_source_runs( + "if (any(selected_real_kind(18) == [-1, selected_real_kind(33)])) stop 1; end" + WITH_XDP +) +set(WITH_XDP ${WITH_XDP} PARENT_SCOPE) + include(CMakePackageConfigHelpers) configure_package_config_file( "${CMAKE_CURRENT_SOURCE_DIR}/template.cmake" diff --git a/config/meson.build b/config/meson.build index 02c7e5e..07ee15d 100644 --- a/config/meson.build +++ b/config/meson.build @@ -53,3 +53,11 @@ if get_option('openmp') omp_dep = dependency('openmp') lib_deps += omp_dep endif + +with_qp = fc.run('if (selected_real_kind(33) == -1) stop 1; end').returncode() == 0 +with_xdp = fc.run('if (any(selected_real_kind(18) == [-1, selected_real_kind(33)])) stop 1; end').returncode() == 0 +add_project_arguments( + '-DWITH_QP=@0@'.format(with_qp.to_int()), + '-DWITH_XDP=@0@'.format(with_xdp.to_int()), + language: 'fortran', +) diff --git a/config/template.cmake b/config/template.cmake index 4746fe4..d01dafc 100644 --- a/config/template.cmake +++ b/config/template.cmake @@ -1,5 +1,8 @@ @PACKAGE_INIT@ +set("@PROJECT_NAME@_WITH_QP" @WITH_QP@) +set("@PROJECT_NAME@_WITH_XDP" @WITH_XDP@) + if(NOT TARGET "@PROJECT_NAME@::@PROJECT_NAME@") include("${CMAKE_CURRENT_LIST_DIR}/@PROJECT_NAME@-targets.cmake") endif() diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 7ef1e8e..b6b5a8e 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -15,7 +15,7 @@ set(dir "${CMAKE_CURRENT_SOURCE_DIR}") list( APPEND srcs - "${dir}/testdrive.f90" + "${dir}/testdrive.F90" "${dir}/testdrive_version.f90" ) diff --git a/src/meson.build b/src/meson.build index f1907b5..b56b994 100644 --- a/src/meson.build +++ b/src/meson.build @@ -12,6 +12,6 @@ # limitations under the License. srcs += files( - 'testdrive.f90', + 'testdrive.F90', 'testdrive_version.f90', ) diff --git a/src/testdrive.f90 b/src/testdrive.F90 similarity index 70% rename from src/testdrive.f90 rename to src/testdrive.F90 index 314d0ad..a63196c 100644 --- a/src/testdrive.f90 +++ b/src/testdrive.F90 @@ -11,6 +11,16 @@ ! 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 1 +#endif + +!# Enable support for extended double precision +#ifndef WITH_XDP +#define WITH_XDP 0 +#endif + !> Provides a light-weight procedural testing framework for Fortran projects. !> !> Testsuites are defined by a [[collect_interface]] returning a set of @@ -95,7 +105,6 @@ !> For an example setup checkout the ``test/`` directory in this project. module testdrive use, intrinsic :: iso_fortran_env, only : error_unit - use, intrinsic :: ieee_arithmetic, only : ieee_is_nan implicit none private @@ -113,6 +122,16 @@ module testdrive !> 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) @@ -157,12 +176,36 @@ module testdrive module procedure :: check_logical module procedure :: check_float_sp module procedure :: check_float_dp +#if WITH_XDP + module procedure :: check_float_xdp +#endif +#if WITH_QP + module procedure :: check_float_qp +#endif module procedure :: check_float_exceptional_sp module procedure :: check_float_exceptional_dp +#if WITH_XDP + module procedure :: check_float_exceptional_xdp +#endif +#if WITH_QP + module procedure :: check_float_exceptional_qp +#endif module procedure :: check_complex_sp module procedure :: check_complex_dp +#if WITH_XDP + module procedure :: check_complex_xdp +#endif +#if WITH_QP + module procedure :: check_complex_qp +#endif module procedure :: check_complex_exceptional_sp module procedure :: check_complex_exceptional_dp +#if WITH_XDP + module procedure :: check_complex_exceptional_xdp +#endif +#if WITH_QP + module procedure :: check_complex_exceptional_qp +#endif module procedure :: check_int_i1 module procedure :: check_int_i2 module procedure :: check_int_i4 @@ -179,11 +222,37 @@ module testdrive module procedure :: integer_i8_to_char module procedure :: real_sp_to_char module procedure :: real_dp_to_char +#if WITH_XDP + module procedure :: real_xdp_to_char +#endif +#if WITH_QP + module procedure :: real_qp_to_char +#endif module procedure :: complex_sp_to_char module procedure :: complex_dp_to_char +#if WITH_XDP + module procedure :: complex_xdp_to_char +#endif +#if WITH_QP + module procedure :: complex_qp_to_char +#endif end interface ch + !> Implementation of check for not a number value, in case a compiler does not + !> provide the IEEE intrinsic ``ieee_is_nan`` (currently this is Intel oneAPI on MacOS) + interface is_nan + module procedure :: is_nan_sp + module procedure :: is_nan_dp +#if WITH_XDP + module procedure :: is_nan_xdp +#endif +#if WITH_QP + module procedure :: is_nan_qp +#endif + end interface is_nan + + abstract interface !> Entry point for tests subroutine test_interface(error) @@ -242,7 +311,7 @@ end subroutine collect_interface !> Driver for testsuite - subroutine run_testsuite(collect, unit, stat) + recursive subroutine run_testsuite(collect, unit, stat) !> Collect tests procedure(collect_interface) :: collect @@ -271,7 +340,7 @@ end subroutine run_testsuite !> Driver for selective testing - subroutine run_selected(collect, name, unit, stat) + recursive subroutine run_selected(collect, name, unit, stat) !> Collect tests procedure(collect_interface) :: collect @@ -306,7 +375,7 @@ end subroutine run_selected !> Run a selected unit test - subroutine run_unittest(test, unit, stat) + recursive subroutine run_unittest(test, unit, stat) !> Unit test type(unittest_type), intent(in) :: test @@ -321,8 +390,8 @@ subroutine run_unittest(test, unit, stat) character(len=:), allocatable :: message call test%test(error) - if (.not.test_skipped(error) .and. allocated(error) .neqv. test%should_fail) then - stat = stat + 1 + if (.not.test_skipped(error)) then + if (allocated(error) .neqv. test%should_fail) stat = stat + 1 end if call make_output(message, test, error) !$omp critical(testdrive_testsuite) @@ -616,7 +685,7 @@ subroutine check_float_exceptional_dp(error, actual, message, more) !> Another line of error message character(len=*), intent(in), optional :: more - if (ieee_is_nan(actual)) then + if (is_nan(actual)) then if (present(message)) then call test_failed(error, message, more) else @@ -711,7 +780,7 @@ subroutine check_float_exceptional_sp(error, actual, message, more) !> Another line of error message character(len=*), intent(in), optional :: more - if (ieee_is_nan(actual)) then + if (is_nan(actual)) then if (present(message)) then call test_failed(error, message, more) else @@ -722,6 +791,200 @@ subroutine check_float_exceptional_sp(error, actual, message, more) end subroutine check_float_exceptional_sp +#if WITH_XDP + subroutine check_float_xdp(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + real(xdp), intent(in) :: actual + + !> Expected floating point value + real(xdp), intent(in) :: 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 + real(xdp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + logical :: relative + real(xdp) :: diff, threshold + + call check(error, actual, message, more) + if (allocated(error)) return + + if (present(thr)) then + threshold = thr + else + threshold = epsilon(expected) + end if + + if (present(rel)) then + relative = rel + else + relative = .false. + end if + + if (relative) then + diff = abs(actual - expected) / abs(expected) + else + diff = abs(actual - expected) + end if + + if (diff > threshold) then + if (present(message)) then + call test_failed(error, message, more) + else + if (relative) then + call test_failed(error, & + "Floating point value missmatch", & + "expected "//ch(expected)//" but got "//ch(actual)//" "//& + "(difference: "//ch(int(diff*100))//"%)", & + more) + else + call test_failed(error, & + "Floating point value missmatch", & + "expected "//ch(expected)//" but got "//ch(actual)//" "//& + "(difference: "//ch(diff)//")", & + more) + end if + end if + end if + + end subroutine check_float_xdp + + + subroutine check_float_exceptional_xdp(error, actual, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + real(xdp), intent(in) :: actual + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (is_nan(actual)) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Exceptional value 'not a number' found", more) + end if + end if + + end subroutine check_float_exceptional_xdp +#endif + + +#if WITH_QP + subroutine check_float_qp(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + real(qp), intent(in) :: actual + + !> Expected floating point value + real(qp), intent(in) :: 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 + real(qp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + logical :: relative + real(qp) :: diff, threshold + + call check(error, actual, message, more) + if (allocated(error)) return + + if (present(thr)) then + threshold = thr + else + threshold = epsilon(expected) + end if + + if (present(rel)) then + relative = rel + else + relative = .false. + end if + + if (relative) then + diff = abs(actual - expected) / abs(expected) + else + diff = abs(actual - expected) + end if + + if (diff > threshold) then + if (present(message)) then + call test_failed(error, message, more) + else + if (relative) then + call test_failed(error, & + "Floating point value missmatch", & + "expected "//ch(expected)//" but got "//ch(actual)//" "//& + "(difference: "//ch(int(diff*100))//"%)", & + more) + else + call test_failed(error, & + "Floating point value missmatch", & + "expected "//ch(expected)//" but got "//ch(actual)//" "//& + "(difference: "//ch(diff)//")", & + more) + end if + end if + end if + + end subroutine check_float_qp + + + subroutine check_float_exceptional_qp(error, actual, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + real(qp), intent(in) :: actual + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (is_nan(actual)) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Exceptional value 'not a number' found", more) + end if + end if + + end subroutine check_float_exceptional_qp +#endif + + subroutine check_complex_dp(error, actual, expected, message, more, thr, rel) !> Error handling @@ -806,7 +1069,7 @@ subroutine check_complex_exceptional_dp(error, actual, message, more) !> Another line of error message character(len=*), intent(in), optional :: more - if (ieee_is_nan(real(actual)) .or. ieee_is_nan(aimag(actual))) then + if (is_nan(real(actual)) .or. is_nan(aimag(actual))) then if (present(message)) then call test_failed(error, message, more) else @@ -901,7 +1164,7 @@ subroutine check_complex_exceptional_sp(error, actual, message, more) !> Another line of error message character(len=*), intent(in), optional :: more - if (ieee_is_nan(real(actual)) .or. ieee_is_nan(aimag(actual))) then + if (is_nan(real(actual)) .or. is_nan(aimag(actual))) then if (present(message)) then call test_failed(error, message, more) else @@ -912,6 +1175,200 @@ subroutine check_complex_exceptional_sp(error, actual, message, more) end subroutine check_complex_exceptional_sp +#if WITH_XDP + subroutine check_complex_xdp(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + complex(xdp), intent(in) :: actual + + !> Expected floating point value + complex(xdp), intent(in) :: 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 + real(xdp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + logical :: relative + real(xdp) :: diff, threshold + + call check(error, actual, message, more) + if (allocated(error)) return + + if (present(thr)) then + threshold = thr + else + threshold = epsilon(abs(expected)) + end if + + if (present(rel)) then + relative = rel + else + relative = .false. + end if + + if (relative) then + diff = abs(actual - expected) / abs(expected) + else + diff = abs(actual - expected) + end if + + if (diff > threshold) then + if (present(message)) then + call test_failed(error, message, more) + else + if (relative) then + call test_failed(error, & + "Floating point value missmatch", & + "expected "//ch(expected)//" but got "//ch(actual)//" "//& + "(difference: "//ch(int(diff*100))//"%)", & + more) + else + call test_failed(error, & + "Floating point value missmatch", & + "expected "//ch(expected)//" but got "//ch(actual)//" "//& + "(difference: "//ch(diff)//")", & + more) + end if + end if + end if + + end subroutine check_complex_xdp + + + subroutine check_complex_exceptional_xdp(error, actual, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + complex(xdp), intent(in) :: actual + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (is_nan(real(actual)) .or. is_nan(aimag(actual))) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Exceptional value 'not a number' found", more) + end if + end if + + end subroutine check_complex_exceptional_xdp +#endif + + +#if WITH_QP + subroutine check_complex_qp(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + complex(qp), intent(in) :: actual + + !> Expected floating point value + complex(qp), intent(in) :: 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 + real(qp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + logical :: relative + real(qp) :: diff, threshold + + call check(error, actual, message, more) + if (allocated(error)) return + + if (present(thr)) then + threshold = thr + else + threshold = epsilon(abs(expected)) + end if + + if (present(rel)) then + relative = rel + else + relative = .false. + end if + + if (relative) then + diff = abs(actual - expected) / abs(expected) + else + diff = abs(actual - expected) + end if + + if (diff > threshold) then + if (present(message)) then + call test_failed(error, message, more) + else + if (relative) then + call test_failed(error, & + "Floating point value missmatch", & + "expected "//ch(expected)//" but got "//ch(actual)//" "//& + "(difference: "//ch(int(diff*100))//"%)", & + more) + else + call test_failed(error, & + "Floating point value missmatch", & + "expected "//ch(expected)//" but got "//ch(actual)//" "//& + "(difference: "//ch(diff)//")", & + more) + end if + end if + end if + + end subroutine check_complex_qp + + + subroutine check_complex_exceptional_qp(error, actual, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + complex(qp), intent(in) :: actual + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (is_nan(real(actual)) .or. is_nan(aimag(actual))) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Exceptional value 'not a number' found", more) + end if + end if + + end subroutine check_complex_exceptional_qp +#endif + + subroutine check_int_i1(error, actual, expected, message, more) !> Error handling @@ -1253,7 +1710,7 @@ pure function integer_i2_to_char(val) result(string) pos = buffer_len + 1 do while (n > 0_i2) pos = pos - 1 - buffer(pos:pos) = numbers(mod(n, 10_i1)) + buffer(pos:pos) = numbers(mod(n, 10_i2)) n = n/10_i2 end do if (val < 0_i2) then @@ -1286,7 +1743,7 @@ pure function integer_i4_to_char(val) result(string) pos = buffer_len + 1 do while (n > 0_i4) pos = pos - 1 - buffer(pos:pos) = numbers(mod(n, 10_i1)) + buffer(pos:pos) = numbers(mod(n, 10_i4)) n = n/10_i4 end do if (val < 0_i4) then @@ -1319,7 +1776,7 @@ pure function integer_i8_to_char(val) result(string) pos = buffer_len + 1 do while (n > 0_i8) pos = pos - 1 - buffer(pos:pos) = numbers(mod(n, 10_i1)) + buffer(pos:pos) = numbers(mod(n, 10_i8)) n = n/10_i8 end do if (val < 0_i8) then @@ -1355,6 +1812,34 @@ pure function real_dp_to_char(val) result(string) end function real_dp_to_char +#if WITH_XDP + pure function real_xdp_to_char(val) result(string) + real(xdp), intent(in) :: val + character(len=:), allocatable :: string + integer, parameter :: buffer_len = 128 + character(len=buffer_len) :: buffer + + write(buffer, '(g0)') val + string = trim(buffer) + + end function real_xdp_to_char +#endif + + +#if WITH_QP + pure function real_qp_to_char(val) result(string) + real(qp), intent(in) :: val + character(len=:), allocatable :: string + integer, parameter :: buffer_len = 128 + character(len=buffer_len) :: buffer + + write(buffer, '(g0)') val + string = trim(buffer) + + end function real_qp_to_char +#endif + + pure function complex_sp_to_char(val) result(string) complex(sp), intent(in) :: val character(len=:), allocatable :: string @@ -1373,6 +1858,28 @@ pure function complex_dp_to_char(val) result(string) end function complex_dp_to_char +#if WITH_XDP + pure function complex_xdp_to_char(val) result(string) + complex(xdp), intent(in) :: val + character(len=:), allocatable :: string + + string = "("//ch(real(val))//", "//ch(aimag(val))//")" + + end function complex_xdp_to_char +#endif + + +#if WITH_QP + pure function complex_qp_to_char(val) result(string) + complex(qp), intent(in) :: val + character(len=:), allocatable :: string + + string = "("//ch(real(val))//", "//ch(aimag(val))//")" + + end function complex_qp_to_char +#endif + + !> Clear error type after it has been handled. subroutine clear_error(error) @@ -1409,4 +1916,49 @@ subroutine escalate_error(error) end subroutine escalate_error + !> Determine whether a value is not a number without requiring IEEE arithmetic support + elemental function is_nan_sp(val) result(is_nan) + !> Value to check + real(sp), intent(in) :: val + !> Value is not a number + logical :: is_nan + + is_nan = .not.((val <= huge(val) .and. val >= -huge(val)) .or. abs(val) > huge(val)) + end function is_nan_sp + + !> Determine whether a value is not a number without requiring IEEE arithmetic support + elemental function is_nan_dp(val) result(is_nan) + !> Value to check + real(dp), intent(in) :: val + !> Value is not a number + logical :: is_nan + + is_nan = .not.((val <= huge(val) .and. val >= -huge(val)) .or. abs(val) > huge(val)) + end function is_nan_dp + +#if WITH_XDP + !> Determine whether a value is not a number without requiring IEEE arithmetic support + elemental function is_nan_xdp(val) result(is_nan) + !> Value to check + real(xdp), intent(in) :: val + !> Value is not a number + logical :: is_nan + + is_nan = .not.((val <= huge(val) .and. val >= -huge(val)) .or. abs(val) > huge(val)) + end function is_nan_xdp +#endif + +#if WITH_QP + !> Determine whether a value is not a number without requiring IEEE arithmetic support + elemental function is_nan_qp(val) result(is_nan) + !> Value to check + real(qp), intent(in) :: val + !> Value is not a number + logical :: is_nan + + is_nan = .not.((val <= huge(val) .and. val >= -huge(val)) .or. abs(val) > huge(val)) + end function is_nan_qp +#endif + + end module testdrive diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index fb0d3ad..0c98279 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -23,7 +23,7 @@ set( ) foreach(t IN LISTS tests) string(MAKE_C_IDENTIFIER ${t} t) - list(APPEND test-srcs "test_${t}.f90") + list(APPEND test-srcs "test_${t}.F90") endforeach() add_executable( @@ -35,6 +35,12 @@ target_link_libraries( PRIVATE "${PROJECT_NAME}-lib" ) +target_compile_definitions( + "${PROJECT_NAME}-tester" + PRIVATE + "WITH_QP=$" + "WITH_XDP=$" +) add_test("${PROJECT_NAME}/all-tests" "${PROJECT_NAME}-tester") diff --git a/test/meson.build b/test/meson.build index f3b8b41..ae2956b 100644 --- a/test/meson.build +++ b/test/meson.build @@ -20,7 +20,7 @@ test_srcs = files( 'main.f90', ) foreach t : tests - test_srcs += files('test_@0@.f90'.format(t.underscorify())) + test_srcs += files('test_@0@.F90'.format(t.underscorify())) endforeach tester = executable( diff --git a/test/test_check.f90 b/test/test_check.F90 similarity index 61% rename from test/test_check.f90 rename to test/test_check.F90 index fc3feeb..ca47a55 100644 --- a/test/test_check.f90 +++ b/test/test_check.F90 @@ -11,6 +11,16 @@ ! 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 1 +#endif + +!# Enable support for extended double precision +#ifndef WITH_XDP +#define WITH_XDP 0 +#endif + module test_check use, intrinsic :: ieee_arithmetic, only : ieee_value, ieee_quiet_nan use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test @@ -26,6 +36,16 @@ module test_check !> 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) @@ -71,6 +91,20 @@ subroutine collect_check(testsuite) 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.), & @@ -85,6 +119,20 @@ subroutine collect_check(testsuite) 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.), & @@ -401,6 +449,258 @@ subroutine test_rdp_nan_message(error) 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 + + val = 3.3_xdp + + call check(error, val, 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 + + val = 3.3_xdp + + call check(error, val, 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 + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, 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 + + val = 1.0_xdp + + call check(error, val, 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 + + val = 1.0_xdp + + call check(error, val, 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 + + val = 1.0_xdp + + call check(error, val, 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 + + 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 + + val = 3.3_qp + + call check(error, val, 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 + + val = 3.3_qp + + call check(error, val, 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 + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, 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 + + val = 1.0_qp + + call check(error, val, 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 + + val = 1.0_qp + + call check(error, val, 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 + + val = 1.0_qp + + call check(error, val, 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 + + 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 @@ -422,8 +722,8 @@ subroutine test_csp_nan(error) complex(sp) :: val - val = cmplx(ieee_value(real(val), ieee_quiet_nan), & - & ieee_value(aimag(val), ieee_quiet_nan), sp) + 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), rel=.true.) @@ -493,7 +793,7 @@ subroutine test_csp_nan_message(error) complex(sp) :: val - val = cmplx(ieee_value(real(val), ieee_quiet_nan), 0.0_sp, sp) + 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") @@ -535,7 +835,7 @@ subroutine test_cdp_nan(error) complex(dp) :: val - val = cmplx(ieee_value(real(val), ieee_quiet_nan), 0.0_dp, dp) + 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), rel=.true.) @@ -591,13 +891,265 @@ subroutine test_cdp_nan_message(error) complex(dp) :: val - val = cmplx(ieee_value(real(val), ieee_quiet_nan), 0.0_dp, dp) + 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 + + val = cmplx(3.3_xdp, 1.0_xdp, xdp) + + call check(error, val, 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 + + val = cmplx(3.3_xdp, 1.0_xdp, xdp) + + call check(error, val, 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 + + 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), 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 + + val = cmplx(1.0_xdp, 2.0_xdp, xdp) + + call check(error, val, cmplx(2.0_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 + + val = cmplx(1.0_xdp, 1.5_xdp, xdp) + + call check(error, val, cmplx(1.5_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 + + val = cmplx(1.0_xdp, 1.5_xdp, xdp) + + call check(error, val, cmplx(1.5_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 + + 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 + + val = cmplx(3.3_qp, 1.0_qp, qp) + + call check(error, val, 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 + + val = cmplx(3.3_qp, 1.0_qp, qp) + + call check(error, val, 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 + + 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), 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 + + val = cmplx(1.0_qp, 2.0_qp, qp) + + call check(error, val, cmplx(2.0_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 + + val = cmplx(1.0_qp, 1.5_qp, qp) + + call check(error, val, 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 + + val = cmplx(1.0_qp, 1.5_qp, qp) + + call check(error, val, 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 + + 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 diff --git a/test/test_select.f90 b/test/test_select.F90 similarity index 100% rename from test/test_select.f90 rename to test/test_select.F90