From ace781225cab3a1c2a01f21c0f76a93ca47dd4f4 Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Sat, 21 Aug 2021 20:40:42 +0200 Subject: [PATCH 01/34] Add testing module to allow better structuring of test suites --- src/tests/CMakeLists.txt | 15 +- src/tests/Makefile.manual | 24 +- src/tests/Makefile.manual.test.mk | 4 +- src/tests/ascii/test_ascii.f90 | 741 ++++++++++++++----------- src/tests/stdlib_test.fypp | 874 ++++++++++++++++++++++++++++++ src/tests/test/CMakeLists.txt | 2 + src/tests/test/Makefile.manual | 4 + src/tests/test/test_check.f90 | 631 +++++++++++++++++++++ src/tests/test/test_select.f90 | 171 ++++++ 9 files changed, 2142 insertions(+), 324 deletions(-) create mode 100644 src/tests/stdlib_test.fypp create mode 100644 src/tests/test/CMakeLists.txt create mode 100644 src/tests/test/Makefile.manual create mode 100644 src/tests/test/test_check.f90 create mode 100644 src/tests/test/test_select.f90 diff --git a/src/tests/CMakeLists.txt b/src/tests/CMakeLists.txt index 7d2286fef..b81a7c4c3 100644 --- a/src/tests/CMakeLists.txt +++ b/src/tests/CMakeLists.txt @@ -1,6 +1,18 @@ +fypp_f90("${fyppFlags};-I${CMAKE_CURRENT_SOURCE_DIR}/.." "stdlib_test.fypp" outFiles) +add_library("${PROJECT_NAME}-testing" "${outFiles}") +target_link_libraries("${PROJECT_NAME}-testing" PUBLIC "${PROJECT_NAME}") +set_target_properties( + "${PROJECT_NAME}-testing" PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} +) +target_include_directories( + "${PROJECT_NAME}-testing" PUBLIC + $ +) + macro(ADDTEST name) add_executable(test_${name} test_${name}.f90) - target_link_libraries(test_${name} ${PROJECT_NAME}) + target_link_libraries(test_${name} "${PROJECT_NAME}-testing") add_test(NAME ${name} COMMAND $ ${CMAKE_CURRENT_BINARY_DIR} WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) @@ -16,6 +28,7 @@ add_subdirectory(sorting) add_subdirectory(stats) add_subdirectory(string) add_subdirectory(system) +add_subdirectory(test) add_subdirectory(quadrature) add_subdirectory(math) diff --git a/src/tests/Makefile.manual b/src/tests/Makefile.manual index 7ab184016..91504d120 100644 --- a/src/tests/Makefile.manual +++ b/src/tests/Makefile.manual @@ -1,6 +1,15 @@ .PHONY: all clean test -all test clean: +LIB = libstdlib-testing.a +SRCFYPP = stdlib_test.fypp +SRCGEN = $(SRCFYPP:.fypp=.f90) +SRC = $(SRCGEN) +OBJS = $(SRC:.f90=.o) +MODS = $(OBJS:.o=.mod) + +all test:: $(LIB) + +all test clean:: $(MAKE) -f Makefile.manual --directory=ascii $@ $(MAKE) -f Makefile.manual --directory=bitsets $@ $(MAKE) -f Makefile.manual --directory=io $@ @@ -10,4 +19,17 @@ all test clean: $(MAKE) -f Makefile.manual --directory=quadrature $@ $(MAKE) -f Makefile.manual --directory=stats $@ $(MAKE) -f Makefile.manual --directory=string $@ + $(MAKE) -f Makefile.manual --directory=test $@ $(MAKE) -f Makefile.manual --directory=math $@ + +$(LIB): $(OBJS) + ar rcs $@ $^ + +clean:: + $(RM) $(LIB) $(OBJS) $(MODS) $(SRCGEN) + +%.o: %.f90 + $(FC) $(FFLAGS) -I.. -c $< + +$(SRCGEN): %.f90: %.fypp ../common.fypp + fypp $(FYPPFLAGS) -I.. $< $@ diff --git a/src/tests/Makefile.manual.test.mk b/src/tests/Makefile.manual.test.mk index ee0eed31e..3aba355e1 100644 --- a/src/tests/Makefile.manual.test.mk +++ b/src/tests/Makefile.manual.test.mk @@ -1,8 +1,8 @@ # Common Makefile rules that are included from each test subdirectory's # Makefile -CPPFLAGS += -I../.. -LDFLAGS += -L../.. -lstdlib +CPPFLAGS += -I../.. -I.. +LDFLAGS += -L../.. -L.. -lstdlib-testing -lstdlib OBJS = $(PROGS_SRC:.f90=.o) PROGS = $(OBJS:.o=) diff --git a/src/tests/ascii/test_ascii.f90 b/src/tests/ascii/test_ascii.f90 index 9ea29d5f7..f2542f5eb 100644 --- a/src/tests/ascii/test_ascii.f90 +++ b/src/tests/ascii/test_ascii.f90 @@ -1,6 +1,5 @@ -program test_ascii - - use stdlib_error, only: check +module test_ascii + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_ascii, only: lowercase, uppercase, digits, & octal_digits, fullhex_digits, hex_digits, lowerhex_digits, & whitespace, letters, is_alphanum, is_alpha, is_lower, is_upper, & @@ -9,312 +8,336 @@ program test_ascii to_lower, to_upper, to_title, to_sentence, reverse, LF, TAB, NUL, DEL, & to_string use stdlib_kinds, only : int8, int16, int32, int64, lk, c_bool - implicit none + private - print *, "Lowercase letters: ", lowercase - print *, "Uppercase letters: ", uppercase - print *, "Digits: ", digits - print *, "Octal digits: ", octal_digits - print *, "Full hex digits: ", fullhex_digits - print *, "Hex digits: ", hex_digits - print *, "Lower hex digits: ", lowerhex_digits - - call test_is_alphanum_short - call test_is_alphanum_long - - call test_is_alpha_short - call test_is_alpha_long - - call test_is_lower_short - call test_is_lower_long - - call test_is_upper_short - call test_is_upper_long - - call test_is_digit_short - call test_is_digit_long - - call test_is_octal_digit_short - call test_is_octal_digit_long - - call test_is_hex_digit_short - call test_is_hex_digit_long - - call test_is_white_short - call test_is_white_long - - call test_is_blank_short - call test_is_blank_long - - call test_is_control_short - call test_is_control_long - - call test_is_punctuation_short - call test_is_punctuation_long - - call test_is_graphical_short - call test_is_graphical_long - - call test_is_printable_short - call test_is_printable_long - - call test_is_ascii_short - call test_is_ascii_long - - call test_to_lower_short - call test_to_lower_long - - call test_to_upper_short - call test_to_upper_long - - ! call test_ascii_table - - call test_to_upper_string - call test_to_lower_string - call test_to_title_string - call test_to_sentence_string - call test_reverse_string - - call test_to_string + public :: collect_ascii contains - subroutine test_is_alphanum_short - print *, "test_is_alphanum_short" - call check(is_alphanum('A')) - call check(is_alphanum('1')) - call check(.not. is_alphanum('#')) - + !> Collect all exported unit tests + subroutine collect_ascii(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("is_alphanum_short", test_is_alphanum_short), & + new_unittest("is_alphanum_long", test_is_alphanum_long), & + new_unittest("is_alpha_short", test_is_alpha_short), & + new_unittest("is_alpha_long", test_is_alpha_long), & + new_unittest("is_lower_short", test_is_lower_short), & + new_unittest("is_lower_long", test_is_lower_long), & + new_unittest("is_upper_short", test_is_upper_short), & + new_unittest("is_upper_long", test_is_upper_long), & + new_unittest("is_digit_short", test_is_digit_short), & + new_unittest("is_digit_long", test_is_digit_long), & + new_unittest("is_octal_digit_short", test_is_octal_digit_short), & + new_unittest("is_octal_digit_long", test_is_octal_digit_long), & + new_unittest("is_hex_digit_short", test_is_hex_digit_short), & + new_unittest("is_hex_digit_long", test_is_hex_digit_long), & + new_unittest("is_white_short", test_is_white_short), & + new_unittest("is_white_long", test_is_white_long), & + new_unittest("is_blank_short", test_is_blank_short), & + new_unittest("is_blank_long", test_is_blank_long), & + new_unittest("is_control_short", test_is_control_short), & + new_unittest("is_control_long", test_is_control_long), & + new_unittest("is_punctuation_short", test_is_punctuation_short), & + new_unittest("is_punctuation_long", test_is_punctuation_long), & + new_unittest("is_graphical_short", test_is_graphical_short), & + new_unittest("is_graphical_long", test_is_graphical_long), & + new_unittest("is_printable_short", test_is_printable_short), & + new_unittest("is_printable_long", test_is_printable_long), & + new_unittest("is_ascii_short", test_is_ascii_short), & + new_unittest("is_ascii_long", test_is_ascii_long), & + new_unittest("to_lower_short", test_to_lower_short), & + new_unittest("to_lower_long", test_to_lower_long), & + new_unittest("to_upper_short", test_to_upper_short), & + new_unittest("to_upper_long", test_to_upper_long), & + new_unittest("to_upper_string", test_to_upper_string), & + new_unittest("to_lower_string", test_to_lower_string), & + new_unittest("to_title_string", test_to_title_string), & + new_unittest("to_sentence_string", test_to_sentence_string), & + new_unittest("reverse_string", test_reverse_string), & + new_unittest("to_string", test_to_string) & + ] + end subroutine collect_ascii + + subroutine test_is_alphanum_short(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, is_alphanum('A')) + call check(error, is_alphanum('1')) + call check(error, .not. is_alphanum('#')) ! N.B.: does not return true for non-ASCII Unicode alphanumerics - call check(.not. is_alphanum('á')) + call check(error, .not. is_alphanum('á')) end subroutine - subroutine test_is_alphanum_long + subroutine test_is_alphanum_long(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i character(len=:), allocatable :: clist - print *, "test_is_alphanum_long" - clist = digits//octal_digits//fullhex_digits//letters//lowercase//uppercase do i = 1, len(clist) - call check(is_alphanum(clist(i:i))) + call check(error, is_alphanum(clist(i:i))) end do clist = whitespace do i = 1, len(clist) - call check(.not. is_alphanum(clist(i:i))) + call check(error, .not. is_alphanum(clist(i:i))) end do end subroutine - subroutine test_is_alpha_short - print *, "test_is_alpha_short" - call check(is_alpha('A')) - call check(.not. is_alpha('1')) - call check(.not. is_alpha('#')) + subroutine test_is_alpha_short(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, is_alpha('A')) + call check(error, .not. is_alpha('1')) + call check(error, .not. is_alpha('#')) ! N.B.: does not return true for non-ASCII Unicode alphabetic characters - call check(.not. is_alpha('á')) + call check(error, .not. is_alpha('á')) end subroutine - subroutine test_is_alpha_long + subroutine test_is_alpha_long(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i character(len=:), allocatable :: clist - print *, "test_is_alpha_long" - clist = letters//lowercase//uppercase do i = 1, len(clist) - call check(is_alpha(clist(i:i))) + call check(error, is_alpha(clist(i:i))) end do clist = digits//octal_digits//whitespace do i = 1, len(clist) - call check(.not. is_alpha(clist(i:i))) + call check(error, .not. is_alpha(clist(i:i))) end do end subroutine - subroutine test_is_lower_short - print *, "test_is_lower_short" - call check(is_lower('a')) - call check(.not. is_lower('A')) - call check(.not. is_lower('#')) + subroutine test_is_lower_short(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, is_lower('a')) + call check(error, .not. is_lower('A')) + call check(error, .not. is_lower('#')) ! N.B.: does not return true for non-ASCII Unicode lowercase letters - call check(.not. is_lower('á')) - call check(.not. is_lower('Á')) + call check(error, .not. is_lower('á')) + call check(error, .not. is_lower('Á')) end subroutine - subroutine test_is_lower_long + subroutine test_is_lower_long(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i character(len=:), allocatable :: clist - print *, "test_is_lower_long" do i = 1, len(lowercase) - call check(is_lower(lowercase(i:i))) + call check(error, is_lower(lowercase(i:i))) end do clist = digits//uppercase//whitespace do i = 1, len(clist) - call check(.not. is_lower(clist(i:i))) + call check(error, .not. is_lower(clist(i:i))) end do end subroutine - subroutine test_is_upper_short - print *, "test_is_upper_short" - call check(is_upper('A')) - call check(.not. is_upper('a')) - call check(.not. is_upper('#')) + subroutine test_is_upper_short(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, is_upper('A')) + call check(error, .not. is_upper('a')) + call check(error, .not. is_upper('#')) ! N.B.: does not return true for non-ASCII Unicode uppercase letters - call check(.not. is_upper('á')) - call check(.not. is_upper('Á')) + call check(error, .not. is_upper('á')) + call check(error, .not. is_upper('Á')) end subroutine - subroutine test_is_upper_long + subroutine test_is_upper_long(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i character(len=:), allocatable :: clist - print *, "test_is_upper_long" + do i = 1, len(uppercase) - call check(is_upper(uppercase(i:i))) + call check(error, is_upper(uppercase(i:i))) end do clist = digits//lowercase//whitespace do i = 1, len(clist) - call check(.not. is_upper(clist(i:i))) + call check(error, .not. is_upper(clist(i:i))) end do end subroutine - subroutine test_is_digit_short - print *, "test_is_digit_short" - call check(is_digit('3')) - call check(is_digit('8')) - call check(.not. is_digit('B')) - call check(.not. is_digit('#')) + subroutine test_is_digit_short(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, is_digit('3')) + call check(error, is_digit('8')) + call check(error, .not. is_digit('B')) + call check(error, .not. is_digit('#')) ! N.B.: does not return true for non-ASCII Unicode numbers - call check(.not. is_digit('０')) ! full-width digit zero (U+FF10) - call check(.not. is_digit('４')) ! full-width digit four (U+FF14)) + call check(error, .not. is_digit('０')) ! full-width digit zero (U+FF10) + call check(error, .not. is_digit('４')) ! full-width digit four (U+FF14)) end subroutine - subroutine test_is_digit_long + subroutine test_is_digit_long(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i character(len=:), allocatable :: clist - print *, "test_is_digit_long" + do i = 1, len(digits) - call check(is_digit(digits(i:i))) + call check(error, is_digit(digits(i:i))) end do clist = letters//whitespace do i = 1, len(clist) - call check(.not. is_digit(clist(i:i))) + call check(error, .not. is_digit(clist(i:i))) end do end subroutine - subroutine test_is_octal_digit_short - print *, "test_is_octal_digit_short" - call check(is_octal_digit('0')) - call check(is_octal_digit('7')) - call check(.not. is_octal_digit('8')) - call check(.not. is_octal_digit('A')) - call check(.not. is_octal_digit('#')) + subroutine test_is_octal_digit_short(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, is_octal_digit('0')) + call check(error, is_octal_digit('7')) + call check(error, .not. is_octal_digit('8')) + call check(error, .not. is_octal_digit('A')) + call check(error, .not. is_octal_digit('#')) end subroutine - subroutine test_is_octal_digit_long + subroutine test_is_octal_digit_long(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i character(len=:), allocatable :: clist - print *, "test_is_octal_digit_long" + do i = 1, len(octal_digits) - call check(is_octal_digit(octal_digits(i:i))) + call check(error, is_octal_digit(octal_digits(i:i))) end do clist = letters//'89'//whitespace do i = 1, len(clist) - call check(.not. is_octal_digit(clist(i:i))) + call check(error, .not. is_octal_digit(clist(i:i))) end do end subroutine - subroutine test_is_hex_digit_short - print *, "test_is_hex_digit_short" - call check(is_hex_digit('0')) - call check(is_hex_digit('A')) - call check(is_hex_digit('f')) !! lowercase hex digits are accepted - call check(.not. is_hex_digit('g')) - call check(.not. is_hex_digit('G')) - call check(.not. is_hex_digit('#')) + subroutine test_is_hex_digit_short(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, is_hex_digit('0')) + call check(error, is_hex_digit('A')) + call check(error, is_hex_digit('f')) !! lowercase hex digits are accepted + call check(error, .not. is_hex_digit('g')) + call check(error, .not. is_hex_digit('G')) + call check(error, .not. is_hex_digit('#')) end subroutine - subroutine test_is_hex_digit_long + subroutine test_is_hex_digit_long(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i character(len=:), allocatable :: clist - print *, "test_is_hex_digit_long" + do i = 1, len(fullhex_digits) - call check(is_hex_digit(fullhex_digits(i:i))) + call check(error, is_hex_digit(fullhex_digits(i:i))) end do clist = lowercase(7:)//uppercase(7:)//whitespace do i = 1, len(clist) - call check(.not. is_hex_digit(clist(i:i))) + call check(error, .not. is_hex_digit(clist(i:i))) end do end subroutine - subroutine test_is_white_short - print *, "test_is_white_short" - call check(is_white(' ')) - call check(is_white(TAB)) - call check(is_white(LF)) - call check(.not. is_white('1')) - call check(.not. is_white('a')) - call check(.not. is_white('#')) + subroutine test_is_white_short(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, is_white(' ')) + call check(error, is_white(TAB)) + call check(error, is_white(LF)) + call check(error, .not. is_white('1')) + call check(error, .not. is_white('a')) + call check(error, .not. is_white('#')) end subroutine - subroutine test_is_white_long + subroutine test_is_white_long(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i character(len=:), allocatable :: clist - print *, "test_is_white_long" + do i = 1, len(whitespace) - call check(is_white(whitespace(i:i))) + call check(error, is_white(whitespace(i:i))) end do clist = digits//letters do i = 1, len(clist) - call check(.not. is_white(clist(i:i))) + call check(error, .not. is_white(clist(i:i))) end do end subroutine - subroutine test_is_blank_short - print *, "test_is_blank_short" - call check(is_blank(' ')) - call check(is_blank(TAB)) - call check(.not. is_blank('1')) - call check(.not. is_blank('a')) - call check(.not. is_blank('#')) + subroutine test_is_blank_short(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, is_blank(' ')) + call check(error, is_blank(TAB)) + call check(error, .not. is_blank('1')) + call check(error, .not. is_blank('a')) + call check(error, .not. is_blank('#')) end subroutine - subroutine test_is_blank_long + subroutine test_is_blank_long(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i character(len=:), allocatable :: clist - print *, "test_is_blank_long" + do i = 1, len(whitespace) if (whitespace(i:i) == ' ' .or. whitespace(i:i) == TAB) then - call check(is_blank(whitespace(i:i))) + call check(error, is_blank(whitespace(i:i))) else - call check(.not. is_blank(whitespace(i:i))) + call check(error, .not. is_blank(whitespace(i:i))) end if end do clist = digits//letters do i = 1, len(clist) - call check(.not. is_blank(clist(i:i))) + call check(error, .not. is_blank(clist(i:i))) end do end subroutine - subroutine test_is_control_short - print *, "test_is_control_short" + subroutine test_is_control_short(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + ! print *, is_control('\0') ! print *, is_control('\022') - call check(is_control(new_line('a'))) ! newline is both whitespace and control - call check(.not. is_control(' ')) - call check(.not. is_control('1')) - call check(.not. is_control('a')) - call check(.not. is_control('#')) + call check(error, is_control(new_line('a'))) ! newline is both whitespace and control + call check(error, .not. is_control(' ')) + call check(error, .not. is_control('1')) + call check(error, .not. is_control('a')) + call check(error, .not. is_control('#')) ! N.B.: non-ASCII Unicode control characters are not recognized: ! print *, .not. is_control('\u0080') @@ -322,170 +345,203 @@ subroutine test_is_control_short ! print *, .not. is_control('\u2029') end subroutine - subroutine test_is_control_long + subroutine test_is_control_long(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i character(len=:), allocatable :: clist - print *, "test_is_control_long" + do i = 0, 31 - call check(is_control(achar(i))) + call check(error, is_control(achar(i))) end do - call check(is_control(DEL)) + call check(error, is_control(DEL)) clist = digits//letters//' ' do i = 1, len(clist) - call check(.not. is_control(clist(i:i))) + call check(error, .not. is_control(clist(i:i))) end do end subroutine - subroutine test_is_punctuation_short - print *, "test_is_punctuation_short" - call check(is_punctuation('.')) - call check(is_punctuation(',')) - call check(is_punctuation(':')) - call check(is_punctuation('!')) - call check(is_punctuation('#')) - call check(is_punctuation('~')) - call check(is_punctuation('+')) - call check(is_punctuation('_')) + subroutine test_is_punctuation_short(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, is_punctuation('.')) + call check(error, is_punctuation(',')) + call check(error, is_punctuation(':')) + call check(error, is_punctuation('!')) + call check(error, is_punctuation('#')) + call check(error, is_punctuation('~')) + call check(error, is_punctuation('+')) + call check(error, is_punctuation('_')) - call check(.not. is_punctuation('1')) - call check(.not. is_punctuation('a')) - call check(.not. is_punctuation(' ')) - call check(.not. is_punctuation(LF)) ! new line character - call check(.not. is_punctuation(NUL)) + call check(error, .not. is_punctuation('1')) + call check(error, .not. is_punctuation('a')) + call check(error, .not. is_punctuation(' ')) + call check(error, .not. is_punctuation(LF)) ! new line character + call check(error, .not. is_punctuation(NUL)) ! N.B.: Non-ASCII Unicode punctuation characters are not recognized. ! print *, is_punctuation('\u2012') ! (U+2012 = en-dash) end subroutine - subroutine test_is_punctuation_long + subroutine test_is_punctuation_long(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i character(len=1) :: c - print *, "test_is_punctuation_long" + do i = 0, 127 c = achar(i) if (is_control(c) .or. is_alphanum(c) .or. c == ' ') then - call check(.not. is_punctuation(c)) + call check(error, .not. is_punctuation(c)) else - call check(is_punctuation(c)) + call check(error, is_punctuation(c)) end if end do end subroutine - subroutine test_is_graphical_short - print *, "test_is_graphical" - call check(is_graphical('1')) - call check(is_graphical('a')) - call check(is_graphical('#')) - call check(.not. is_graphical(' ')) ! whitespace is not graphical - call check(.not. is_graphical(LF)) - call check(.not. is_graphical(NUL)) + subroutine test_is_graphical_short(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, is_graphical('1')) + call check(error, is_graphical('a')) + call check(error, is_graphical('#')) + call check(error, .not. is_graphical(' ')) ! whitespace is not graphical + call check(error, .not. is_graphical(LF)) + call check(error, .not. is_graphical(NUL)) ! N.B.: Unicode graphical characters are not regarded as such. - call check(.not. is_graphical('ä')) + call check(error, .not. is_graphical('ä')) end subroutine - subroutine test_is_graphical_long + subroutine test_is_graphical_long(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i character(len=1) :: c - print *, "test_is_graphical_long" + do i = 0, 127 c = achar(i) if (is_control(c) .or. c == ' ') then - call check(.not. is_graphical(c)) + call check(error, .not. is_graphical(c)) else - call check(is_graphical(c)) + call check(error, is_graphical(c)) end if end do end subroutine - subroutine test_is_printable_short - print *, "test_is_printable_short" - call check(is_printable(' ')) ! whitespace is printable - call check(is_printable('1')) - call check(is_printable('a')) - call check(is_printable('#')) - call check(.not. is_printable(NUL)) ! control characters are not printable + subroutine test_is_printable_short(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, is_printable(' ')) ! whitespace is printable + call check(error, is_printable('1')) + call check(error, is_printable('a')) + call check(error, is_printable('#')) + call check(error, .not. is_printable(NUL)) ! control characters are not printable ! N.B.: Printable non-ASCII Unicode characters are not recognized. - call check(.not. is_printable('ä')) + call check(error, .not. is_printable('ä')) end subroutine - subroutine test_is_printable_long + subroutine test_is_printable_long(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i character(len=1) :: c - print *, "test_is_printable_long" + do i = 0, 127 c = achar(i) if (is_control(c)) then - call check(.not. is_printable(c)) + call check(error, .not. is_printable(c)) else - call check(is_printable(c)) + call check(error, is_printable(c)) end if end do end subroutine - subroutine test_is_ascii_short() - print *, "test_is_ascii_short" - call check(is_ascii('a')) - call check(.not. is_ascii('ä')) + subroutine test_is_ascii_short(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, is_ascii('a')) + call check(error, .not. is_ascii('ä')) end subroutine - subroutine test_is_ascii_long() + subroutine test_is_ascii_long(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i - print *, "test_is_ascii_long" + do i = 0, 127 - call check(is_ascii(achar(i))) + call check(error, is_ascii(achar(i))) end do - call check(.not. is_ascii(achar(128))) ! raises compiler warning + call check(error, .not. is_ascii(achar(128))) ! raises compiler warning end subroutine - subroutine test_to_lower_short() - print *, "test_to_lower_short" - call check(to_lower('a') == 'a') - call check(to_lower('A') == 'a') - call check(to_lower('#') == '#') + subroutine test_to_lower_short(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, to_lower('a'), 'a') + call check(error, to_lower('A'), 'a') + call check(error, to_lower('#'), '#') end subroutine - subroutine test_to_lower_long() + subroutine test_to_lower_long(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i character(len=1) :: c - print *, "test_to_lower_long" + do i = 1, len(uppercase) - call check(to_lower(uppercase(i:i)) == lowercase(i:i)) + call check(error, to_lower(uppercase(i:i)), lowercase(i:i)) end do do i = 0, 127 c = achar(i) if (c < 'A' .or. c > 'Z') then - call check(to_lower(c) == c) + call check(error, to_lower(c), c) else - call check(to_lower(c) /= c) + call check(error, to_lower(c) /= c) end if end do end subroutine - subroutine test_to_upper_short() - print *, "test_to_upper_short" - call check(to_upper('a') == 'A') - call check(to_upper('A') == 'A') - call check(to_upper('#') == '#') + subroutine test_to_upper_short(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, to_upper('a'), 'A') + call check(error, to_upper('A'), 'A') + call check(error, to_upper('#'), '#') end subroutine - subroutine test_to_upper_long() + subroutine test_to_upper_long(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i character(len=1) :: c - print *, "test_to_upper_long" + do i = 1, len(lowercase) - call check(to_upper(lowercase(i:i)) == uppercase(i:i)) + call check(error, to_upper(lowercase(i:i)), uppercase(i:i)) end do do i = 0, 127 c = achar(i) if (c < 'a' .or. c > 'z') then - call check(to_upper(c) == c) + call check(error, to_upper(c), c) else - call check(to_upper(c) /= c) + call check(error, to_upper(c) /= c) end if end do end subroutine @@ -550,137 +606,182 @@ pure logical function validation_func_interface(c) write(*,'(5X,12(I4))') (count(table(:,i)),i=1,12) end subroutine test_ascii_table - subroutine test_to_lower_string + subroutine test_to_lower_string(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + character(len=:), allocatable :: dlc character(len=32), parameter :: input = "UPPERCASE" dlc = to_lower("UPPERCASE") - call check(dlc == "uppercase") + call check(error, dlc, "uppercase") dlc = to_lower(input) - call check(len(dlc) == 32) - call check(len_trim(dlc) == 9) - call check(trim(dlc) == "uppercase") + call check(error, len(dlc), 32) + call check(error, len_trim(dlc), 9) + call check(error, trim(dlc), "uppercase") dlc = to_lower("0123456789ABCDE") - call check(dlc == "0123456789abcde") + call check(error, dlc, "0123456789abcde") end subroutine test_to_lower_string - subroutine test_to_upper_string + subroutine test_to_upper_string(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + character(len=:), allocatable :: dlc character(len=32), parameter :: input = "lowercase" dlc = to_upper("lowercase") - call check(dlc == "LOWERCASE") + call check(error, dlc, "LOWERCASE") dlc = to_upper(input) - call check(len(dlc) == 32) - call check(len_trim(dlc) == 9) - call check(trim(dlc) == "LOWERCASE") + call check(error, len(dlc), 32) + call check(error, len_trim(dlc), 9) + call check(error, trim(dlc), "LOWERCASE") dlc = to_upper("0123456789abcde") - call check(dlc == "0123456789ABCDE") + call check(error, dlc, "0123456789ABCDE") end subroutine test_to_upper_string - subroutine test_to_title_string + subroutine test_to_title_string(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + character(len=:), allocatable :: dlc character(len=32), parameter :: input = "tHis Is tO bE tiTlEd" dlc = to_title("tHis Is tO bE tiTlEd") - call check(dlc == "This Is To Be Titled") + call check(error, dlc, "This Is To Be Titled") dlc = to_title(input) - call check(len(dlc) == 32) - call check(len_trim(dlc) == 20) - call check(trim(dlc) == "This Is To Be Titled") + call check(error, len(dlc), 32) + call check(error, len_trim(dlc), 20) + call check(error, trim(dlc), "This Is To Be Titled") dlc = to_title(" s P a C e D !") - call check(dlc == " S P A C E D !") + call check(error, dlc, " S P A C E D !") dlc = to_title("1st, 2nD, 3RD") - call check(dlc == "1st, 2nd, 3rd") + call check(error, dlc, "1st, 2nd, 3rd") dlc = to_title("""quOTed""") - call check(dlc == """Quoted""") + call check(error, dlc, """Quoted""") end subroutine test_to_title_string - subroutine test_to_sentence_string + subroutine test_to_sentence_string(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + character(len=:), allocatable :: dlc character(len=32), parameter :: input = "tHis iS A seNteNcE." dlc = to_sentence("tHis iS A seNteNcE.") - call check(dlc == "This is a sentence.") + call check(error, dlc, "This is a sentence.") dlc = to_sentence(input) - call check(len(dlc) == 32) - call check(len_trim(dlc) == 19) - call check(trim(dlc) == "This is a sentence.") + call check(error, len(dlc), 32) + call check(error, len_trim(dlc), 19) + call check(error, trim(dlc), "This is a sentence.") dlc = to_sentence(" s P a C e D !") - call check(dlc == " S p a c e d !") + call check(error, dlc, " S p a c e d !") dlc = to_sentence("1st, 2nd, 3rd") - call check(dlc == "1st, 2nd, 3rd") + call check(error, dlc, "1st, 2nd, 3rd") dlc = to_sentence("""quOTed""") - call check(dlc == """Quoted""") + call check(error, dlc, """Quoted""") end subroutine test_to_sentence_string - subroutine test_reverse_string + subroutine test_reverse_string(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + character(len=:), allocatable :: dlc character(len=32), parameter :: input = "reversed" dlc = reverse("reversed") - call check(dlc == "desrever") + call check(error, dlc, "desrever") dlc = reverse(input) - call check(len(dlc) == 32) - call check(len_trim(dlc) == 32) - call check(trim(dlc) == " desrever") - call check(trim(adjustl(dlc)) == "desrever") + call check(error, len(dlc), 32) + call check(error, len_trim(dlc), 32) + call check(error, trim(dlc), " desrever") + call check(error, trim(adjustl(dlc)), "desrever") end subroutine test_reverse_string - subroutine test_to_string - character(len=128) :: flc + subroutine test_to_string(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - write(flc, '(g0)') 1026192 - call check(to_string(1026192) == trim(flc)) + character(len=128) :: flc - write(flc, '(g0)') -124784 - call check(to_string(-124784) == trim(flc)) + write(flc, '(g0)') 1026192 + call check(error, to_string(1026192), trim(flc)) - write(flc, '(g0)') 1_int8 - call check(to_string(1_int8) == trim(flc)) + write(flc, '(g0)') -124784 + call check(error, to_string(-124784), trim(flc)) - write(flc, '(g0)') -3_int8 - call check(to_string(-3_int8) == trim(flc)) + write(flc, '(g0)') 1_int8 + call check(error, to_string(1_int8), trim(flc)) - write(flc, '(g0)') 80_int16 - call check(to_string(80_int16) == trim(flc)) + write(flc, '(g0)') -3_int8 + call check(error, to_string(-3_int8), trim(flc)) - write(flc, '(g0)') 8924890_int32 - call check(to_string(8924890_int32) == trim(flc)) + write(flc, '(g0)') 80_int16 + call check(error, to_string(80_int16), trim(flc)) - write(flc, '(g0)') -2378401_int32 - call check(to_string(-2378401_int32) == trim(flc)) + write(flc, '(g0)') 8924890_int32 + call check(error, to_string(8924890_int32), trim(flc)) - write(flc, '(g0)') -921092378401_int64 - call check(to_string(-921092378401_int64) == trim(flc)) + write(flc, '(g0)') -2378401_int32 + call check(error, to_string(-2378401_int32), trim(flc)) - write(flc, '(g0)') 1272835771_int64 - call check(to_string(1272835771_int64) == trim(flc)) + write(flc, '(g0)') -921092378401_int64 + call check(error, to_string(-921092378401_int64), trim(flc)) - write(flc, '(g0)') .true. - call check(to_string(.true.) == trim(flc)) + write(flc, '(g0)') 1272835771_int64 + call check(error, to_string(1272835771_int64), trim(flc)) - write(flc, '(g0)') .false. - call check(to_string(.false.) == trim(flc)) + write(flc, '(g0)') .true. + call check(error, to_string(.true.), trim(flc)) - write(flc, '(g0)') .true._c_bool - call check(to_string(.true._c_bool) == trim(flc)) + write(flc, '(g0)') .false. + call check(error, to_string(.false.), trim(flc)) - write(flc, '(g0)') .false._lk - call check(to_string(.false._lk) == trim(flc)) + write(flc, '(g0)') .true._c_bool + call check(error, to_string(.true._c_bool), trim(flc)) + + write(flc, '(g0)') .false._lk + call check(error, to_string(.false._lk), trim(flc)) end subroutine test_to_string -end program test_ascii +end module test_ascii + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_ascii, only : collect_ascii + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("ascii", collect_ascii) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program diff --git a/src/tests/stdlib_test.fypp b/src/tests/stdlib_test.fypp new file mode 100644 index 000000000..d0cc832f3 --- /dev/null +++ b/src/tests/stdlib_test.fypp @@ -0,0 +1,874 @@ +! SPDX-Identifier: MIT + +#:include "common.fypp" + +!> Provides a light-weight procedural testing framework for Fortran's stdlib. +!> +!> Testsuites are defined by a [[collect_interface]] returning a set of +!> [[unittest_type]] objects. To create a new test use the [[new_unittest]] +!> constructor, which requires a test identifier and a procedure with a +!> [[test_interface]] compatible signature. The error status is communicated +!> by the allocation status of an [[error_type]]. +!> +!> The necessary boilerplate code to setup the test entry point is just +!> +!>```fortran +!>program tester +!> use, intrinsic :: iso_fortran_env, only : error_unit +!> use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type +!> use test_suite1, only : collect_suite1 +!> use test_suite2, only : collect_suite2 +!> implicit none +!> integer :: stat, is +!> type(testsuite_type), allocatable :: testsuites(:) +!> character(len=*), parameter :: fmt = '("#", *(1x, a))' +!> +!> stat = 0 +!> +!> testsuites = [ & +!> new_testsuite("suite1", collect_suite1), & +!> new_testsuite("suite2", collect_suite2) & +!> ] +!> +!> do is = 1, size(testsuites) +!> write(error_unit, fmt) "Testing:", testsuites(is)%name +!> call run_testsuite(testsuites(is)%collect, error_unit, stat) +!> end do +!> +!> if (stat > 0) then +!> write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" +!> error stop +!> end if +!> +!>end program tester +!>``` +!> +!> Every test is defined in a separate module using a ``collect`` function, which +!> is exported and added to the ``testsuites`` array in the test runner. +!> All test have a simple interface with just an allocatable [[error_type]] as +!> output to provide the test results. +!> +!>```fortran +!>module test_suite1 +!> use stdlib_test, only : new_unittest, unittest_type, error_type, check +!> implicit none +!> private +!> +!> public :: collect_suite1 +!> +!>contains +!> +!>!> Collect all exported unit tests +!>subroutine collect_suite1(testsuite) +!> !> Collection of tests +!> type(unittest_type), allocatable, intent(out) :: testsuite(:) +!> +!> testsuite = [ & +!> new_unittest("valid", test_valid), & +!> new_unittest("invalid", test_invalid, should_fail=.true.) & +!> ] +!> +!>end subroutine collect_suite1 +!> +!>subroutine test_valid(error) +!> type(error_type), allocatable, intent(out) :: error +!> ! ... +!>end subroutine test_valid +!> +!>subroutine test_invalid(error) +!> type(error_type), allocatable, intent(out) :: error +!> ! ... +!>end subroutine test_invalid +!> +!>end module test_suite1 +!>``` +!> +!> For an example setup checkout the ``test/`` directory in this project. +module stdlib_test + use, intrinsic :: iso_fortran_env, only : error_unit + use, intrinsic :: ieee_arithmetic, only : ieee_is_nan + use stdlib_ascii, only : to_string + use stdlib_kinds, only : sp, dp, qp, int8, int16, int32, int64 + use stdlib_optval, only : optval + implicit none + private + + public :: run_testsuite, run_selected, new_unittest, new_testsuite + public :: select_test, select_suite + public :: unittest_type, testsuite_type, error_type + public :: check, test_failed, skip_test + public :: test_interface, collect_interface + public :: get_argument, get_variable + + + !> Status code for success + integer, parameter :: success = 0 + + !> Status code for failure + integer, parameter :: fatal = 1 + + !> Status code for skipping a test + integer, parameter :: skipped = 77 + + + !> Error message + type :: error_type + !> Error code + integer :: stat = success + !> Payload of the error + character(len=:), allocatable :: message + contains + !> Escalate uncaught errors + final :: escalate_error + end type error_type + + + interface check + module procedure :: check_stat + module procedure :: check_logical + #:for kind in REAL_KINDS + module procedure :: check_float_${kind}$ + module procedure :: check_float_exceptional_${kind}$ + #:endfor + #:for kind in CMPLX_KINDS + module procedure :: check_complex_${kind}$ + module procedure :: check_complex_exceptional_${kind}$ + #:endfor + #:for kind in INT_KINDS + module procedure :: check_int_${kind}$ + #:endfor + module procedure :: check_bool + module procedure :: check_string + end interface check + + + interface to_string + #:for kind in REAL_KINDS + module procedure :: real_${kind}$_to_string + #:endfor + #:for kind in CMPLX_KINDS + module procedure :: complex_${kind}$_to_string + #:endfor + end interface to_string + + + abstract interface + !> Entry point for tests + subroutine test_interface(error) + import :: error_type + !> Error handling + type(error_type), allocatable, intent(out) :: error + end subroutine test_interface + end interface + + + !> Declaration of a unit test + type :: unittest_type + !> Name of the test + character(len=:), allocatable :: name + !> Entry point of the test + procedure(test_interface), pointer, nopass :: test => null() + !> Whether test is supposed to fail + logical :: should_fail = .false. + end type unittest_type + + + abstract interface + !> Collect all tests + subroutine collect_interface(testsuite) + import :: unittest_type + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + end subroutine collect_interface + end interface + + + !> Collection of unit tests + type :: testsuite_type + !> Name of the testsuite + character(len=:), allocatable :: name + !> Entry point of the test + procedure(collect_interface), pointer, nopass :: collect => null() + end type testsuite_type + + + character(len=*), parameter :: fmt = '(1x, *(1x, a))' + + +contains + + + !> Driver for testsuite + recursive subroutine run_testsuite(collect, unit, stat) + !> Collect tests + procedure(collect_interface) :: collect + !> Unit for IO + integer, intent(in) :: unit + !> Number of failed tests + integer, intent(inout) :: stat + + type(unittest_type), allocatable :: testsuite(:) + integer :: it + + call collect(testsuite) + + !$omp parallel do schedule(dynamic) shared(testsuite, unit) reduction(+:stat) + do it = 1, size(testsuite) + !$omp critical(testdrive_testsuite) + write(unit, '(1x, 3(1x, a), 1x, "(", i0, "/", i0, ")")') & + & "Starting", testsuite(it)%name, "...", it, size(testsuite) + !$omp end critical(testdrive_testsuite) + call run_unittest(testsuite(it), unit, stat) + end do + + end subroutine run_testsuite + + + !> Driver for selective testing + recursive subroutine run_selected(collect, name, unit, stat) + !> Collect tests + procedure(collect_interface) :: collect + !> Name of the selected test + character(len=*), intent(in) :: name + !> Unit for IO + integer, intent(in) :: unit + !> Number of failed tests + integer, intent(inout) :: stat + + type(unittest_type), allocatable :: testsuite(:) + integer :: it + + call collect(testsuite) + + it = select_test(testsuite, name) + + if (it > 0 .and. it <= size(testsuite)) then + call run_unittest(testsuite(it), unit, stat) + else + write(unit, fmt) "Available tests:" + do it = 1, size(testsuite) + write(unit, fmt) "-", testsuite(it)%name + end do + stat = -huge(it) + end if + + end subroutine run_selected + + + !> Run a selected unit test + recursive subroutine run_unittest(test, unit, stat) + !> Unit test + type(unittest_type), intent(in) :: test + !> Unit for IO + integer, intent(in) :: unit + !> Number of failed tests + integer, intent(inout) :: stat + + type(error_type), allocatable :: error + character(len=:), allocatable :: message + + call test%test(error) + if (.not.test_skipped(error) .and. allocated(error) .neqv. test%should_fail) then + stat = stat + 1 + end if + call make_output(message, test, error) + !$omp critical(testdrive_testsuite) + write(unit, '(a)') message + !$omp end critical(testdrive_testsuite) + if (allocated(error)) then + call clear_error(error) + end if + + end subroutine run_unittest + + + pure function test_skipped(error) result(is_skipped) + !> Error handling + type(error_type), intent(in), optional :: error + !> Test was skipped + logical :: is_skipped + + is_skipped = .false. + if (present(error)) then + is_skipped = error%stat == skipped + end if + end function test_skipped + + + !> Create output message for test (this procedure is pure and therefore cannot launch tests) + pure subroutine make_output(output, test, error) + !> Output message for display + character(len=:), allocatable, intent(out) :: output + !> Unit test + type(unittest_type), intent(in) :: test + !> Error handling + type(error_type), intent(in), optional :: error + + character(len=:), allocatable :: label + character(len=*), parameter :: indent = repeat(" ", 7) // repeat(".", 3) // " " + + if (test_skipped(error)) then + output = indent // test%name // " [SKIPPED]" & + & // new_line("a") // " Message: " // error%message + return + end if + + if (present(error) .neqv. test%should_fail) then + if (test%should_fail) then + label = " [UNEXPECTED PASS]" + else + label = " [FAILED]" + end if + else + if (test%should_fail) then + label = " [EXPECTED FAIL]" + else + label = " [PASSED]" + end if + end if + output = indent // test%name // label + if (present(error)) then + output = output // new_line("a") // " Message: " // error%message + end if + end subroutine make_output + + + !> Select a unit test from all available tests + function select_test(tests, name) result(pos) + !> Name identifying the test suite + character(len=*), intent(in) :: name + !> Available unit tests + type(unittest_type) :: tests(:) + !> Selected test suite + integer :: pos + + integer :: it + + pos = 0 + do it = 1, size(tests) + if (name == tests(it)%name) then + pos = it + exit + end if + end do + + end function select_test + + + !> Select a test suite from all available suites + function select_suite(suites, name) result(pos) + !> Name identifying the test suite + character(len=*), intent(in) :: name + !> Available test suites + type(testsuite_type) :: suites(:) + !> Selected test suite + integer :: pos + + integer :: it + + pos = 0 + do it = 1, size(suites) + if (name == suites(it)%name) then + pos = it + exit + end if + end do + + end function select_suite + + + !> Register a new unit test + function new_unittest(name, test, should_fail) result(self) + !> Name of the test + character(len=*), intent(in) :: name + !> Entry point for the test + procedure(test_interface) :: test + !> Whether test is supposed to error or not + logical, intent(in), optional :: should_fail + + !> Newly registered test + type(unittest_type) :: self + + self%name = name + self%test => test + if (present(should_fail)) self%should_fail = should_fail + + end function new_unittest + + + !> Register a new testsuite + function new_testsuite(name, collect) result(self) + !> Name of the testsuite + character(len=*), intent(in) :: name + !> Entry point to collect tests + procedure(collect_interface) :: collect + + !> Newly registered testsuite + type(testsuite_type) :: self + + self%name = name + self%collect => collect + + end function new_testsuite + + + !> Check whether a status value is in error, we assume non-zero values are errors. + !> + !> Generate a generic error message, since we cannot recover the context of status. + subroutine check_stat(error, stat, message, more) + !> Error handling + type(error_type), allocatable, intent(out) :: error + !> Status of operation + integer, intent(in) :: stat + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (stat /= success) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Non-zero exit code encountered", more) + end if + end if + + end subroutine check_stat + + + !> Check whether a logical expression has evaluated to a truthy value. + !> + !> Generate a generic error message, since we cannot recover the expression here. + subroutine check_logical(error, expression, message, more) + !> Error handling + type(error_type), allocatable, intent(out) :: error + !> Result of logical operator + logical, intent(in) :: expression + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (.not.expression) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Condition not fullfilled", more) + end if + end if + end subroutine check_logical + + +#:for kind in REAL_KINDS + subroutine check_float_${kind}$(error, actual, expected, message, more, thr, rel) + integer, parameter :: wp = ${kind}$ + !> Error handling + type(error_type), allocatable, intent(out) :: error + !> Found floating point value + real(wp), intent(in) :: actual + !> Expected floating point value + real(wp), 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(wp), intent(in), optional :: thr + !> Check for relative errors instead + logical, intent(in), optional :: rel + + logical :: relative + real(wp) :: diff, threshold + + call check(error, actual, message, more) + if (allocated(error)) return + + threshold = optval(thr, epsilon(expected)) + relative = optval(rel, .false.) + + 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 "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(int(diff*100))//"%)", & + more) + else + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(diff)//")", & + more) + end if + end if + end if + + end subroutine check_float_${kind}$ +#:endfor + + +#:for kind in REAL_KINDS + subroutine check_float_exceptional_${kind}$(error, actual, message, more) + integer, parameter :: wp = ${kind}$ + !> Error handling + type(error_type), allocatable, intent(out) :: error + !> Found floating point value + real(wp), 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 (ieee_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_${kind}$ +#:endfor + + +#:for kind in CMPLX_KINDS + subroutine check_complex_${kind}$(error, actual, expected, message, more, thr, rel) + integer, parameter :: wp = ${kind}$ + !> Error handling + type(error_type), allocatable, intent(out) :: error + !> Found floating point value + complex(wp), intent(in) :: actual + !> Expected floating point value + complex(wp), 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(wp), intent(in), optional :: thr + !> Check for relative errors instead + logical, intent(in), optional :: rel + + logical :: relative + real(wp) :: diff, threshold + + call check(error, actual, message, more) + if (allocated(error)) return + + threshold = optval(thr, epsilon(expected%re)) + relative = optval(rel, .false.) + + 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 "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(int(diff*100))//"%)", & + more) + else + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(diff)//")", & + more) + end if + end if + end if + + end subroutine check_complex_${kind}$ +#:endfor + + +#:for kind in CMPLX_KINDS + subroutine check_complex_exceptional_${kind}$(error, actual, message, more) + integer, parameter :: wp = ${kind}$ + !> Error handling + type(error_type), allocatable, intent(out) :: error + !> Found floating point value + complex(wp), 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 (ieee_is_nan(actual%re) .or. ieee_is_nan(actual%im)) 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_${kind}$ +#:endfor + + +#:for kind in INT_KINDS + subroutine check_int_${kind}$(error, actual, expected, message, more) + integer, parameter :: ik = ${kind}$ + !> Error handling + type(error_type), allocatable, intent(out) :: error + !> Found integer value + integer(ik), intent(in) :: actual + !> Expected integer value + integer(ik), 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 + + if (expected /= actual) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, & + "Integer value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual), & + more) + end if + end if + + end subroutine check_int_${kind}$ +#:endfor + + + subroutine check_bool(error, actual, expected, message, more) + !> Error handling + type(error_type), allocatable, intent(out) :: error + !> Found boolean value + logical, intent(in) :: actual + !> Expected boolean value + logical, 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 + + if (expected .neqv. actual) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, & + "Logical value missmatch", & + "expected "//merge("T", "F", expected)//" but got "//merge("T", "F", actual), & + more) + end if + end if + + end subroutine check_bool + + + subroutine check_string(error, actual, expected, message, more) + !> Error handling + type(error_type), allocatable, intent(out) :: error + !> Found boolean value + character(len=*), intent(in) :: actual + !> Expected boolean value + character(len=*), 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 + + if (expected /= actual) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, & + "Character value missmatch", & + "expected '"//expected//"' but got '"//actual//"'", & + more) + end if + end if + + end subroutine check_string + + + subroutine test_failed(error, message, more, and_more) + !> Error handling + type(error_type), allocatable, intent(out) :: error + !> A detailed message describing the error + character(len=*), intent(in) :: message + !> Another line of error message + character(len=*), intent(in), optional :: more + !> Another line of error message + character(len=*), intent(in), optional :: and_more + + character(len=*), parameter :: skip = new_line("a") // repeat(" ", 11) + + allocate(error) + error%stat = fatal + + error%message = message + if (present(more)) then + error%message = error%message // skip // more + end if + if (present(and_more)) then + error%message = error%message // skip // and_more + end if + end subroutine test_failed + + + !> A test is skipped because certain requirements are not met to run the actual test + subroutine skip_test(error, message, more, and_more) + !> Error handling + type(error_type), allocatable, intent(out) :: error + !> A detailed message describing the error + character(len=*), intent(in) :: message + !> Another line of error message + character(len=*), intent(in), optional :: more + !> Another line of error message + character(len=*), intent(in), optional :: and_more + + character(len=*), parameter :: skip = new_line("a") // repeat(" ", 11) + + allocate(error) + error%stat = skipped + + error%message = message + if (present(more)) then + error%message = error%message // skip // more + end if + if (present(and_more)) then + error%message = error%message // skip // and_more + end if + end subroutine skip_test + + + !> Obtain the command line argument at a given index + subroutine get_argument(idx, arg) + !> Index of command line argument, range [0:command_argument_count()] + integer, intent(in) :: idx + !> Command line argument + character(len=:), allocatable, intent(out) :: arg + + integer :: length, stat + + call get_command_argument(idx, length=length, status=stat) + if (stat /= success) then + return + endif + + allocate(character(len=length) :: arg, stat=stat) + if (stat /= success) then + return + endif + + if (length > 0) then + call get_command_argument(idx, arg, status=stat) + if (stat /= success) then + deallocate(arg) + return + end if + end if + end subroutine get_argument + + + !> Obtain the value of an environment variable + subroutine get_variable(var, val) + !> Name of variable + character(len=*), intent(in) :: var + !> Value of variable + character(len=:), allocatable, intent(out) :: val + + integer :: length, stat + + call get_environment_variable(var, length=length, status=stat) + if (stat /= success) then + return + endif + + allocate(character(len=length) :: val, stat=stat) + if (stat /= success) then + return + endif + + if (length > 0) then + call get_environment_variable(var, val, status=stat) + if (stat /= success) then + deallocate(val) + return + end if + end if + end subroutine get_variable + + +#:for kind in REAL_KINDS + pure function real_${kind}$_to_string(val) result(string) + integer, parameter :: wp = ${kind}$ + real(wp), 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_${kind}$_to_string +#:endfor + + +#:for kind in CMPLX_KINDS + pure function complex_${kind}$_to_string(val) result(string) + integer, parameter :: wp = ${kind}$ + complex(wp), intent(in) :: val + character(len=:), allocatable :: string + integer, parameter :: buffer_len = 256 + character(len=buffer_len) :: buffer + + write(buffer, '(g0)') val + string = trim(buffer) + end function complex_${kind}$_to_string +#:endfor + + + !> Clear error type after it has been handled. + subroutine clear_error(error) + !> Error handling + type(error_type), intent(inout) :: error + + if (error%stat /= success) then + error%stat = success + end if + + if (allocated(error%message)) then + deallocate(error%message) + end if + end subroutine clear_error + + + !> Finalizer of the error type, in case the error is not correctly cleared it will + !> be escalated at runtime in a fatal way + subroutine escalate_error(error) + !> Error handling + type(error_type), intent(inout) :: error + + if (error%stat /= success) then + write(error_unit, '(a)') "[Fatal] Uncaught error" + if (allocated(error%message)) then + write(error_unit, '(a, 1x, i0, *(1x, a))') & + "Code:", error%stat, "Message:", error%message + end if + error stop + end if + end subroutine escalate_error + + +end module stdlib_test diff --git a/src/tests/test/CMakeLists.txt b/src/tests/test/CMakeLists.txt new file mode 100644 index 000000000..31a6159bc --- /dev/null +++ b/src/tests/test/CMakeLists.txt @@ -0,0 +1,2 @@ +ADDTEST(check) +ADDTEST(select) diff --git a/src/tests/test/Makefile.manual b/src/tests/test/Makefile.manual new file mode 100644 index 000000000..2eac3ec26 --- /dev/null +++ b/src/tests/test/Makefile.manual @@ -0,0 +1,4 @@ +PROGS_SRC = test_check.f90 test_select.f90 + + +include ../Makefile.manual.test.mk diff --git a/src/tests/test/test_check.f90 b/src/tests/test/test_check.f90 new file mode 100644 index 000000000..19d482b5a --- /dev/null +++ b/src/tests/test/test_check.f90 @@ -0,0 +1,631 @@ +! SPDX-Identifier: MIT + +module test_check + use, intrinsic :: ieee_arithmetic, only : ieee_value, ieee_quiet_nan + use stdlib_test, only : new_unittest, unittest_type, error_type, check, skip_test + implicit none + private + + public :: collect_check + + + !> Single precision real numbers + integer, parameter :: sp = selected_real_kind(6) + + !> Double precision real numbers + integer, parameter :: dp = selected_real_kind(15) + + !> 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(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("skipped", test_skipped), & + 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-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("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 + + + subroutine test_success(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, 0) + + end subroutine test_success + + + subroutine test_failure(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, 7) + + end subroutine test_failure + + + subroutine test_skipped(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call skip_test(error, "This test is always skipped") + + end subroutine test_skipped + + + subroutine test_failure_message(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, 4, "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, 3, 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, index("info!", "!") > 0) + + end subroutine test_expression + + + subroutine test_expression_fail(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, index("info!", "?") > 0) + + end subroutine test_expression_fail + + + subroutine test_expression_message(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, index("info!", "!") == 0, 'index("info!", "!") == 0') + + end subroutine test_expression_message + + + subroutine test_expression_with_more(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, index("info!", "?") /= 0, more='index("info!", "?")') + + end subroutine test_expression_with_more + + + subroutine test_rsp_abs(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val + + val = 3.3_sp + + call check(error, val, 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 + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, 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 + + val = 3.3_sp + + call check(error, val, 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 + + val = 1.0_sp + + call check(error, val, 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 + + val = 1.0_sp + + call check(error, val, 1.5_sp, rel=.true.) + + end subroutine test_rsp_rel_fail + + + subroutine test_rdp_abs(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val + + val = 3.3_dp + + call check(error, val, 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 + + val = 3.3_dp + + call check(error, val, 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 + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, 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 + + val = 1.0_dp + + call check(error, val, 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 + + val = 1.0_dp + + call check(error, val, 1.5_dp, rel=.true.) + + end subroutine test_rdp_rel_fail + + + subroutine test_i1(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i1) :: val + + val = 3_i1 + + call check(error, val, 3_i1) + + end subroutine test_i1 + + + subroutine test_i1_fail(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i1) :: val + + val = 3_i1 + + call check(error, val, -4_i1) + + end subroutine test_i1_fail + + + subroutine test_i1_message(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i1) :: val + + val = -3_i1 + + call check(error, val, 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 + + val = 0_i1 + + call check(error, val, 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 + + val = 3_i2 + + call check(error, val, 3_i2) + + end subroutine test_i2 + + + subroutine test_i2_fail(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i2) :: val + + val = 3_i2 + + call check(error, val, -4_i2) + + end subroutine test_i2_fail + + + subroutine test_i2_message(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i2) :: val + + val = -3_i2 + + call check(error, val, 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 + + val = 0_i2 + + call check(error, val, 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 + + val = 3_i4 + + call check(error, val, 3_i4) + + end subroutine test_i4 + + + subroutine test_i4_fail(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i4) :: val + + val = 3_i4 + + call check(error, val, -4_i4) + + end subroutine test_i4_fail + + + subroutine test_i4_message(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i4) :: val + + val = -3_i4 + + call check(error, val, 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 + + val = 0_i4 + + call check(error, val, 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 + + val = 3_i8 + + call check(error, val, 3_i8) + + end subroutine test_i8 + + + subroutine test_i8_fail(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i8) :: val + + val = 3_i8 + + call check(error, val, -4_i8) + + end subroutine test_i8_fail + + + subroutine test_i8_message(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i8) :: val + + val = -3_i8 + + call check(error, val, 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 + + val = 0_i8 + + call check(error, val, 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.) + + end subroutine test_l4_true + + + subroutine test_l4_false(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, .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 + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_check, only : collect_check + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("check", collect_check) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program diff --git a/src/tests/test/test_select.f90 b/src/tests/test/test_select.f90 new file mode 100644 index 000000000..6311caffb --- /dev/null +++ b/src/tests/test/test_select.f90 @@ -0,0 +1,171 @@ +! SPDX-Identifier: MIT + +module test_select + use, intrinsic :: ieee_arithmetic, only : ieee_value, ieee_quiet_nan + use stdlib_test, only : new_unittest, unittest_type, error_type, check, & + & run_testsuite, new_testsuite, testsuite_type, select_suite, run_selected + implicit none + private + + public :: collect_select + + +contains + + + !> Collect all exported unit tests + subroutine collect_select(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("always-pass", always_pass), & + new_unittest("always-fail", always_fail, should_fail=.true.), & + new_unittest("run-good-suite", test_run_good_suite), & + new_unittest("run-bad-suite", test_run_bad_suite), & + new_unittest("run-selected", test_run_selected), & + new_unittest("select-missing", test_select_missing) & + ] + + end subroutine collect_select + + + subroutine always_pass(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, 0) + + end subroutine always_pass + + + subroutine always_fail(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, 1, "Always failing test") + + end subroutine always_fail + + + !> Stub test suite collector defining passing unit tests + subroutine stub_collect(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("always-pass", always_pass), & + new_unittest("always-fail", always_fail, should_fail=.true.) & + ] + + end subroutine stub_collect + + + !> Bad test suite collector defining flaky unit tests + subroutine stub_collect_bad(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("always-pass", always_pass, should_fail=.true.), & + new_unittest("always-fail", always_fail) & + ] + + end subroutine stub_collect_bad + + + subroutine test_run_good_suite(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: unit, stat + + open(status='scratch', newunit=unit) + + stat = 7 + call run_testsuite(stub_collect, unit, stat) + call check(error, stat, 7) + + close(unit) + + end subroutine test_run_good_suite + + + subroutine test_run_bad_suite(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: unit, stat + + open(status='scratch', newunit=unit) + + stat = 3 + call run_testsuite(stub_collect_bad, unit, stat) + call check(error, stat, 5) + + close(unit) + + end subroutine test_run_bad_suite + + + subroutine test_run_selected(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: unit, stat + + open(status='scratch', newunit=unit) + + stat = 1 + call run_selected(stub_collect, "always-fail", unit, stat) + call check(error, stat, 1) + + close(unit) + + end subroutine test_run_selected + + + subroutine test_select_missing(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: unit, stat + + open(status='scratch', newunit=unit) + + call run_selected(stub_collect, "not-available", unit, stat) + call check(error, stat < 0) + + close(unit) + + end subroutine test_select_missing + + +end module test_select + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_select, only : collect_select + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("select", collect_select) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program From d038530c675ba8db31cffa4b45aee951dd2ec597 Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Sun, 22 Aug 2021 14:39:43 +0200 Subject: [PATCH 02/34] Rewrite stdlib math tests --- src/tests/ascii/test_ascii.f90 | 230 ++++++++++++++++++ src/tests/math/test_linspace.f90 | 323 ++++++++++++++----------- src/tests/math/test_logspace.f90 | 357 +++++++++++++++------------- src/tests/math/test_math_arange.f90 | 103 +++++--- src/tests/math/test_stdlib_math.f90 | 309 +++++++++++++++++------- src/tests/stdlib_test.fypp | 3 +- src/tests/test/test_check.f90 | 275 ++++++++++++++++++++- 7 files changed, 1155 insertions(+), 445 deletions(-) diff --git a/src/tests/ascii/test_ascii.f90 b/src/tests/ascii/test_ascii.f90 index f2542f5eb..cce5fe32c 100644 --- a/src/tests/ascii/test_ascii.f90 +++ b/src/tests/ascii/test_ascii.f90 @@ -67,10 +67,17 @@ subroutine test_is_alphanum_short(error) type(error_type), allocatable, intent(out) :: error call check(error, is_alphanum('A')) + if (allocated(error)) return + call check(error, is_alphanum('1')) + if (allocated(error)) return + call check(error, .not. is_alphanum('#')) + if (allocated(error)) return + ! N.B.: does not return true for non-ASCII Unicode alphanumerics call check(error, .not. is_alphanum('á')) + if (allocated(error)) return end subroutine subroutine test_is_alphanum_long(error) @@ -83,11 +90,13 @@ subroutine test_is_alphanum_long(error) clist = digits//octal_digits//fullhex_digits//letters//lowercase//uppercase do i = 1, len(clist) call check(error, is_alphanum(clist(i:i))) + if (allocated(error)) return end do clist = whitespace do i = 1, len(clist) call check(error, .not. is_alphanum(clist(i:i))) + if (allocated(error)) return end do end subroutine @@ -96,11 +105,17 @@ subroutine test_is_alpha_short(error) type(error_type), allocatable, intent(out) :: error call check(error, is_alpha('A')) + if (allocated(error)) return + call check(error, .not. is_alpha('1')) + if (allocated(error)) return + call check(error, .not. is_alpha('#')) + if (allocated(error)) return ! N.B.: does not return true for non-ASCII Unicode alphabetic characters call check(error, .not. is_alpha('á')) + if (allocated(error)) return end subroutine subroutine test_is_alpha_long(error) @@ -113,11 +128,13 @@ subroutine test_is_alpha_long(error) clist = letters//lowercase//uppercase do i = 1, len(clist) call check(error, is_alpha(clist(i:i))) + if (allocated(error)) return end do clist = digits//octal_digits//whitespace do i = 1, len(clist) call check(error, .not. is_alpha(clist(i:i))) + if (allocated(error)) return end do end subroutine @@ -126,12 +143,20 @@ subroutine test_is_lower_short(error) type(error_type), allocatable, intent(out) :: error call check(error, is_lower('a')) + if (allocated(error)) return + call check(error, .not. is_lower('A')) + if (allocated(error)) return + call check(error, .not. is_lower('#')) + if (allocated(error)) return ! N.B.: does not return true for non-ASCII Unicode lowercase letters call check(error, .not. is_lower('á')) + if (allocated(error)) return + call check(error, .not. is_lower('Á')) + if (allocated(error)) return end subroutine subroutine test_is_lower_long(error) @@ -143,11 +168,13 @@ subroutine test_is_lower_long(error) do i = 1, len(lowercase) call check(error, is_lower(lowercase(i:i))) + if (allocated(error)) return end do clist = digits//uppercase//whitespace do i = 1, len(clist) call check(error, .not. is_lower(clist(i:i))) + if (allocated(error)) return end do end subroutine @@ -156,12 +183,20 @@ subroutine test_is_upper_short(error) type(error_type), allocatable, intent(out) :: error call check(error, is_upper('A')) + if (allocated(error)) return + call check(error, .not. is_upper('a')) + if (allocated(error)) return + call check(error, .not. is_upper('#')) + if (allocated(error)) return ! N.B.: does not return true for non-ASCII Unicode uppercase letters call check(error, .not. is_upper('á')) + if (allocated(error)) return + call check(error, .not. is_upper('Á')) + if (allocated(error)) return end subroutine subroutine test_is_upper_long(error) @@ -173,11 +208,13 @@ subroutine test_is_upper_long(error) do i = 1, len(uppercase) call check(error, is_upper(uppercase(i:i))) + if (allocated(error)) return end do clist = digits//lowercase//whitespace do i = 1, len(clist) call check(error, .not. is_upper(clist(i:i))) + if (allocated(error)) return end do end subroutine @@ -187,13 +224,23 @@ subroutine test_is_digit_short(error) type(error_type), allocatable, intent(out) :: error call check(error, is_digit('3')) + if (allocated(error)) return + call check(error, is_digit('8')) + if (allocated(error)) return + call check(error, .not. is_digit('B')) + if (allocated(error)) return + call check(error, .not. is_digit('#')) + if (allocated(error)) return ! N.B.: does not return true for non-ASCII Unicode numbers call check(error, .not. is_digit('０')) ! full-width digit zero (U+FF10) + if (allocated(error)) return + call check(error, .not. is_digit('４')) ! full-width digit four (U+FF14)) + if (allocated(error)) return end subroutine subroutine test_is_digit_long(error) @@ -205,11 +252,13 @@ subroutine test_is_digit_long(error) do i = 1, len(digits) call check(error, is_digit(digits(i:i))) + if (allocated(error)) return end do clist = letters//whitespace do i = 1, len(clist) call check(error, .not. is_digit(clist(i:i))) + if (allocated(error)) return end do end subroutine @@ -218,10 +267,19 @@ subroutine test_is_octal_digit_short(error) type(error_type), allocatable, intent(out) :: error call check(error, is_octal_digit('0')) + if (allocated(error)) return + call check(error, is_octal_digit('7')) + if (allocated(error)) return + call check(error, .not. is_octal_digit('8')) + if (allocated(error)) return + call check(error, .not. is_octal_digit('A')) + if (allocated(error)) return + call check(error, .not. is_octal_digit('#')) + if (allocated(error)) return end subroutine subroutine test_is_octal_digit_long(error) @@ -233,10 +291,12 @@ subroutine test_is_octal_digit_long(error) do i = 1, len(octal_digits) call check(error, is_octal_digit(octal_digits(i:i))) + if (allocated(error)) return end do clist = letters//'89'//whitespace do i = 1, len(clist) call check(error, .not. is_octal_digit(clist(i:i))) + if (allocated(error)) return end do end subroutine @@ -245,11 +305,22 @@ subroutine test_is_hex_digit_short(error) type(error_type), allocatable, intent(out) :: error call check(error, is_hex_digit('0')) + if (allocated(error)) return + call check(error, is_hex_digit('A')) + if (allocated(error)) return + call check(error, is_hex_digit('f')) !! lowercase hex digits are accepted + if (allocated(error)) return + call check(error, .not. is_hex_digit('g')) + if (allocated(error)) return + call check(error, .not. is_hex_digit('G')) + if (allocated(error)) return + call check(error, .not. is_hex_digit('#')) + if (allocated(error)) return end subroutine subroutine test_is_hex_digit_long(error) @@ -261,10 +332,12 @@ subroutine test_is_hex_digit_long(error) do i = 1, len(fullhex_digits) call check(error, is_hex_digit(fullhex_digits(i:i))) + if (allocated(error)) return end do clist = lowercase(7:)//uppercase(7:)//whitespace do i = 1, len(clist) call check(error, .not. is_hex_digit(clist(i:i))) + if (allocated(error)) return end do end subroutine @@ -273,11 +346,22 @@ subroutine test_is_white_short(error) type(error_type), allocatable, intent(out) :: error call check(error, is_white(' ')) + if (allocated(error)) return + call check(error, is_white(TAB)) + if (allocated(error)) return + call check(error, is_white(LF)) + if (allocated(error)) return + call check(error, .not. is_white('1')) + if (allocated(error)) return + call check(error, .not. is_white('a')) + if (allocated(error)) return + call check(error, .not. is_white('#')) + if (allocated(error)) return end subroutine subroutine test_is_white_long(error) @@ -289,10 +373,12 @@ subroutine test_is_white_long(error) do i = 1, len(whitespace) call check(error, is_white(whitespace(i:i))) + if (allocated(error)) return end do clist = digits//letters do i = 1, len(clist) call check(error, .not. is_white(clist(i:i))) + if (allocated(error)) return end do end subroutine @@ -301,10 +387,19 @@ subroutine test_is_blank_short(error) type(error_type), allocatable, intent(out) :: error call check(error, is_blank(' ')) + if (allocated(error)) return + call check(error, is_blank(TAB)) + if (allocated(error)) return + call check(error, .not. is_blank('1')) + if (allocated(error)) return + call check(error, .not. is_blank('a')) + if (allocated(error)) return + call check(error, .not. is_blank('#')) + if (allocated(error)) return end subroutine subroutine test_is_blank_long(error) @@ -320,10 +415,12 @@ subroutine test_is_blank_long(error) else call check(error, .not. is_blank(whitespace(i:i))) end if + if (allocated(error)) return end do clist = digits//letters do i = 1, len(clist) call check(error, .not. is_blank(clist(i:i))) + if (allocated(error)) return end do end subroutine @@ -334,10 +431,19 @@ subroutine test_is_control_short(error) ! print *, is_control('\0') ! print *, is_control('\022') call check(error, is_control(new_line('a'))) ! newline is both whitespace and control + if (allocated(error)) return + call check(error, .not. is_control(' ')) + if (allocated(error)) return + call check(error, .not. is_control('1')) + if (allocated(error)) return + call check(error, .not. is_control('a')) + if (allocated(error)) return + call check(error, .not. is_control('#')) + if (allocated(error)) return ! N.B.: non-ASCII Unicode control characters are not recognized: ! print *, .not. is_control('\u0080') @@ -354,12 +460,15 @@ subroutine test_is_control_long(error) do i = 0, 31 call check(error, is_control(achar(i))) + if (allocated(error)) return end do call check(error, is_control(DEL)) + if (allocated(error)) return clist = digits//letters//' ' do i = 1, len(clist) call check(error, .not. is_control(clist(i:i))) + if (allocated(error)) return end do end subroutine @@ -368,19 +477,43 @@ subroutine test_is_punctuation_short(error) type(error_type), allocatable, intent(out) :: error call check(error, is_punctuation('.')) + if (allocated(error)) return + call check(error, is_punctuation(',')) + if (allocated(error)) return + call check(error, is_punctuation(':')) + if (allocated(error)) return + call check(error, is_punctuation('!')) + if (allocated(error)) return + call check(error, is_punctuation('#')) + if (allocated(error)) return + call check(error, is_punctuation('~')) + if (allocated(error)) return + call check(error, is_punctuation('+')) + if (allocated(error)) return + call check(error, is_punctuation('_')) + if (allocated(error)) return call check(error, .not. is_punctuation('1')) + if (allocated(error)) return + call check(error, .not. is_punctuation('a')) + if (allocated(error)) return + call check(error, .not. is_punctuation(' ')) + if (allocated(error)) return + call check(error, .not. is_punctuation(LF)) ! new line character + if (allocated(error)) return + call check(error, .not. is_punctuation(NUL)) + if (allocated(error)) return ! N.B.: Non-ASCII Unicode punctuation characters are not recognized. ! print *, is_punctuation('\u2012') ! (U+2012 = en-dash) @@ -400,6 +533,7 @@ subroutine test_is_punctuation_long(error) else call check(error, is_punctuation(c)) end if + if (allocated(error)) return end do end subroutine @@ -408,14 +542,26 @@ subroutine test_is_graphical_short(error) type(error_type), allocatable, intent(out) :: error call check(error, is_graphical('1')) + if (allocated(error)) return + call check(error, is_graphical('a')) + if (allocated(error)) return + call check(error, is_graphical('#')) + if (allocated(error)) return + call check(error, .not. is_graphical(' ')) ! whitespace is not graphical + if (allocated(error)) return + call check(error, .not. is_graphical(LF)) + if (allocated(error)) return + call check(error, .not. is_graphical(NUL)) + if (allocated(error)) return ! N.B.: Unicode graphical characters are not regarded as such. call check(error, .not. is_graphical('ä')) + if (allocated(error)) return end subroutine subroutine test_is_graphical_long(error) @@ -432,6 +578,7 @@ subroutine test_is_graphical_long(error) else call check(error, is_graphical(c)) end if + if (allocated(error)) return end do end subroutine @@ -440,13 +587,23 @@ subroutine test_is_printable_short(error) type(error_type), allocatable, intent(out) :: error call check(error, is_printable(' ')) ! whitespace is printable + if (allocated(error)) return + call check(error, is_printable('1')) + if (allocated(error)) return + call check(error, is_printable('a')) + if (allocated(error)) return + call check(error, is_printable('#')) + if (allocated(error)) return + call check(error, .not. is_printable(NUL)) ! control characters are not printable + if (allocated(error)) return ! N.B.: Printable non-ASCII Unicode characters are not recognized. call check(error, .not. is_printable('ä')) + if (allocated(error)) return end subroutine subroutine test_is_printable_long(error) @@ -463,6 +620,7 @@ subroutine test_is_printable_long(error) else call check(error, is_printable(c)) end if + if (allocated(error)) return end do end subroutine @@ -471,7 +629,10 @@ subroutine test_is_ascii_short(error) type(error_type), allocatable, intent(out) :: error call check(error, is_ascii('a')) + if (allocated(error)) return + call check(error, .not. is_ascii('ä')) + if (allocated(error)) return end subroutine subroutine test_is_ascii_long(error) @@ -482,8 +643,10 @@ subroutine test_is_ascii_long(error) do i = 0, 127 call check(error, is_ascii(achar(i))) + if (allocated(error)) return end do call check(error, .not. is_ascii(achar(128))) ! raises compiler warning + if (allocated(error)) return end subroutine @@ -492,8 +655,13 @@ subroutine test_to_lower_short(error) type(error_type), allocatable, intent(out) :: error call check(error, to_lower('a'), 'a') + if (allocated(error)) return + call check(error, to_lower('A'), 'a') + if (allocated(error)) return + call check(error, to_lower('#'), '#') + if (allocated(error)) return end subroutine subroutine test_to_lower_long(error) @@ -505,6 +673,7 @@ subroutine test_to_lower_long(error) do i = 1, len(uppercase) call check(error, to_lower(uppercase(i:i)), lowercase(i:i)) + if (allocated(error)) return end do do i = 0, 127 c = achar(i) @@ -513,6 +682,7 @@ subroutine test_to_lower_long(error) else call check(error, to_lower(c) /= c) end if + if (allocated(error)) return end do end subroutine @@ -521,8 +691,13 @@ subroutine test_to_upper_short(error) type(error_type), allocatable, intent(out) :: error call check(error, to_upper('a'), 'A') + if (allocated(error)) return + call check(error, to_upper('A'), 'A') + if (allocated(error)) return + call check(error, to_upper('#'), '#') + if (allocated(error)) return end subroutine subroutine test_to_upper_long(error) @@ -534,6 +709,7 @@ subroutine test_to_upper_long(error) do i = 1, len(lowercase) call check(error, to_upper(lowercase(i:i)), uppercase(i:i)) + if (allocated(error)) return end do do i = 0, 127 @@ -543,6 +719,7 @@ subroutine test_to_upper_long(error) else call check(error, to_upper(c) /= c) end if + if (allocated(error)) return end do end subroutine @@ -615,14 +792,21 @@ subroutine test_to_lower_string(error) dlc = to_lower("UPPERCASE") call check(error, dlc, "uppercase") + if (allocated(error)) return dlc = to_lower(input) call check(error, len(dlc), 32) + if (allocated(error)) return + call check(error, len_trim(dlc), 9) + if (allocated(error)) return + call check(error, trim(dlc), "uppercase") + if (allocated(error)) return dlc = to_lower("0123456789ABCDE") call check(error, dlc, "0123456789abcde") + if (allocated(error)) return end subroutine test_to_lower_string subroutine test_to_upper_string(error) @@ -634,14 +818,21 @@ subroutine test_to_upper_string(error) dlc = to_upper("lowercase") call check(error, dlc, "LOWERCASE") + if (allocated(error)) return dlc = to_upper(input) call check(error, len(dlc), 32) + if (allocated(error)) return + call check(error, len_trim(dlc), 9) + if (allocated(error)) return + call check(error, trim(dlc), "LOWERCASE") + if (allocated(error)) return dlc = to_upper("0123456789abcde") call check(error, dlc, "0123456789ABCDE") + if (allocated(error)) return end subroutine test_to_upper_string subroutine test_to_title_string(error) @@ -653,20 +844,29 @@ subroutine test_to_title_string(error) dlc = to_title("tHis Is tO bE tiTlEd") call check(error, dlc, "This Is To Be Titled") + if (allocated(error)) return dlc = to_title(input) call check(error, len(dlc), 32) + if (allocated(error)) return + call check(error, len_trim(dlc), 20) + if (allocated(error)) return + call check(error, trim(dlc), "This Is To Be Titled") + if (allocated(error)) return dlc = to_title(" s P a C e D !") call check(error, dlc, " S P A C E D !") + if (allocated(error)) return dlc = to_title("1st, 2nD, 3RD") call check(error, dlc, "1st, 2nd, 3rd") + if (allocated(error)) return dlc = to_title("""quOTed""") call check(error, dlc, """Quoted""") + if (allocated(error)) return end subroutine test_to_title_string subroutine test_to_sentence_string(error) @@ -678,20 +878,29 @@ subroutine test_to_sentence_string(error) dlc = to_sentence("tHis iS A seNteNcE.") call check(error, dlc, "This is a sentence.") + if (allocated(error)) return dlc = to_sentence(input) call check(error, len(dlc), 32) + if (allocated(error)) return + call check(error, len_trim(dlc), 19) + if (allocated(error)) return + call check(error, trim(dlc), "This is a sentence.") + if (allocated(error)) return dlc = to_sentence(" s P a C e D !") call check(error, dlc, " S p a c e d !") + if (allocated(error)) return dlc = to_sentence("1st, 2nd, 3rd") call check(error, dlc, "1st, 2nd, 3rd") + if (allocated(error)) return dlc = to_sentence("""quOTed""") call check(error, dlc, """Quoted""") + if (allocated(error)) return end subroutine test_to_sentence_string subroutine test_reverse_string(error) @@ -703,12 +912,20 @@ subroutine test_reverse_string(error) dlc = reverse("reversed") call check(error, dlc, "desrever") + if (allocated(error)) return dlc = reverse(input) call check(error, len(dlc), 32) + if (allocated(error)) return + call check(error, len_trim(dlc), 32) + if (allocated(error)) return + call check(error, trim(dlc), " desrever") + if (allocated(error)) return + call check(error, trim(adjustl(dlc)), "desrever") + if (allocated(error)) return end subroutine test_reverse_string subroutine test_to_string(error) @@ -719,42 +936,55 @@ subroutine test_to_string(error) write(flc, '(g0)') 1026192 call check(error, to_string(1026192), trim(flc)) + if (allocated(error)) return write(flc, '(g0)') -124784 call check(error, to_string(-124784), trim(flc)) + if (allocated(error)) return write(flc, '(g0)') 1_int8 call check(error, to_string(1_int8), trim(flc)) + if (allocated(error)) return write(flc, '(g0)') -3_int8 call check(error, to_string(-3_int8), trim(flc)) + if (allocated(error)) return write(flc, '(g0)') 80_int16 call check(error, to_string(80_int16), trim(flc)) + if (allocated(error)) return write(flc, '(g0)') 8924890_int32 call check(error, to_string(8924890_int32), trim(flc)) + if (allocated(error)) return write(flc, '(g0)') -2378401_int32 call check(error, to_string(-2378401_int32), trim(flc)) + if (allocated(error)) return write(flc, '(g0)') -921092378401_int64 call check(error, to_string(-921092378401_int64), trim(flc)) + if (allocated(error)) return write(flc, '(g0)') 1272835771_int64 call check(error, to_string(1272835771_int64), trim(flc)) + if (allocated(error)) return write(flc, '(g0)') .true. call check(error, to_string(.true.), trim(flc)) + if (allocated(error)) return write(flc, '(g0)') .false. call check(error, to_string(.false.), trim(flc)) + if (allocated(error)) return write(flc, '(g0)') .true._c_bool call check(error, to_string(.true._c_bool), trim(flc)) + if (allocated(error)) return write(flc, '(g0)') .false._lk call check(error, to_string(.false._lk), trim(flc)) + if (allocated(error)) return end subroutine test_to_string end module test_ascii diff --git a/src/tests/math/test_linspace.f90 b/src/tests/math/test_linspace.f90 index 25e5b9202..6674a3d02 100644 --- a/src/tests/math/test_linspace.f90 +++ b/src/tests/math/test_linspace.f90 @@ -1,12 +1,13 @@ -program test_linspace - use stdlib_error, only: check +module test_linspace + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_kinds, only: sp, dp, int8, int16 use stdlib_math, only: linspace, DEFAULT_LINSPACE_LENGTH implicit none + private + + public :: collect_linspace - integer :: iunit - logical :: warn = .false. real(sp), parameter :: TOLERANCE_SP = 1000 * epsilon(1.0_sp) real(dp), parameter :: TOLERANCE_DP = 1000 * epsilon(1.0_dp) ! Percentage of the range for which the actual gap must not exceed @@ -20,30 +21,36 @@ program test_linspace ! I would convert this repeated code into a subroutine but that would require the implementation of a ! generic procedure given that each linear space will have a different expected_value type and kind. - open(newunit=iunit, file="test_linspace_log.txt", status="unknown") ! Log the results of the functions +contains - write(iunit,*) "Writing to unit #: ", iunit + !> Collect all exported unit tests + subroutine collect_linspace(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) - call test_linspace_sp - call test_linspace_dp - call test_linspace_neg_index ! Make sure that when passed a negative index the result is an empty array - call test_linspace_cmplx - call test_linspace_cmplx_2 - call test_linspace_cmplx_3 - call test_linspace_cmplx_sp - call test_linspace_cmplx_sp_2 - call test_linspace_int16 - call test_linspace_int8 + testsuite = [ & + new_unittest("linspace_sp", test_linspace_sp), & + new_unittest("linspace_dp", test_linspace_dp), & + new_unittest("linspace_neg_index", test_linspace_neg_index), & + new_unittest("linspace_cmplx", test_linspace_cmplx), & + new_unittest("linspace_cmplx_2", test_linspace_cmplx_2), & + new_unittest("linspace_cmplx_3", test_linspace_cmplx_3), & + new_unittest("linspace_cmplx_sp", test_linspace_cmplx_sp), & + new_unittest("linspace_cmplx_sp_2", test_linspace_cmplx_sp_2), & + new_unittest("linspace_int16", test_linspace_int16), & + new_unittest("linspace_int8", test_linspace_int8) & + ] - close(unit=iunit) + end subroutine collect_linspace -contains - subroutine test_linspace_sp + subroutine test_linspace_sp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error integer, parameter :: n = 20 - real(sp) :: start = 1.0_sp - real(sp) :: end = 10.0_sp + real(sp), parameter :: start = 1.0_sp + real(sp), parameter :: end = 10.0_sp real(sp) :: expected_interval real(sp) :: true_difference @@ -54,9 +61,12 @@ subroutine test_linspace_sp expected_interval =( end - start ) / real(( n - 1 ), sp) - call check(x(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn) - call check(x(n) == end, msg="Final array value is not equal to end parameter", warn=warn) - call check(size(x) == n, msg="Array not allocated to appropriate size", warn=warn) + call check(error, x(1), start, "Initial value of array is not equal to the passed start parameter") + if (allocated(error)) return + call check(error, x(n), end, "Final array value is not equal to end parameter") + if (allocated(error)) return + call check(error, size(x), n, "Array not allocated to appropriate size") + if (allocated(error)) return print *, "Made it through first round of tests" @@ -64,16 +74,19 @@ subroutine test_linspace_sp do i = 1, n-1 true_difference = x(i + 1) - x(i) - call check(abs(true_difference - expected_interval) < abs(expected_interval) * TOLERANCE_SP) + call check(error, abs(true_difference - expected_interval) < abs(expected_interval) * TOLERANCE_SP) + if (allocated(error)) return end do end subroutine - subroutine test_linspace_dp + subroutine test_linspace_dp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - real(dp) :: start = 1.0_dp - real(dp) :: end = 10.0_dp + real(dp), parameter :: start = 1.0_dp + real(dp), parameter :: end = 10.0_dp integer, parameter :: n = DEFAULT_LINSPACE_LENGTH real(dp) :: expected_interval real(dp) :: true_difference @@ -85,37 +98,46 @@ subroutine test_linspace_dp expected_interval =( end - start ) / ( n - 1 ) - call check(x(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn) - call check(x(n) == end, msg="Final array value is not equal to end parameter", warn=warn) - call check(size(x) == n, msg="Array not allocated to default size", warn=warn) + call check(error, size(x), n, "Array not allocated to default size") + if (allocated(error)) return + call check(error, x(1), start, "Initial value of array is not equal to the passed start parameter") + if (allocated(error)) return + call check(error, x(n), end, "Final array value is not equal to end parameter") + if (allocated(error)) return ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval do i = 1, n-1 true_difference = x(i + 1) - x(i) - call check(abs(true_difference - expected_interval) < abs(expected_interval) * TOLERANCE_DP) + call check(error, true_difference, expected_interval, & + & thr=abs(expected_interval) * TOLERANCE_DP) + if (allocated(error)) return end do end subroutine - subroutine test_linspace_neg_index + subroutine test_linspace_neg_index(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - real(dp) :: start = 1.0_dp - real(dp) :: end = 10.0_dp + real(dp), parameter :: start = 1.0_dp + real(dp), parameter :: end = 10.0_dp real(dp), allocatable :: x(:) x = linspace(start, end, -15) - call check(size(x) == 0, msg="Allocated array is not empty", warn=warn) + call check(error, size(x), 0, "Allocated array is not empty") end subroutine - subroutine test_linspace_cmplx + subroutine test_linspace_cmplx(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - complex(dp) :: start = (0.0_dp, 10.0_dp) - complex(dp) :: end = (1.0_dp, 0.0_dp) + complex(dp), parameter :: start = (0.0_dp, 10.0_dp) + complex(dp), parameter :: end = (1.0_dp, 0.0_dp) complex(dp) :: expected_interval integer, parameter :: n = 10 @@ -127,31 +149,30 @@ subroutine test_linspace_cmplx expected_interval =( end - start ) / ( n - 1 ) - call check(z(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn) - call check(z(n) == end, msg="Final array value is not equal to end parameter", warn=warn) - call check(size(z) == n, msg="Array not allocated to correct size", warn=warn) + call check(error, size(z), n, "Array not allocated to correct size") + if (allocated(error)) return + call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter") + if (allocated(error)) return + call check(error, z(n), end, "Final array value is not equal to end parameter") + if (allocated(error)) return ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval do i = 1, n-1 - call check(abs( ( z(i + 1) - z(i) ) - expected_interval) < abs(expected_interval) * TOLERANCE_DP) - - end do + call check(error, z(i + 1) - z(i), expected_interval, & + & thr=abs(expected_interval) * TOLERANCE_DP) + if (allocated(error)) return - write(unit=iunit, fmt=*) "linspace((0.0_dp, 10.0_dp), (1.0_dp, 0.0_dp), 10): " - write(unit=iunit,fmt='(70("="))') - do i = 1, n - write(unit=iunit,fmt=*) z(i) end do - write(iunit,*) - write(iunit,*) end subroutine - subroutine test_linspace_cmplx_2 + subroutine test_linspace_cmplx_2(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - complex(dp) :: start = (10.0_dp, 10.0_dp) - complex(dp) :: end = (1.0_dp, 1.0_dp) + complex(dp), parameter :: start = (10.0_dp, 10.0_dp) + complex(dp), parameter :: end = (1.0_dp, 1.0_dp) complex(dp) :: expected_interval integer, parameter :: n = 5 @@ -164,31 +185,30 @@ subroutine test_linspace_cmplx_2 expected_interval =( end - start ) / ( n - 1 ) - call check(z(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn) - call check(z(n) == end, msg="Final array value is not equal to end parameter", warn=warn) - call check(size(z) == n, msg="Array not allocated to correct size", warn=warn) + call check(error, size(z), n, "Array not allocated to correct size") + if (allocated(error)) return + call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter") + if (allocated(error)) return + call check(error, z(n), end, "Final array value is not equal to end parameter") + if (allocated(error)) return ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval do i = 1, n-1 - call check(abs( ( z(i + 1) - z(i) ) - expected_interval) < abs(expected_interval) * TOLERANCE_DP) + call check(error, z(i + 1) - z(i), expected_interval, & + & thr=abs(expected_interval) * TOLERANCE_DP) + if (allocated(error)) return end do - write(unit=iunit, fmt=*) "linspace((10.0_dp, 10.0_dp), (1.0_dp, 1.0_dp), 5): " - write(unit=iunit,fmt='(70("="))') - do i = 1, n - write(unit=iunit,fmt=*) z(i) - end do - write(iunit,*) - write(iunit,*) - end subroutine - subroutine test_linspace_cmplx_3 + subroutine test_linspace_cmplx_3(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - complex(dp) :: start = (-5.0_dp, 100.0_dp) - complex(dp) :: end = (20.0_dp, 13.0_dp) + complex(dp), parameter :: start = (-5.0_dp, 100.0_dp) + complex(dp), parameter :: end = (20.0_dp, 13.0_dp) complex(dp) :: expected_interval integer, parameter :: n = 20 @@ -201,31 +221,30 @@ subroutine test_linspace_cmplx_3 expected_interval = ( end - start ) / ( n - 1 ) - call check(z(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn) - call check(z(n) == end, msg="Final array value is not equal to end parameter", warn=warn) - call check(size(z) == n, msg="Array not allocated to correct size", warn=warn) + call check(error, size(z), n, "Array not allocated to correct size") + if (allocated(error)) return + call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter") + if (allocated(error)) return + call check(error, z(n), end, "Final array value is not equal to end parameter") + if (allocated(error)) return ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval do i = 1, n-1 - call check(abs( ( z(i + 1) - z(i) ) - expected_interval) < abs(expected_interval) * TOLERANCE_DP) + call check(error, z(i + 1) - z(i), expected_interval, & + & thr=abs(expected_interval) * TOLERANCE_DP) + if (allocated(error)) return end do - write(unit=iunit, fmt=*) "linspace((-5.0_dp, 100.0_dp), (20.0_dp, 13.0_dp), 20): " - write(unit=iunit,fmt='(70("="))') - do i = 1, n - write(unit=iunit,fmt=*) z(i) - end do - write(iunit,*) - write(iunit,*) - end subroutine - subroutine test_linspace_cmplx_sp + subroutine test_linspace_cmplx_sp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - complex(sp) :: start = (0.5_sp, 5.0_sp) - complex(sp) :: end = (1.0_sp, -30.0_sp) + complex(sp), parameter :: start = (0.5_sp, 5.0_sp) + complex(sp), parameter :: end = (1.0_sp, -30.0_sp) complex(sp) :: expected_interval integer, parameter :: n = 10 @@ -238,31 +257,30 @@ subroutine test_linspace_cmplx_sp expected_interval =( end - start ) / ( n - 1 ) - call check(z(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn) - call check(z(n) == end, msg="Final array value is not equal to end parameter", warn=warn) - call check(size(z) == n, msg="Array not allocated to correct size", warn=warn) + call check(error, size(z), n, "Array not allocated to correct size") + if (allocated(error)) return + call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter") + if (allocated(error)) return + call check(error, z(n), end, "Final array value is not equal to end parameter") + if (allocated(error)) return ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval do i = 1, n-1 - call check(abs( ( z(i + 1) - z(i) ) - expected_interval) < abs(expected_interval) * TOLERANCE_SP) + call check(error, z(i + 1) - z(i), expected_interval, & + & thr=abs(expected_interval) * TOLERANCE_SP) + if (allocated(error)) return end do - write(unit=iunit, fmt=*) "linspace((0.5_sp, 5.0_sp), (1.0_sp, -30.0_sp), 10): " - write(unit=iunit,fmt='(70("="))') - do i = 1, n - write(unit=iunit,fmt=*) z(i) - end do - write(iunit,*) - write(iunit,*) - end subroutine - subroutine test_linspace_cmplx_sp_2 + subroutine test_linspace_cmplx_sp_2(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - complex(sp) :: start = (50.0_sp, 500.0_sp) - complex(sp) :: end = (-100.0_sp, 2000.0_sp) + complex(sp), parameter :: start = (50.0_sp, 500.0_sp) + complex(sp), parameter :: end = (-100.0_sp, 2000.0_sp) complex(sp) :: expected_interval complex(sp) :: true_interval real(sp) :: offset @@ -277,34 +295,33 @@ subroutine test_linspace_cmplx_sp_2 expected_interval =( end - start ) / ( n - 1 ) - call check(z(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn) - call check(z(n) == end, msg="Final array value is not equal to end parameter", warn=warn) - call check(size(z) == n, msg="Array not allocated to default size", warn=warn) + call check(error, size(z), n, "Array not allocated to default size") + if (allocated(error)) return + call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter") + if (allocated(error)) return + call check(error, z(n), end, "Final array value is not equal to end parameter") + if (allocated(error)) return ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval do i = 1, n-1 true_interval = (z(i + 1) - z(i)) offset = abs(true_interval - expected_interval) - call check(abs( ( z(i + 1) - z(i) ) - expected_interval) < abs(expected_interval) * TOLERANCE_SP) + call check(error, z(i + 1) - z(i), expected_interval, & + & thr=abs(expected_interval) * TOLERANCE_SP) + if (allocated(error)) return ! print *, i end do - write(unit=iunit, fmt=*) "linspace((50.0_sp, 500.0_sp), (-100.0_sp, 2000.0_sp)): " - write(unit=iunit,fmt='(70("="))') - do i = 1, n - write(unit=iunit,fmt=*) z(i) - end do - write(iunit,*) - write(iunit,*) - end subroutine - subroutine test_linspace_int16 + subroutine test_linspace_int16(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - integer(int16) :: start = 5 - integer(int16) :: end = 10 + integer(int16), parameter :: start = 5 + integer(int16), parameter :: end = 10 real(dp) :: expected_interval integer, parameter :: n = 6 @@ -317,31 +334,30 @@ subroutine test_linspace_int16 expected_interval =( end - start ) / ( n - 1 ) - call check(z(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn) - call check(z(n) == end, msg="Final array value is not equal to end parameter", warn=warn) - call check(size(z) == n, msg="Array not allocated to correct size", warn=warn) + call check(error, size(z), n, "Array not allocated to correct size") + if (allocated(error)) return + call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter") + if (allocated(error)) return + call check(error, z(n), end, "Final array value is not equal to end parameter") + if (allocated(error)) return ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval do i = 1, n-1 - call check(abs( ( z(i + 1) - z(i) ) - expected_interval) < abs(expected_interval) * TOLERANCE_DP) - - end do + call check(error, real(z(i + 1) - z(i), dp), expected_interval, & + & thr=abs(expected_interval) * TOLERANCE_DP) + if (allocated(error)) return - write(unit=iunit, fmt=*) "linspace(5_int16, 10_int16, 10): " - write(unit=iunit,fmt='(70("="))') - do i = 1, n - write(unit=iunit,fmt=*) z(i) end do - write(iunit,*) - write(iunit,*) end subroutine - subroutine test_linspace_int8 + subroutine test_linspace_int8(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - integer(int8) :: start = 20 - integer(int8) :: end = 50 + integer(int8), parameter :: start = 20 + integer(int8), parameter :: end = 50 real(dp) :: expected_interval @@ -357,27 +373,50 @@ subroutine test_linspace_int8 expected_interval =real( end - start, dp ) / ( n - 1 ) - call check(z(1) == start, msg="Initial value of array is not equal to the passed start parameter", warn=warn) - call check(z(n) == end, msg="Final array value is not equal to end parameter", warn=warn) - call check(size(z) == n, msg="Array not allocated to correct size", warn=warn) + call check(error, size(z), n, "Array not allocated to correct size") + if (allocated(error)) return + call check(error, z(1), real(start, dp), "Initial value of array is not equal to the passed start parameter") + if (allocated(error)) return + call check(error, z(n), real(end, dp), "Final array value is not equal to end parameter") + if (allocated(error)) return ! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval do i = 1, n-1 - call check(abs( ( z(i + 1) - z(i) ) - expected_interval) < abs(expected_interval) * TOLERANCE_DP) + call check(error, z(i + 1) - z(i), expected_interval, & + & thr=abs(expected_interval) * TOLERANCE_DP) + if (allocated(error)) return end do - write(unit=iunit, fmt=*) "linspace(5_int16, 10_int16, 10): " - write(unit=iunit,fmt='(70("="))') - do i = 1, n - write(unit=iunit,fmt=*) z(i) - end do - write(iunit,*) - write(iunit,*) - end subroutine -end program +end module + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_linspace, only : collect_linspace + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("linspace", collect_linspace) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program tester diff --git a/src/tests/math/test_logspace.f90 b/src/tests/math/test_logspace.f90 index 57196ead6..ed27756e6 100644 --- a/src/tests/math/test_logspace.f90 +++ b/src/tests/math/test_logspace.f90 @@ -1,243 +1,272 @@ -program test_logspace - - use stdlib_error, only: check +module test_logspace + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_kinds, only: sp, dp, int8, int16, int32, int64 use stdlib_math, only: logspace, DEFAULT_LOGSPACE_BASE, DEFAULT_LOGSPACE_LENGTH implicit none - logical :: warn = .false. - - integer :: iunit - - ! Testing logspace - ! - ! logspace should return a rank 1 array of values equally logarithmically spaced - ! from the base**start to base**end, using 10 as the base. If no length - ! is specified, return a rank 1 array with 50 elements. - ! - ! Also test to verify that the proportion between adjacent elements is constant within - ! a certain tolerance - - real(sp), parameter :: TOLERANCE_SP = 1000 * epsilon(1.0_sp) - real(dp), parameter :: TOLERANCE_DP = 1000 * epsilon(1.0_dp) ! Percentage of the range for which the actual gap must not exceed - - open(newunit=iunit, file="test_logspace_log.txt", status="unknown") ! Log the results of the function + ! Testing logspace + ! + ! logspace should return a rank 1 array of values equally logarithmically spaced + ! from the base**start to base**end, using 10 as the base. If no length + ! is specified, return a rank 1 array with 50 elements. + ! + ! Also test to verify that the proportion between adjacent elements is constant within + ! a certain tolerance - write(iunit,*) "Writing to unit #: ", iunit + real(sp), parameter :: TOLERANCE_SP = 1000 * epsilon(1.0_sp) + real(dp), parameter :: TOLERANCE_DP = 1000 * epsilon(1.0_dp) ! Percentage of the range for which the actual gap must not exceed - call test_logspace_sp - call test_logspace_dp - call test_logspace_default - call test_logspace_base_2 - call test_logspace_base_2_cmplx_start - call test_logspace_base_i_int_start - close(unit=iunit) +contains - contains + !> Collect all exported unit tests + subroutine collect_logspace(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) - subroutine test_logspace_sp + testsuite = [ & + new_unittest("logspace_sp", test_logspace_sp), & + new_unittest("logspace_dp", test_logspace_dp), & + new_unittest("logspace_default", test_logspace_default), & + new_unittest("logspace_base_2", test_logspace_base_2), & + new_unittest("logspace_base_2_cmplx_start", test_logspace_base_2_cmplx_start), & + new_unittest("logspace_base_i_int_start", test_logspace_base_i_int_start) & + ] - integer :: n = 20 - real(sp) :: start = 0.0_sp - real(sp) :: end = 2.0_sp + end subroutine collect_logspace - real(sp) :: expected_proportion - integer :: i = 1 + subroutine test_logspace_sp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - real(sp), allocatable :: x(:) + integer, parameter :: n = 20 + real(sp), parameter :: start = 0.0_sp + real(sp), parameter :: end = 2.0_sp - x = logspace(start, end, n) + real(sp) :: expected_proportion + integer :: i - expected_proportion = 10 ** ( ( end - start ) / ( n - 1 ) ) + real(sp), allocatable :: x(:) - call check(x(1) == DEFAULT_LOGSPACE_BASE ** start, msg="Initial value of array is not equal to 10^start", warn=warn) - call check(x(n) == DEFAULT_LOGSPACE_BASE ** end, msg="Final value of array is not equal to 10^end", warn=warn) - call check(size(x) == n, msg="Array not allocated to appropriate size", warn=warn) + x = logspace(start, end, n) - do i = 1, n-1 + expected_proportion = 10 ** ( ( end - start ) / ( n - 1 ) ) - call check(abs(x(i + 1) / x(i) - expected_proportion) < abs(expected_proportion) * TOLERANCE_SP) + call check(error, size(x), n, "Array not allocated to appropriate size") + if (allocated(error)) return + call check(error, x(1), DEFAULT_LOGSPACE_BASE ** start, "Initial value of array is not equal to 10^start") + if (allocated(error)) return + call check(error, x(n), DEFAULT_LOGSPACE_BASE ** end, "Final value of array is not equal to 10^end") + if (allocated(error)) return - end do + do i = 1, n-1 + call check(error, x(i + 1) / x(i), expected_proportion, & + & thr=abs(expected_proportion) * TOLERANCE_SP) + if (allocated(error)) return - write(unit=iunit, fmt=*) "logspace(0.0_sp, 2.0_sp, 20): " - write(unit=iunit,fmt='(70("="))') - write(unit=iunit,fmt="(20(F7.3, 2X))") x - write(iunit,*) - write(iunit,*) + end do - end subroutine - subroutine test_logspace_dp + end subroutine - integer :: n = 10 - real(dp) :: start = 1.0_dp - real(dp) :: end = 0.0_dp - real(dp) :: expected_proportion - integer :: i = 1 + subroutine test_logspace_dp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - real(dp), allocatable :: x(:) + integer, parameter :: n = 10 + real(dp), parameter :: start = 1.0_dp + real(dp), parameter :: end = 0.0_dp + real(dp) :: expected_proportion + integer :: i - x = logspace(start, end, n) + real(dp), allocatable :: x(:) - expected_proportion = 10 ** ( ( end - start ) / ( n - 1 ) ) + x = logspace(start, end, n) + expected_proportion = 10 ** ( ( end - start ) / ( n - 1 ) ) - call check(x(1) == DEFAULT_LOGSPACE_BASE ** start, msg="Initial value of array is not equal to 10^start", warn=warn) - call check(x(n) == DEFAULT_LOGSPACE_BASE ** end, msg="Final value of array is not equal to 10^end", warn=warn) - call check(size(x) == n, msg="Array not allocated to appropriate size", warn=warn) - do i = 1, n-1 + call check(error, size(x), n, "Array not allocated to appropriate size") + if (allocated(error)) return + call check(error, x(1), DEFAULT_LOGSPACE_BASE ** start, "Initial value of array is not equal to 10^start") + if (allocated(error)) return + call check(error, x(n), DEFAULT_LOGSPACE_BASE ** end, "Final value of array is not equal to 10^end") + if (allocated(error)) return - call check(abs(x(i + 1) / x(i) - expected_proportion) < abs(expected_proportion) * TOLERANCE_DP) + do i = 1, n-1 - end do + call check(error, x(i + 1) / x(i), expected_proportion, & + & thr=abs(expected_proportion) * TOLERANCE_DP) + if (allocated(error)) return - write(unit=iunit, fmt=*) "logspace(1.0_dp, 0.0_dp, 10): " - write(unit=iunit,fmt=99) - write(unit=iunit,fmt="(10(F7.3, 2X))") x - write(iunit,*) - write(iunit,*) + end do - 99 format(70("=")) + end subroutine - end subroutine + subroutine test_logspace_default(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - subroutine test_logspace_default + real(dp), parameter :: start = 0.0_dp + real(dp), parameter :: end = 1.0_dp + integer, parameter :: n = DEFAULT_LOGSPACE_LENGTH + real(dp) :: expected_proportion + integer :: i - real(dp) :: start = 0.0_dp - real(dp) :: end = 1.0_dp - integer :: n = DEFAULT_LOGSPACE_LENGTH - real(dp) :: expected_proportion - integer :: i + real(dp), allocatable :: x(:) - real(dp), allocatable :: x(:) + x = logspace(start, end) - x = logspace(start, end) + expected_proportion = 10 ** ( ( end - start ) / ( n - 1 ) ) - expected_proportion = 10 ** ( ( end - start ) / ( n - 1 ) ) + call check(error, size(x), n, "Array not allocated to appropriate size") + if (allocated(error)) return + call check(error, x(1), DEFAULT_LOGSPACE_BASE ** start, "Initial value of array is not equal to 10^start") + if (allocated(error)) return + call check(error, x(n), DEFAULT_LOGSPACE_BASE ** end, "Final value of array is not equal to 10^end") + if (allocated(error)) return - call check(x(1) == DEFAULT_LOGSPACE_BASE ** start, msg="Initial value of array is not equal to 10^start", warn=warn) - call check(x(n) == DEFAULT_LOGSPACE_BASE ** end, msg="Final value of array is not equal to 10^end", warn=warn) - call check(size(x) == n, msg="Array not allocated to appropriate size", warn=warn) + do i = 1, n-1 - do i = 1, n-1 + call check(error, x(i + 1) / x(i), expected_proportion, & + & thr=abs(expected_proportion) * TOLERANCE_DP) + if (allocated(error)) return - call check(abs(x(i + 1) / x(i) - expected_proportion) < abs(expected_proportion) * TOLERANCE_DP) + end do - end do + end subroutine - write(unit=iunit, fmt=*) "logspace(0.0_dp, 1.0_dp): " - write(unit=iunit,fmt='(70("="))') - write(unit=iunit,fmt="(50(F7.3, 2X))") x - write(iunit,*) - write(iunit,*) + subroutine test_logspace_base_2(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - end subroutine + integer, parameter :: n = 10 + real(dp), parameter :: start = 1.0_dp + real(dp), parameter :: end = 10.0_dp + integer, parameter :: base = 2 + integer :: i + real(dp) :: expected_proportion - subroutine test_logspace_base_2 + real(dp), allocatable :: x(:) - integer :: n = 10 - real(dp) :: start = 1.0_dp - real(dp) :: end = 10.0_dp - integer :: base = 2 - integer :: i - real(dp) :: expected_proportion + x = logspace(start, end, n, base) - real(dp), allocatable :: x(:) + expected_proportion = 2 ** ( ( end - start ) / ( n - 1 ) ) - x = logspace(start, end, n, base) + call check(error, size(x), n, "Array not allocated to appropriate size") + if (allocated(error)) return + call check(error, x(1), base ** start, "Initial value of array is not equal to 2^start") + if (allocated(error)) return + call check(error, x(n), base ** end, "Final value of array is not equal to 2^end") + if (allocated(error)) return - expected_proportion = 2 ** ( ( end - start ) / ( n - 1 ) ) + do i = 1, n-1 - call check(x(1) == base ** start, msg="Initial value of array is not equal to 2^start", warn=warn) - call check(x(n) == base ** end, msg="Final value of array is not equal to 2^end", warn=warn) - call check(size(x) == n, msg="Array not allocated to appropriate size", warn=warn) + call check(error, x(i + 1) / x(i), expected_proportion, & + & thr=abs(expected_proportion) * TOLERANCE_DP) + if (allocated(error)) return - do i = 1, n-1 + end do - call check(abs(x(i + 1) / x(i) - expected_proportion) < abs(expected_proportion) * TOLERANCE_DP) + end subroutine - end do + subroutine test_logspace_base_2_cmplx_start(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - write(unit=iunit, fmt=*) "logspace(1.0_dp, 10.0_dp, 10, 2): " - write(unit=iunit,fmt='(70("="))') - write(unit=iunit,fmt="(10(F9.3, 2X))") x - write(iunit,*) - write(iunit,*) + integer, parameter :: n = 10 + complex(dp), parameter :: start = (1, 0) + complex(dp), parameter :: end = (0, 1) + integer, parameter :: base = 2 + complex(dp) :: expected_proportion + integer :: i - end subroutine + complex(dp), allocatable :: x(:) - subroutine test_logspace_base_2_cmplx_start + x = logspace(start, end, n, base) - integer :: n = 10 - complex(dp) :: start = (1, 0) - complex(dp) :: end = (0, 1) - integer :: base = 2 - complex(dp) :: expected_proportion - integer :: i + expected_proportion = 2 ** ( ( end - start ) / ( n - 1 ) ) - complex(dp), allocatable :: x(:) - x = logspace(start, end, n, base) + call check(error, size(x), n, "Array not allocated to appropriate size") + if (allocated(error)) return + call check(error, x(1), base ** start, "Initial value of array is not equal to 2^start") + if (allocated(error)) return + call check(error, x(n), base ** end, "Final value of array is not equal to 2^end") + if (allocated(error)) return - expected_proportion = 2 ** ( ( end - start ) / ( n - 1 ) ) + do i = 1, n-1 + call check(error, x(i + 1) / x(i), expected_proportion, & + & thr=abs(expected_proportion) * TOLERANCE_DP) + if (allocated(error)) return - call check(x(1) == base ** start, msg="Initial value of array is not equal to 2^start", warn=warn) - call check(x(n) == base ** end, msg="Final value of array is not equal to 2^end", warn=warn) - call check(size(x) == n, msg="Array not allocated to appropriate size", warn=warn) + end do - do i = 1, n-1 + end subroutine - call check(abs(x(i + 1) / x(i) - expected_proportion) < abs(expected_proportion) * TOLERANCE_DP) + subroutine test_logspace_base_i_int_start(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - end do + integer, parameter :: n = 5 + integer, parameter :: start = 1 + integer, parameter :: end = 5 + complex(dp), parameter :: base = (0, 1) ! i + complex(dp) :: expected_proportion + integer :: i - write(unit=iunit, fmt=*) "logspace(1, i, 10, 2): " - write(unit=iunit,fmt='(70("="))') - write(unit=iunit,fmt="(10('(', F6.3, ',', 1X, F6.3, ')', 2X))") x - write(iunit,*) - write(iunit,*) + complex(dp), allocatable :: x(:) - end subroutine + x = logspace(start, end, n, base) - subroutine test_logspace_base_i_int_start + expected_proportion = base ** ( ( end - start ) / ( n - 1 ) ) - integer :: n = 5 - integer :: start = 1 - integer :: end = 5 - complex(dp) :: base = (0, 1) ! i - complex(dp) :: expected_proportion - integer :: i = 1 + call check(error, size(x), n, "Array not allocated to appropriate size") + if (allocated(error)) return + call check(error, x(1), base ** start, "Initial value of array is not equal to 2^start") + if (allocated(error)) return + call check(error, x(n), base ** end, "Final value of array is not equal to 2^end") + if (allocated(error)) return - complex(dp), allocatable :: x(:) + do i = 1, n-1 - x = logspace(start, end, n, base) + call check(error, x(i + 1) / x(i), expected_proportion, & + & thr=abs(expected_proportion) * TOLERANCE_DP) + if (allocated(error)) return - expected_proportion = base ** ( ( end - start ) / ( n - 1 ) ) + end do - call check(x(1) == base ** start, msg="Initial value of array is not equal to 2^start", warn=warn) - call check(x(n) == base ** end, msg="Final value of array is not equal to 2^end", warn=warn) - call check(size(x) == n, msg="Array not allocated to appropriate size", warn=warn) + end subroutine - do i = 1, n-1 - call check(abs(x(i + 1) / x(i) - expected_proportion) < abs(expected_proportion) * TOLERANCE_DP) +end module - end do - - write(unit=iunit, fmt=*) "logspace(1, 5, 5, i): " - write(unit=iunit,fmt='(70("="))') - write(unit=iunit,fmt="(10('(', F6.3, ',', 1X, F6.3, ')', 2X))") x - write(iunit,*) - write(iunit,*) - - end subroutine - - - end program \ No newline at end of file +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_logspace, only : collect_logspace + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("logspace", collect_logspace) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program tester diff --git a/src/tests/math/test_math_arange.f90 b/src/tests/math/test_math_arange.f90 index 0da565afe..ad2ddf3ef 100644 --- a/src/tests/math/test_math_arange.f90 +++ b/src/tests/math/test_math_arange.f90 @@ -1,53 +1,86 @@ -!> SPDX-Identifier: MIT -module test_math_arange +! SPDX-Identifier: MIT - use stdlib_error, only: check +module test_math_arange + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_math, only: arange implicit none - logical, private :: warn = .false. + public :: collect_math_arange contains - subroutine test_math_arange_real - !> Normal - call check(all(arange(3.0) == [1.0, 2.0, 3.0]), msg="all(arange(3.0) == [1.0,2.0,3.0]) failed.", warn=warn) - call check(all(arange(-1.0) == [1.0, 0.0, -1.0]), msg="all(arange(-1.0) == [1.0,0.0,-1.0]) failed.", warn=warn) - call check(all(arange(0.0, 2.0) == [0.0, 1.0, 2.0]), msg="all(arange(0.0,2.0) == [0.0,1.0,2.0]) failed.", warn=warn) - call check(all(arange(1.0, -1.0) == [1.0, 0.0, -1.0]), msg="all(arange(1.0,-1.0) == [1.0,0.0,-1.0]) failed.", warn=warn) - call check(all(arange(1.0, 1.0) == [1.0]), msg="all(arange(1.0,1.0) == [1.0]) failed.", warn=warn) - call check(all(arange(0.0, 2.0, 2.0) == [0.0, 2.0]), msg="all(arange(0.0,2.0,2.0) == [0.0,2.0]) failed.", warn=warn) - call check(all(arange(1.0, -1.0, 2.0) == [1.0, -1.0]), msg="all(arange(1.0,-1.0,2.0) == [1.0,-1.0]) failed.", warn=warn) - !> Not recommended - call check(all(arange(0.0, 2.0, -2.0) == [0.0, 2.0]), msg="all(arange(0.0,2.0,-2.0) == [0.0,2.0]) failed.", warn=warn) - call check(all(arange(1.0, -1.0, -2.0) == [1.0, -1.0]),msg="all(arange(1.0,-1.0,-2.0) == [1.0,-1.0]) failed.", warn=warn) - call check(all(arange(0.0, 2.0, 0.0) == [0.0,1.0,2.0]),msg="all(arange(0.0, 2.0, 0.0) == [0.0,1.0,2.0]) failed.", warn=warn) + !> Collect all exported unit tests + subroutine collect_math_arange(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("arange-real", test_math_arange_real), & + new_unittest("arange-integer", test_math_arange_integer) & + ] + + end subroutine collect_math_arange + + subroutine test_math_arange_real(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + ! Normal + call check(error, all(arange(3.0) == [1.0, 2.0, 3.0]), "all(arange(3.0) == [1.0,2.0,3.0]) failed.") + call check(error, all(arange(-1.0) == [1.0, 0.0, -1.0]), "all(arange(-1.0) == [1.0,0.0,-1.0]) failed.") + call check(error, all(arange(0.0, 2.0) == [0.0, 1.0, 2.0]), "all(arange(0.0,2.0) == [0.0,1.0,2.0]) failed.") + call check(error, all(arange(1.0, -1.0) == [1.0, 0.0, -1.0]), "all(arange(1.0,-1.0) == [1.0,0.0,-1.0]) failed.") + call check(error, all(arange(1.0, 1.0) == [1.0]), "all(arange(1.0,1.0) == [1.0]) failed.") + call check(error, all(arange(0.0, 2.0, 2.0) == [0.0, 2.0]), "all(arange(0.0,2.0,2.0) == [0.0,2.0]) failed.") + call check(error, all(arange(1.0, -1.0, 2.0) == [1.0, -1.0]), "all(arange(1.0,-1.0,2.0) == [1.0,-1.0]) failed.") + ! Not recommended + call check(error, all(arange(0.0, 2.0, -2.0) == [0.0, 2.0]), "all(arange(0.0,2.0,-2.0) == [0.0,2.0]) failed.") + call check(error, all(arange(1.0, -1.0, -2.0) == [1.0, -1.0]),"all(arange(1.0,-1.0,-2.0) == [1.0,-1.0]) failed.") + call check(error, all(arange(0.0, 2.0, 0.0) == [0.0,1.0,2.0]),"all(arange(0.0, 2.0, 0.0) == [0.0,1.0,2.0]) failed.") end subroutine test_math_arange_real - subroutine test_math_arange_integer - !> Normal - call check(all(arange(3) == [1, 2, 3]), msg="all(arange(3) == [1,2,3]) failed.", warn=warn) - call check(all(arange(-1) == [1, 0, -1]), msg="all(arange(-1) == [1,0,-1]) failed.", warn=warn) - call check(all(arange(0, 2) == [0, 1, 2]), msg="all(arange(0,2) == [0,1,2]) failed.", warn=warn) - call check(all(arange(1, -1) == [1, 0, -1]), msg="all(arange(1,-1) == [1,0,-1]) failed.", warn=warn) - call check(all(arange(1, 1) == [1]), msg="all(arange(1,1) == [1]) failed.", warn=warn) - call check(all(arange(0, 2, 2) == [0, 2]), msg="all(arange(0,2,2) == [0,2]) failed.", warn=warn) - call check(all(arange(1, -1, 2) == [1, -1]), msg="all(arange(1,-1,2) == [1,-1]) failed.", warn=warn) - !> Not recommended - call check(all(arange(0, 2, -2) == [0, 2]), msg="all(arange(0,2,-2) == [0,2]) failed.", warn=warn) - call check(all(arange(1, -1, -2) == [1, -1]), msg="all(arange(1,-1,-2) == [1,-1]) failed.", warn=warn) - call check(all(arange(0, 2, 0) == [0,1,2]), msg="all(arange(0, 2, 0) == [0,1,2]) failed.", warn=warn) + subroutine test_math_arange_integer(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + ! Normal + call check(error, all(arange(3) == [1, 2, 3]), "all(arange(3) == [1,2,3]) failed.") + call check(error, all(arange(-1) == [1, 0, -1]), "all(arange(-1) == [1,0,-1]) failed.") + call check(error, all(arange(0, 2) == [0, 1, 2]), "all(arange(0,2) == [0,1,2]) failed.") + call check(error, all(arange(1, -1) == [1, 0, -1]), "all(arange(1,-1) == [1,0,-1]) failed.") + call check(error, all(arange(1, 1) == [1]), "all(arange(1,1) == [1]) failed.") + call check(error, all(arange(0, 2, 2) == [0, 2]), "all(arange(0,2,2) == [0,2]) failed.") + call check(error, all(arange(1, -1, 2) == [1, -1]), "all(arange(1,-1,2) == [1,-1]) failed.") + ! Not recommended + call check(error, all(arange(0, 2, -2) == [0, 2]), "all(arange(0,2,-2) == [0,2]) failed.") + call check(error, all(arange(1, -1, -2) == [1, -1]), "all(arange(1,-1,-2) == [1,-1]) failed.") + call check(error, all(arange(0, 2, 0) == [0,1,2]), "all(arange(0, 2, 0) == [0,1,2]) failed.") end subroutine test_math_arange_integer end module test_math_arange program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_math_arange, only : collect_math_arange + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 - use test_math_arange + testsuites = [ & + new_testsuite("math-arange", collect_math_arange) & + ] - call test_math_arange_real - call test_math_arange_integer - - print *, "All tests in `test_math_arange` passed." + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if end program tester diff --git a/src/tests/math/test_stdlib_math.f90 b/src/tests/math/test_stdlib_math.f90 index 7fafc6bfe..e916ff73f 100644 --- a/src/tests/math/test_stdlib_math.f90 +++ b/src/tests/math/test_stdlib_math.f90 @@ -1,98 +1,223 @@ ! SPDX-Identifier: MIT -program test_stdlib_math +module test_stdlib_math + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_math, only: clip - use stdlib_error, only: check use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, qp implicit none - ! clip function - ! testing format: check(clip(x, xmin, xmax) == correct answer) - ! valid case: xmin is not greater than xmax - ! invalid case: xmin is greater than xmax - - ! type: integer(int8), kind: int8 - ! valid test case - call check(clip(2_int8, -2_int8, 5_int8) == 2_int8, & - 'clip_int8 failed for valid case', warn=.true.) - call check(clip(127_int8, -127_int8, 0_int8) == 0_int8, & - 'clip_int8 failed for valid case', warn=.true.) - ! invalid test case - call check(clip(2_int8, 5_int8, -2_int8) == 5_int8, & - 'clip_int8 failed for invalid case', warn=.true.) - call check(clip(127_int8, 0_int8, -127_int8) == 0_int8, & - 'clip_int8 failed for invalid case', warn=.true.) - - ! type: integer(int16), kind: int16 - ! valid test case - call check(clip(2_int16, -2_int16, 5_int16) == 2_int16, & - 'clip_int16 failed for valid case', warn=.true.) - call check(clip(32767_int16, -32767_int16, 0_int16) == 0_int16, & - 'clip_int16 failed for valid case', warn=.true.) - ! invalid test case - call check(clip(2_int16, 5_int16, -2_int16) == 5_int16, & - 'clip_int16 failed for invalid case', warn=.true.) - call check(clip(32767_int16, 0_int16, -32767_int16) == 0_int16, & - 'clip_int16 failed for invalid case', warn=.true.) - - ! type: integer(int32), kind: int32 - ! valid test case - call check(clip(2_int32, -2_int32, 5_int32) == 2_int32, & - 'clip_int32 failed for valid case', warn=.true.) - call check(clip(-2147483647_int32, 0_int32, 2147483647_int32) == 0_int32, & - 'clip_int32 failed for valid case', warn=.true.) - ! invalid test case - call check(clip(2_int32, 5_int32, -2_int32) == 5_int32, & - 'clip_int32 failed for invalid case', warn=.true.) - call check(clip(-2147483647_int32, 2147483647_int32, 0_int32) == 2147483647_int32, & - 'clip_int32 failed for invalid case', warn=.true.) - - ! type: integer(int64), kind: int64 - ! valid test case - call check(clip(2_int64, -2_int64, 5_int64) == 2_int64, & - 'clip_int64 failed for valid case', warn=.true.) - call check(clip(-922337203_int64, -10_int64, 25_int64) == -10_int64, & - 'clip_int64 failed for valid case', warn=.true.) - ! invalid test case - call check(clip(2_int64, 5_int64, -2_int64) == 5_int64, & - 'clip_int64 failed for invalid case', warn=.true.) - call check(clip(-922337203_int64, 25_int64, -10_int64) == 25_int64, & - 'clip_int64 failed for invalid case', warn=.true.) - - ! type: real(sp), kind: sp - ! valid test case - call check(clip(3.025_sp, -5.77_sp, 3.025_sp) == 3.025_sp, & - 'clip_sp failed for valid case', warn=.true.) - call check(clip(0.0_sp, -1578.025_sp, -59.68_sp) == -59.68_sp, & - 'clip_sp failed for valid case', warn=.true.) - ! invalid test case - call check(clip(3.025_sp, 3.025_sp, -5.77_sp) == 3.025_sp, & - 'clip_sp failed for invalid case', warn=.true.) - call check(clip(0.0_sp, -59.68_sp, -1578.025_sp) == -59.68_sp, & - 'clip_sp failed for invalid case', warn=.true.) - - ! type: real(dp), kind: dp - ! valid test case - call check(clip(3.025_dp, -5.77_dp, 3.025_dp) == 3.025_dp, & - 'clip_dp failed for valid case', warn=.true.) - call check(clip(-7.0_dp, 0.059668_dp, 1.00268_dp) == 0.059668_dp, & - 'clip_dp failed for valid case', warn=.true.) - ! invalid test case - call check(clip(3.025_dp, 3.025_dp, -5.77_dp) == 3.025_dp, & - 'clip_dp failed for invalid case', warn=.true.) - call check(clip(-7.0_dp, 1.00268_dp, 0.059668_dp) == 1.00268_dp, & - 'clip_dp failed for invalid case', warn=.true.) - - ! type: real(qp), kind: qp - ! valid test case - call check(clip(3.025_qp, -5.77_qp, 3.025_qp) == 3.025_qp, & - 'clip_qp failed for valid case', warn=.true.) - call check(clip(-55891546.2_qp, -8958133457.23_qp, -689712245.23_qp) == -689712245.23_qp, & - 'clip_qp failed for valid case', warn=.true.) - ! invalid test case - call check(clip(3.025_qp, 3.025_qp, -5.77_qp) == 3.025_qp, & - 'clip_qp failed for invalid case', warn=.true.) - call check(clip(-55891546.2_qp, -689712245.23_qp, -8958133457.23_qp) == -689712245.23_qp, & - 'clip_qp failed for invalid case', warn=.true.) - -end program test_stdlib_math + public :: collect_stdlib_math + +contains + + !> Collect all exported unit tests + subroutine collect_stdlib_math(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("clip-int8", test_clip_int8), & + new_unittest("clip-int8-bounds", test_clip_int8_bounds), & + new_unittest("clip-int16", test_clip_int16), & + new_unittest("clip-int16-bounds", test_clip_int16_bounds), & + new_unittest("clip-int32", test_clip_int32), & + new_unittest("clip-int32-bounds", test_clip_int32_bounds), & + new_unittest("clip-int64", test_clip_int64), & + new_unittest("clip-int64-bounds", test_clip_int64_bounds), & + new_unittest("clip-real-single", test_clip_rsp), & + new_unittest("clip-real-single-bounds", test_clip_rsp_bounds), & + new_unittest("clip-real-double", test_clip_rdp), & + new_unittest("clip-real-double-bounds", test_clip_rdp_bounds), & + new_unittest("clip-real-quad", test_clip_rqp), & + new_unittest("clip-real-quad-bounds", test_clip_rqp_bounds) & + ] + + end subroutine collect_stdlib_math + + subroutine test_clip_int8(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + ! clip function + ! testing format: check(clip(x, xmin, xmax) == correct answer) + ! valid case: xmin is not greater than xmax + ! invalid case: xmin is greater than xmax + + ! type: integer(int8), kind: int8 + ! valid test case + call check(error, clip(2_int8, -2_int8, 5_int8), 2_int8) + if (allocated(error)) return + call check(error, clip(127_int8, -127_int8, 0_int8), 0_int8) + if (allocated(error)) return + end subroutine test_clip_int8 + + subroutine test_clip_int8_bounds(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + ! invalid test case + call check(error, clip(2_int8, 5_int8, -2_int8), 5_int8) + if (allocated(error)) return + call check(error, clip(127_int8, 0_int8, -127_int8), 0_int8) + if (allocated(error)) return + end subroutine test_clip_int8_bounds + + + subroutine test_clip_int16(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + ! type: integer(int16), kind: int16 + ! valid test case + call check(error, clip(2_int16, -2_int16, 5_int16), 2_int16) + if (allocated(error)) return + call check(error, clip(32767_int16, -32767_int16, 0_int16), 0_int16) + if (allocated(error)) return + end subroutine test_clip_int16 + + subroutine test_clip_int16_bounds(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + ! invalid test case + call check(error, clip(2_int16, 5_int16, -2_int16), 5_int16) + if (allocated(error)) return + call check(error, clip(32767_int16, 0_int16, -32767_int16), 0_int16) + if (allocated(error)) return + end subroutine test_clip_int16_bounds + + + subroutine test_clip_int32(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + ! type: integer(int32), kind: int32 + ! valid test case + call check(error, clip(2_int32, -2_int32, 5_int32), 2_int32) + if (allocated(error)) return + call check(error, clip(-2147483647_int32, 0_int32, 2147483647_int32), 0_int32) + if (allocated(error)) return + end subroutine test_clip_int32 + + subroutine test_clip_int32_bounds(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + ! invalid test case + call check(error, clip(2_int32, 5_int32, -2_int32), 5_int32) + if (allocated(error)) return + call check(error, clip(-2147483647_int32, 2147483647_int32, 0_int32), 2147483647_int32) + if (allocated(error)) return + end subroutine test_clip_int32_bounds + + + subroutine test_clip_int64(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + ! type: integer(int64), kind: int64 + ! valid test case + call check(error, clip(2_int64, -2_int64, 5_int64), 2_int64) + if (allocated(error)) return + call check(error, clip(-922337203_int64, -10_int64, 25_int64), -10_int64) + if (allocated(error)) return + end subroutine test_clip_int64 + + subroutine test_clip_int64_bounds(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + ! invalid test case + call check(error, clip(2_int64, 5_int64, -2_int64), 5_int64) + if (allocated(error)) return + call check(error, clip(-922337203_int64, 25_int64, -10_int64), 25_int64) + if (allocated(error)) return + end subroutine test_clip_int64_bounds + + + subroutine test_clip_rsp(error) + !> Error handling + 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) + if (allocated(error)) return + 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 + + subroutine test_clip_rsp_bounds(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + ! invalid test case + call check(error, clip(3.025_sp, 3.025_sp, -5.77_sp), 3.025_sp) + if (allocated(error)) return + call check(error, clip(0.0_sp, -59.68_sp, -1578.025_sp), -59.68_sp) + if (allocated(error)) return + end subroutine test_clip_rsp_bounds + + + subroutine test_clip_rdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + ! type: real(dp), kind: dp + ! valid test case + call check(error, clip(3.025_dp, -5.77_dp, 3.025_dp), 3.025_dp) + if (allocated(error)) return + call check(error, clip(-7.0_dp, 0.059668_dp, 1.00268_dp), 0.059668_dp) + if (allocated(error)) return + end subroutine test_clip_rdp + + subroutine test_clip_rdp_bounds(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + ! invalid test case + call check(error, clip(3.025_dp, 3.025_dp, -5.77_dp), 3.025_dp) + if (allocated(error)) return + call check(error, clip(-7.0_dp, 1.00268_dp, 0.059668_dp), 1.00268_dp) + if (allocated(error)) return + end subroutine test_clip_rdp_bounds + + + subroutine test_clip_rqp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + ! type: real(qp), kind: qp + ! valid test case + 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) + if (allocated(error)) return + end subroutine test_clip_rqp + + + subroutine test_clip_rqp_bounds(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + ! 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) + if (allocated(error)) return + + end subroutine test_clip_rqp_bounds + +end module test_stdlib_math + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_stdlib_math, only : collect_stdlib_math + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("stdlib-math", collect_stdlib_math) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program tester diff --git a/src/tests/stdlib_test.fypp b/src/tests/stdlib_test.fypp index d0cc832f3..30c8b1bae 100644 --- a/src/tests/stdlib_test.fypp +++ b/src/tests/stdlib_test.fypp @@ -833,8 +833,7 @@ contains integer, parameter :: buffer_len = 256 character(len=buffer_len) :: buffer - write(buffer, '(g0)') val - string = trim(buffer) + string = "("//to_string(real(val))//", "//to_string(aimag(val))//")" end function complex_${kind}$_to_string #:endfor diff --git a/src/tests/test/test_check.f90 b/src/tests/test/test_check.f90 index 19d482b5a..83cd59be7 100644 --- a/src/tests/test/test_check.f90 +++ b/src/tests/test/test_check.f90 @@ -38,9 +38,9 @@ subroutine collect_check(testsuite) testsuite = [ & new_unittest("success", test_success), & new_unittest("failure", test_failure, should_fail=.true.), & - new_unittest("skipped", test_skipped), & new_unittest("failure-message", test_failure_message, should_fail=.true.), & new_unittest("failure-with-more", test_failure_with_more, should_fail=.true.), & + new_unittest("skipped", test_skipped), & 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.), & @@ -50,11 +50,29 @@ subroutine collect_check(testsuite) 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("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("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.), & @@ -103,15 +121,6 @@ subroutine test_failure(error) end subroutine test_failure - subroutine test_skipped(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - call skip_test(error, "This test is always skipped") - - end subroutine test_skipped - - subroutine test_failure_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -130,6 +139,15 @@ subroutine test_failure_with_more(error) end subroutine test_failure_with_more + subroutine test_skipped(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call skip_test(error, "This test is always skipped") + + end subroutine test_skipped + + subroutine test_expression(error) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -193,6 +211,7 @@ end subroutine test_rsp_nan subroutine test_rsp_rel(error) + !> Error handling type(error_type), allocatable, intent(out) :: error @@ -231,6 +250,33 @@ subroutine test_rsp_rel_fail(error) end subroutine test_rsp_rel_fail + subroutine test_rsp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val + + val = 1.0_sp + + call check(error, val, 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 + + 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 @@ -296,6 +342,215 @@ subroutine test_rdp_rel_fail(error) end subroutine test_rdp_rel_fail + subroutine test_rdp_abs_message(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val + + val = 1.0_dp + + call check(error, val, 1.5_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 + + 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_csp_abs(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: val + + val = cmplx(3.3_sp, 1.0_sp, sp) + + call check(error, val, 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 + + val = cmplx(ieee_value(real(val), ieee_quiet_nan), & + & ieee_value(aimag(val), ieee_quiet_nan), sp) + + call check(error, val, 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 + + val = cmplx(3.3_sp, 1.0_sp, sp) + + call check(error, val, 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 + + val = cmplx(1.0_sp, 2.0_sp, sp) + + call check(error, val, cmplx(2.0_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 + + val = cmplx(1.0_sp, 1.5_sp, sp) + + call check(error, val, cmplx(1.5_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 + + val = cmplx(1.0_sp, 1.5_sp, sp) + + call check(error, val, cmplx(1.5_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 + + val = cmplx(ieee_value(real(val), 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 + + val = cmplx(3.3_dp, 1.0_dp, dp) + + call check(error, val, 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 + + val = cmplx(3.3_dp, 1.0_dp, dp) + + call check(error, val, 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 + + val = cmplx(ieee_value(real(val), ieee_quiet_nan), 0.0_dp, dp) + + call check(error, val, 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 + + val = cmplx(1.0_dp, 2.0_dp, dp) + + call check(error, val, cmplx(2.0_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 + + val = cmplx(1.0_dp, 1.5_dp, dp) + + call check(error, val, cmplx(1.5_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 + + val = cmplx(1.0_dp, 1.5_dp, dp) + + call check(error, val, cmplx(1.5_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 + + val = cmplx(ieee_value(real(val), 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_i1(error) !> Error handling type(error_type), allocatable, intent(out) :: error From 6cd38511acfc04e7dbaa537a822fdba4ead3db53 Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Sun, 22 Aug 2021 20:27:18 +0200 Subject: [PATCH 03/34] Use to_string routines provided by stdlib --- src/tests/stdlib_test.fypp | 39 +------------------------------------- 1 file changed, 1 insertion(+), 38 deletions(-) diff --git a/src/tests/stdlib_test.fypp b/src/tests/stdlib_test.fypp index 30c8b1bae..1bbfae9ae 100644 --- a/src/tests/stdlib_test.fypp +++ b/src/tests/stdlib_test.fypp @@ -87,7 +87,7 @@ module stdlib_test use, intrinsic :: iso_fortran_env, only : error_unit use, intrinsic :: ieee_arithmetic, only : ieee_is_nan - use stdlib_ascii, only : to_string + use stdlib_strings, only : to_string use stdlib_kinds, only : sp, dp, qp, int8, int16, int32, int64 use stdlib_optval, only : optval implicit none @@ -142,16 +142,6 @@ module stdlib_test end interface check - interface to_string - #:for kind in REAL_KINDS - module procedure :: real_${kind}$_to_string - #:endfor - #:for kind in CMPLX_KINDS - module procedure :: complex_${kind}$_to_string - #:endfor - end interface to_string - - abstract interface !> Entry point for tests subroutine test_interface(error) @@ -811,33 +801,6 @@ contains end subroutine get_variable -#:for kind in REAL_KINDS - pure function real_${kind}$_to_string(val) result(string) - integer, parameter :: wp = ${kind}$ - real(wp), 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_${kind}$_to_string -#:endfor - - -#:for kind in CMPLX_KINDS - pure function complex_${kind}$_to_string(val) result(string) - integer, parameter :: wp = ${kind}$ - complex(wp), intent(in) :: val - character(len=:), allocatable :: string - integer, parameter :: buffer_len = 256 - character(len=buffer_len) :: buffer - - string = "("//to_string(real(val))//", "//to_string(aimag(val))//")" - end function complex_${kind}$_to_string -#:endfor - - !> Clear error type after it has been handled. subroutine clear_error(error) !> Error handling From 3f186d278039c546f31ed330c285eb3fcc6e70a5 Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Sun, 22 Aug 2021 23:41:46 +0200 Subject: [PATCH 04/34] Rewrite tests for stdlib_bitset_64 --- src/tests/bitsets/test_stdlib_bitset_64.f90 | 1038 ++++++++----------- 1 file changed, 454 insertions(+), 584 deletions(-) diff --git a/src/tests/bitsets/test_stdlib_bitset_64.f90 b/src/tests/bitsets/test_stdlib_bitset_64.f90 index 2ca1d3af0..c0f26ef0c 100644 --- a/src/tests/bitsets/test_stdlib_bitset_64.f90 +++ b/src/tests/bitsets/test_stdlib_bitset_64.f90 @@ -1,232 +1,225 @@ -program test_stdlib_bitset_64 +module test_stdlib_bitset_64 + use stdlib_test, only : new_unittest, unittest_type, error_type, check use :: stdlib_kinds, only : int8, int16, int32, int64 use stdlib_bitsets + implicit none + private + + public :: collect_stdlib_bitset_64 + character(*), parameter :: & bitstring_0 = '000000000000000000000000000000000', & bitstring_33 = '100000000000000000000000000000000', & bitstring_all = '111111111111111111111111111111111' - type(bitset_64) :: set0, set1, set2, set3, set4, set5 - integer :: status - character(:), allocatable :: string0 - call test_string_operations() +contains - call test_io() + !> Collect all exported unit tests + subroutine collect_stdlib_bitset_64(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) - call test_initialization() + testsuite = [ & + new_unittest("string-operations-0", test_string_operations_0), & + new_unittest("string-operations-1", test_string_operations_1), & + new_unittest("string-operations-3", test_string_operations_3), & + new_unittest("string-operations-4", test_string_operations_4), & + new_unittest("io", test_io), & + new_unittest("initialization", test_initialization), & + new_unittest("bitset-inquiry", test_bitset_inquiry), & + new_unittest("bit-operations", test_bit_operations), & + new_unittest("bitset-comparisons", test_bitset_comparisons), & + new_unittest("bitset-operations-and", test_bitset_operations_and), & + new_unittest("bitset-operations-nand", test_bitset_operations_nand), & + new_unittest("bitset-operations-or", test_bitset_operations_or), & + new_unittest("bitset-operations-xor", test_bitset_operations_xor) & + ] - call test_bitset_inquiry() + end subroutine collect_stdlib_bitset_64 - call test_bit_operations() + subroutine test_string_operations_0(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - call test_bitset_comparisons() + type(bitset_64) :: set + character(:), allocatable :: string0 - call test_bitset_operations() + call set%from_string(bitstring_0) -contains + call check(error, bits(set), 33) + if (allocated(error)) return - subroutine test_string_operations() - character(*), parameter:: procedure = 'TEST_STRING_OPERATIONS' - - write(*,'(/a)') 'Test string operations: from_string, ' // & - 'read_bitset, to_string, and write_bitset' - - call set0 % from_string( bitstring_0 ) - if ( bits(set0) /= 33 ) then - error stop procedure // ' from_string failed to interpret ' // & - 'bitstring_0 size properly.' - else if ( .not. set0 % none() ) then - error stop procedure // ' failed to interpret bitstring_0 ' // & - 'value properly.' - else if ( set0 % any() ) then - error stop procedure // ' failed to interpret bitstring_0 ' // & - 'value properly.' - else - write(*,*) 'from_string transferred bitstring_0 properly into set0' - end if + call check(error, set%none()) + if (allocated(error)) return - call set1 % from_string( bitstring_all ) - if ( bits(set1) /= 33 ) then - error stop procedure // ' from_string failed to interpret ' // & - 'bitstring_all size properly.' - else if ( set1 % none() ) then - error stop procedure // ' failed to interpret bitstring_all ' // & - 'value properly.' - else if ( .not. set1 % any() ) then - error stop procedure // ' failed to interpret bitstring_all ' // & - 'value properly.' - else if ( .not. set1 % all() ) then - error stop procedure // ' failed to interpret bitstring_all ' // & - 'value properly.' - else - write(*,*) 'from_string transferred bitstring_all properly ' // & - 'into set1' - end if + call check(error, .not.set%any()) + if (allocated(error)) return - call set3 % read_bitset( bitstring_0, status ) - if ( status /= success ) then - write(*,*) 'read_bitset_string failed with bitstring_0 as expected.' - else - error stop procedure // ' read_bitset_string did not fail ' // & - 'with bitstring_0 as expected.' - end if + call set%to_string(string0) - call set3 % read_bitset( 's33b' // bitstring_0, status ) - - if ( bits(set3) /= 33 ) then - error stop procedure // ' read_bitset_string failed to ' // & - 'interpret "s33b" // bitstring_0 size properly.' - else if ( .not. set3 % none() ) then - error stop procedure // ' failed to interpret "s33b" // ' // & - 'bitstring_0 value properly.' - else - write(*,*) 'read_bitset_string transferred "s33b" // ' // & - 'bitstring_0 properly into set3' - end if + call check(error, string0, bitstring_0) + if (allocated(error)) return - call set4 % read_bitset( 's33b' // bitstring_all ) - if ( bits(set4) /= 33 ) then - error stop procedure // ' read_bitset_string failed to ' // & - 'interpret "s33b" // bitstring_all size properly.' - else if ( set4 % none() ) then - error stop procedure // ' read_bitset_string failed to ' // & - 'interpret "s33b" // bitstring_all value properly.' - else if ( .not. set4 % any() ) then - error stop procedure // ' read_bitset_string failed to // ' // & - 'interpret "s33b" bitstring_all value properly.' - else if ( .not. set4 % all() ) then - error stop procedure // ' read_bitset_string failed to // ' // & - 'interpret "s33b" bitstring_all value properly.' - else - write(*,*) 'read_bitset_string transferred "s33b" // ' // & - 'bitstring_all properly into set4.' - end if + call set%write_bitset(string0) - call set0 % to_string( string0 ) - if ( bitstring_0 /= string0 ) then - error stop procedure // ' to_string failed to convert set0 ' // & - 'value properly.' - else - write(*,*) 'to_string properly converted the set0 value' - end if + call check(error, string0, ('S33B' // bitstring_0)) + if (allocated(error)) return - call set1 % to_string( string0 ) - if ( bitstring_all /= string0 ) then - error stop procedure // ' to_string failed to convert set1 ' // & - 'value properly.' - else - write(*,*) 'to_string properly converted the set1 value' - end if + end subroutine test_string_operations_0 - call set0 % write_bitset( string0 ) - if ( ('S33B' // bitstring_0) /= string0 ) then - error stop procedure // ' write_bitset_string failed to ' // & - 'convert set0 value properly.' - else - write(*,*) 'write_bitset_string properly converted the set0 value' - end if + subroutine test_string_operations_1(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - call set1 % write_bitset( string0 ) - if ( ('S33B' // bitstring_all) /= string0 ) then - error stop procedure // ' write_bitset_string failed to ' // & - 'convert set1 value properly.' - else - write(*,*) 'write_bitset_string properly converted the set1 value' - end if + type(bitset_64) :: set + character(:), allocatable :: string0 + + call set%from_string(bitstring_all) + + call check(error, bits(set), 33) + if (allocated(error)) return + + call check(error, .not.set%none() ) + if (allocated(error)) return + + call check(error, set%any() ) + if (allocated(error)) return + + call check(error, set%all() ) + if (allocated(error)) return + + call set%to_string(string0) + + call check(error, string0, bitstring_all) + if (allocated(error)) return + + call set%write_bitset(string0) + + call check(error, string0, ('S33B' // bitstring_all)) + if (allocated(error)) return + + end subroutine test_string_operations_1 + + subroutine test_string_operations_3(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(bitset_64) :: set + integer :: status + + call set%read_bitset(bitstring_0, status) + + call check(error, status /= success) + if (allocated(error)) return + + call set%read_bitset('s33b' // bitstring_0, status) + + call check(error, bits(set), 33) + if (allocated(error)) return - return - end subroutine test_string_operations + call check(error, set%none()) + if (allocated(error)) return - subroutine test_io() - character(*), parameter:: procedure = 'TEST_IO' + end subroutine test_string_operations_3 + + subroutine test_string_operations_4(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(bitset_64) :: set + + call set%read_bitset('s33b' // bitstring_all ) + + call check(error, bits(set), 33) + if (allocated(error)) return + + call check(error, .not.set%none()) + if (allocated(error)) return + + call check(error, set%any()) + if (allocated(error)) return + + call check(error, set%all()) + if (allocated(error)) return + + end subroutine test_string_operations_4 + + subroutine test_io(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error integer :: unit + type(bitset_64) :: set0, set1, set2, set3, set4, set5 - write(*,*) - write(*,*) 'Test bitset I/O: input, read_bitset, output, and ' // & - 'write_bitset' + call set0%from_string(bitstring_0) + call set1%from_string(bitstring_all) + call set2%from_string(bitstring_33) - call set2 % from_string( bitstring_33 ) open( newunit=unit, status='scratch', form='formatted', & action='readwrite' ) - call set2 % write_bitset(unit) - call set1 % write_bitset(unit) - call set0 % write_bitset(unit) + call set2%write_bitset(unit) + call set1%write_bitset(unit) + call set0%write_bitset(unit) rewind( unit ) - call set3 % read_bitset(unit) - call set5 % read_bitset(unit) - call set4 % read_bitset(unit) - - if ( set4 /= set0 .or. set5 /= set1 .or. set3 /= set2 ) then - error stop procedure // ' transfer to and from units using ' // & - 'bitset literals failed.' - else - write(*,*) 'Transfer to and from units using ' // & - 'plain write_bitset_unit and read_bitset_unit succeeded.' - end if - - rewind( unit ) - - call set2 % write_bitset(unit, advance='no') - call set1 % write_bitset(unit, advance='no') - call set0 % write_bitset(unit) - rewind( unit ) - call set3 % read_bitset(unit, advance='no') - call set4 % read_bitset(unit, advance='no') - call set5 % read_bitset(unit) - - if ( set5 /= set0 .or. set4 /= set1 .or. set3 /= set2 ) then - error stop procedure // ' transfer to and from units using ' // & - 'bitset literals with advance == "no" failed.' - else - write(*,*) 'Transfer to and from units using ' // & - 'write_bitset_unit and read_bitset_unit with ' // & - 'advance=="no" succeeded.' + call set3%read_bitset(unit) + call set5%read_bitset(unit) + call set4%read_bitset(unit) + + call check(error, set4 == set0 .and. set5 == set1 .and. set3 == set2, & + 'transfer to and from units using bitset literals failed.') + if (.not.allocated(error)) then + rewind( unit ) + + call set2%write_bitset(unit, advance='no') + call set1%write_bitset(unit, advance='no') + call set0%write_bitset(unit) + rewind( unit ) + call set3%read_bitset(unit, advance='no') + call set4%read_bitset(unit, advance='no') + call set5%read_bitset(unit) + + call check(error, set5 == set0 .and. set4 == set1 .and. set3 == set2, & + 'transfer to and from units using bitset literals with advance="no" failed.') end if close(unit) + if (allocated(error)) return open( newunit=unit, form='unformatted', status='scratch', & action='readwrite' ) - call set2 % output(unit) - call set1 % output(unit) - call set0 % output(unit) + call set2%output(unit) + call set1%output(unit) + call set0%output(unit) rewind( unit ) - call set5 % input(unit) - call set4 % input(unit) - call set3 % input(unit) + call set5%input(unit) + call set4%input(unit) + call set3%input(unit) close( unit ) - if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then - error stop procedure // ' transfer to and from units using ' // & - 'output and input failed.' - else - write(*,*) 'Transfer to and from units using ' // & - 'output and input succeeded.' - end if + call check(error, set3 == set0 .and. set4 == set1 .and. set5 == set2, & + 'transfer to and from units using output and input failed.') + if (allocated(error)) return open( newunit=unit, form='unformatted', access='stream', & status='scratch', action='readwrite' ) - call set2 % output(unit) - call set1 % output(unit) - call set0 % output(unit) + call set2%output(unit) + call set1%output(unit) + call set0%output(unit) rewind( unit ) - call set5 % input(unit) - call set4 % input(unit) - call set3 % input(unit) + call set5%input(unit) + call set4%input(unit) + call set3%input(unit) close( unit ) - if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then - error stop procedure // ' transfer to and from units using ' // & - 'stream output and input failed.' - else - write(*,*) 'Transfer to and from units using ' // & - 'stream output and input succeeded.' - end if + call check(error, set3 == set0 .and. set4 == set1 .and. set5 == set2, & + 'transfer to and from units using stream output and input failed.') + if (allocated(error)) return end subroutine test_io - subroutine test_initialization() - character(*), parameter:: procedure = 'TEST_INITIALIZATION' + subroutine test_initialization(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + logical(int8) :: log1(64) = .true. logical(int16) :: log2(31) = .false. logical(int32) :: log3(15) = .true. @@ -236,508 +229,385 @@ subroutine test_initialization() logical(int32), allocatable :: log7(:) logical(int64), allocatable :: log8(:) - write(*,*) - write(*,*) 'Test initialization: assignment, extract, and init' + type(bitset_64) :: set4, set5 set5 = log1 - if ( set5 % bits() /= 64 ) then - error stop procedure // & - ' initialization with logical(int8) failed to set' // & - ' the right size.' - else if ( .not. set5 % all() ) then - error stop procedure // ' initialization with' // & - ' logical(int8) failed to set the right values.' - else - write(*,*) 'Initialization with logical(int8) succeeded.' - end if + call check(error, set5%bits(), 64, & + 'initialization with logical(int8) failed to set the right size.') + if (allocated(error)) return + call check(error, set5%all(), & + 'initialization with logical(int8) failed to set the right values.') + if (allocated(error)) return set5 = log2 - if ( set5 % bits() /= 31 ) then - error stop procedure // & - ' initialization with logical(int16) failed to set' // & - ' the right size.' - else if ( .not. set5 % none() ) then - error stop procedure // & - ' initialization with logical(int16) failed to set' // & - ' the right values.' - else - write(*,*) 'Initialization with logical(int16) succeeded.' - end if + call check(error, set5%bits(), 31, & + 'initialization with logical(int16) failed to set the right size.') + if (allocated(error)) return + call check(error, set5%none(), & + 'initialization with logical(int16) failed to set the right values.') + if (allocated(error)) return set5 = log3 - if ( set5 % bits() /= 15 ) then - error stop procedure // & - ' initialization with logical(int32) failed to set' // & - ' the right size.' - else if ( .not. set5 % all() ) then - error stop procedure // & - ' initialization with logical(int32) failed to set' // & - ' the right values.' - else - write(*,*) 'Initialization with logical(int32) succeeded.' - end if + call check(error, set5%bits(), 15, & + 'initialization with logical(int32) failed to set the right size.') + if (allocated(error)) return + call check(error, set5%all(), & + 'initialization with logical(int32) failed to set the right values.') + if (allocated(error)) return set5 = log4 - if ( set5 % bits() /= 33 ) then - error stop procedure // & - ' initialization with logical(int64) failed to set' // & - ' the right size.' - else if ( .not. set5 % none() ) then - error stop procedure // & - ' initialization with logical(int64) failed to set' // & - ' the right values.' - else - write(*,*) 'Initialization with logical(int64) succeeded.' - end if + call check(error, set5%bits(), 33, & + 'initialization with logical(int64) failed to set the right size.') + if (allocated(error)) return + call check(error, set5%none(), & + 'initialization with logical(int64) failed to set the right values.') + if (allocated(error)) return set5 = log1 call extract( set4, set5, 1_bits_kind, 33_bits_kind ) - if ( set4 % bits() /= 33 ) then - error stop procedure // & - ' initialization with extract failed to set' // & - ' the right size.' - else if ( .not. set4 % all() ) then - error stop procedure // & - ' initialization with extract failed to set' // & - ' the right values.' - else - write(*,*) 'Initialization with extract succeeded.' - end if + call check(error, set4%bits(), 33, & + 'initialization with extract failed to set the right size.') + if (allocated(error)) return + call check(error, set4%all(), & + 'initialization with extract failed to set the right values.') + if (allocated(error)) return set4 = set5 - if ( set4 % bits() /= 64 ) then - write(*,*) 'Bits = ', set4 % bits() - error stop procedure // & - ' initialization with simple assignment failed to set' // & - ' the right size.' - else if ( .not. set4 % all() ) then - error stop procedure // & - ' initialization with simple assignment failed to set' // & - ' the right values.' - else - write(*,*) 'Initialization with simple assignment succeeded.' - end if + call check(error, set4%bits(), 64, & + 'initialization with simple assignment failed to set the right size.') + if (allocated(error)) return + call check(error, set4%all(), & + 'initialization with simple assignment failed to set the right values.') + if (allocated(error)) return log5 = set5 - if ( size(log5) /= 64 ) then - error stop procedure // & - ' initialization of logical(int8) with assignment failed' // & - ' to set the right size.' - else if ( .not. all(log5) ) then - error stop procedure // & - ' initialization of logical(int8) with assignment failed' // & - ' to set the right values.' - else - write(*,*) 'Initialization of logical(int8) succeeded.' - end if + call check(error, size(log5), 64, & + 'initialization of logical(int8) with assignment failed to set the right size.') + if (allocated(error)) return + call check(error, all(log5) .eqv. .true., & ! FIXME + 'initialization of logical(int8) with assignment failed to set the right values.') + if (allocated(error)) return log6 = set5 - if ( size(log6) /= 64 ) then - error stop procedure // & - ' initialization of logical(int16) with assignment failed' // & - ' to set the right size.' - else if ( .not. all(log6) ) then - error stop procedure // & - ' initialization of logical(int16) with assignment failed' // & - ' to set the right values.' - else - write(*,*) 'Initialization of logical(int16) succeeded.' - end if + call check(error, size(log6), 64, & + 'initialization of logical(int16) with assignment failed to set the right size.') + if (allocated(error)) return + call check(error, all(log6) .eqv. .true., & ! FIXME + 'initialization of logical(int16) with assignment failed to set the right values.') + if (allocated(error)) return log7 = set5 - if ( size(log7) /= 64 ) then - error stop procedure // & - ' initialization of logical(int32) with assignment failed' // & - ' to set the right size.' - else if ( .not. all(log7) ) then - error stop procedure // & - ' initialization of logical(int32) with assignment failed' // & - ' to set the right values.' - else - write(*,*) 'Initialization of logical(int32) succeeded.' - end if + call check(error, size(log7), 64, & + 'initialization of logical(int32) with assignment failed to set the right size.') + if (allocated(error)) return + call check(error, all(log7), & + 'initialization of logical(int32) with assignment failed to set the right values.') + if (allocated(error)) return log8 = set5 - if ( size(log8) /= 64 ) then - error stop procedure // & - ' initialization of logical(int64) with assignment failed' // & - ' to set the right size.' - else if ( .not. all(log8) ) then - error stop procedure // & - ' initialization of logical(int64) with assignment failed' // & - ' to set the right values.' - else - write(*,*) 'Initialization of logical(int64) succeeded.' - end if + call check(error, size(log8), 64, & + 'initialization of logical(int64) with assignment failed to set the right size.') + if (allocated(error)) return + call check(error, merge(.true., .false., all(log8)), & ! FIXME + 'initialization of logical(int64) with assignment failed to set the right values.') + if (allocated(error)) return end subroutine test_initialization - subroutine test_bitset_inquiry() - character(*), parameter:: procedure = 'TEST_BITSET_INQUIRY' - integer(bits_kind) :: i + subroutine test_bitset_inquiry(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - write(*,*) - write(*,*) 'Test bitset inquiry: all, any, bits, none, test, and value' - - if ( set0 % none() ) then - if ( .not. set0 % any() ) then - write(*,*) 'As expected set0 has no bits set' - else - error stop procedure // ' set0 had some bits set which ' // & - 'was unexpected.' - end if - else - error stop procedure // ' set0 did not have none set which ' // & - 'was unexpected' - end if - - call set0 % not() - if ( set0 % all() ) then - if ( set0 % any() ) then - write(*,*) 'As expected set0 now has all bits set' - else - error stop procedure // ' set0 had no bits set which ' // & - 'was unexpected.' - end if - else - error stop procedure // ' set0 did not have all bits set ' // & - 'which was unexpected' - end if - - if ( set1 % any() ) then - if ( set1 % all() ) then - write(*,*) 'As expected set1 has all bits set' - else - error stop procedure // ' set1 did not have all bits set ' // & - 'which was unexpected.' - end if - else - error stop procedure // ' set1 had no bits set ' // & - 'which was unexpected' - end if + integer(bits_kind) :: i - call set0 % not() - do i=0, set0 % bits() - 1 - if ( set0 % test(i) ) then - error stop procedure // ' against expectations set0 has ' // & - 'at least 1 bit set.' - end if + type(bitset_64) :: set0, set1 + + call set0%from_string(bitstring_0) + call set1%from_string(bitstring_all) + + call check(error, set0%none(), 'set0 did not have none set which ' // & + 'was unexpected') + if (allocated(error)) return + call check(error, .not. set0%any(), 'set0 had some bits set which ' // & + 'was unexpected.') + if (allocated(error)) return + + call set0%not() + call check(error, set0%all(), 'set0 did not have all bits set ' // & + 'which was unexpected') + if (allocated(error)) return + call check(error, set0%any(), 'set0 had no bits set which ' // & + 'was unexpected.') + if (allocated(error)) return + + call check(error, set1%any(), 'set1 had no bits set ' // & + 'which was unexpected') + if (allocated(error)) return + call check(error, set1%all(), 'set1 did not have all bits set ' // & + 'which was unexpected.') + if (allocated(error)) return + + call set0%not() + do i=0, set0%bits() - 1 + call check(error, .not. set0%test(i), & + 'against expectations set0 has at least 1 bit set.') end do - write(*,*) 'As expected set0 had no bits set.' - - do i=0, set1 % bits() - 1 - if ( .not. set1 % test(i) ) then - error stop procedure // ' against expectations set1 has ' // & - 'at least 1 bit unset.' - end if + do i=0, set1%bits() - 1 + call check(error, set1%test(i), & + 'against expectations set1 has at least 1 bit unset.') end do - write(*,*) 'As expected set1 had all bits set.' - - do i=0, set0 % bits() - 1 - if ( set0 % value(i) /= 0 ) then - error stop procedure // ' against expectations set0 has ' // & - 'at least 1 bit set.' - end if + do i=0, set0%bits() - 1 + call check(error, .not.( set0%value(i) /= 0), & + 'against expectations set0 has at least 1 bit set.') end do - write(*,*) 'As expected set0 had no bits set.' - - do i=0, set1 % bits() - 1 - if ( set1 % value(i) /= 1 ) then - error stop procedure // ' against expectations set1 has ' // & - 'at least 1 bit unset.' - end if + do i=0, set1%bits() - 1 + call check(error, .not.( set1%value(i) /= 1), & + 'against expectations set1 has at least 1 bit unset.') end do - write(*,*) 'As expected set1 had all bits set.' - - if ( set0 % bits() == 33 ) then - write(*,*) 'set0 has 33 bits as expected.' - else - error stop procedure // 'set0 unexpectedly does not have 33 bits.' - end if + call check(error, set0%bits() == 33, 'et0 unexpectedly does not have 33 bits.') + if (allocated(error)) return end subroutine test_bitset_inquiry - subroutine test_bit_operations() - character(*), parameter:: procedure = 'TEST_BIT_OPERATIONS' + subroutine test_bit_operations(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - write(*,*) - write(*,*) 'Test bit operations: clear, flip, not, and set' + type(bitset_64) :: set1 - if ( .not. set1 % all() ) then - error stop procedure // ' set1 is not all set.' - end if + call set1%from_string(bitstring_all) - call set1 % clear(0_bits_kind) - if ( .not. set1 % test(0_bits_kind) ) then - if ( set1 % test(1_bits_kind) ) then - write(*,*) 'Cleared one bit in set1 as expected.' - else - error stop procedure // ' cleared more than one bit in set1.' - end if - else - error stop procedure // ' did not clear the first bit in set1.' - end if + call check(error, set1%all(), 'set1 is not all set.') + if (allocated(error)) return - call set1 % clear(1_bits_kind, 32_bits_kind) - if ( set1 % none() ) then - write(*,*) 'Cleared remaining bits in set1 as expected.' - else - error stop procedure // ' did not clear remaining bits ' // & - 'in set1.' - end if + call set1%clear(0_bits_kind) + call check(error, .not. set1%test(0_bits_kind), 'did not clear the first bit in set1.') + if (allocated(error)) return + call check(error, set1%test(1_bits_kind), 'cleared more than one bit in set1.') + if (allocated(error)) return - call set1 % flip(0_bits_kind) - if ( set1 % test(0_bits_kind) ) then - if ( .not. set1 % test(1_bits_kind) ) then - write(*,*) 'Flipped one bit in set1 as expected.' - else - error stop procedure // ' flipped more than one bit in set1.' - end if - else - error stop procedure // ' did not flip the first bit in set1.' - end if + call set1%clear(1_bits_kind, 32_bits_kind) + call check(error, set1%none(), 'did not clear remaining bits in set1.') + if (allocated(error)) return - call set1 % flip(1_bits_kind, 32_bits_kind) - if ( set1 % all() ) then - write(*,*) 'Flipped remaining bits in set1 as expected.' - else - error stop procedure // ' did not flip remaining bits ' // & - 'in set1.' - end if + call set1%flip(0_bits_kind) + call check(error, set1%test(0_bits_kind), 'did not flip the first bit in set1.') + if (allocated(error)) return + call check(error, .not. set1%test(1_bits_kind), 'flipped more than one bit in set1.') + if (allocated(error)) return - call set1 % not() - if ( set1 % none() ) then - write(*,*) 'Unset bits in set1 as expected.' - else - error stop procedure // ' did not unset bits in set1.' - end if + call set1%flip(1_bits_kind, 32_bits_kind) + call check(error, set1%all(), 'did not flip remaining bits in set1.') + if (allocated(error)) return - call set1 % set(0_bits_kind) - if ( set1 % test(0_bits_kind) ) then - if ( .not. set1 % test(1_bits_kind) ) then - write(*,*) 'Set first bit in set1 as expected.' - else - error stop procedure // ' set more than one bit in set1.' - end if - else - error stop procedure // ' did not set the first bit in set1.' - end if + call set1%not() + call check(error, set1%none(), 'did not unset bits in set1.') + if (allocated(error)) return - call set1 % set(1_bits_kind, 32_bits_kind) - if ( set1 % all() ) then - write(*,*) 'Set the remaining bits in set1 as expected.' - else - error stop procedure // ' did not set the remaining bits ' // & - 'in set1.' - end if + call set1%set(0_bits_kind) + call check(error, set1%test(0_bits_kind), 'did not set the first bit in set1.') + if (allocated(error)) return + call check(error, .not. set1%test(1_bits_kind), 'set more than one bit in set1.') + if (allocated(error)) return + + call set1%set(1_bits_kind, 32_bits_kind) + call check(error, set1%all(), 'did not set the remaining bits in set1.') + if (allocated(error)) return end subroutine test_bit_operations - subroutine test_bitset_comparisons() - character(*), parameter:: procedure = 'TEST_BITSET_COMPARISON' + subroutine test_bitset_comparisons(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - write(*,*) - write(*,*) 'Test bitset comparisons: ==, /=, <, <=, >, and >=' + type(bitset_64) :: set0, set1, set2 - if ( set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. & + call set0%from_string(bitstring_0) + call set1%from_string(bitstring_all) + call set2%from_string(bitstring_33) + + call check(error, set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. & .not. set0 == set1 .and. .not. set0 == set2 .and. .not. & - set1 == set2 ) then - write(*,*) 'Passed 64 bit equality tests.' - else - error stop procedure // ' failed 64 bit equality tests.' - end if + set1 == set2, 'failed 64 bit equality tests.') + if (allocated(error)) return - if ( set0 /= set1 .and. set1 /= set2 .and. set0 /= set2 .and. & + call check(error, set0 /= set1 .and. set1 /= set2 .and. set0 /= set2 .and. & .not. set0 /= set0 .and. .not. set1 /= set1 .and. .not. & - set2 /= set2 ) then - write(*,*) 'Passed 64 bit inequality tests.' - else - error stop procedure // ' failed 64 bit inequality tests.' - end if + set2 /= set2, 'failed 64 bit inequality tests.') + if (allocated(error)) return - if ( set1 > set0 .and. set2 > set0 .and. set1 > set2 .and. & + call check(error, set1 > set0 .and. set2 > set0 .and. set1 > set2 .and. & .not. set0 > set1 .and. .not. set1 > set1 .and. .not. & - set2 > set1 ) then - write(*,*) 'Passed 64 bit greater than tests.' - else - error stop procedure // ' failed 64 bit greater than tests.' - end if + set2 > set1, 'failed 64 bit greater than tests.') + if (allocated(error)) return - if ( set1 >= set0 .and. set1 >= set2 .and. set2 >= set2 .and. & + call check(error, set1 >= set0 .and. set1 >= set2 .and. set2 >= set2 .and. & .not. set0 >= set1 .and. .not. set0 >= set1 .and. .not. & - set2 >= set1 ) then - write(*,*) 'Passed 64 bit greater than or equal tests.' - else - error stop procedure // ' failed 64 bit greater than or ' // & - 'equal tests.' - end if + set2 >= set1, 'failed 64 bit greater than or equal tests.') + if (allocated(error)) return - if ( set0 < set1 .and. set0 < set1 .and. set2 < set1 .and. & + call check(error, set0 < set1 .and. set0 < set1 .and. set2 < set1 .and. & .not. set1 < set0 .and. .not. set0 < set0 .and. .not. & - set1 < set2 ) then - write(*,*) 'Passed 64 bit less than tests.' - else - error stop procedure // ' failed 64 bit less than tests.' - end if + set1 < set2, 'failed 64 bit less than tests.') + if (allocated(error)) return - if ( set0 <= set1 .and. set2 <= set1 .and. set2 <= set2 .and. & + call check(error, set0 <= set1 .and. set2 <= set1 .and. set2 <= set2 .and. & .not. set1 <= set0 .and. .not. set2 <= set0 .and. .not. & - set1 <= set2 ) then - write(*,*) 'Passed 64 bit less than or equal tests.' - else - error stop procedure // ' failed 64 bit less than or ' // & - 'equal tests.' - end if + set1 <= set2, 'failed 64 bit less than or equal tests.') + if (allocated(error)) return end subroutine test_bitset_comparisons - subroutine test_bitset_operations() - character(*), parameter:: procedure = 'TEST_BITSET_OPERATIONS' + subroutine test_bitset_operations_and(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - write(*,*) - write(*,*) 'Test bitset operations: and, and_not, or, and xor' + type(bitset_64) :: set3, set4, set0 - call set0 % from_string( bitstring_all ) - call set4 % from_string( bitstring_all ) + call set0%from_string( bitstring_all ) + call set4%from_string( bitstring_all ) call and( set0, set4 ) ! all all - if ( set0 % all() ) then - write(*,*) 'First test of AND worked.' - else - error stop procedure // ' first test of AND failed.' - end if + call check(error, set0%all(), 'first test of AND failed.') + if (allocated(error)) return - call set4 % from_string( bitstring_0 ) - call set3 % from_string( bitstring_all ) + call set4%from_string( bitstring_0 ) + call set3%from_string( bitstring_all ) call and( set3, set4 ) ! all none - if ( set3 % none() ) then - write(*,*) 'Second test of AND worked.' - else - error stop procedure // ' second test of AND failed.' - end if + call check(error, set3%none(), 'second test of AND failed.') + if (allocated(error)) return - call set3 % from_string( bitstring_all ) - call set4 % from_string( bitstring_0 ) + call set3%from_string( bitstring_all ) + call set4%from_string( bitstring_0 ) call and( set4, set3 ) ! none all - if ( set4 % none() ) then - write(*,*) 'Third test of AND worked.' - else - error stop procedure // ' third test of AND failed.' - end if + call check(error, set4%none(), 'third test of AND failed.') + if (allocated(error)) return - call set3 % from_string( bitstring_0 ) + call set3%from_string( bitstring_0 ) call and( set4, set3 ) ! none none - if ( set4 % none() ) then - write(*,*) 'Fourth test of AND worked.' - else - error stop procedure // ' fourth test of AND failed.' - end if + call check(error, set4%none(), 'fourth test of AND failed.') + if (allocated(error)) return + + end subroutine test_bitset_operations_and + + subroutine test_bitset_operations_nand(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(bitset_64) :: set3, set4 - call set3 % from_string( bitstring_all ) - call set4 % from_string( bitstring_all ) + call set3%from_string( bitstring_all ) + call set4%from_string( bitstring_all ) call and_not( set4, set3 ) ! all all - if ( set4 % none() ) then - write(*,*) 'First test of AND_NOT worked.' - else - error stop procedure // ' first test of AND_NOT failed.' - end if + call check(error, set4%none(), 'first test of AND_NOT failed.') + if (allocated(error)) return - call set4 % from_string( bitstring_0 ) + call set4%from_string( bitstring_0 ) call and_not( set4, set3 ) ! none all - if ( set4 % none() ) then - write(*,*) 'Second test of AND_NOT worked.' - else - error stop procedure // ' second test of AND_NOT failed.' - end if + call check(error, set4%none(), 'second test of AND_NOT failed.') + if (allocated(error)) return - call set3 % from_string( bitstring_all ) - call set4 % from_string( bitstring_0 ) + call set3%from_string( bitstring_all ) + call set4%from_string( bitstring_0 ) call and_not( set3, set4 ) ! all none - if ( set3 % all() ) then - write(*,*) 'Third test of AND_NOT worked.' - else - error stop procedure // ' third test of AND_NOT failed.' - end if + call check(error, set3%all(), 'third test of AND_NOT failed.') + if (allocated(error)) return - call set3 % from_string( bitstring_0 ) - call set4 % from_string( bitstring_0 ) + call set3%from_string( bitstring_0 ) + call set4%from_string( bitstring_0 ) call and_not( set3, set4 ) ! none none - if ( set3 % none() ) then - write(*,*) 'Fourth test of AND_NOT worked.' - else - error stop procedure // ' fourth test of AND_NOT failed.' - end if + call check(error, set3%none(), 'fourth test of AND_NOT failed.') + if (allocated(error)) return + + end subroutine test_bitset_operations_nand + + subroutine test_bitset_operations_or(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(bitset_64) :: set3, set4 - call set3 % from_string( bitstring_all ) - call set4 % from_string( bitstring_all ) + call set3%from_string( bitstring_all ) + call set4%from_string( bitstring_all ) call or( set3, set4 ) ! all all - if ( set3 % all() ) then - write(*,*) 'First test of OR worked.' - else - error stop procedure // ' first test of OR failed.' - end if + call check(error, set3%all(), 'first test of OR failed.') + if (allocated(error)) return - call set3 % from_string( bitstring_0 ) + call set3%from_string( bitstring_0 ) call or( set4, set3 ) ! all none - if ( set4 % all() ) then - write(*,*) 'Second test of OR worked.' - else - error stop procedure // ' second test of OR failed.' - end if + call check(error, set4%all(), 'second test of OR failed.') + if (allocated(error)) return call or( set3, set4 ) ! none all - if ( set3 % all() ) then - write(*,*) 'Third test of OR worked.' - else - error stop procedure // ' third test of OR failed.' - end if + call check(error, set3%all(), 'third test of OR failed.') + if (allocated(error)) return - call set3 % from_string( bitstring_0 ) - call set4 % from_string( bitstring_0 ) + call set3%from_string( bitstring_0 ) + call set4%from_string( bitstring_0 ) call or( set4, set3 ) !none none - if ( set4 % none() ) then - write(*,*) 'Fourth test of OR worked.' - else - error stop procedure // ' fourth test of OR failed.' - end if + call check(error, set4%none(), 'fourth test of OR failed.') + if (allocated(error)) return + + end subroutine test_bitset_operations_or + + subroutine test_bitset_operations_xor(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(bitset_64) :: set3, set4 - call set3 % from_string( bitstring_0 ) - call set4 % from_string( bitstring_0 ) + call set3%from_string( bitstring_0 ) + call set4%from_string( bitstring_0 ) call xor( set3, set4 ) ! none none - if ( set3 % none() ) then - write(*,*) 'First test of XOR worked.' - else - error stop procedure // ' first test of XOR failed.' - end if + call check(error, set3%none(), 'first test of XOR failed.') + if (allocated(error)) return - call set4 % from_string( bitstring_all ) + call set4%from_string( bitstring_all ) call xor( set3, set4 ) ! none all - if ( set3 % all() ) then - write(*,*) 'Second test of XOR worked.' - else - error stop procedure // ' second test of XOR failed.' - end if + call check(error, set3%all(), 'second test of XOR failed.') + if (allocated(error)) return - call set4 % from_string( bitstring_0 ) + call set4%from_string( bitstring_0 ) call xor( set3, set4 ) ! all none - if ( set3 % all() ) then - write(*,*) 'Third test of XOR worked.' - else - error stop procedure // ' third test of XOR failed.' - end if + call check(error, set3%all(), 'third test of XOR failed.') + if (allocated(error)) return - call set4 % from_string( bitstring_all ) + call set4%from_string( bitstring_all ) call xor( set3, set4 ) ! all all - if ( set3 % none() ) then - write(*,*) 'Fourth test of XOR worked.' - else - error stop procedure // ' fourth test of XOR failed.' - end if + call check(error, set3%none(), 'fourth test of XOR failed.') + if (allocated(error)) return + + end subroutine test_bitset_operations_xor + + +end module test_stdlib_bitset_64 + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_stdlib_bitset_64, only : collect_stdlib_bitset_64 + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 - end subroutine test_bitset_operations + testsuites = [ & + new_testsuite("stdlib-bitset-64", collect_stdlib_bitset_64) & + ] + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do -end program test_stdlib_bitset_64 + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program From 24387b039863f1e42d566530b61927c596bd7824 Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Mon, 23 Aug 2021 16:28:20 +0200 Subject: [PATCH 05/34] Moved test mean --- src/tests/stats/CMakeLists.txt | 1 + src/tests/stats/common.fypp | 9 + src/tests/stats/test_mean.f90 | 143 ------------ src/tests/stats/test_mean.fypp | 393 +++++++++++++++++++++++++++++++++ 4 files changed, 403 insertions(+), 143 deletions(-) delete mode 100644 src/tests/stats/test_mean.f90 create mode 100644 src/tests/stats/test_mean.fypp diff --git a/src/tests/stats/CMakeLists.txt b/src/tests/stats/CMakeLists.txt index 600e925e5..ce27497b0 100644 --- a/src/tests/stats/CMakeLists.txt +++ b/src/tests/stats/CMakeLists.txt @@ -2,6 +2,7 @@ # Create a list of the files to be preprocessed set(fppFiles + test_mean.fypp test_median.fypp ) diff --git a/src/tests/stats/common.fypp b/src/tests/stats/common.fypp index 9ebaac6b9..68ac9b253 100644 --- a/src/tests/stats/common.fypp +++ b/src/tests/stats/common.fypp @@ -9,6 +9,15 @@ #! Collected (kind, type) tuples for real types #:set REAL_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES)) +#! Complex kinds to be considered during templating +#:set CMPLX_KINDS = ["sp", "dp", "qp"] + +#! Complex types to be considered during templating +#:set CMPLX_TYPES = ["complex({})".format(k) for k in CMPLX_KINDS] + +#! Collected (kind, type) tuples for complex types +#:set CMPLX_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES)) + #! Integer kinds to be considered during templating #:set INT_KINDS = ["int8", "int16", "int32", "int64"] diff --git a/src/tests/stats/test_mean.f90 b/src/tests/stats/test_mean.f90 deleted file mode 100644 index f609555c1..000000000 --- a/src/tests/stats/test_mean.f90 +++ /dev/null @@ -1,143 +0,0 @@ -program test_mean -use stdlib_error, only: check -use stdlib_kinds, only: sp, dp, int32, int64 -use stdlib_io, only: loadtxt -use stdlib_stats, only: mean -use,intrinsic :: ieee_arithmetic, only : ieee_is_nan -implicit none - -real(sp), parameter :: sptol = 1000 * epsilon(1._sp) -real(dp), parameter :: dptol = 2000 * epsilon(1._dp) - -real(sp) :: s1(3) = [1.0_sp, 2.0_sp, 3.0_sp] - -real(sp), allocatable :: s(:, :) -real(dp), allocatable :: d(:, :) - -complex(dp), allocatable :: cs(:, :) -complex(dp), allocatable :: cd(:, :) - -real(dp), allocatable :: d3(:, :, :) -real(dp), allocatable :: d4(:, :, :, :) - -complex(dp), allocatable :: cd3(:, :, :) - -!sp -call loadtxt("array3.dat", s) - -call check( abs(mean(s) - sum(s)/real(size(s), sp)) < sptol) -call check( sum( abs( mean(s,1) - sum(s,1)/real(size(s,1), sp) )) < sptol) -call check( sum( abs( mean(s,2) - sum(s,2)/real(size(s,2), sp) )) < sptol) - -! check reduction of rank one array to scalar -call check(abs(mean(s1) - sum(s1) / real(size(s1), sp)) < sptol) -call check(abs(mean(s1, dim=1) - sum(s1, dim=1) / real(size(s1, dim=1), sp)) < sptol) - - -!dp -call loadtxt("array3.dat", d) - -call check( abs(mean(d) - sum(d)/real(size(d), dp)) < dptol) -call check( sum( abs( mean(d,1) - sum(d,1)/real(size(d,1), dp) )) < dptol) -call check( sum( abs( mean(d,2) - sum(d,2)/real(size(d,2), dp) )) < dptol) - -!csp - -call loadtxt("array3.dat", d) -cs = cmplx(1._sp, 1._sp,kind=sp)*d - -call check( abs(mean(cs) - sum(cs)/real(size(cs), sp)) < sptol) -call check( sum( abs( mean(cs,1) - sum(cs,1)/real(size(cs,1), sp) )) < sptol) -call check( sum( abs( mean(cs,2) - sum(cs,2)/real(size(cs,2), sp) )) < sptol) - -!cdp - -call loadtxt("array3.dat", d) -cd = cmplx(1._dp, 1._dp,kind=dp)*d - -call check( abs(mean(cd) - sum(cd)/real(size(cd), dp)) < dptol) -call check( sum( abs( mean(cd,1) - sum(cd,1)/real(size(cd,1), dp) )) < dptol) -call check( sum( abs( mean(cd,2) - sum(cd,2)/real(size(cd,2), dp) )) < dptol) - -! check mask = .false. - -call check( ieee_is_nan(mean(d, .false.))) -call check( any(ieee_is_nan(mean(d, 1, .false.)))) -call check( any(ieee_is_nan(mean(d, 2, .false.)))) - -! check mask of the same shape as input -call check( abs(mean(d, d > 0) - sum(d, d > 0)/real(count(d > 0), dp)) < dptol) -call check( sum(abs(mean(d, 1, d > 0) - sum(d, 1, d > 0)/real(count(d > 0, 1), dp))) < dptol) -call check( sum(abs(mean(d, 2, d > 0) - sum(d, 2, d > 0)/real(count(d > 0, 2), dp))) < dptol) - -!int32 -call loadtxt("array3.dat", d) - -call check( abs(mean(int(d, int32)) - sum(real(int(d, int32),dp))/real(size(d), dp)) < dptol) -call check( sum(abs( mean(int(d, int32),1) - sum(real(int(d, int32),dp),1)/real(size(d,1), dp) )) < dptol) -call check( sum(abs( mean(int(d, int32),2) - sum(real(int(d, int32),dp),2)/real(size(d,2), dp) )) < dptol) - - -!int64 -call loadtxt("array3.dat", d) - -call check( abs(mean(int(d, int64)) - sum(real(int(d, int64),dp))/real(size(d), dp)) < dptol) -call check( sum(abs( mean(int(d, int64),1) - sum(real(int(d, int64),dp),1)/real(size(d,1), dp) )) < dptol) -call check( sum(abs( mean(int(d, int64),2) - sum(real(int(d, int64),dp),2)/real(size(d,2), dp) )) < dptol) - - -!dp rank 3 -allocate(d3(size(d,1),size(d,2),3)) -d3(:,:,1)=d; -d3(:,:,2)=d*1.5; -d3(:,:,3)=d*4; - -call check( abs(mean(d3) - sum(d3)/real(size(d3), dp)) < dptol) -call check( sum( abs( mean(d3,1) - sum(d3,1)/real(size(d3,1), dp) )) < dptol) -call check( sum( abs( mean(d3,2) - sum(d3,2)/real(size(d3,2), dp) )) < dptol) -call check( sum( abs( mean(d3,3) - sum(d3,3)/real(size(d3,3), dp) )) < dptol) - -!cdp rank 3 -allocate(cd3(size(d,1),size(d,2),3)) -cd3(:,:,1)=d; -cd3(:,:,2)=d*1.5; -cd3(:,:,3)=d*4; -cd3 = cmplx(1._sp, 1._sp,kind=sp)*cd3 - -call check( abs(mean(cd3) - sum(cd3)/real(size(cd3), dp)) < dptol) -call check( sum( abs( mean(cd3,1) - sum(cd3,1)/real(size(cd3,1), dp) )) < dptol) -call check( sum( abs( mean(cd3,2) - sum(cd3,2)/real(size(cd3,2), dp) )) < dptol) -call check( sum( abs( mean(cd3,3) - sum(cd3,3)/real(size(cd3,3), dp) )) < dptol) - - -!dp rank 4 -allocate(d4(size(d,1),size(d,2),3,9)) -d4 = -1 -d4(:,:,1,1)=d; -d4(:,:,2,1)=d*1.5; -d4(:,:,3,1)=d*4; -d4(:,:,3,9)=d*4; - -call check( abs(mean(d4) - sum(d4)/real(size(d4), dp)) < dptol) -call check( sum( abs( mean(d4,1) - sum(d4,1)/real(size(d4,1), dp) )) < dptol) -call check( sum( abs( mean(d4,2) - sum(d4,2)/real(size(d4,2), dp) )) < dptol) -call check( sum( abs( mean(d4,3) - sum(d4,3)/real(size(d4,3), dp) )) < dptol) -call check( sum( abs( mean(d4,4) - sum(d4,4)/real(size(d4,4), dp) )) < dptol) - -! check mask = .false. - -call check( ieee_is_nan(mean(d4, .false.))) -call check( any(ieee_is_nan(mean(d4, 1, .false.)))) -call check( any(ieee_is_nan(mean(d4, 2, .false.)))) -call check( any(ieee_is_nan(mean(d4, 3, .false.)))) -call check( any(ieee_is_nan(mean(d4, 4, .false.)))) - - -! check mask of the same shape as input -call check( abs(mean(d4, d4 > 0) - sum(d4, d4 > 0)/real(count(d4 > 0), dp)) < dptol) -call check( any(ieee_is_nan(mean(d4, 1, d4 > 0))) ) -call check( any(ieee_is_nan(mean(d4, 2, d4 > 0))) ) -call check( any(ieee_is_nan(mean(d4, 3, d4 > 0))) ) -call check( sum(abs(mean(d4, 4, d4 > 0) - sum(d4, 4, d4 > 0)/real(count(d4 > 0, 4), dp))) < dptol) - -end program diff --git a/src/tests/stats/test_mean.fypp b/src/tests/stats/test_mean.fypp new file mode 100644 index 000000000..08e9b1dd3 --- /dev/null +++ b/src/tests/stats/test_mean.fypp @@ -0,0 +1,393 @@ +#:include "common.fypp" +#:set IR_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES + +#:set NRANK = 4 + +module test_stats_mean + use stdlib_test, only : new_unittest, unittest_type, error_type, check + use stdlib_stats, only: mean + use stdlib_kinds, only : int8, int16, int32, int64, sp, dp, qp + use, intrinsic :: ieee_arithmetic, only : ieee_is_nan + implicit none + private + + public :: collect_stats_mean + + real(sp), parameter :: sptol = 1000 * epsilon(1._sp) + real(dp), parameter :: dptol = 2000 * epsilon(1._dp) + real(qp), parameter :: qptol = 2000 * epsilon(1._qp) + + #:for k1,t1 in IR_KINDS_TYPES + ${t1}$ , parameter :: d1_${k1}$(18) = [-10, 2, 3, 4, -6, 6, -7, 8, 9, 4, 1, -20, 9, 10, 14, 15, 40, 30] + ${t1}$ :: d2_${k1}$(3, 6) = reshape(d1_${k1}$, [3, 6]) + ${t1}$ :: d3_${k1}$(3, 2, 3) = reshape(d1_${k1}$, [3, 2, 3]) + ${t1}$ :: d4_${k1}$(3, 2, 3, 2) = reshape(d1_${k1}$, [3, 2, 3, 2], [${t1}$ :: 3]) + #:endfor + + #:for k1,t1 in CMPLX_KINDS_TYPES + ${t1}$ , parameter :: d1_c${k1}$(18) = d1_${k1}$ + ${t1}$ :: d2_c${k1}$(3, 6) = reshape(d1_c${k1}$, [3, 6]) + ${t1}$ :: d3_c${k1}$(3, 2, 3) = reshape(d1_c${k1}$, [3, 2, 3]) + ${t1}$ :: d4_c${k1}$(3, 2, 3, 2) = reshape(d1_c${k1}$, [3, 2, 3, 2], [${t1}$ :: (3, -2)] ) + #:endfor + + +contains + + !> Collect all exported unit tests + subroutine collect_stats_mean(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("test_stats_mean_all_int8", test_stats_mean_all_int8) & + #:for k1,t1 in IR_KINDS_TYPES + ,new_unittest("test_stats_mean_all_${k1}$", test_stats_mean_all_${k1}$) & + , new_unittest("test_stats_mean_all_optmask_${k1}$", test_stats_mean_all_optmask_${k1}$) & + , new_unittest("test_stats_mean_${k1}$", test_stats_mean_${k1}$) & + , new_unittest("test_stats_mean_optmask_${k1}$", test_stats_mean_optmask_${k1}$) & + , new_unittest("test_stats_mean_mask_all_${k1}$", test_stats_mean_mask_all_${k1}$) & + , new_unittest("test_stats_mean_mask_${k1}$", test_stats_mean_mask_${k1}$) & + #:endfor + #:for k1,t1 in CMPLX_KINDS_TYPES + ,new_unittest("test_stats_mean_all_c${k1}$", test_stats_mean_all_c${k1}$) & + , new_unittest("test_stats_mean_all_optmask_c${k1}$", test_stats_mean_all_optmask_c${k1}$) & + , new_unittest("test_stats_mean_c${k1}$", test_stats_mean_c${k1}$) & + , new_unittest("test_stats_mean_optmask_c${k1}$", test_stats_mean_optmask_c${k1}$) & + , new_unittest("test_stats_mean_mask_all_c${k1}$", test_stats_mean_mask_all_c${k1}$) & + , new_unittest("test_stats_mean_mask_c${k1}$", test_stats_mean_mask_c${k1}$) & + #:endfor + ] + end subroutine collect_stats_mean + + #:for k1,t1 in INT_KINDS_TYPES + subroutine test_stats_mean_all_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + #:for rank in range(1, NRANK + 1) + call check(error, mean(d${rank}$_${k1}$), sum(real(d${rank}$_${k1}$, dp))/real(size(d${rank}$_${k1}$), dp)& + , 'mean(d${rank}$_${k1}$): uncorrect answer'& + , thr = dptol) + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_mean_all_optmask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + #:for rank in range(1, NRANK + 1) + call check(error, ieee_is_nan(mean(d${rank}$_${k1}$, .false.))& + , 'mean(d${rank}$_${k1}$, .false.): uncorrect answer') + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_mean_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error& + , abs(mean(d1_${k1}$, 1) -& + sum(real(d1_${k1}$, dp), 1)/real(size(d1_${k1}$, 1), dp)) < dptol& + , 'mean(d1_${k1}$, 1): uncorrect answer'& + ) + if (allocated(error)) return + + #:for rank in range(2, NRANK+1) + #:for dim in range(1, rank+1) + call check(error& + , sum(abs(mean(d${rank}$_${k1}$, ${dim}$) -& + sum(real(d${rank}$_${k1}$, dp), ${dim}$)/real(size(d${rank}$_${k1}$, ${dim}$), dp))) < dptol& + , 'mean(d${rank}$_${k1}$, ${dim}$): uncorrect answer'& + ) + if (allocated(error)) return + #:endfor + #:endfor + end subroutine + + subroutine test_stats_mean_optmask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(mean(d1_${k1}$, 1, .false.))& + , 'mean(d1_${k1}$, 1, .false.): uncorrect answer'& + ) + if (allocated(error)) return + + #:for rank in range(2, NRANK+1) + #:for dim in range(1, rank+1) + call check(error, any(ieee_is_nan(mean(d${rank}$_${k1}$, ${dim}$, .false.)))& + , 'mean(d${rank}$_${k1}$, ${dim}$, .false.): uncorrect answer') + if (allocated(error)) return + #:endfor + #:endfor + end subroutine + + subroutine test_stats_mean_mask_all_${k1}$(error) + !> Error handling + 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(real(d${rank}$_${k1}$, dp), d${rank}$_${k1}$ > 0)/real(count(d${rank}$_${k1}$ > 0), dp)& + , 'mean(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0): uncorrect answer'& + , thr = dptol) + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_mean_mask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error& + , abs(mean(d1_${k1}$, 1, d1_${k1}$ > 0) -& + sum(real(d1_${k1}$, dp), 1, d1_${k1}$ > 0)/real(count(d1_${k1}$ > 0, 1), dp)) < dptol& + , 'mean(d1_${k1}$, 1, d1_${k1}$ > 0): uncorrect answer'& + ) + if (allocated(error)) return + + #:for rank in range(2, NRANK+1) + #:for dim in range(1, rank+1) + call check(error& + , sum(abs(mean(d${rank}$_${k1}$, ${dim}$, d${rank}$_${k1}$ > 0) -& + sum(real(d${rank}$_${k1}$, dp), ${dim}$, d${rank}$_${k1}$ > 0)/real(count(d${rank}$_${k1}$ > 0, ${dim}$), dp))) < dptol& + , 'mean(d${rank}$_${k1}$, ${dim}$, d${rank}$_${k1}$ > 0): uncorrect answer'& + ) + if (allocated(error)) return + #:endfor + #:endfor + end subroutine + #:endfor + + #:for k1,t1 in REAL_KINDS_TYPES + subroutine test_stats_mean_all_${k1}$(error) + !> Error handling + 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) + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_mean_all_optmask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + #:for rank in range(1, NRANK+1) + call check(error, ieee_is_nan(mean(d${rank}$_${k1}$, .false.))& + , 'mean(d${rank}$_${k1}$, .false.): uncorrect answer') + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_mean_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error& + , abs(mean(d1_${k1}$, 1) - sum(d1_${k1}$, 1)/real(size(d1_${k1}$, 1), ${k1}$)) <${k1}$tol& + , 'mean(d1_${k1}$, 1): uncorrect answer'& + ) + if (allocated(error)) return + + #:for rank in range(2, NRANK+1) + #:for dim in range(1, rank+1) + call check(error& + , sum(abs(mean(d${rank}$_${k1}$, ${dim}$) -& + sum(d${rank}$_${k1}$, ${dim}$)/real(size(d${rank}$_${k1}$, ${dim}$), ${k1}$))) < ${k1}$tol& + , 'mean(d${rank}$_${k1}$, ${dim}$): uncorrect answer'& + ) + if (allocated(error)) return + #:endfor + #:endfor + end subroutine + + subroutine test_stats_mean_optmask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(mean(d1_${k1}$, 1, .false.))& + , 'mean(d1_${k1}$, 1, .false.): uncorrect answer'& + ) + if (allocated(error)) return + + #:for rank in range(2, NRANK+1) + #:for dim in range(1, rank+1) + call check(error, any(ieee_is_nan(mean(d${rank}$_${k1}$, ${dim}$, .false.)))& + , 'mean(d${rank}$_${k1}$, ${dim}$, .false.): uncorrect answer') + if (allocated(error)) return + #:endfor + #:endfor + end subroutine + + subroutine test_stats_mean_mask_all_${k1}$(error) + !> Error handling + 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}$)& + , 'mean(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0): uncorrect answer'& + , thr = ${k1}$tol) + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_mean_mask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error& + , abs(mean(d1_${k1}$, 1, d1_${k1}$ > 0) -& + sum(d1_${k1}$, 1, d1_${k1}$ > 0)/real(count(d1_${k1}$ > 0, 1), ${k1}$)) < ${k1}$tol& + , 'mean(d1_${k1}$, 1, d1_${k1}$ > 0): uncorrect answer'& + ) + if (allocated(error)) return + + #:for rank in range(2, NRANK+1) + #:for dim in range(1, rank+1) + call check(error& + , sum(abs(mean(d${rank}$_${k1}$, ${dim}$, d${rank}$_${k1}$ > 0) -& + sum(d${rank}$_${k1}$, ${dim}$, d${rank}$_${k1}$ > 0)/real(count(d${rank}$_${k1}$ > 0, ${dim}$), ${k1}$))) < ${k1}$tol& + , 'mean(d${rank}$_${k1}$, ${dim}$, d${rank}$_${k1}$ > 0): uncorrect answer'& + ) + if (allocated(error)) return + #:endfor + #:endfor + end subroutine + #:endfor + + #:for k1,t1 in CMPLX_KINDS_TYPES + subroutine test_stats_mean_all_c${k1}$(error) + !> Error handling + 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}$)& + , 'mean(d${rank}$_c${k1}$): uncorrect answer'& + , thr = ${k1}$tol) + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_mean_all_optmask_c${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + #:for rank in range(1, NRANK+1) + call check(error, ieee_is_nan(real(mean(d${rank}$_c${k1}$, .false.)))& + , 'mean(d${rank}$_c${k1}$, .false.): uncorrect answer') + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_mean_c${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error& + , abs(mean(d1_c${k1}$, 1) - sum(d1_c${k1}$, 1)/real(size(d1_c${k1}$, 1), ${k1}$)) <${k1}$tol& + , 'mean(d1_c${k1}$, 1): uncorrect answer'& + ) + if (allocated(error)) return + + #:for rank in range(2, NRANK+1) + #:for dim in range(1, rank+1) + call check(error& + , sum(abs(mean(d${rank}$_c${k1}$, ${dim}$) -& + sum(d${rank}$_c${k1}$, ${dim}$)/real(size(d${rank}$_c${k1}$, ${dim}$), ${k1}$))) < ${k1}$tol& + , 'mean(d${rank}$_c${k1}$, ${dim}$): uncorrect answer'& + ) + if (allocated(error)) return + #:endfor + #:endfor + end subroutine + + subroutine test_stats_mean_optmask_c${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(real(mean(d1_c${k1}$, 1, .false.)))& + , 'mean(d1_c${k1}$, 1, .false.): uncorrect answer'& + ) + if (allocated(error)) return + + #:for rank in range(2, NRANK+1) + #:for dim in range(1, rank+1) + call check(error, any(ieee_is_nan(real(mean(d${rank}$_c${k1}$, ${dim}$, .false.))))& + , 'mean(d${rank}$_c${k1}$, ${dim}$, .false.): uncorrect answer') + if (allocated(error)) return + #:endfor + #:endfor + end subroutine + + subroutine test_stats_mean_mask_all_c${k1}$(error) + !> Error handling + 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}$)& + , 'mean(d${rank}$_c${k1}$, d${rank}$_c${k1}$%re > 0): uncorrect answer'& + , thr = ${k1}$tol) + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_mean_mask_c${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error& + , abs(mean(d1_c${k1}$, 1, d1_c${k1}$%re > 0) -& + sum(d1_c${k1}$, 1, d1_c${k1}$%re > 0)/real(count(d1_c${k1}$%re > 0, 1), ${k1}$)) < ${k1}$tol& + , 'mean(d1_c${k1}$, 1, d1_c${k1}$%re > 0): uncorrect answer'& + ) + if (allocated(error)) return + + #:for rank in range(2, NRANK+1) + #:for dim in range(1, rank+1) + call check(error& + , sum(abs(mean(d${rank}$_c${k1}$, ${dim}$, d${rank}$_c${k1}$%re > 0) -& + sum(d${rank}$_c${k1}$, ${dim}$, d${rank}$_c${k1}$%re > 0)/real(count(d${rank}$_c${k1}$%re > 0, ${dim}$), ${k1}$))) < ${k1}$tol& + , 'mean(d${rank}$_c${k1}$, ${dim}$, d${rank}$_c${k1}$%re > 0): uncorrect answer'& + ) + if (allocated(error)) return + #:endfor + #:endfor + end subroutine + #:endfor + +end module test_stats_mean + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_stats_mean, only : collect_stats_mean + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("stats_mean", collect_stats_mean) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program From 789b91291125c22db00948e6046ae19d4401fc53 Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Tue, 24 Aug 2021 22:29:24 +0200 Subject: [PATCH 06/34] Rewrite test fir stdlib_bitset_large --- .../bitsets/test_stdlib_bitset_large.f90 | 1763 +++++++---------- 1 file changed, 715 insertions(+), 1048 deletions(-) diff --git a/src/tests/bitsets/test_stdlib_bitset_large.f90 b/src/tests/bitsets/test_stdlib_bitset_large.f90 index aac8389b1..dd6a9f899 100644 --- a/src/tests/bitsets/test_stdlib_bitset_large.f90 +++ b/src/tests/bitsets/test_stdlib_bitset_large.f90 @@ -1,4 +1,5 @@ -program test_stdlib_bitset_large +module test_stdlib_bitset_large + use stdlib_test, only : new_unittest, unittest_type, error_type, check use :: stdlib_kinds, only : int8, int16, int32, int64 use stdlib_bitsets implicit none @@ -6,253 +7,195 @@ program test_stdlib_bitset_large bitstring_0 = '000000000000000000000000000000000', & bitstring_33 = '100000000000000000000000000000000', & bitstring_all = '111111111111111111111111111111111' - type(bitset_large) :: set0, set1, set2, set3, set4, set5 - type(bitset_large) :: set10, set11, set12, set13, set14, set15 - integer :: status - character(:), allocatable :: string0 - call test_string_operations() - - call test_io() - - call test_initialization() +contains - call test_bitset_inquiry() - call test_bit_operations() + !> Collect all exported unit tests + subroutine collect_stdlib_bitset_large(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) - call test_bitset_comparisons() + testsuite = [ & + new_unittest("string-operations", test_string_operations), & + new_unittest("io", test_io), & + new_unittest("initialization", test_initialization), & + new_unittest("bitset-inquiry", test_bitset_inquiry), & + new_unittest("bit-operations", test_bit_operations), & + new_unittest("bitset-comparisons", test_bitset_comparisons), & + new_unittest("bitset-operations", test_bitset_operations) & + ] - call test_bitset_operations() + end subroutine collect_stdlib_bitset_large -contains - subroutine test_string_operations() - character(*), parameter:: procedure = 'TEST_STRING_OPERATIONS' + subroutine test_string_operations(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - write(*,'(/a)') 'Test string operations: from_string, ' // & - 'read_bitset, to_string, and write_bitset' + integer :: status + character(:), allocatable :: string0 + type(bitset_large) :: set0, set1, set3, set4 + type(bitset_large) :: set10, set11, set13, set14 call set0 % from_string( bitstring_0 ) - if ( bits(set0) /= 33 ) then - error stop procedure // ' from_string failed to interpret ' // & - 'bitstring_0 size properly.' - else if ( .not. set0 % none() ) then - error stop procedure // ' failed to interpret bitstring_0 ' // & - 'value properly.' - else if ( set0 % any() ) then - error stop procedure // ' failed to interpret bitstring_0 ' // & - 'value properly.' - else - write(*,*) 'from_string transferred bitstring_0 properly into set0' - end if + call check(error, bits(set0), 33, & + 'from_string failed to interpret bitstring_0 size properly.') + if (allocated(error)) return + call check(error, set0 % none(), & + 'failed to interpret bitstring_0 value properly.') + if (allocated(error)) return + call check(error, .not. set0 % any(), & + 'failed to interpret bitstring_0 value properly.') + if (allocated(error)) return call set10 % from_string( bitstring_0 // bitstring_0 ) - if ( bits(set10) /= 66 ) then - error stop procedure // ' from_string failed to interpret ' // & - 'bitstring_0 // bitstring_0 size properly.' - else if ( .not. set10 % none() ) then - error stop procedure // ' failed to interpret bitstring_0 ' // & - '// bitstring_0 value properly.' - else if ( set10 % any() ) then - error stop procedure // ' failed to interpret bitstring_0 ' // & - '// bitstring_0 value properly.' - else - write(*,*) 'from_string transferred bitstring_0//bitstring_0' // & - ' properly into set10' - end if + call check(error, bits(set10), 66, & + 'from_string failed to interpret bitstring_0 // bitstring_0 size properly.') + if (allocated(error)) return + call check(error, set10 % none(), & + 'failed to interpret bitstring_0 // bitstring_0 value properly.') + if (allocated(error)) return + call check(error, .not. set10 % any(), & + 'failed to interpret bitstring_0 // bitstring_0 value properly.') + if (allocated(error)) return call set1 % from_string( bitstring_all ) - if ( bits(set1) /= 33 ) then - error stop procedure // ' from_string failed to interpret ' // & - 'bitstring_all size properly.' - else if ( set1 % none() ) then - error stop procedure // ' failed to interpret bitstring_all ' // & - 'value properly.' - else if ( .not. set1 % any() ) then - error stop procedure // ' failed to interpret bitstring_all ' // & - 'value properly.' - else if ( .not. set1 % all() ) then - error stop procedure // ' failed to interpret bitstring_all ' // & - 'value properly.' - else - write(*,*) 'from_string transferred bitstring_1 properly into set1' - end if + call check(error, bits(set1), 33, & + 'from_string failed to interpret bitstring_all size properly.') + if (allocated(error)) return + call check(error, .not. set1 % none(), & + 'failed to interpret bitstring_all value properly.') + if (allocated(error)) return + call check(error, set1 % any(), & + 'failed to interpret bitstring_all value properly.') + if (allocated(error)) return + call check(error, set1 % all(), & + 'failed to interpret bitstring_all value properly.') + if (allocated(error)) return call set11 % from_string( bitstring_all // bitstring_all ) - if ( bits(set11) /= 66 ) then - error stop procedure // ' from_string failed to interpret ' // & - 'bitstring_all // bitstring_all size properly.' - else if ( set11 % none() ) then - error stop procedure // ' failed to interpret bitstring_all ' // & - '// bitstring_all value properly.' - else if ( .not. set11 % any() ) then - error stop procedure // ' failed to interpret bitstring_all ' // & - '// bitstring_all value properly.' - else if ( .not. set11 % all() ) then - error stop procedure // ' failed to interpret bitstring_all ' // & - '// bitstring_all value properly.' - else - write(*,*) 'from_string transferred bitstring_all // ' // & - 'bitstring_all properly into set11' - end if + call check(error, bits(set11), 66, & + 'from_string failed to interpret bitstring_all // bitstring_all size properly.') + if (allocated(error)) return + call check(error, .not. set11 % none(), & + 'failed to interpret bitstring_all // bitstring_all value properly.') + if (allocated(error)) return + call check(error, set11 % any(), & + 'failed to interpret bitstring_all // bitstring_all value properly.') + if (allocated(error)) return + call check(error, set11 % all(), & + 'failed to interpret bitstring_all // bitstring_all value properly.') + if (allocated(error)) return call set3 % read_bitset( bitstring_0, status ) - if ( status /= success ) then - write(*,*) 'read_bitset_string failed with bitstring_0 as expected.' - else - error stop procedure // ' read_bitset_string did not fail ' // & - 'with bitstring_0 as expected.' - end if + call check(error, status /= success, & + 'read_bitset_string did not fail with bitstring_0 as expected.') + if (allocated(error)) return call set13 % read_bitset( bitstring_0 // bitstring_0, status ) - if ( status /= success ) then - write(*,*) 'read_bitset_string failed with bitstring_0 ' // & - '// bitstring_0 as expected.' - end if + call check(error, status /= success, & + 'read_bitset_string did not fail with bitstring_0 // bitstring_0 as expected.') + if (allocated(error)) return call set3 % read_bitset( 's33b' // bitstring_0, status ) - if ( bits(set3) /= 33 ) then - error stop procedure // ' read_bitset_string failed to ' // & - 'interpret "s33b" // bitstring_0 size properly.' - else if ( .not. set3 % none() ) then - error stop procedure // ' failed to interpret "s33b" // ' // & - 'bitstring_0 value properly.' - else - write(*,*) 'read_bitset_string transferred "s33b" // ' // & - 'bitstring_0 properly into set3' - end if + call check(error, bits(set3), 33, & + 'read_bitset_string failed to interpret "s33b" // bitstring_0 size properly.') + if (allocated(error)) return + call check(error, set3 % none(), & + 'failed to interpret "s33b" // bitstring_0 value properly.') + if (allocated(error)) return call set13 % read_bitset( 's66b' // bitstring_0 // bitstring_0, & status ) - if ( bits(set13) /= 66 ) then - error stop procedure // ' read_bitset_string failed to ' // & - 'interpret "s66b" // bitstring_0 // bitstring_0 size properly.' - else if ( .not. set13 % none() ) then - error stop procedure // ' failed to interpret "s66b" // ' // & - 'bitstring_0 // bitstring_0 value properly.' - else - write(*,*) 'read_bitset_string transferred "s66b" // ' // & - 'bitstring_0 // bitstring_0 properly into set13' - end if + call check(error, bits(set13), 66, 'read_bitset_string failed to ' // & + 'interpret "s66b" // bitstring_0 // bitstring_0 size properly.') + if (allocated(error)) return + call check(error, set13 % none(), & + 'failed to interpret "s66b" // bitstring_0 // bitstring_0 value properly.') + if (allocated(error)) return call set4 % read_bitset( 's33b' // bitstring_all ) - if ( bits(set4) /= 33 ) then - error stop procedure // ' read_bitset_string failed to ' // & - 'interpret "s33b" // bitstring_all size properly.' - else if ( set4 % none() ) then - error stop procedure // ' read_bitset_string failed to ' // & - 'interpret "s33b" // bitstring_all value properly.' - else if ( .not. set4 % any() ) then - error stop procedure // ' read_bitset_string failed to // ' // & - 'interpret "s33b" bitstring_all value properly.' - else if ( .not. set4 % all() ) then - error stop procedure // ' read_bitset_string failed to // ' // & - 'interpret "s33b" bitstring_all value properly.' - else - write(*,*) 'read_bitset_string transferred "s33b" // ' // & - 'bitstring_all properly into set4.' - end if - - call set14 % read_bitset( 's66b' // bitstring_all & - // bitstring_all ) - if ( bits(set14) /= 66 ) then - error stop procedure // ' read_bitset_string failed to ' // & - 'interpret "s66b" // bitstring_all // bitstring_all ' // & - 'size properly.' - else if ( set14 % none() ) then - error stop procedure // ' read_bitset_string failed to ' // & - 'interpret "s66b" // bitstring_all // bitstring_all ' // & - 'value properly.' - else if ( .not. set14 % any() ) then - error stop procedure // ' read_bitset_string failed to // ' // & - 'interpret "s66b" bitstring_all // bitstring_all ' // & - 'value properly.' - else if ( .not. set14 % all() ) then - error stop procedure // ' read_bitset_string failed to // ' // & - 'interpret "s66b" bitstring_all // bitstring_all ' // & - 'value properly.' - else - write(*,*) 'read_bitset_string transferred "s66b" // ' // & - 'bitstring_all // bitstring_all properly into set14.' - end if + call check(error, bits(set4), 33, & + 'read_bitset_string failed to interpret "s33b" // bitstring_all size properly.') + if (allocated(error)) return + call check(error, .not. set4 % none(), & + 'read_bitset_string failed to interpret "s33b" // bitstring_all value properly.') + if (allocated(error)) return + call check(error, set4 % any(), & + 'read_bitset_string failed to // interpret "s33b" bitstring_all value properly.') + if (allocated(error)) return + call check(error, set4 % all(), & + 'read_bitset_string failed to // interpret "s33b" bitstring_all value properly.') + if (allocated(error)) return + + call set14 % read_bitset( 's66b' // bitstring_all // bitstring_all ) + call check(error, bits(set14), 66, & + 'read_bitset_string failed to ' // & + 'interpret "s66b" // bitstring_all // bitstring_all size properly.') + if (allocated(error)) return + call check(error, .not. set14 % none(), 'read_bitset_string failed to ' // & + 'interpret "s66b" // bitstring_all // bitstring_all value properly.') + if (allocated(error)) return + call check(error, set14 % any(), 'read_bitset_string failed to // ' // & + 'interpret "s66b" bitstring_all // bitstring_all value properly.') + if (allocated(error)) return + call check(error, set14 % all(), 'read_bitset_string failed to // ' // & + 'interpret "s66b" bitstring_all // bitstring_all value properly.') + if (allocated(error)) return call set0 % to_string( string0 ) - if ( bitstring_0 /= string0 ) then - error stop procedure // ' to_string failed to convert set0 ' // & - 'value properly.' - else - write(*,*) 'to_string properly converted the set0 value' - end if + call check(error, bitstring_0, string0, & + 'to_string failed to convert set0 value properly.') + if (allocated(error)) return call set10 % to_string( string0 ) - if ( bitstring_0 // bitstring_0 /= string0 ) then - error stop procedure // ' to_string failed to convert set10 ' // & - 'value properly.' - else - write(*,*) 'to_string properly converted the set10 value' - end if + call check(error, bitstring_0 // bitstring_0, string0, & + 'to_string failed to convert set10 value properly.') + if (allocated(error)) return call set1 % to_string( string0 ) - if ( bitstring_all /= string0 ) then - error stop procedure // ' to_string failed to convert set1 ' // & - 'value properly.' - else - write(*,*) 'to_string properly converted the set1 value' - end if + call check(error, bitstring_all, string0, & + 'to_string failed to convert set1 value properly.') + if (allocated(error)) return call set11 % to_string( string0 ) - if ( bitstring_all // bitstring_all /= string0 ) then - error stop procedure // ' to_string failed to convert set11 ' // & - 'value properly.' - else - write(*,*) 'to_string properly converted the set11 value' - end if + call check(error, bitstring_all // bitstring_all, string0, & + 'to_string failed to convert set11 value properly.') + if (allocated(error)) return call set0 % write_bitset( string0 ) - if ( ('S33B' // bitstring_0) /= string0 ) then - error stop procedure // ' write_bitset_string failed to ' // & - 'convert set2 value properly.' - else - write(*,*) 'write_bitset_string properly converted the set0 value' - end if + call check(error, ('S33B' // bitstring_0), string0, & + 'write_bitset_string failed to convert set2 value properly.') + if (allocated(error)) return call set10 % write_bitset( string0 ) - if ( ('S66B' // bitstring_0 // bitstring_0) /= string0 ) then - error stop procedure // ' write_bitset_string failed to ' // & - 'convert set10 value properly.' - else - write(*,*) 'write_bitset_string properly converted the set10 value' - end if + call check(error, ('S66B' // bitstring_0 // bitstring_0), string0, & + 'write_bitset_string failed to convert set10 value properly.') + if (allocated(error)) return call set1 % write_bitset( string0 ) - if ( ('S33B' // bitstring_all) /= string0 ) then - error stop procedure // ' write_bitset_string failed to ' // & - 'convert set1 value properly.' - else - write(*,*) 'write_bitset_string properly converted the set1 value' - end if + call check(error, ('S33B' // bitstring_all), string0, & + 'write_bitset_string failed to convert set1 value properly.') + if (allocated(error)) return call set11 % write_bitset( string0 ) - if ( ('S66B' // bitstring_all // bitstring_all) /= string0 ) then - error stop procedure // ' write_bitset_string failed to ' // & - 'convert set11 value properly.' - else - write(*,*) 'write_bitset_string properly converted the set11 value' - end if + call check(error, ('S66B' // bitstring_all // bitstring_all), string0, & + 'write_bitset_string failed to convert set11 value properly.') + if (allocated(error)) return - return end subroutine test_string_operations - subroutine test_io() - character(*), parameter:: procedure = 'TEST_IO' + subroutine test_io(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error integer :: unit + type(bitset_large) :: set0, set1, set2, set3, set4, set5 + type(bitset_large) :: set10, set11, set12, set13, set14, set15 - write(*,*) - write(*,*) 'Test bitset I/O: input, read_bitset, output, and ' // & - 'write_bitset' - + call set0 % from_string( bitstring_0 ) + call set1 % from_string( bitstring_all ) call set2 % from_string( bitstring_33 ) open( newunit=unit, status='scratch', form='formatted', & action='readwrite' ) @@ -263,72 +206,60 @@ subroutine test_io() call set3 % read_bitset(unit) call set5 % read_bitset(unit) call set4 % read_bitset(unit) - if ( set4 /= set0 .or. set5 /= set1 .or. set3 /= set2 ) then - error stop procedure // ' transfer to and from units using ' // & - 'bitset literals failed.' - else - write(*,*) 'Transfer to and from units using ' // & - 'plain write_bitset_unit and read_bitset_unit succeeded.' - end if - - rewind( unit ) - - call set12 % from_string( bitstring_33 // bitstring_33 ) - call set12 % write_bitset(unit) - call set11 % write_bitset(unit) - call set10 % write_bitset(unit) - rewind( unit ) - call set13 % read_bitset(unit) - call set15 % read_bitset(unit) - call set14 % read_bitset(unit) - if ( set14 /= set10 .or. set15 /= set11 .or. set3 /= set12 ) then - error stop procedure // ' transfer to and from units using ' // & - 'bitset literals for bits > 64 failed.' - else - write(*,*) 'Transfer bits > 64 to and from units using ' // & - 'plain write_bitset_unit and read_bitset_unit succeeded.' - end if - - rewind( unit ) - - call set2 % write_bitset(unit, advance='no') - call set1 % write_bitset(unit, advance='no') - call set0 % write_bitset(unit) - rewind( unit ) - call set3 % read_bitset(unit, advance='no') - call set4 % read_bitset(unit, advance='no') - call set5 % read_bitset(unit) - if ( set5 /= set0 .or. set4 /= set1 .or. set3 /= set2 ) then - error stop procedure // ' transfer to and from units using ' // & - 'bitset literals with advance == "no" failed.' - else - write(*,*) 'Transfer to and from units using ' // & - 'write_bitset_unit and read_bitset_unit with ' // & - 'advance=="no" succeeded.' - end if - - rewind( unit ) - - call set12 % write_bitset(unit, advance='no') - call set11 % write_bitset(unit, advance='no') - call set10 % write_bitset(unit) - rewind( unit ) - call set13 % read_bitset(unit, advance='no') - call set14 % read_bitset(unit, advance='no') - call set15 % read_bitset(unit) - if ( set15 /= set10 .or. set14 /= set11 .or. set13 /= set12 ) then - error stop procedure // ' transfer to and from units using ' // & - ' bitset literals for bitss > 64 with advance == "no" failed.' - else - write(*,*) 'Transfer bits > 64 to and from units using ' // & - 'write_bitset_unit and read_bitset_unit with ' // & - 'advance=="no" succeeded.' + call check(error, set4 /= set0 .or. set5 /= set1 .or. set3 /= set2, & + 'transfer to and from units using bitset literals failed.') + + if (.not.allocated(error)) then + rewind( unit ) + + call set10 % from_string( bitstring_0 // bitstring_0 ) + call set11 % from_string( bitstring_all // bitstring_all ) + call set12 % from_string( bitstring_33 // bitstring_33 ) + + call set12 % write_bitset(unit) + call set11 % write_bitset(unit) + call set10 % write_bitset(unit) + rewind( unit ) + call set13 % read_bitset(unit) + call set15 % read_bitset(unit) + call set14 % read_bitset(unit) + call check(error, set14 /= set10 .or. set15 /= set11 .or. set3 /= set12, & + 'transfer to and from units using bitset literals for bits > 64 failed.') + end if + if (.not.allocated(error)) then + + rewind( unit ) + + call set2 % write_bitset(unit, advance='no') + call set1 % write_bitset(unit, advance='no') + call set0 % write_bitset(unit) + rewind( unit ) + call set3 % read_bitset(unit, advance='no') + call set4 % read_bitset(unit, advance='no') + call set5 % read_bitset(unit) + call check(error, set5 /= set0 .or. set4 /= set1 .or. set3 /= set2, & + 'transfer to and from units using bitset literals with advance == "no" failed.') + end if + if (.not.allocated(error)) then + + rewind( unit ) + + call set12 % write_bitset(unit, advance='no') + call set11 % write_bitset(unit, advance='no') + call set10 % write_bitset(unit) + rewind( unit ) + call set13 % read_bitset(unit, advance='no') + call set14 % read_bitset(unit, advance='no') + call set15 % read_bitset(unit) + call check(error, set15 /= set10 .or. set14 /= set11 .or. set13 /= set12, & + 'transfer to and from units using bitset literals for bitss > 64 with advance == "no" failed.') end if close(unit) + if (allocated(error)) return open( newunit=unit, form='unformatted', status='scratch', & - action='readwrite' ) + action='readwrite' ) call set2 % output(unit) call set1 % output(unit) call set0 % output(unit) @@ -336,18 +267,14 @@ subroutine test_io() call set5 % input(unit) call set4 % input(unit) call set3 % input(unit) - if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then - error stop procedure // ' transfer to and from units using ' // & - 'output and input failed.' - else - write(*,*) 'Transfer to and from units using ' // & - 'output and input succeeded.' - end if + call check(error, set3 /= set0 .or. set4 /= set1 .or. set5 /= set2, & + 'transfer to and from units using output and input failed.') close( unit ) + if (allocated(error)) return open( newunit=unit, form='unformatted', access='stream', & - status='scratch', action='readwrite' ) + status='scratch', action='readwrite' ) call set2 % output(unit) call set1 % output(unit) call set0 % output(unit) @@ -355,18 +282,14 @@ subroutine test_io() call set5 % input(unit) call set4 % input(unit) call set3 % input(unit) - if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then - error stop procedure // ' transfer to and from units using ' // & - 'stream output and input failed.' - else - write(*,*) 'Transfer to and from units using ' // & - 'stream output and input succeeded.' - end if + call check(error, set3 /= set0 .or. set4 /= set1 .or. set5 /= set2, & + 'transfer to and from units using stream output and input failed.') close( unit ) + if (allocated(error)) return open( newunit=unit, form='unformatted', status='scratch', & - action='readwrite' ) + action='readwrite' ) call set12 % output(unit) call set11 % output(unit) call set10 % output(unit) @@ -374,17 +297,13 @@ subroutine test_io() call set15 % input(unit) call set14 % input(unit) call set13 % input(unit) - if ( set13 /= set10 .or. set14 /= set11 .or. set15 /= set12 ) then - error stop procedure // ' transfer to and from units using ' // & - 'output and input failed for bits . 64.' - else - write(*,*) 'Transfer to and from units using ' // & - 'output and input succeeded for bits > 64.' - end if + call check(error, set13 /= set10 .or. set14 /= set11 .or. set15 /= set12, & + 'transfer to and from units using output and input failed for bits . 64.') close(unit) + if (allocated(error)) return open( newunit=unit, form='unformatted', access='stream', & - status='scratch', action='readwrite' ) + status='scratch', action='readwrite' ) call set12 % output(unit) call set11 % output(unit) call set10 % output(unit) @@ -392,19 +311,17 @@ subroutine test_io() call set15 % input(unit) call set14 % input(unit) call set13 % input(unit) - if ( set13 /= set10 .or. set14 /= set11 .or. set15 /= set12 ) then - error stop procedure // ' transfer to and from units using ' // & - 'stream output and input failed for bits . 64.' - else - write(*,*) 'Transfer to and from units using ' // & - 'stream output and input succeeded for bits > 64.' - end if + call check(error, set13 /= set10 .or. set14 /= set11 .or. set15 /= set12, & + 'transfer to and from units using stream output and input failed for bits . 64.') close(unit) + if (allocated(error)) return end subroutine test_io - subroutine test_initialization() - character(*), parameter:: procedure = 'TEST_INITIALIZATION' + subroutine test_initialization(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + logical(int8) :: log1(64) = .true. logical(int16) :: log2(31) = .false. logical(int32) :: log3(15) = .true. @@ -417,703 +334,542 @@ subroutine test_initialization() logical(int16), allocatable :: log6(:) logical(int32), allocatable :: log7(:) logical(int64), allocatable :: log8(:) - - write(*,*) - write(*,*) 'Test initialization: assignment, extract, and init' + type(bitset_large) :: set4, set5 set5 = log1 - if ( set5 % bits() /= 64 ) then - error stop procedure // & - ' initialization with logical(int8) failed to set' // & - ' the right size.' - else if ( .not. set5 % all() ) then - error stop procedure // ' initialization with' // & - ' logical(int8) failed to set the right values.' - else - write(*,*) 'Initialization with logical(int8) succeeded.' - end if + call check(error, set5 % bits(), 64, & + ' initialization with logical(int8) failed to set' // & + ' the right size.') + if (allocated(error)) return + call check(error, set5 % all(), & + ' initialization with' // & + ' logical(int8) failed to set the right values.') + if (allocated(error)) return set5 = log11 - if ( set5 % bits() /= 66 ) then - error stop procedure // & - ' initialization with logical(int8) failed to set' // & - ' the right size > 64 bits.' - else if ( .not. set5 % all() ) then - error stop procedure // ' initialization with' // & - ' logical(int8) failed to set the right values.' - else - write(*,*) 'Initialization > 64 bits with logical(int8)succeeded.' - end if + call check(error, set5 % bits(), 66, & + ' initialization with logical(int8) failed to set' // & + ' the right size > 64 bits.') + if (allocated(error)) return + call check(error, set5 % all(), & + ' initialization with' // & + ' logical(int8) failed to set the right values.') + if (allocated(error)) return set5 = log2 - if ( set5 % bits() /= 31 ) then - error stop procedure // & - ' initialization with logical(int16) failed to set' // & - ' the right size.' - else if ( .not. set5 % none() ) then - error stop procedure // & - ' initialization with logical(int16) failed to set' // & - ' the right values.' - else - write(*,*) 'Initialization with logical(int16) succeeded.' - end if + call check(error, set5 % bits(), 31, & + ' initialization with logical(int16) failed to set' // & + ' the right size.') + if (allocated(error)) return + call check(error, set5 % none(), & + ' initialization with logical(int16) failed to set' // & + ' the right values.') + if (allocated(error)) return set5 = log12 - if ( set5 % bits() /= 99 ) then - error stop procedure // & - ' initialization with logical(int16) failed to set' // & - ' the right size > 64 bits .' - else if ( .not. set5 % none() ) then - error stop procedure // & - ' initialization with logical(int16) failed to set' // & - ' the right values > 64 bits .' - else - write(*,*) 'Initialization > 64 bits with logical(int16) ' // & - 'succeeded.' - end if + call check(error, set5 % bits(), 99, & + ' initialization with logical(int16) failed to set' // & + ' the right size > 64 bits .') + if (allocated(error)) return + call check(error, set5 % none(), & + ' initialization with logical(int16) failed to set' // & + ' the right values > 64 bits .') + if (allocated(error)) return set5 = log3 - if ( set5 % bits() /= 15 ) then - error stop procedure // & - ' initialization with logical(int32) failed to set' // & - ' the right size.' - else if ( .not. set5 % all() ) then - error stop procedure // & - ' initialization with logical(int32) failed to set' // & - ' the right values.' - else - write(*,*) 'Initialization with logical(int32) succeeded.' - end if + call check(error, set5 % bits(), 15, & + ' initialization with logical(int32) failed to set' // & + ' the right size.') + if (allocated(error)) return + call check(error, set5 % all(), & + ' initialization with logical(int32) failed to set' // & + ' the right values.') + if (allocated(error)) return set5 = log13 - if ( set5 % bits() /= 132 ) then - error stop procedure // & - ' initialization with logical(int32) failed to set' // & - ' the right size > 64 bits .' - else if ( .not. set5 % all() ) then - error stop procedure // & - ' initialization with logical(int32) failed to set' // & - ' the right values > 64 bits .' - else - write(*,*) 'Initialization > 64 bits with logical(int32) ' // & - 'succeeded.' - end if + call check(error, set5 % bits(), 132, & + ' initialization with logical(int32) failed to set' // & + ' the right size > 64 bits .') + if (allocated(error)) return + call check(error, set5 % all(), & + ' initialization with logical(int32) failed to set' // & + ' the right values > 64 bits .') + if (allocated(error)) return set5 = log4 - if ( set5 % bits() /= 33 ) then - error stop procedure // & - ' initialization with logical(int64) failed to set' // & - ' the right size.' - else if ( .not. set5 % none() ) then - error stop procedure // & - ' initialization with logical(int64) failed to set' // & - ' the right values.' - else - write(*,*) 'Initialization with logical(int64) succeeded.' - end if + call check(error, set5 % bits(), 33, & + ' initialization with logical(int64) failed to set' // & + ' the right size.') + if (allocated(error)) return + call check(error, set5 % none(), & + ' initialization with logical(int64) failed to set' // & + ' the right values.') + if (allocated(error)) return set5 = log14 - if ( set5 % bits() /= 165 ) then - error stop procedure // & - ' initialization with logical(int64) failed to set' // & - ' the right size > 64 bits .' - else if ( .not. set5 % none() ) then - error stop procedure // & - ' initialization with logical(int64) failed to set' // & - ' the right values > 64 bits .' - else - write(*,*) 'Initialization > 64 bits with logical(int64) ' // & - 'succeeded.' - end if + call check(error, set5 % bits(), 165, & + ' initialization with logical(int64) failed to set' // & + ' the right size > 64 bits .') + if (allocated(error)) return + call check(error, set5 % none(), & + ' initialization with logical(int64) failed to set' // & + ' the right values > 64 bits .') + if (allocated(error)) return set5 = log1 call extract( set4, set5, 1_bits_kind, 33_bits_kind ) - if ( set4 % bits() /= 33 ) then - error stop procedure // & - ' initialization with extract failed to set' // & - ' the right size.' - else if ( .not. set4 % all() ) then - error stop procedure // & - ' initialization with extract failed to set' // & - ' the right values.' - else - write(*,*) 'Initialization with extract succeeded.' - end if + call check(error, set4 % bits(), 33, & + ' initialization with extract failed to set' // & + ' the right size.') + if (allocated(error)) return + call check(error, set4 % all(), & + ' initialization with extract failed to set' // & + ' the right values.') + if (allocated(error)) return set5 = log11 call extract( set4, set5, 1_bits_kind, 65_bits_kind ) - if ( set4 % bits() /= 65 ) then - error stop procedure // & - ' initialization with extract failed to set' // & - ' the right size > 64 bits.' - else if ( .not. set4 % all() ) then - error stop procedure // & - ' initialization with extract failed to set' // & - ' the right values > 64 bits.' - else - write(*,*) 'Initialization with extract succeeded.' - end if + call check(error, set4 % bits(), 65, & + ' initialization with extract failed to set' // & + ' the right size > 64 bits.') + if (allocated(error)) return + call check(error, set4 % all(), & + ' initialization with extract failed to set' // & + ' the right values > 64 bits.') + if (allocated(error)) return set5 = log1 set4 = set5 - if ( set4 % bits() /= 64 ) then - write(*,*) 'Bits = ', set4 % bits() - error stop procedure // & - ' initialization with simple assignment failed to set' // & - ' the right size.' - else if ( .not. set4 % all() ) then - error stop procedure // & - ' initialization with simple assignment failed to set' // & - ' the right values.' - else - write(*,*) 'Initialization with simple assignment succeeded.' - end if + call check(error, set4 % bits(), 64, & + ' initialization with simple assignment failed to set' // & + ' the right size.') + if (allocated(error)) return + call check(error, set4 % all(), & + ' initialization with simple assignment failed to set' // & + ' the right values.') + if (allocated(error)) return set5 = log11 set4 = set5 - if ( set4 % bits() /= 66 ) then - write(*,*) 'Bits = ', set4 % bits() - error stop procedure // & - ' initialization with simple assignment failed to set' // & - ' the right size > 64 bits.' - else if ( .not. set4 % all() ) then - error stop procedure // & - ' initialization with simple assignment failed to set' // & - ' the right values > 64 bits.' - else - write(*,*) 'Initialization > 64 bits with simple assignment ' // & - 'succeeded.' - end if + call check(error, set4 % bits(), 66, & + ' initialization with simple assignment failed to set' // & + ' the right size > 64 bits.') + if (allocated(error)) return + call check(error, set4 % all(), & + ' initialization with simple assignment failed to set' // & + ' the right values > 64 bits.') + if (allocated(error)) return set5 = log1 log5 = set5 - if ( size(log5) /= 64 ) then - error stop procedure // & - ' initialization of logical(int8) with assignment failed' // & - ' to set the right size.' - else if ( .not. all(log5) ) then - error stop procedure // & - ' initialization of logical(int8) with assignment failed' // & - ' to set the right values.' - else - write(*,*) 'Initialization of logical(int8) succeeded.' - end if + call check(error, size(log5), 64, & + ' initialization of logical(int8) with assignment failed' // & + ' to set the right size.') + if (allocated(error)) return + call check(error, all(log5) .eqv. .true., & ! FIXME + ' initialization of logical(int8) with assignment failed' // & + ' to set the right values.') + if (allocated(error)) return set5 = log11 log5 = set5 - if ( size(log5) /= 66 ) then - error stop procedure // & - ' initialization of logical(int8) with assignment failed' // & - ' to set the right size > 64 bits.' - else if ( .not. all(log5) ) then - error stop procedure // & - ' initialization of logical(int8) with assignment failed' // & - ' to set the right values > 64 bits.' - else - write(*,*) 'Initialization > 64 bits of logical(int8) succeeded.' - end if + call check(error, size(log5), 66, & + ' initialization of logical(int8) with assignment failed' // & + ' to set the right size > 64 bits.') + if (allocated(error)) return + call check(error, all(log5) .eqv. .true., & ! FIXME + ' initialization of logical(int8) with assignment failed' // & + ' to set the right values > 64 bits.') + if (allocated(error)) return set5 = log1 log6 = set5 - if ( size(log6) /= 64 ) then - error stop procedure // & - ' initialization of logical(int16) with assignment failed' // & - ' to set the right size.' - else if ( .not. all(log6) ) then - error stop procedure // & - ' initialization of logical(int16) with assignment failed' // & - ' to set the right values.' - else - write(*,*) 'Initialization of logical(int16) succeeded.' - end if + call check(error, size(log6), 64, & + ' initialization of logical(int16) with assignment failed' // & + ' to set the right size.') + if (allocated(error)) return + call check(error, all(log6) .eqv. .true., & ! FIXME + ' initialization of logical(int16) with assignment failed' // & + ' to set the right values.') + if (allocated(error)) return set5 = log11 log6 = set5 - if ( size(log6) /= 66 ) then - error stop procedure // & - ' initialization of logical(int16) with assignment failed' // & - ' to set the right size > 64 bits.' - else if ( .not. all(log6) ) then - error stop procedure // & - ' initialization of logical(int16) with assignment failed' // & - ' to set the right values > 64 bits.' - else - write(*,*) 'Initialization > 64 bits of logical(int16) succeeded.' - end if + call check(error, size(log6), 66, & + ' initialization of logical(int16) with assignment failed' // & + ' to set the right size > 64 bits.') + if (allocated(error)) return + call check(error, all(log6) .eqv. .true., & ! FIXME + ' initialization of logical(int16) with assignment failed' // & + ' to set the right values > 64 bits.') + if (allocated(error)) return set5 = log1 log7 = set5 - if ( size(log7) /= 64 ) then - error stop procedure // & - ' initialization of logical(int32) with assignment failed' // & - ' to set the right size.' - else if ( .not. all(log7) ) then - error stop procedure // & - ' initialization of logical(int32) with assignment failed' // & - ' to set the right values.' - else - write(*,*) 'Initialization of logical(int32) succeeded.' - end if + call check(error, size(log7), 64, & + ' initialization of logical(int32) with assignment failed' // & + ' to set the right size.') + if (allocated(error)) return + call check(error, all(log7), & + ' initialization of logical(int32) with assignment failed' // & + ' to set the right values.') + if (allocated(error)) return set5 = log11 log7 = set5 - if ( size(log7) /= 66 ) then - error stop procedure // & - ' initialization of logical(int32) with assignment failed' // & - ' to set the right size > 64 bits.' - else if ( .not. all(log7) ) then - error stop procedure // & - ' initialization of logical(int32) with assignment failed' // & - ' to set the right values > 64 bits.' - else - write(*,*) 'Initialization > 64 bits of logical(int32) succeeded.' - end if + call check(error, size(log7), 66, & + ' initialization of logical(int32) with assignment failed' // & + ' to set the right size > 64 bits.') + if (allocated(error)) return + call check(error, all(log7), & + ' initialization of logical(int32) with assignment failed' // & + ' to set the right values > 64 bits.') + if (allocated(error)) return set5 = log1 log8 = set5 - if ( size(log8) /= 64 ) then - error stop procedure // & - ' initialization of logical(int64) with assignment failed' // & - ' to set the right size.' - else if ( .not. all(log8) ) then - error stop procedure // & - ' initialization of logical(int64) with assignment failed' // & - ' to set the right values.' - else - write(*,*) 'Initialization of logical(int64) succeeded.' - end if + call check(error, size(log8), 64, & + ' initialization of logical(int64) with assignment failed' // & + ' to set the right size.') + if (allocated(error)) return + call check(error, merge(.true., .false., all(log8)), & ! FIXME + ' initialization of logical(int64) with assignment failed' // & + ' to set the right values.') + if (allocated(error)) return set5 = log11 log8 = set5 - if ( size(log8) /= 66 ) then - error stop procedure // & - ' initialization of logical(int64) with assignment failed' // & - ' to set the right size > 64 bits.' - else if ( .not. all(log8) ) then - error stop procedure // & - ' initialization of logical(int64) with assignment failed' // & - ' to set the right values > 64 bits.' - else - write(*,*) 'Initialization > 64 bits of logical(int64) succeeded.' - end if + call check(error, size(log8), 66, & + ' initialization of logical(int64) with assignment failed' // & + ' to set the right size > 64 bits.') + if (allocated(error)) return + call check(error, merge(.true., .false., all(log8)), & ! FIXME + ' initialization of logical(int64) with assignment failed' // & + ' to set the right values > 64 bits.') + if (allocated(error)) return end subroutine test_initialization - subroutine test_bitset_inquiry() - character(*), parameter:: procedure = 'TEST_BITSET_INQUIRY' + subroutine test_bitset_inquiry(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer(bits_kind) :: i + type(bitset_large) :: set0, set1 + type(bitset_large) :: set10, set11 - write(*,*) - write(*,*) 'Test bitset inquiry: all, any, bits, none, test, and value' - - if ( set0 % none() ) then - if ( .not. set0 % any() ) then - write(*,*) 'As expected set0 has no bits set' - else - error stop procedure // ' set0 had some bits set which ' // & - 'was unexpected.' - end if - else - error stop procedure // ' set0 did not have none set which ' // & - 'was unexpected' - end if + call set0 % from_string( bitstring_0 ) + call set1 % from_string( bitstring_all ) + + call check(error, set0 % none(), & + ' set0 did not have none set which was unexpected') + if (allocated(error)) return + + call check(error, .not. set0 % any(), & + ' set0 had some bits set which was unexpected.') + if (allocated(error)) return call set0 % not() - if ( set0 % all() ) then - if ( set0 % any() ) then - write(*,*) 'As expected set0 now has all bits set' - else - error stop procedure // ' set0 had no bits set which ' // & - 'was unexpected.' - end if - else - error stop procedure // ' set0 did not have all bits set ' // & - 'which was unexpected' - end if + call check(error, set0 % all(), & + ' set0 did not have all bits set which was unexpected') + if (allocated(error)) return - if ( set1 % any() ) then - if ( set1 % all() ) then - write(*,*) 'As expected set1 has all bits set' - else - error stop procedure // ' set1 did not have all bits set ' // & - 'which was unexpected.' - end if - else - error stop procedure // ' set1 had none bits set ' // & - 'which was unexpected' - end if + call check(error, set0 % any(), & + ' set0 had no bits set which was unexpected.') + if (allocated(error)) return + + call check(error, set1 % any(), & + ' set1 had none bits set which was unexpected') + if (allocated(error)) return + + call check(error, set1 % all(), & + ' set1 did not have all bits set which was unexpected.') + if (allocated(error)) return call set0 % not() do i=0, set0 % bits() - 1 - if ( set0 % test(i) ) then - error stop procedure // ' against expectations set0 has ' // & - 'at least 1 bit set.' - end if + call check(error, .not. set0 % test(i), & + 'against expectations set0 has at least 1 bit set.') + if (allocated(error)) return end do write(*,*) 'As expected set0 had no bits set.' do i=0, set1 % bits() - 1 - if ( .not. set1 % test(i) ) then - error stop procedure // ' against expectations set0 has ' // & - 'at least 1 bit unset.' - end if + call check(error, set1 % test(i), & + 'against expectations set0 has at least 1 bit unset.') + if (allocated(error)) return end do write(*,*) 'As expected set1 had all bits set.' do i=0, set0 % bits() - 1 - if ( set0 % value(i) /= 0 ) then - error stop procedure // ' against expectations set0 has ' // & - 'at least 1 bit set.' - end if + call check(error, set0 % value(i), 0, & + 'against expectations set0 has at least 1 bit set.') + if (allocated(error)) return end do write(*,*) 'As expected set0 had no bits set.' do i=0, set1 % bits() - 1 - if ( set1 % value(i) /= 1 ) then - error stop procedure // ' against expectations set0 has ' // & - 'at least 1 bit unset.' - end if + call check(error, set1 % value(i), 1, & + 'against expectations set0 has at least 1 bit unset.') + if (allocated(error)) return end do write(*,*) 'As expected set1 had all bits set.' - if ( set0 % bits() == 33 ) then - write(*,*) 'set0 has 33 bits as expected.' - else - error stop procedure // 'set0 unexpectedly does not have 33 bits.' - end if + call check(error, set0 % bits() == 33, & + 'set0 unexpectedly does not have 33 bits.') + if (allocated(error)) return ! > 64 bit inquiries call set10 % from_string( bitstring_0 // bitstring_0 // bitstring_0 ) - if ( set10 % none() ) then - if ( .not. set10 % any() ) then - write(*,*) 'As expected set10 has no bits set' - else - error stop procedure // ' set10 had some bits set which ' // & - 'was unexpected.' - end if - else - error stop procedure // ' set10 did not have none set which ' // & - 'was unexpected' - end if + call check(error, set10 % none(), & + ' set10 did not have none set which was unexpected') + if (allocated(error)) return + + call check(error, .not. set10 % any(), & + ' set10 had some bits set which was unexpected.') + if (allocated(error)) return call set10 % not() - if ( set10 % all() ) then - if ( set10 % any() ) then - write(*,*) 'As expected set10 now has all bits set' - else - error stop procedure // ' set10 had no bits set which ' // & - 'was unexpected.' - end if - else - error stop procedure // ' set10 did not have all bits set ' // & - 'which was unexpected' - end if + call check(error, set10 % all(), & + ' set10 did not have all bits set which was unexpected') + if (allocated(error)) return + + call check(error, set10 % any(), & + ' set10 had no bits set which was unexpected.') + if (allocated(error)) return call set11 % from_string( bitstring_all // bitstring_all // & bitstring_all ) - if ( set11 % any() ) then - if ( set11 % all() ) then - write(*,*) 'As expected set11 has all bits set' - else - error stop procedure // ' set11 did not have all bits set ' // & - 'which was unexpected.' - end if - else - error stop procedure // ' set11 had none bits set ' // & - 'which was unexpected' - end if + call check(error, set11 % any(), & + ' set11 had none bits set which was unexpected') + if (allocated(error)) return + + call check(error, set11 % all(), & + ' set11 did not have all bits set which was unexpected.') + if (allocated(error)) return call set10 % not() do i=0, set10 % bits() - 1 - if ( set10 % test(i) ) then - error stop procedure // ' against expectations set10 has ' // & - 'at least 1 bit set.' - end if + call check(error, .not. set10 % test(i), & + 'against expectations set10 has at least 1 bit set.') + if (allocated(error)) return end do - write(*,*) 'As expected set10 had no bits set.' - do i=0, set11 % bits() - 1 - if ( .not. set11 % test(i) ) then - error stop procedure // ' against expectations set11 has ' // & - 'at least 1 bit unset.' - end if + call check(error, set11 % test(i), & + 'against expectations set11 has at least 1 bit unset.') + if (allocated(error)) return end do - write(*,*) 'As expected set11 had all bits set.' - do i=0, set10 % bits() - 1 - if ( set10 % value(i) /= 0 ) then - error stop procedure // ' against expectations set10 has ' // & - 'at least 1 bit set.' - end if + call check(error, set10 % value(i), 0, & + 'against expectations set10 has at least 1 bit set.') + if (allocated(error)) return end do - write(*,*) 'As expected set10 had no bits set.' - do i=0, set11 % bits() - 1 - if ( set11 % value(i) /= 1 ) then - error stop procedure // ' against expectations set11 has ' // & - 'at least 1 bit unset.' - end if + call check(error, set11 % value(i), 1, & + 'against expectations set11 has at least 1 bit unset.') + if (allocated(error)) return end do - write(*,*) 'As expected set11 had all bits set.' - - if ( set0 % bits() == 33 ) then - write(*,*) 'set0 has 33 bits as expected.' - else - error stop procedure // 'set0 unexpectedly does not have 33 bits.' - end if + call check(error, set0 % bits() == 33, & + 'set0 unexpectedly does not have 33 bits.') + if (allocated(error)) return - if ( set10 % bits() == 99 ) then - write(*,*) 'set10 has 99 bits as expected.' - else - error stop procedure // 'set10 unexpectedly does not have 99 bits.' - end if + call check(error, set10 % bits() == 99, & + 'set10 unexpectedly does not have 99 bits.') + if (allocated(error)) return end subroutine test_bitset_inquiry - subroutine test_bit_operations() - character(*), parameter:: procedure = 'TEST_BIT_OPERATIONS' + subroutine test_bit_operations(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - write(*,*) - write(*,*) 'Test bit operations: clear, flip, not, and set' + type(bitset_large) :: set1, set11 - if ( .not. set1 % all() ) then - error stop procedure // ' set1 is not all set.' - end if + call set1 % from_string( bitstring_all ) + + call check(error, set1 % all(), & + 'set1 is not all set.') + if (allocated(error)) return call set1 % clear(0_bits_kind) - if ( .not. set1 % test(0_bits_kind) ) then - if ( set1 % test(1_bits_kind) ) then - write(*,*) 'Cleared one bit in set1 as expected.' - else - error stop procedure // ' cleared more than one bit in set1.' - end if - else - error stop procedure // ' did not clear the first bit in set1.' - end if + call check(error, .not. set1 % test(0_bits_kind), & + 'did not clear the first bit in set1.') + if (allocated(error)) return + + call check(error, set1 % test(1_bits_kind), & + 'cleared more than one bit in set1.') + if (allocated(error)) return call set1 % clear(1_bits_kind, 32_bits_kind) - if ( set1 % none() ) then - write(*,*) 'Cleared remaining bits in set1 as expected.' - else - error stop procedure // ' did not clear remaining bits ' // & - 'in set1.' - end if + call check(error, set1 % none(), & + 'did not clear remaining bits in set1.') + if (allocated(error)) return call set1 % flip(0_bits_kind) - if ( set1 % test(0_bits_kind) ) then - if ( .not. set1 % test(1_bits_kind) ) then - write(*,*) 'Flipped one bit in set1 as expected.' - else - error stop procedure // ' flipped more than one bit in set1.' - end if - else - error stop procedure // ' did not flip the first bit in set1.' - end if + call check(error, set1 % test(0_bits_kind), & + 'did not flip the first bit in set1.') + if (allocated(error)) return + + call check(error, .not. set1 % test(1_bits_kind), & + 'flipped more than one bit in set1.') + if (allocated(error)) return call set1 % flip(1_bits_kind, 32_bits_kind) - if ( set1 % all() ) then - write(*,*) 'Flipped remaining bits in set1 as expected.' - else - error stop procedure // ' did not flip remaining bits ' // & - 'in set1.' - end if + call check(error, set1 % all(), & + 'did not flip remaining bits in set1.') + if (allocated(error)) return call set1 % not() - if ( set1 % none() ) then - write(*,*) 'Unset bits in set1 as expected.' - else - error stop procedure // ' did not unset bits in set1.' - end if + call check(error, set1 % none(), & + 'did not unset bits in set1.') + if (allocated(error)) return call set1 % set(0_bits_kind) - if ( set1 % test(0_bits_kind) ) then - if ( .not. set1 % test(1_bits_kind) ) then - write(*,*) 'Set first bit in set1 as expected.' - else - error stop procedure // ' set more than one bit in set1.' - end if - else - error stop procedure // ' did not set the first bit in set1.' - end if + call check(error, set1 % test(0_bits_kind), & + 'did not set the first bit in set1.') + if (allocated(error)) return + + call check(error, .not. set1 % test(1_bits_kind), & + 'set more than one bit in set1.') + if (allocated(error)) return call set1 % set(1_bits_kind, 32_bits_kind) - if ( set1 % all() ) then - write(*,*) 'Set the remaining bits in set1 as expected.' - else - error stop procedure // ' did not set the remaining bits ' // & - 'in set1.' - end if + call check(error, set1 % all(), & + 'did not set the remaining bits in set1.') + if (allocated(error)) return call set11 % init( 166_bits_kind ) call set11 % not() - if ( .not. set11 % all() ) then - error stop procedure // ' set11 is not all set.' - end if + call check(error, .not. set11 % all(), & + 'set11 is not all set.') + if (allocated(error)) return call set11 % clear(0_bits_kind) - if ( .not. set11 % test(0_bits_kind) ) then - if ( set11 % test(1_bits_kind) ) then - write(*,*) 'Cleared one bit in set11 as expected.' - else - error stop procedure // ' cleared more than one bit in set11.' - end if - else - error stop procedure // ' did not clear the first bit in set11.' - end if + call check(error, .not. set11 % test(0_bits_kind), & + 'did not clear the first bit in set11.') + if (allocated(error)) return + + call check(error, set11 % test(1_bits_kind), & + 'cleared more than one bit in set11.') + if (allocated(error)) return call set11 % clear(165_bits_kind) - if ( .not. set11 % test(165_bits_kind) ) then - if ( set11 % test(164_bits_kind) ) then - write(*,*) 'Cleared the last bit in set11 as expected.' - else - error stop procedure // ' cleared more than one bit in set11.' - end if - else - error stop procedure // ' did not clear the last bit in set11.' - end if + call check(error, .not. set11 % test(165_bits_kind), & + 'did not clear the last bit in set11.') + if (allocated(error)) return + + call check(error, set11 % test(164_bits_kind), & + 'cleared more than one bit in set11.') + if (allocated(error)) return call set11 % clear(1_bits_kind, 164_bits_kind) - if ( set11 % none() ) then - write(*,*) 'Cleared remaining bits in set11 as expected.' - else - error stop procedure // ' did not clear remaining bits ' // & - 'in set11.' - end if + call check(error, set11 % none(), & + 'did not clear remaining bits in set11.') + if (allocated(error)) return call set11 % flip(0_bits_kind) - if ( set11 % test(0_bits_kind) ) then - if ( .not. set11 % test(1_bits_kind) ) then - write(*,*) 'Flipped one bit in set11 as expected.' - else - error stop procedure // ' flipped more than one bit in set11.' - end if - else - error stop procedure // ' did not flip the first bit in set11.' - end if + call check(error, set11 % test(0_bits_kind), & + 'did not flip the first bit in set11.') + if (allocated(error)) return + + call check(error, .not. set11 % test(1_bits_kind), & + 'flipped more than one bit in set11.') + if (allocated(error)) return call set11 % flip(165_bits_kind) - if ( set11 % test(165_bits_kind) ) then - if ( .not. set11 % test(164_bits_kind) ) then - write(*,*) 'Flipped last bit in set11 as expected.' - else - error stop procedure // ' flipped more than one bit in set11.' - end if - else - error stop procedure // ' did not flip the last bit in set11.' - end if + call check(error, set11 % test(165_bits_kind), & + 'did not flip the last bit in set11.') + if (allocated(error)) return + + call check(error, .not. set11 % test(164_bits_kind), & + 'flipped more than one bit in set11.') + if (allocated(error)) return call set11 % flip(1_bits_kind, 164_bits_kind) - if ( set11 % all() ) then - write(*,*) 'Flipped remaining bits in set11 as expected.' - else - error stop procedure // ' did not flip remaining bits ' // & - 'in set11.' - end if + call check(error, set11 % all(), & + 'did not flip remaining bits in set11.') + if (allocated(error)) return call set11 % not() - if ( set11 % none() ) then - write(*,*) 'Unset bits in set11 as expected.' - else - error stop procedure // ' did not unset bits in set11.' - end if + call check(error, set11 % none(), & + 'did not unset bits in set11.') + if (allocated(error)) return call set11 % set(0_bits_kind) - if ( set11 % test(0_bits_kind) ) then - if ( .not. set11 % test(1_bits_kind) ) then - write(*,*) 'Set first bit in set11 as expected.' - else - error stop procedure // ' set more than one bit in set11.' - end if - else - error stop procedure // ' did not set the first bit in set11.' - end if + call check(error, set11 % test(0_bits_kind), & + 'did not set the first bit in set11.') + if (allocated(error)) return + + call check(error, .not. set11 % test(1_bits_kind), & + 'set more than one bit in set11.') + if (allocated(error)) return call set11 % set(165_bits_kind) - if ( set11 % test(165_bits_kind) ) then - if ( .not. set11 % test(164_bits_kind) ) then - write(*,*) 'Set last bit in set11 as expected.' - else - error stop procedure // ' set more than one bit in set11.' - end if - else - error stop procedure // ' did not set the last bit in set11.' - end if + call check(error, set11 % test(165_bits_kind), & + 'did not set the last bit in set11.') + if (allocated(error)) return + + call check(error, .not. set11 % test(164_bits_kind), & + 'set more than one bit in set11.') + if (allocated(error)) return call set11 % set(1_bits_kind, 164_bits_kind) - if ( set11 % all() ) then - write(*,*) 'Set the remaining bits in set11 as expected.' - else - error stop procedure // ' did not set the remaining bits ' // & - 'in set11.' - end if + call check(error, set11 % all(), & + 'did not set the remaining bits in set11.') + if (allocated(error)) return end subroutine test_bit_operations - subroutine test_bitset_comparisons() - character(*), parameter:: procedure = 'TEST_BITSET_COMPARISON' + subroutine test_bitset_comparisons(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - write(*,*) - write(*,*) 'Test bitset comparisons: ==, /=, <, <=, >, and >=' + type(bitset_large) :: set0, set1, set2 + type(bitset_large) :: set10, set11, set12, set13, set14 - if ( set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. & + call set0 % from_string( bitstring_0 ) + call set1 % from_string( bitstring_all ) + call set2 % from_string( bitstring_33 ) + + call check(error, set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. & .not. set0 == set1 .and. .not. set0 == set2 .and. .not. & - set1 == set2 ) then - write(*,*) 'Passed 64 bit equality tests.' - else - error stop procedure // ' failed 64 bit equality tests.' - end if + set1 == set2, 'failed 64 bit equality tests.') + if (allocated(error)) return - if ( set0 /= set1 .and. set1 /= set2 .and. set0 /= set2 .and. & + call check(error, set0 /= set1 .and. set1 /= set2 .and. set0 /= set2 .and. & .not. set0 /= set0 .and. .not. set1 /= set1 .and. .not. & - set2 /= set2 ) then - write(*,*) 'Passed 64 bit inequality tests.' - else - error stop procedure // ' failed 64 bit inequality tests.' - end if + set2 /= set2, 'failed 64 bit inequality tests.') + if (allocated(error)) return - if ( set1 > set0 .and. set2 > set0 .and. set1 > set2 .and. & + call check(error, set1 > set0 .and. set2 > set0 .and. set1 > set2 .and. & .not. set0 > set1 .and. .not. set1 > set1 .and. .not. & - set2 > set1 ) then - write(*,*) 'Passed 64 bit greater than tests.' - else - error stop procedure // ' failed 64 bit greater than tests.' - end if + set2 > set1, 'failed 64 bit greater than tests.') + if (allocated(error)) return - if ( set1 >= set0 .and. set1 >= set2 .and. set2 >= set2 .and. & + call check(error, set1 >= set0 .and. set1 >= set2 .and. set2 >= set2 .and. & .not. set0 >= set1 .and. .not. set0 >= set1 .and. .not. & - set2 >= set1 ) then - write(*,*) 'Passed 64 bit greater than or equal tests.' - else - error stop procedure // ' failed 64 bit greater than or ' // & - 'equal tests.' - end if + set2 >= set1, 'failed 64 bit greater than or equal tests.') + if (allocated(error)) return - if ( set0 < set1 .and. set0 < set1 .and. set2 < set1 .and. & + call check(error, set0 < set1 .and. set0 < set1 .and. set2 < set1 .and. & .not. set1 < set0 .and. .not. set0 < set0 .and. .not. & - set1 < set2 ) then - write(*,*) 'Passed 64 bit less than tests.' - else - error stop procedure // ' failed 64 bit less than tests.' - end if + set1 < set2, 'failed 64 bit less than tests.') + if (allocated(error)) return - if ( set0 <= set1 .and. set2 <= set1 .and. set2 <= set2 .and. & + call check(error, set0 <= set1 .and. set2 <= set1 .and. set2 <= set2 .and. & .not. set1 <= set0 .and. .not. set2 <= set0 .and. .not. & - set1 <= set2 ) then - write(*,*) 'Passed 64 bit less than or equal tests.' - else - error stop procedure // ' failed 64 bit less than or ' // & - 'equal tests.' - end if + set1 <= set2, 'failed 64 bit less than or equal tests.') + if (allocated(error)) return call set10 % init(166_bits_kind) call set11 % init(166_bits_kind) @@ -1124,345 +880,256 @@ subroutine test_bitset_comparisons() call set13 % set(65_bits_kind) call set14 % init(166_bits_kind) call set14 % set(0_bits_kind) - if ( set10 == set10 .and. set11 == set11 .and. set12 == set12 .and. & - set13 == set13 .and. set14 == set14 .and. & - .not. set13 == set14 .and. .not. set12 == set13 .and. & - .not. set10 == set11 .and. .not. set10 == set12 .and. .not. & - set11 == set12 ) then - write(*,*) 'Passed > 64 bit equality tests.' - else - error stop procedure // ' failed > 64 bit equality tests.' - end if - - if ( set10 /= set11 .and. set11 /= set12 .and. set10 /= set12 .and. & - set13 /= set12 .and. set14 /= set13 .and. set14 /= set12 .and. & - .not. set13 /= set13 .and. .not. set12 /= set12 .and. & - .not. set10 /= set10 .and. .not. set11 /= set11 .and. .not. & - set12 /= set12 ) then - write(*,*) 'Passed > 64 bit inequality tests.' - else - error stop procedure // ' failed > 64 bit inequality tests.' - end if - - if ( set11 > set10 .and. set12 > set10 .and. set11 > set12 .and. & - set13 > set14 .and. set12 > set13 .and. set12 > set14 .and. & - .not. set14 > set12 .and. .not. set12 > set11 .and. & - .not. set10 > set11 .and. .not. set11 > set11 .and. .not. & - set12 > set11 ) then - write(*,*) 'Passed > 64 bit greater than tests.' - else - error stop procedure // ' failed > 64 bit greater than tests.' - end if - - if ( set11 >= set10 .and. set11 >= set12 .and. set12 >= set12 .and. & - set13 >= set14 .and. set12 >= set13 .and. set12 >= set14 .and. & - .not. set14 >= set12 .and. .not. set12 >= set11 .and. & - .not. set10 >= set11 .and. .not. set10 >= set11 .and. .not. & - set12 >= set11 ) then - write(*,*) 'Passed > 64 bit greater than or equal tests.' - else - error stop procedure // ' failed 64 bit greater than or ' // & - 'equal tests.' - end if - - if ( set10 < set11 .and. set10 < set11 .and. set12 < set11 .and. & - set14 < set13 .and. set13 < set12 .and. set14 < set12 .and. & - .not. set12 < set14 .and. .not. set11 < set12 .and. & + call check(error, set10 == set10 .and. set11 == set11 .and. set12 == set12 .and. & + set13 == set13 .and. set14 == set14 .and. & + .not. set13 == set14 .and. .not. set12 == set13 .and. & + .not. set10 == set11 .and. .not. set10 == set12 .and. .not. & + set11 == set12, 'failed > 64 bit equality tests.') + if (allocated(error)) return + + call check(error, set10 /= set11 .and. set11 /= set12 .and. set10 /= set12 .and. & + set13 /= set12 .and. set14 /= set13 .and. set14 /= set12 .and. & + .not. set13 /= set13 .and. .not. set12 /= set12 .and. & + .not. set10 /= set10 .and. .not. set11 /= set11 .and. .not. & + set12 /= set12, 'failed > 64 bit inequality tests.') + if (allocated(error)) return + + call check(error, set11 > set10 .and. set12 > set10 .and. set11 > set12 .and. & + set13 > set14 .and. set12 > set13 .and. set12 > set14 .and. & + .not. set14 > set12 .and. .not. set12 > set11 .and. & + .not. set10 > set11 .and. .not. set11 > set11 .and. .not. & + set12 > set11, 'failed > 64 bit greater than tests.') + if (allocated(error)) return + + call check(error, set11 >= set10 .and. set11 >= set12 .and. set12 >= set12 .and. & + set13 >= set14 .and. set12 >= set13 .and. set12 >= set14 .and. & + .not. set14 >= set12 .and. .not. set12 >= set11 .and. & + .not. set10 >= set11 .and. .not. set10 >= set11 .and. .not. & + set12 >= set11, 'failed 64 bit greater than or equal tests.') + if (allocated(error)) return + + call check(error, set10 < set11 .and. set10 < set11 .and. set12 < set11 .and. & + set14 < set13 .and. set13 < set12 .and. set14 < set12 .and. & + .not. set12 < set14 .and. .not. set11 < set12 .and. & .not. set11 < set10 .and. .not. set10 < set10 .and. .not. & - set11 < set12 ) then - write(*,*) 'Passed > 64 bit less than tests.' - else - error stop procedure // ' failed > 64 bit less than tests.' - end if + set11 < set12, 'failed > 64 bit less than tests.') + if (allocated(error)) return - if ( set10 <= set11 .and. set12 <= set11 .and. set12 <= set12 .and. & - set14 <= set13 .and. set13 <= set12 .and. set14 <= set12 .and. & - .not. set12 <= set14 .and. .not. set11 <= set12 .and. & + call check(error, set10 <= set11 .and. set12 <= set11 .and. set12 <= set12 .and. & + set14 <= set13 .and. set13 <= set12 .and. set14 <= set12 .and. & + .not. set12 <= set14 .and. .not. set11 <= set12 .and. & .not. set11 <= set10 .and. .not. set12 <= set10 .and. .not. & - set11 <= set12 ) then - write(*,*) 'Passed > 64 bit less than or equal tests.' - else - error stop procedure // ' failed > 64 bit less than or ' // & - 'equal tests.' - end if + set11 <= set12, 'failed > 64 bit less than or equal tests.') + if (allocated(error)) return end subroutine test_bitset_comparisons - subroutine test_bitset_operations() - character(*), parameter:: procedure = 'TEST_BITSET_OPERATIONS' + subroutine test_bitset_operations(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - write(*,*) - write(*,*) 'Test bitset operations: and, and_not, or, and xor' + type(bitset_large) :: set0, set3, set4 call set0 % from_string( bitstring_all ) call set4 % from_string( bitstring_all ) call and( set0, set4 ) ! all all - if ( set0 % all() ) then - write(*,*) 'First test of < 64 bit AND worked.' - else - error stop procedure // ' first test of < 64 bit AND failed.' - end if + call check(error, set0 % all(), 'first test of < 64 bit AND failed.') + if (allocated(error)) return call set4 % from_string( bitstring_0 ) call and( set0, set4 ) ! all none - if ( set0 % none() ) then - write(*,*) 'Second test of < 64 bit AND worked.' - else - error stop procedure // ' second test of < 64 bit AND failed.' - end if + call check(error, set0 % none(), 'second test of < 64 bit AND failed.') + if (allocated(error)) return call set3 % from_string( bitstring_all ) call set4 % from_string( bitstring_0 ) call and( set4, set3 ) ! none all - if ( set4 % none() ) then - write(*,*) 'Third test of < 64 bit AND worked.' - else - error stop procedure // ' third test of < 64 bit AND failed.' - end if + call check(error, set4 % none(), 'third test of < 64 bit AND failed.') + if (allocated(error)) return call set3 % from_string( bitstring_0 ) call and( set4, set3 ) ! none none - if ( set4 % none() ) then - write(*,*) 'Fourth test of < 64 bit AND worked.' - else - error stop procedure // ' fourth test of < 64 bit AND failed.' - end if + call check(error, set4 % none(), 'fourth test of < 64 bit AND failed.') + if (allocated(error)) return call set3 % from_string( bitstring_all ) call set4 % from_string( bitstring_all ) call and_not( set4, set3 ) ! all all - if ( set4 % none() ) then - write(*,*) 'First test of < 64 bit AND_NOT worked.' - else - error stop procedure // ' first test of < 64 bit AND_NOT failed.' - end if + call check(error, set4 % none(), 'first test of < 64 bit AND_NOT failed.') + if (allocated(error)) return call set4 % from_string( bitstring_0 ) call and_not( set4, set3 ) ! none all - if ( set4 % none() ) then - write(*,*) 'Second test of < 64 bit AND_NOT worked.' - else - error stop procedure // ' second test of < 64 bit AND_NOT failed.' - end if + call check(error, set4 % none(), 'second test of < 64 bit AND_NOT failed.') + if (allocated(error)) return call set3 % from_string( bitstring_all ) call set4 % from_string( bitstring_0 ) call and_not( set3, set4 ) ! all none - if ( set3 % all() ) then - write(*,*) 'Third test of < 64 bit AND_NOT worked.' - else - error stop procedure // ' third test of < 64 bit AND_NOT failed.' - end if + call check(error, set3 % all(), 'third test of < 64 bit AND_NOT failed.') + if (allocated(error)) return call set3 % from_string( bitstring_0 ) call set4 % from_string( bitstring_0 ) call and_not( set3, set4 ) ! none none - if ( set3 % none() ) then - write(*,*) 'Fourth test of < 64 bit AND_NOT worked.' - else - error stop procedure // ' fourth test of < 64 bit AND_NOT failed.' - end if + call check(error, set3 % none(), 'fourth test of < 64 bit AND_NOT failed.') + if (allocated(error)) return call set3 % from_string( bitstring_all ) call set4 % from_string( bitstring_all ) call or( set3, set4 ) ! all all - if ( set3 % all() ) then - write(*,*) 'First test of < 64 bit OR worked.' - else - error stop procedure // ' first test of < 64 bit OR failed.' - end if + call check(error, set3 % all(), 'first test of < 64 bit OR failed.') + if (allocated(error)) return call set3 % from_string( bitstring_0 ) call or( set4, set3 ) ! all none - if ( set4 % all() ) then - write(*,*) 'Second test of < 64 bit OR worked.' - else - error stop procedure // ' second test of < 64 bit OR failed.' - end if + call check(error, set4 % all(), 'second test of < 64 bit OR failed.') + if (allocated(error)) return call or( set3, set4 ) ! none all - if ( set3 % all() ) then - write(*,*) 'Third test of < 64 bit OR worked.' - else - error stop procedure // ' third test of < 64 bit OR failed.' - end if + call check(error, set3 % all(), 'third test of < 64 bit OR failed.') + if (allocated(error)) return call set3 % from_string( bitstring_0 ) call set4 % from_string( bitstring_0 ) call or( set4, set3 ) !none none - if ( set4 % none() ) then - write(*,*) 'Fourth test of < 64 bit OR worked.' - else - error stop procedure // ' fourth test of < 64 bit OR failed.' - end if + call check(error, set4 % none(), 'fourth test of < 64 bit OR failed.') + if (allocated(error)) return call set3 % from_string( bitstring_0 ) call set4 % from_string( bitstring_0 ) call xor( set3, set4 ) ! none none - if ( set3 % none() ) then - write(*,*) 'First test of < 64 bit XOR worked.' - else - error stop procedure // ' first test of < 64 bit XOR failed.' - end if + call check(error, set3 % none(), 'first test of < 64 bit XOR failed.') + if (allocated(error)) return call set4 % from_string( bitstring_all ) call xor( set3, set4 ) ! none all - if ( set3 % all() ) then - write(*,*) 'Second test of < 64 bit XOR worked.' - else - error stop procedure // ' second test of < 64 bit XOR failed.' - end if + call check(error, set3 % all(), 'second test of < 64 bit XOR failed.') + if (allocated(error)) return call set4 % from_string( bitstring_0 ) call xor( set3, set4 ) ! all none - if ( set3 % all() ) then - write(*,*) 'Third test of < 64 bit XOR worked.' - else - error stop procedure // ' third test of < 64 bit XOR failed.' - end if + call check(error, set3 % all(), 'third test of < 64 bit XOR failed.') + if (allocated(error)) return call set4 % from_string( bitstring_all ) call xor( set3, set4 ) ! all all - if ( set3 % none() ) then - write(*,*) 'Fourth test of < 64 bit XOR worked.' - else - error stop procedure // ' fourth test of < 64 bit XOR failed.' - end if + call check(error, set3 % none(), 'fourth test of < 64 bit XOR failed.') + if (allocated(error)) return call set0 % init(166_bits_kind) call set0 % not() call set4 % init(166_bits_kind) call set4 % not() call and( set0, set4 ) ! all all - if ( set0 % all() ) then - write(*,*) 'First test of > 64 bit AND worked.' - else - error stop procedure // ' first test of > 64 bit AND failed.' - end if + call check(error, set0 % all(), 'first test of > 64 bit AND failed.') + if (allocated(error)) return call set4 % init(166_bits_kind) call and( set0, set4 ) ! all none - if ( set0 % none() ) then - write(*,*) 'Second test of > 64 bit AND worked.' - else - error stop procedure // ' second test of > 64 bit AND failed.' - end if + call check(error, set0 % none(), 'second test of > 64 bit AND failed.') + if (allocated(error)) return call set3 % init(166_bits_kind) call set3 % not() call and( set4, set3 ) ! none all - if ( set4 % none() ) then - write(*,*) 'Third test of > 64 bit AND worked.' - else - error stop procedure // ' third test of > 64 bit AND failed.' - end if + call check(error, set4 % none(), 'third test of > 64 bit AND failed.') + if (allocated(error)) return call set3 % init(166_bits_kind) call and( set4, set3 ) ! none none - if ( set4 % none() ) then - write(*,*) 'Fourth test of > 64 bit AND worked.' - else - error stop procedure // ' fourth test of > 64 bit AND failed.' - end if + call check(error, set4 % none(), 'fourth test of > 64 bit AND failed.') + if (allocated(error)) return call set3 % not() call set4 % not() call and_not( set4, set3 ) ! all all - if ( set4 % none() ) then - write(*,*) 'First test of > 64 bit AND_NOT worked.' - else - error stop procedure // ' first test of > 64 bit AND_NOT failed.' - end if + call check(error, set4 % none(), 'first test of > 64 bit AND_NOT failed.') + if (allocated(error)) return call and_not( set4, set3 ) ! none all - if ( set4 % none() ) then - write(*,*) 'Second test of > 64 bit AND_NOT worked.' - else - error stop procedure // ' second test of > 64 bit AND_NOT failed.' - end if + call check(error, set4 % none(), 'second test of > 64 bit AND_NOT failed.') + if (allocated(error)) return call and_not( set3, set4 ) ! all none - if ( set3 % all() ) then - write(*,*) 'Third test of > 64 bit AND_NOT worked.' - else - error stop procedure // ' third test of > 64 bit AND_NOT failed.' - end if + call check(error, set3 % all(), 'third test of > 64 bit AND_NOT failed.') + if (allocated(error)) return call set3 % not() call and_not( set3, set4 ) ! none none - if ( set3 % none() ) then - write(*,*) 'Fourth test of > 64 bit AND_NOT worked.' - else - error stop procedure // ' fourth test of > 64 bit AND_NOT failed.' - end if + call check(error, set3 % none(), 'fourth test of > 64 bit AND_NOT failed.') + if (allocated(error)) return call set3 % init(166_bits_kind) call set3 % not() call set4 % init(166_bits_kind) call set4 % not() call or( set3, set4 ) ! all all - if ( set3 % all() ) then - write(*,*) 'First test of > 64 bit OR worked.' - else - error stop procedure // ' first test of > 64 bit OR failed.' - end if + call check(error, set3 % all(), 'first test of > 64 bit OR failed.') + if (allocated(error)) return call set3 % init(166_bits_kind) call or( set4, set3 ) ! all none - if ( set4 % all() ) then - write(*,*) 'Second test of > 64 bit OR worked.' - else - error stop procedure // ' second test of > 64 bit OR failed.' - end if + call check(error, set4 % all(), 'second test of > 64 bit OR failed.') + if (allocated(error)) return call or( set3, set4 ) ! none all - if ( set3 % all() ) then - write(*,*) 'Third test of > 64 bit OR worked.' - else - error stop procedure // ' third test of > 64 bit OR failed.' - end if + call check(error, set3 % all(), 'third test of > 64 bit OR failed.') + if (allocated(error)) return call set3 % init(166_bits_kind) call set4 % init(166_bits_kind) call or( set4, set3 ) !none none - if ( set4 % none() ) then - write(*,*) 'Fourth test of > 64 bit OR worked.' - else - error stop procedure // ' fourth test of > 64 bit OR failed.' - end if + call check(error, set4 % none(), 'fourth test of > 64 bit OR failed.') + if (allocated(error)) return call xor( set3, set4 ) ! none none - if ( set3 % none() ) then - write(*,*) 'First test of > 64 bit XOR worked.' - else - error stop procedure // ' first test of > 64 bit XOR failed.' - end if + call check(error, set3 % none(), 'first test of > 64 bit XOR failed.') + if (allocated(error)) return call set4 % not() call xor( set3, set4 ) ! none all - if ( set3 % all() ) then - write(*,*) 'Second test of > 64 bit XOR worked.' - else - error stop procedure // ' second test of > 64 bit XOR failed.' - end if + call check(error, set3 % all(), 'second test of > 64 bit XOR failed.') + if (allocated(error)) return call set4 % not() call xor( set3, set4 ) ! all none - if ( set3 % all() ) then - write(*,*) 'Third test of > 64 bit XOR worked.' - else - error stop procedure // ' third test of > 64 bit XOR failed.' - end if + call check(error, set3 % all(), 'third test of > 64 bit XOR failed.') + if (allocated(error)) return call set4 % not() call xor( set3, set4 ) ! all all - if ( set3 % none() ) then - write(*,*) 'Fourth test of > 64 bit XOR worked.' - else - error stop procedure // ' fourth test of > 64 bit XOR failed.' - end if + call check(error, set3 % none(), 'fourth test of > 64 bit XOR failed.') + if (allocated(error)) return end subroutine test_bitset_operations -end program test_stdlib_bitset_large +end module test_stdlib_bitset_large + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_stdlib_bitset_large, only : collect_stdlib_bitset_large + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("stdlib-bitset-large", collect_stdlib_bitset_large) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program From a941a9a27c7af644f4d26701031c18f7f891de42 Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Tue, 24 Aug 2021 22:42:26 +0200 Subject: [PATCH 07/34] Rewrite linear algebra tests --- src/tests/linalg/test_linalg.f90 | 1272 ++++++++++++++++-------------- 1 file changed, 700 insertions(+), 572 deletions(-) diff --git a/src/tests/linalg/test_linalg.f90 b/src/tests/linalg/test_linalg.f90 index cc8d0db68..64b14e0d4 100644 --- a/src/tests/linalg/test_linalg.f90 +++ b/src/tests/linalg/test_linalg.f90 @@ -1,581 +1,709 @@ -program test_linalg - - use stdlib_error, only: check - use stdlib_kinds, only: sp, dp, qp, int8, int16, int32, int64 - use stdlib_linalg, only: diag, eye, trace, outer_product - - implicit none - - real(sp), parameter :: sptol = 1000 * epsilon(1._sp) - real(dp), parameter :: dptol = 1000 * epsilon(1._dp) - real(qp), parameter :: qptol = 1000 * epsilon(1._qp) - - logical :: warn - - ! whether calls to check issue a warning - ! or stop execution - warn = .false. - - ! - ! eye - ! - call test_eye - - ! - ! diag - ! - call test_diag_rsp - call test_diag_rsp_k - call test_diag_rdp - call test_diag_rqp - - call test_diag_csp - call test_diag_cdp - call test_diag_cqp - - call test_diag_int8 - call test_diag_int16 - call test_diag_int32 - call test_diag_int64 - - ! - ! trace - ! - call test_trace_rsp - call test_trace_rsp_nonsquare - call test_trace_rdp - call test_trace_rdp_nonsquare - call test_trace_rqp - - call test_trace_csp - call test_trace_cdp - call test_trace_cqp - - call test_trace_int8 - call test_trace_int16 - call test_trace_int32 - call test_trace_int64 - - ! - ! outer product - ! - call test_outer_product_rsp - call test_outer_product_rdp - call test_outer_product_rqp - - call test_outer_product_csp - call test_outer_product_cdp - call test_outer_product_cqp - - call test_outer_product_int8 - call test_outer_product_int16 - call test_outer_product_int32 - call test_outer_product_int64 +module test_linalg + use stdlib_test, only : new_unittest, unittest_type, error_type, check + use stdlib_kinds, only: sp, dp, qp, int8, int16, int32, int64 + use stdlib_linalg, only: diag, eye, trace, outer_product + + implicit none + + real(sp), parameter :: sptol = 1000 * epsilon(1._sp) + real(dp), parameter :: dptol = 1000 * epsilon(1._dp) + real(qp), parameter :: qptol = 1000 * epsilon(1._qp) + contains - subroutine test_eye - real(sp), allocatable :: rye(:,:) - complex(sp) :: cye(7,7) - integer :: i - write(*,*) "test_eye" - - call check(all(eye(5) == diag([(1,i=1,5)])), & - msg="all(eye(5) == diag([(1,i=1,5)] failed.",warn=warn) - - rye = eye(6) - call check(sum(rye - diag([(1.0_sp,i=1,6)])) < sptol, & - msg="sum(rye - diag([(1.0_sp,i=1,6)])) < sptol failed.",warn=warn) - - cye = eye(7) - call check(abs(trace(cye) - cmplx(7.0_sp,0.0_sp,kind=sp)) < sptol, & - msg="abs(trace(cye) - cmplx(7.0_sp,0.0_sp,kind=sp)) < sptol failed.",warn=warn) - end subroutine test_eye - - subroutine test_diag_rsp - integer, parameter :: n = 3 - real(sp) :: v(n), a(n,n), b(n,n) - integer :: i,j - write(*,*) "test_diag_rsp" - v = [(i,i=1,n)] - a = diag(v) - b = reshape([((merge(i,0,i==j), i=1,n), j=1,n)], [n,n]) - call check(all(a == b), & - msg="all(a == b) failed.",warn=warn) - - call check(all(diag(3*a) == 3*v), & - msg="all(diag(3*a) == 3*v) failed.",warn=warn) - end subroutine test_diag_rsp - - subroutine test_diag_rsp_k - integer, parameter :: n = 4 - real(sp) :: a(n,n), b(n,n) - integer :: i,j - write(*,*) "test_diag_rsp_k" - - a = diag([(1._sp,i=1,n-1)],-1) - - b = reshape([((merge(1,0,i==j+1), i=1,n), j=1,n)], [n,n]) - - call check(all(a == b), & - msg="all(a == b) failed.",warn=warn) - - call check(sum(diag(a,-1)) - (n-1) < sptol, & - msg="sum(diag(a,-1)) - (n-1) < sptol failed.",warn=warn) - - call check(all(a == transpose(diag([(1._sp,i=1,n-1)],1))), & - msg="all(a == transpose(diag([(1._sp,i=1,n-1)],1))) failed",warn=warn) - - call random_number(a) - do i = 1, n - call check(size(diag(a,i)) == n-i, & - msg="size(diag(a,i)) == n-i failed.",warn=warn) - end do - call check(size(diag(a,n+1)) == 0, & - msg="size(diag(a,n+1)) == 0 failed.",warn=warn) - end subroutine test_diag_rsp_k - - subroutine test_diag_rdp - integer, parameter :: n = 3 - real(dp) :: v(n), a(n,n), b(n,n) - integer :: i,j - write(*,*) "test_diag_rdp" - v = [(i,i=1,n)] - a = diag(v) - b = reshape([((merge(i,0,i==j), i=1,n), j=1,n)], [n,n]) - call check(all(a == b), & - msg="all(a == b) failed.",warn=warn) - - call check(all(diag(3*a) == 3*v), & - msg="all(diag(3*a) == 3*v) failed.",warn=warn) - end subroutine test_diag_rdp - - subroutine test_diag_rqp - integer, parameter :: n = 3 - real(qp) :: v(n), a(n,n), b(n,n) - integer :: i,j - write(*,*) "test_diag_rqp" - v = [(i,i=1,n)] - a = diag(v) - b = reshape([((merge(i,0,i==j), i=1,n), j=1,n)], [n,n]) - call check(all(a == b), & - msg="all(a == b) failed.", warn=warn) - - call check(all(diag(3*a) == 3*v), & - msg="all(diag(3*a) == 3*v) failed.", warn=warn) - end subroutine test_diag_rqp - - subroutine test_diag_csp - integer, parameter :: n = 3 - complex(sp) :: a(n,n), b(n,n) - complex(sp), parameter :: i_ = cmplx(0,1,kind=sp) - integer :: i,j - write(*,*) "test_diag_csp" - a = diag([(i,i=1,n)]) + diag([(i_,i=1,n)]) - b = reshape([((merge(i + 1*i_,0*i_,i==j), i=1,n), j=1,n)], [n,n]) - call check(all(a == b), & - msg="all(a == b) failed.",warn=warn) - - call check(all(abs(real(diag(a)) - [(i,i=1,n)]) < sptol), & - msg="all(abs(real(diag(a)) - [(i,i=1,n)]) < sptol)", warn=warn) - call check(all(abs(aimag(diag(a)) - [(1,i=1,n)]) < sptol), & - msg="all(abs(aimag(diag(a)) - [(1,i=1,n)]) < sptol)", warn=warn) - end subroutine test_diag_csp - - subroutine test_diag_cdp - integer, parameter :: n = 3 - complex(dp) :: a(n,n) - complex(dp), parameter :: i_ = cmplx(0,1,kind=dp) - write(*,*) "test_diag_cdp" - a = diag([i_],-2) + diag([i_],2) - call check(a(3,1) == i_ .and. a(1,3) == i_, & - msg="a(3,1) == i_ .and. a(1,3) == i_ failed.",warn=warn) - end subroutine test_diag_cdp - - subroutine test_diag_cqp - integer, parameter :: n = 3 - complex(qp) :: a(n,n) - complex(qp), parameter :: i_ = cmplx(0,1,kind=qp) - write(*,*) "test_diag_cqp" - a = diag([i_,i_],-1) + diag([i_,i_],1) - call check(all(diag(a,-1) == i_) .and. all(diag(a,1) == i_), & - msg="all(diag(a,-1) == i_) .and. all(diag(a,1) == i_) failed.",warn=warn) - end subroutine test_diag_cqp - - subroutine test_diag_int8 - integer, parameter :: n = 3 - integer(int8), allocatable :: a(:,:) - integer :: i - logical, allocatable :: mask(:,:) - write(*,*) "test_diag_int8" - a = reshape([(i,i=1,n**2)],[n,n]) - mask = merge(.true.,.false.,eye(n) == 1) - call check(all(diag(a) == pack(a,mask)), & - msg="all(diag(a) == pack(a,mask)) failed.", warn=warn) - call check(all(diag(diag(a)) == merge(a,0_int8,mask)), & - msg="all(diag(diag(a)) == merge(a,0_int8,mask)) failed.", warn=warn) - end subroutine test_diag_int8 - subroutine test_diag_int16 - integer, parameter :: n = 4 - integer(int16), allocatable :: a(:,:) - integer :: i - logical, allocatable :: mask(:,:) - write(*,*) "test_diag_int16" - a = reshape([(i,i=1,n**2)],[n,n]) - mask = merge(.true.,.false.,eye(n) == 1) - call check(all(diag(a) == pack(a,mask)), & - msg="all(diag(a) == pack(a,mask))", warn=warn) - call check(all(diag(diag(a)) == merge(a,0_int16,mask)), & - msg="all(diag(diag(a)) == merge(a,0_int16,mask)) failed.", warn=warn) - end subroutine test_diag_int16 - subroutine test_diag_int32 - integer, parameter :: n = 3 - integer(int32) :: a(n,n) - logical :: mask(n,n) - integer :: i, j - write(*,*) "test_diag_int32" - mask = reshape([((merge(.true.,.false.,i==j+1), i=1,n), j=1,n)], [n,n]) - a = 0 - a = unpack([1_int32,1_int32],mask,a) - call check(all(diag([1,1],-1) == a), & - msg="all(diag([1,1],-1) == a) failed.", warn=warn) - call check(all(diag([1,1],1) == transpose(a)), & - msg="all(diag([1,1],1) == transpose(a)) failed.", warn=warn) - end subroutine test_diag_int32 - subroutine test_diag_int64 - integer, parameter :: n = 4 - integer(int64) :: a(n,n), c(0:2*n-1) - logical :: mask(n,n) - integer :: i, j - - write(*,*) "test_diag_int64" - - mask = reshape([((merge(.true.,.false.,i+1==j), i=1,n), j=1,n)], [n,n]) - a = 0 - a = unpack([1_int64,1_int64,1_int64],mask,a) - - call check(all(diag([1,1,1],1) == a), & - msg="all(diag([1,1,1],1) == a) failed.", warn=warn) - call check(all(diag([1,1,1],-1) == transpose(a)), & - msg="all(diag([1,1,1],-1) == transpose(a)) failed.", warn=warn) - - - ! Fill array c with Catalan numbers - do i = 0, 2*n-1 - c(i) = catalan_number(i) - end do - ! Symmetric Hankel matrix filled with Catalan numbers (det(H) = 1) - do i = 1, n - do j = 1, n - a(i,j) = c(i-1 + (j-1)) - end do - end do - call check(all(diag(a,-2) == diag(a,2)), & - msg="all(diag(a,-2) == diag(a,2))", warn=warn) - end subroutine test_diag_int64 - - - - - subroutine test_trace_rsp - integer, parameter :: n = 5 - real(sp) :: a(n,n) - integer :: i - write(*,*) "test_trace_rsp" - a = reshape([(i,i=1,n**2)],[n,n]) - call check(abs(trace(a) - sum(diag(a))) < sptol, & - msg="abs(trace(a) - sum(diag(a))) < sptol failed.",warn=warn) - end subroutine test_trace_rsp - - subroutine test_trace_rsp_nonsquare - integer, parameter :: n = 4 - real(sp) :: a(n,n+1), ans - integer :: i - write(*,*) "test_trace_rsp_nonsquare" - - ! 1 5 9 13 17 - ! 2 6 10 14 18 - ! 3 7 11 15 19 - ! 4 8 12 16 20 - a = reshape([(i,i=1,n*(n+1))],[n,n+1]) - ans = sum([1._sp,6._sp,11._sp,16._sp]) - - call check(abs(trace(a) - ans) < sptol, & - msg="abs(trace(a) - ans) < sptol failed.",warn=warn) - end subroutine test_trace_rsp_nonsquare - - subroutine test_trace_rdp - integer, parameter :: n = 4 - real(dp) :: a(n,n) - integer :: i - write(*,*) "test_trace_rdp" - a = reshape([(i,i=1,n**2)],[n,n]) - call check(abs(trace(a) - sum(diag(a))) < dptol, & - msg="abs(trace(a) - sum(diag(a))) < dptol failed.",warn=warn) - end subroutine test_trace_rdp - - subroutine test_trace_rdp_nonsquare - integer, parameter :: n = 4 - real(dp) :: a(n,n-1), ans - integer :: i - write(*,*) "test_trace_rdp_nonsquare" - - ! 1 25 81 - ! 4 36 100 - ! 9 49 121 - ! 16 64 144 - a = reshape([(i**2,i=1,n*(n-1))],[n,n-1]) - ans = sum([1._dp,36._dp,121._dp]) - - call check(abs(trace(a) - ans) < dptol, & - msg="abs(trace(a) - ans) < dptol failed.",warn=warn) - end subroutine test_trace_rdp_nonsquare - - subroutine test_trace_rqp - integer, parameter :: n = 3 - real(qp) :: a(n,n) - integer :: i - write(*,*) "test_trace_rqp" - a = reshape([(i,i=1,n**2)],[n,n]) - call check(abs(trace(a) - sum(diag(a))) < qptol, & - msg="abs(trace(a) - sum(diag(a))) < qptol failed.",warn=warn) - end subroutine test_trace_rqp - - - subroutine test_trace_csp - integer, parameter :: n = 5 - real(sp) :: re(n,n), im(n,n) - complex(sp) :: a(n,n), b(n,n) - complex(sp), parameter :: i_ = cmplx(0,1,kind=sp) - write(*,*) "test_trace_csp" - - call random_number(re) - call random_number(im) - a = re + im*i_ - - call random_number(re) - call random_number(im) - b = re + im*i_ - - ! tr(A + B) = tr(A) + tr(B) - call check(abs(trace(a+b) - (trace(a) + trace(b))) < sptol, & - msg="abs(trace(a+b) - (trace(a) + trace(b))) < sptol failed.",warn=warn) - end subroutine test_trace_csp - - subroutine test_trace_cdp - integer, parameter :: n = 3 - complex(dp) :: a(n,n), ans - complex(dp), parameter :: i_ = cmplx(0,1,kind=dp) - integer :: j - write(*,*) "test_trace_cdp" - - a = reshape([(j + (n**2 - (j-1))*i_,j=1,n**2)],[n,n]) - ans = cmplx(15,15,kind=dp) !(1 + 5 + 9) + (9 + 5 + 1)i - - call check(abs(trace(a) - ans) < dptol, & - msg="abs(trace(a) - ans) < dptol failed.",warn=warn) - end subroutine test_trace_cdp - - subroutine test_trace_cqp - integer, parameter :: n = 3 - complex(qp) :: a(n,n) - complex(qp), parameter :: i_ = cmplx(0,1,kind=qp) - write(*,*) "test_trace_cqp" - a = 3*eye(n) + 4*eye(n)*i_ ! pythagorean triple - call check(abs(trace(a)) - 3*5.0_qp < qptol, & - msg="abs(trace(a)) - 3*5.0_qp < qptol failed.",warn=warn) - end subroutine test_trace_cqp - - - subroutine test_trace_int8 - integer, parameter :: n = 3 - integer(int8) :: a(n,n) - integer :: i - write(*,*) "test_trace_int8" - a = reshape([(i**2,i=1,n**2)],[n,n]) - call check(trace(a) == (1 + 25 + 81), & - msg="trace(a) == (1 + 25 + 81) failed.",warn=warn) - end subroutine test_trace_int8 - - subroutine test_trace_int16 - integer, parameter :: n = 3 - integer(int16) :: a(n,n) - integer :: i - write(*,*) "test_trace_int16" - a = reshape([(i**3,i=1,n**2)],[n,n]) - call check(trace(a) == (1 + 125 + 729), & - msg="trace(a) == (1 + 125 + 729) failed.",warn=warn) - end subroutine test_trace_int16 - - subroutine test_trace_int32 - integer, parameter :: n = 3 - integer(int32) :: a(n,n) - integer :: i - write(*,*) "test_trace_int32" - a = reshape([(i**4,i=1,n**2)],[n,n]) - call check(trace(a) == (1 + 625 + 6561), & - msg="trace(a) == (1 + 625 + 6561) failed.",warn=warn) - end subroutine test_trace_int32 - - subroutine test_trace_int64 - integer, parameter :: n = 5 - integer, parameter :: nd = 2*n-1 ! number of diagonals - integer :: i, j - integer(int64) :: c(0:nd), H(n,n) - write(*,*) "test_trace_int64" - - ! Fill array with Catalan numbers - do i = 0, nd - c(i) = catalan_number(i) - end do + !> Collect all exported unit tests + subroutine collect_linalg(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("eye", test_eye), & + new_unittest("diag_rsp", test_diag_rsp), & + new_unittest("diag_rsp_k", test_diag_rsp_k), & + new_unittest("diag_rdp", test_diag_rdp), & + new_unittest("diag_rqp", test_diag_rqp), & + new_unittest("diag_csp", test_diag_csp), & + new_unittest("diag_cdp", test_diag_cdp), & + new_unittest("diag_cqp", test_diag_cqp), & + new_unittest("diag_int8", test_diag_int8), & + new_unittest("diag_int16", test_diag_int16), & + new_unittest("diag_int32", test_diag_int32), & + new_unittest("diag_int64", test_diag_int64), & + new_unittest("trace_rsp", test_trace_rsp), & + new_unittest("trace_rsp_nonsquare", test_trace_rsp_nonsquare), & + new_unittest("trace_rdp", test_trace_rdp), & + new_unittest("trace_rdp_nonsquare", test_trace_rdp_nonsquare), & + new_unittest("trace_rqp", test_trace_rqp), & + new_unittest("trace_csp", test_trace_csp), & + new_unittest("trace_cdp", test_trace_cdp), & + new_unittest("trace_cqp", test_trace_cqp), & + new_unittest("trace_int8", test_trace_int8), & + new_unittest("trace_int16", test_trace_int16), & + new_unittest("trace_int32", test_trace_int32), & + new_unittest("trace_int64", test_trace_int64), & + new_unittest("outer_product_rsp", test_outer_product_rsp), & + new_unittest("outer_product_rdp", test_outer_product_rdp), & + new_unittest("outer_product_rqp", test_outer_product_rqp), & + new_unittest("outer_product_csp", test_outer_product_csp), & + new_unittest("outer_product_cdp", test_outer_product_cdp), & + new_unittest("outer_product_cqp", test_outer_product_cqp), & + new_unittest("outer_product_int8", test_outer_product_int8), & + new_unittest("outer_product_int16", test_outer_product_int16), & + new_unittest("outer_product_int32", test_outer_product_int32), & + new_unittest("outer_product_int64", test_outer_product_int64) & + ] + + end subroutine collect_linalg + + + subroutine test_eye(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp), allocatable :: rye(:,:) + complex(sp) :: cye(7,7) + integer :: i + + + call check(error, all(eye(5) == diag([(1,i=1,5)])), & + "all(eye(5) == diag([(1,i=1,5)] failed.") + if (allocated(error)) return + + rye = eye(6) + call check(error, sum(rye - diag([(1.0_sp,i=1,6)])) < sptol, & + "sum(rye - diag([(1.0_sp,i=1,6)])) < sptol failed.") + if (allocated(error)) return + + cye = eye(7) + call check(error, abs(trace(cye) - cmplx(7.0_sp,0.0_sp,kind=sp)) < sptol, & + "abs(trace(cye) - cmplx(7.0_sp,0.0_sp,kind=sp)) < sptol failed.") + end subroutine test_eye + + subroutine test_diag_rsp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 3 + real(sp) :: v(n), a(n,n), b(n,n) + integer :: i,j + + v = [(i,i=1,n)] + a = diag(v) + b = reshape([((merge(i,0,i==j), i=1,n), j=1,n)], [n,n]) + call check(error, all(a == b), & + "all(a == b) failed.") + if (allocated(error)) return + + call check(error, all(diag(3*a) == 3*v), & + "all(diag(3*a) == 3*v) failed.") + end subroutine test_diag_rsp + + subroutine test_diag_rsp_k(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 4 + real(sp) :: a(n,n), b(n,n) + integer :: i,j + + + a = diag([(1._sp,i=1,n-1)],-1) + + b = reshape([((merge(1,0,i==j+1), i=1,n), j=1,n)], [n,n]) + + call check(error, all(a == b), & + "all(a == b) failed.") + if (allocated(error)) return + + call check(error, sum(diag(a,-1)) - (n-1) < sptol, & + "sum(diag(a,-1)) - (n-1) < sptol failed.") + if (allocated(error)) return + + call check(error, all(a == transpose(diag([(1._sp,i=1,n-1)],1))), & + "all(a == transpose(diag([(1._sp,i=1,n-1)],1))) failed") + if (allocated(error)) return + + call random_number(a) + do i = 1, n + call check(error, size(diag(a,i)) == n-i, & + "size(diag(a,i)) == n-i failed.") + if (allocated(error)) return + end do + call check(error, size(diag(a,n+1)) == 0, & + "size(diag(a,n+1)) == 0 failed.") + end subroutine test_diag_rsp_k + + subroutine test_diag_rdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 3 + real(dp) :: v(n), a(n,n), b(n,n) + integer :: i,j + + v = [(i,i=1,n)] + a = diag(v) + b = reshape([((merge(i,0,i==j), i=1,n), j=1,n)], [n,n]) + call check(error, all(a == b), & + "all(a == b) failed.") + if (allocated(error)) return + + call check(error, all(diag(3*a) == 3*v), & + "all(diag(3*a) == 3*v) failed.") + end subroutine test_diag_rdp + + subroutine test_diag_rqp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 3 + real(qp) :: v(n), a(n,n), b(n,n) + integer :: i,j + + v = [(i,i=1,n)] + a = diag(v) + b = reshape([((merge(i,0,i==j), i=1,n), j=1,n)], [n,n]) + call check(error, all(a == b), & + "all(a == b) failed.") + if (allocated(error)) return + + call check(error, all(diag(3*a) == 3*v), & + "all(diag(3*a) == 3*v) failed.") + end subroutine test_diag_rqp + + subroutine test_diag_csp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 3 + complex(sp) :: a(n,n), b(n,n) + complex(sp), parameter :: i_ = cmplx(0,1,kind=sp) + integer :: i,j + + a = diag([(i,i=1,n)]) + diag([(i_,i=1,n)]) + b = reshape([((merge(i + 1*i_,0*i_,i==j), i=1,n), j=1,n)], [n,n]) + call check(error, all(a == b), & + "all(a == b) failed.") + if (allocated(error)) return + + call check(error, all(abs(real(diag(a)) - [(i,i=1,n)]) < sptol), & + "all(abs(real(diag(a)) - [(i,i=1,n)]) < sptol)") + if (allocated(error)) return + call check(error, all(abs(aimag(diag(a)) - [(1,i=1,n)]) < sptol), & + "all(abs(aimag(diag(a)) - [(1,i=1,n)]) < sptol)") + end subroutine test_diag_csp + + subroutine test_diag_cdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 3 + complex(dp) :: a(n,n) + complex(dp), parameter :: i_ = cmplx(0,1,kind=dp) + + a = diag([i_],-2) + diag([i_],2) + call check(error, a(3,1) == i_ .and. a(1,3) == i_, & + "a(3,1) == i_ .and. a(1,3) == i_ failed.") + end subroutine test_diag_cdp + + subroutine test_diag_cqp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 3 + complex(qp) :: a(n,n) + complex(qp), parameter :: i_ = cmplx(0,1,kind=qp) + + a = diag([i_,i_],-1) + diag([i_,i_],1) + call check(error, all(diag(a,-1) == i_) .and. all(diag(a,1) == i_), & + "all(diag(a,-1) == i_) .and. all(diag(a,1) == i_) failed.") + end subroutine test_diag_cqp + + subroutine test_diag_int8(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 3 + integer(int8), allocatable :: a(:,:) + integer :: i + logical, allocatable :: mask(:,:) + + a = reshape([(i,i=1,n**2)],[n,n]) + mask = merge(.true.,.false.,eye(n) == 1) + call check(error, all(diag(a) == pack(a,mask)), & + "all(diag(a) == pack(a,mask)) failed.") + if (allocated(error)) return + call check(error, all(diag(diag(a)) == merge(a,0_int8,mask)), & + "all(diag(diag(a)) == merge(a,0_int8,mask)) failed.") + end subroutine test_diag_int8 + subroutine test_diag_int16(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 4 + integer(int16), allocatable :: a(:,:) + integer :: i + logical, allocatable :: mask(:,:) + + a = reshape([(i,i=1,n**2)],[n,n]) + mask = merge(.true.,.false.,eye(n) == 1) + call check(error, all(diag(a) == pack(a,mask)), & + "all(diag(a) == pack(a,mask))") + if (allocated(error)) return + call check(error, all(diag(diag(a)) == merge(a,0_int16,mask)), & + "all(diag(diag(a)) == merge(a,0_int16,mask)) failed.") + end subroutine test_diag_int16 + subroutine test_diag_int32(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 3 + integer(int32) :: a(n,n) + logical :: mask(n,n) + integer :: i, j + + mask = reshape([((merge(.true.,.false.,i==j+1), i=1,n), j=1,n)], [n,n]) + a = 0 + a = unpack([1_int32,1_int32],mask,a) + call check(error, all(diag([1,1],-1) == a), & + "all(diag([1,1],-1) == a) failed.") + if (allocated(error)) return + call check(error, all(diag([1,1],1) == transpose(a)), & + "all(diag([1,1],1) == transpose(a)) failed.") + end subroutine test_diag_int32 + subroutine test_diag_int64(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 4 + integer(int64) :: a(n,n), c(0:2*n-1) + logical :: mask(n,n) + integer :: i, j + + + + mask = reshape([((merge(.true.,.false.,i+1==j), i=1,n), j=1,n)], [n,n]) + a = 0 + a = unpack([1_int64,1_int64,1_int64],mask,a) + + call check(error, all(diag([1,1,1],1) == a), & + "all(diag([1,1,1],1) == a) failed.") + if (allocated(error)) return + call check(error, all(diag([1,1,1],-1) == transpose(a)), & + "all(diag([1,1,1],-1) == transpose(a)) failed.") + if (allocated(error)) return + + + ! Fill array c with Catalan numbers + do i = 0, 2*n-1 + c(i) = catalan_number(i) + end do + ! Symmetric Hankel matrix filled with Catalan numbers (det(H) = 1) + do i = 1, n + do j = 1, n + a(i,j) = c(i-1 + (j-1)) + end do + end do + call check(error, all(diag(a,-2) == diag(a,2)), & + "all(diag(a,-2) == diag(a,2))") + end subroutine test_diag_int64 + + + + + subroutine test_trace_rsp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 5 + real(sp) :: a(n,n) + integer :: i + + a = reshape([(i,i=1,n**2)],[n,n]) + call check(error, abs(trace(a) - sum(diag(a))) < sptol, & + "abs(trace(a) - sum(diag(a))) < sptol failed.") + end subroutine test_trace_rsp + + subroutine test_trace_rsp_nonsquare(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 4 + real(sp) :: a(n,n+1), ans + integer :: i + + + ! 1 5 9 13 17 + ! 2 6 10 14 18 + ! 3 7 11 15 19 + ! 4 8 12 16 20 + a = reshape([(i,i=1,n*(n+1))],[n,n+1]) + ans = sum([1._sp,6._sp,11._sp,16._sp]) + + call check(error, abs(trace(a) - ans) < sptol, & + "abs(trace(a) - ans) < sptol failed.") + end subroutine test_trace_rsp_nonsquare + + subroutine test_trace_rdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 4 + real(dp) :: a(n,n) + integer :: i + + a = reshape([(i,i=1,n**2)],[n,n]) + call check(error, abs(trace(a) - sum(diag(a))) < dptol, & + "abs(trace(a) - sum(diag(a))) < dptol failed.") + end subroutine test_trace_rdp + + subroutine test_trace_rdp_nonsquare(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 4 + real(dp) :: a(n,n-1), ans + integer :: i + + + ! 1 25 81 + ! 4 36 100 + ! 9 49 121 + ! 16 64 144 + a = reshape([(i**2,i=1,n*(n-1))],[n,n-1]) + ans = sum([1._dp,36._dp,121._dp]) + + call check(error, abs(trace(a) - ans) < dptol, & + "abs(trace(a) - ans) < dptol failed.") + end subroutine test_trace_rdp_nonsquare + + subroutine test_trace_rqp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 3 + real(qp) :: a(n,n) + integer :: i + + a = reshape([(i,i=1,n**2)],[n,n]) + call check(error, abs(trace(a) - sum(diag(a))) < qptol, & + "abs(trace(a) - sum(diag(a))) < qptol failed.") + end subroutine test_trace_rqp + + + subroutine test_trace_csp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 5 + real(sp) :: re(n,n), im(n,n) + complex(sp) :: a(n,n), b(n,n) + complex(sp), parameter :: i_ = cmplx(0,1,kind=sp) + - ! Symmetric Hankel matrix filled with Catalan numbers (det(H) = 1) - do i = 1, n - do j = 1, n - H(i,j) = c(i-1 + (j-1)) - end do + call random_number(re) + call random_number(im) + a = re + im*i_ + + call random_number(re) + call random_number(im) + b = re + im*i_ + + ! tr(A + B) = tr(A) + tr(B) + call check(error, abs(trace(a+b) - (trace(a) + trace(b))) < sptol, & + "abs(trace(a+b) - (trace(a) + trace(b))) < sptol failed.") + end subroutine test_trace_csp + + subroutine test_trace_cdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 3 + complex(dp) :: a(n,n), ans + complex(dp), parameter :: i_ = cmplx(0,1,kind=dp) + integer :: j + + + a = reshape([(j + (n**2 - (j-1))*i_,j=1,n**2)],[n,n]) + ans = cmplx(15,15,kind=dp) !(1 + 5 + 9) + (9 + 5 + 1)i + + call check(error, abs(trace(a) - ans) < dptol, & + "abs(trace(a) - ans) < dptol failed.") + end subroutine test_trace_cdp + + subroutine test_trace_cqp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 3 + complex(qp) :: a(n,n) + complex(qp), parameter :: i_ = cmplx(0,1,kind=qp) + + a = 3*eye(n) + 4*eye(n)*i_ ! pythagorean triple + call check(error, abs(trace(a)) - 3*5.0_qp < qptol, & + "abs(trace(a)) - 3*5.0_qp < qptol failed.") + end subroutine test_trace_cqp + + + subroutine test_trace_int8(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 3 + integer(int8) :: a(n,n) + integer :: i + + a = reshape([(i**2,i=1,n**2)],[n,n]) + call check(error, trace(a) == (1 + 25 + 81), & + "trace(a) == (1 + 25 + 81) failed.") + end subroutine test_trace_int8 + + subroutine test_trace_int16(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 3 + integer(int16) :: a(n,n) + integer :: i + + a = reshape([(i**3,i=1,n**2)],[n,n]) + call check(error, trace(a) == (1 + 125 + 729), & + "trace(a) == (1 + 125 + 729) failed.") + end subroutine test_trace_int16 + + subroutine test_trace_int32(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 3 + integer(int32) :: a(n,n) + integer :: i + + a = reshape([(i**4,i=1,n**2)],[n,n]) + call check(error, trace(a) == (1 + 625 + 6561), & + "trace(a) == (1 + 625 + 6561) failed.") + end subroutine test_trace_int32 + + subroutine test_trace_int64(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 5 + integer, parameter :: nd = 2*n-1 ! number of diagonals + integer :: i, j + integer(int64) :: c(0:nd), H(n,n) + + + ! Fill array with Catalan numbers + do i = 0, nd + c(i) = catalan_number(i) + end do + + ! Symmetric Hankel matrix filled with Catalan numbers (det(H) = 1) + do i = 1, n + do j = 1, n + H(i,j) = c(i-1 + (j-1)) + end do + end do + + call check(error, trace(h) == sum(c(0:nd:2)), & + "trace(h) == sum(c(0:nd:2)) failed.") + + end subroutine test_trace_int64 + + + subroutine test_outer_product_rsp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 2 + real(sp) :: u(n), v(n), expected(n,n), diff(n,n) + + u = [1.,2.] + v = [1.,3.] + expected = reshape([1.,2.,3.,6.],[n,n]) + diff = expected - outer_product(u,v) + call check(error, all(abs(diff) < sptol), & + "all(abs(diff) < sptol) failed.") + end subroutine test_outer_product_rsp + + subroutine test_outer_product_rdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 2 + real(dp) :: u(n), v(n), expected(n,n), diff(n,n) + + u = [1.,2.] + v = [1.,3.] + expected = reshape([1.,2.,3.,6.],[n,n]) + diff = expected - outer_product(u,v) + call check(error, all(abs(diff) < dptol), & + "all(abs(diff) < dptol) failed.") + end subroutine test_outer_product_rdp + + subroutine test_outer_product_rqp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 2 + real(qp) :: u(n), v(n), expected(n,n), diff(n,n) + + u = [1.,2.] + v = [1.,3.] + expected = reshape([1.,2.,3.,6.],[n,n]) + diff = expected - outer_product(u,v) + call check(error, all(abs(diff) < qptol), & + "all(abs(diff) < qptol) failed.") + end subroutine test_outer_product_rqp + + subroutine test_outer_product_csp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 2 + complex(sp) :: u(n), v(n), expected(n,n), diff(n,n) + + u = [cmplx(1.,1.),cmplx(2.,0.)] + v = [cmplx(1.,0.),cmplx(3.,1.)] + expected = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(2.,4.),cmplx(6.,2.)],[n,n]) + diff = expected - outer_product(u,v) + call check(error, all(abs(diff) < sptol), & + "all(abs(diff) < sptol) failed.") + end subroutine test_outer_product_csp + + subroutine test_outer_product_cdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 2 + complex(dp) :: u(n), v(n), expected(n,n), diff(n,n) + + u = [cmplx(1.,1.),cmplx(2.,0.)] + v = [cmplx(1.,0.),cmplx(3.,1.)] + expected = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(2.,4.),cmplx(6.,2.)],[n,n]) + diff = expected - outer_product(u,v) + call check(error, all(abs(diff) < dptol), & + "all(abs(diff) < dptol) failed.") + end subroutine test_outer_product_cdp + + subroutine test_outer_product_cqp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 2 + complex(qp) :: u(n), v(n), expected(n,n), diff(n,n) + + u = [cmplx(1.,1.),cmplx(2.,0.)] + v = [cmplx(1.,0.),cmplx(3.,1.)] + expected = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(2.,4.),cmplx(6.,2.)],[n,n]) + diff = expected - outer_product(u,v) + call check(error, all(abs(diff) < qptol), & + "all(abs(diff) < qptol) failed.") + end subroutine test_outer_product_cqp + + subroutine test_outer_product_int8(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 2 + integer(int8) :: u(n), v(n), expected(n,n), diff(n,n) + + u = [1,2] + v = [1,3] + expected = reshape([1,2,3,6],[n,n]) + diff = expected - outer_product(u,v) + call check(error, all(abs(diff) == 0), & + "all(abs(diff) == 0) failed.") + end subroutine test_outer_product_int8 + + subroutine test_outer_product_int16(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 2 + integer(int16) :: u(n), v(n), expected(n,n), diff(n,n) + + u = [1,2] + v = [1,3] + expected = reshape([1,2,3,6],[n,n]) + diff = expected - outer_product(u,v) + call check(error, all(abs(diff) == 0), & + "all(abs(diff) == 0) failed.") + end subroutine test_outer_product_int16 + + subroutine test_outer_product_int32(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 2 + integer(int32) :: u(n), v(n), expected(n,n), diff(n,n) + + u = [1,2] + v = [1,3] + expected = reshape([1,2,3,6],[n,n]) + diff = expected - outer_product(u,v) + call check(error, all(abs(diff) == 0), & + "all(abs(diff) == 0) failed.") + end subroutine test_outer_product_int32 + + subroutine test_outer_product_int64(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer, parameter :: n = 2 + integer(int64) :: u(n), v(n), expected(n,n), diff(n,n) + + u = [1,2] + v = [1,3] + expected = reshape([1,2,3,6],[n,n]) + diff = expected - outer_product(u,v) + call check(error, all(abs(diff) == 0), & + "all(abs(diff) == 0) failed.") + end subroutine test_outer_product_int64 + + + pure recursive function catalan_number(n) result(value) + integer, intent(in) :: n + integer :: value + integer :: i + if (n <= 1) then + value = 1 + else + value = 0 + do i = 0, n-1 + value = value + catalan_number(i)*catalan_number(n-i-1) + end do + end if + end function + +end module + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_linalg, only : collect_linalg + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("linalg", collect_linalg) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) end do - call check(trace(h) == sum(c(0:nd:2)), & - msg="trace(h) == sum(c(0:nd:2)) failed.",warn=warn) - - end subroutine test_trace_int64 - - - subroutine test_outer_product_rsp - integer, parameter :: n = 2 - real(sp) :: u(n), v(n), expected(n,n), diff(n,n) - write(*,*) "test_outer_product_rsp" - u = [1.,2.] - v = [1.,3.] - expected = reshape([1.,2.,3.,6.],[n,n]) - diff = expected - outer_product(u,v) - call check(all(abs(diff) < sptol), & - msg="all(abs(diff) < sptol) failed.",warn=warn) - end subroutine test_outer_product_rsp - - subroutine test_outer_product_rdp - integer, parameter :: n = 2 - real(dp) :: u(n), v(n), expected(n,n), diff(n,n) - write(*,*) "test_outer_product_rdp" - u = [1.,2.] - v = [1.,3.] - expected = reshape([1.,2.,3.,6.],[n,n]) - diff = expected - outer_product(u,v) - call check(all(abs(diff) < dptol), & - msg="all(abs(diff) < dptol) failed.",warn=warn) - end subroutine test_outer_product_rdp - - subroutine test_outer_product_rqp - integer, parameter :: n = 2 - real(qp) :: u(n), v(n), expected(n,n), diff(n,n) - write(*,*) "test_outer_product_rqp" - u = [1.,2.] - v = [1.,3.] - expected = reshape([1.,2.,3.,6.],[n,n]) - diff = expected - outer_product(u,v) - call check(all(abs(diff) < qptol), & - msg="all(abs(diff) < qptol) failed.",warn=warn) - end subroutine test_outer_product_rqp - - subroutine test_outer_product_csp - integer, parameter :: n = 2 - complex(sp) :: u(n), v(n), expected(n,n), diff(n,n) - write(*,*) "test_outer_product_csp" - u = [cmplx(1.,1.),cmplx(2.,0.)] - v = [cmplx(1.,0.),cmplx(3.,1.)] - expected = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(2.,4.),cmplx(6.,2.)],[n,n]) - diff = expected - outer_product(u,v) - call check(all(abs(diff) < sptol), & - msg="all(abs(diff) < sptol) failed.",warn=warn) - end subroutine test_outer_product_csp - - subroutine test_outer_product_cdp - integer, parameter :: n = 2 - complex(dp) :: u(n), v(n), expected(n,n), diff(n,n) - write(*,*) "test_outer_product_cdp" - u = [cmplx(1.,1.),cmplx(2.,0.)] - v = [cmplx(1.,0.),cmplx(3.,1.)] - expected = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(2.,4.),cmplx(6.,2.)],[n,n]) - diff = expected - outer_product(u,v) - call check(all(abs(diff) < dptol), & - msg="all(abs(diff) < dptol) failed.",warn=warn) - end subroutine test_outer_product_cdp - - subroutine test_outer_product_cqp - integer, parameter :: n = 2 - complex(qp) :: u(n), v(n), expected(n,n), diff(n,n) - write(*,*) "test_outer_product_cqp" - u = [cmplx(1.,1.),cmplx(2.,0.)] - v = [cmplx(1.,0.),cmplx(3.,1.)] - expected = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(2.,4.),cmplx(6.,2.)],[n,n]) - diff = expected - outer_product(u,v) - call check(all(abs(diff) < qptol), & - msg="all(abs(diff) < qptol) failed.",warn=warn) - end subroutine test_outer_product_cqp - - subroutine test_outer_product_int8 - integer, parameter :: n = 2 - integer(int8) :: u(n), v(n), expected(n,n), diff(n,n) - write(*,*) "test_outer_product_int8" - u = [1,2] - v = [1,3] - expected = reshape([1,2,3,6],[n,n]) - diff = expected - outer_product(u,v) - call check(all(abs(diff) == 0), & - msg="all(abs(diff) == 0) failed.",warn=warn) - end subroutine test_outer_product_int8 - - subroutine test_outer_product_int16 - integer, parameter :: n = 2 - integer(int16) :: u(n), v(n), expected(n,n), diff(n,n) - write(*,*) "test_outer_product_int16" - u = [1,2] - v = [1,3] - expected = reshape([1,2,3,6],[n,n]) - diff = expected - outer_product(u,v) - call check(all(abs(diff) == 0), & - msg="all(abs(diff) == 0) failed.",warn=warn) - end subroutine test_outer_product_int16 - - subroutine test_outer_product_int32 - integer, parameter :: n = 2 - integer(int32) :: u(n), v(n), expected(n,n), diff(n,n) - write(*,*) "test_outer_product_int32" - u = [1,2] - v = [1,3] - expected = reshape([1,2,3,6],[n,n]) - diff = expected - outer_product(u,v) - call check(all(abs(diff) == 0), & - msg="all(abs(diff) == 0) failed.",warn=warn) - end subroutine test_outer_product_int32 - - subroutine test_outer_product_int64 - integer, parameter :: n = 2 - integer(int64) :: u(n), v(n), expected(n,n), diff(n,n) - write(*,*) "test_outer_product_int64" - u = [1,2] - v = [1,3] - expected = reshape([1,2,3,6],[n,n]) - diff = expected - outer_product(u,v) - call check(all(abs(diff) == 0), & - msg="all(abs(diff) == 0) failed.",warn=warn) - end subroutine test_outer_product_int64 - - - pure recursive function catalan_number(n) result(value) - integer, intent(in) :: n - integer :: value - integer :: i - if (n <= 1) then - value = 1 - else - value = 0 - do i = 0, n-1 - value = value + catalan_number(i)*catalan_number(n-i-1) - end do + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop end if - end function - end program From d5911578f33dce5c231e0dba819bed2fb471d304 Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Tue, 24 Aug 2021 22:49:06 +0200 Subject: [PATCH 08/34] Rewrite testsuite for optval --- src/tests/optval/test_optval.f90 | 649 ++++++++++++++++++------------- 1 file changed, 373 insertions(+), 276 deletions(-) diff --git a/src/tests/optval/test_optval.f90 b/src/tests/optval/test_optval.f90 index ca1971cd2..c32d6ec4b 100644 --- a/src/tests/optval/test_optval.f90 +++ b/src/tests/optval/test_optval.f90 @@ -1,376 +1,473 @@ -program test_optval - use, intrinsic :: iso_fortran_env, only: & - sp => real32, dp => real64, qp => real128, & - int8, int16, int32, int64 - use stdlib_error, only: check - use stdlib_optval, only: optval +module test_optval + use, intrinsic :: iso_fortran_env, only: & + sp => real32, dp => real64, qp => real128, & + int8, int16, int32, int64 + use stdlib_test, only : new_unittest, unittest_type, error_type, check + use stdlib_optval, only: optval - implicit none + implicit none - call test_optval_rsp - call test_optval_rdp - call test_optval_rqp +contains - call test_optval_csp - call test_optval_cdp - call test_optval_cqp + !> Collect all exported unit tests + subroutine collect_optval(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("rsp", test_optval_rsp), & + new_unittest("rdp", test_optval_rdp), & + new_unittest("rqp", test_optval_rqp), & + new_unittest("csp", test_optval_csp), & + new_unittest("cdp", test_optval_cdp), & + new_unittest("cqp", test_optval_cqp), & + new_unittest("iint8", test_optval_iint8), & + new_unittest("iint16", test_optval_iint16), & + new_unittest("iint32", test_optval_iint32), & + new_unittest("iint64", test_optval_iint64), & + new_unittest("logical", test_optval_logical), & + new_unittest("character", test_optval_character), & + new_unittest("rsp_arr", test_optval_rsp_arr), & + new_unittest("rdp_arr", test_optval_rdp_arr), & + new_unittest("rqp_arr", test_optval_rqp_arr), & + new_unittest("csp_arr", test_optval_csp_arr), & + new_unittest("cdp_arr", test_optval_cdp_arr), & + new_unittest("cqp_arr", test_optval_cqp_arr), & + new_unittest("iint8_arr", test_optval_iint8_arr), & + new_unittest("iint16_arr", test_optval_iint16_arr), & + new_unittest("iint32_arr", test_optval_iint32_arr), & + new_unittest("iint64_arr", test_optval_iint64_arr) & + ] + + end subroutine collect_optval + + subroutine test_optval_rsp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, foo_sp(1.0_sp) == 1.0_sp) + if (allocated(error)) return + call check(error, foo_sp() == 2.0_sp) + end subroutine test_optval_rsp + + + function foo_sp(x) result(z) + real(sp), intent(in), optional :: x + real(sp) :: z + z = optval(x, 2.0_sp) + endfunction foo_sp + + + subroutine test_optval_rdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, foo_dp(1.0_dp) == 1.0_dp) + if (allocated(error)) return + call check(error, foo_dp() == 2.0_dp) + end subroutine test_optval_rdp + + + function foo_dp(x) result(z) + real(dp), intent(in), optional :: x + real(dp) :: z + z = optval(x, 2.0_dp) + endfunction foo_dp + + + subroutine test_optval_rqp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, foo_qp(1.0_qp) == 1.0_qp) + if (allocated(error)) return + call check(error, foo_qp() == 2.0_qp) + end subroutine test_optval_rqp + + + function foo_qp(x) result(z) + real(qp), intent(in), optional :: x + real(qp) :: z + z = optval(x, 2.0_qp) + endfunction foo_qp + + + subroutine test_optval_csp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: z1 + z1 = cmplx(1.0_sp, 2.0_sp, kind=sp) + call check(error, foo_csp(z1) == z1) + if (allocated(error)) return + call check(error, foo_csp() == z1) + end subroutine test_optval_csp + + function foo_csp(x) result(z) + complex(sp), intent(in), optional :: x + complex(sp) :: z + z = optval(x, cmplx(1.0_sp, 2.0_sp, kind=sp)) + endfunction foo_csp + + + subroutine test_optval_cdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - call test_optval_iint8 - call test_optval_iint16 - call test_optval_iint32 - call test_optval_iint64 + complex(dp) :: z1 + z1 = cmplx(1.0_dp, 2.0_dp,kind=dp) + call check(error, foo_cdp(z1) == z1) + if (allocated(error)) return + call check(error, foo_cdp() == z1) + end subroutine test_optval_cdp - call test_optval_logical + function foo_cdp(x) result(z) + complex(dp), intent(in), optional :: x + complex(dp) :: z + z = optval(x, cmplx(1.0_dp, 2.0_dp, kind=dp)) + endfunction foo_cdp - call test_optval_character + subroutine test_optval_cqp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - call test_optval_rsp_arr - call test_optval_rdp_arr - call test_optval_rqp_arr + complex(qp) :: z1 + z1 = cmplx(1.0_qp, 2.0_qp, kind=qp) + call check(error, foo_cqp(z1) == z1) + if (allocated(error)) return + call check(error, foo_cqp() == z1) + end subroutine test_optval_cqp - call test_optval_csp_arr - call test_optval_cdp_arr - call test_optval_cqp_arr + function foo_cqp(x) result(z) + complex(qp), intent(in), optional :: x + complex(qp) :: z + z = optval(x, cmplx(1.0_qp, 2.0_qp, kind=qp)) + endfunction foo_cqp - call test_optval_iint8_arr - call test_optval_iint16_arr - call test_optval_iint32_arr - call test_optval_iint64_arr -contains + subroutine test_optval_iint8(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, foo_int8(1_int8) == 1_int8) + if (allocated(error)) return + call check(error, foo_int8() == 2_int8) + end subroutine test_optval_iint8 - subroutine test_optval_rsp - print *, "test_optval_rsp" - call check(foo_sp(1.0_sp) == 1.0_sp) - call check(foo_sp() == 2.0_sp) - end subroutine test_optval_rsp + function foo_int8(x) result(z) + integer(int8), intent(in), optional :: x + integer(int8) :: z + z = optval(x, 2_int8) + endfunction foo_int8 - function foo_sp(x) result(z) - real(sp), intent(in), optional :: x - real(sp) :: z - z = optval(x, 2.0_sp) - endfunction foo_sp + subroutine test_optval_iint16(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - subroutine test_optval_rdp - print *, "test_optval_rdp" - call check(foo_dp(1.0_dp) == 1.0_dp) - call check(foo_dp() == 2.0_dp) - end subroutine test_optval_rdp + call check(error, foo_int16(1_int16) == 1_int16) + if (allocated(error)) return + call check(error, foo_int16() == 2_int16) + end subroutine test_optval_iint16 - function foo_dp(x) result(z) - real(dp), intent(in), optional :: x - real(dp) :: z - z = optval(x, 2.0_dp) - endfunction foo_dp + function foo_int16(x) result(z) + integer(int16), intent(in), optional :: x + integer(int16) :: z + z = optval(x, 2_int16) + endfunction foo_int16 - subroutine test_optval_rqp - print *, "test_optval_rqp" - call check(foo_qp(1.0_qp) == 1.0_qp) - call check(foo_qp() == 2.0_qp) - end subroutine test_optval_rqp + subroutine test_optval_iint32(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + call check(error, foo_int32(1_int32) == 1_int32) + if (allocated(error)) return + call check(error, foo_int32() == 2_int32) + end subroutine test_optval_iint32 - function foo_qp(x) result(z) - real(qp), intent(in), optional :: x - real(qp) :: z - z = optval(x, 2.0_qp) - endfunction foo_qp + function foo_int32(x) result(z) + integer(int32), intent(in), optional :: x + integer(int32) :: z + z = optval(x, 2_int32) + endfunction foo_int32 - subroutine test_optval_csp - complex(sp) :: z1 - print *, "test_optval_csp" - z1 = cmplx(1.0_sp, 2.0_sp, kind=sp) - call check(foo_csp(z1) == z1) - call check(foo_csp() == z1) - end subroutine test_optval_csp - function foo_csp(x) result(z) - complex(sp), intent(in), optional :: x - complex(sp) :: z - z = optval(x, cmplx(1.0_sp, 2.0_sp, kind=sp)) - endfunction foo_csp + subroutine test_optval_iint64(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + call check(error, foo_int64(1_int64) == 1_int64) + if (allocated(error)) return + call check(error, foo_int64() == 2_int64) + end subroutine test_optval_iint64 - subroutine test_optval_cdp - complex(dp) :: z1 - print *, "test_optval_cdp" - z1 = cmplx(1.0_dp, 2.0_dp,kind=dp) - call check(foo_cdp(z1) == z1) - call check(foo_cdp() == z1) - end subroutine test_optval_cdp - function foo_cdp(x) result(z) - complex(dp), intent(in), optional :: x - complex(dp) :: z - z = optval(x, cmplx(1.0_dp, 2.0_dp, kind=dp)) - endfunction foo_cdp + function foo_int64(x) result(z) + integer(int64), intent(in), optional :: x + integer(int64) :: z + z = optval(x, 2_int64) + endfunction foo_int64 - subroutine test_optval_cqp - complex(qp) :: z1 - print *, "test_optval_cqp" - z1 = cmplx(1.0_qp, 2.0_qp, kind=qp) - call check(foo_cqp(z1) == z1) - call check(foo_cqp() == z1) - end subroutine test_optval_cqp + subroutine test_optval_logical(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - function foo_cqp(x) result(z) - complex(qp), intent(in), optional :: x - complex(qp) :: z - z = optval(x, cmplx(1.0_qp, 2.0_qp, kind=qp)) - endfunction foo_cqp + call check(error, foo_logical(.true.)) + if (allocated(error)) return + call check(error, .not.foo_logical()) + end subroutine test_optval_logical - subroutine test_optval_iint8 - print *, "test_optval_iint8" - call check(foo_int8(1_int8) == 1_int8) - call check(foo_int8() == 2_int8) - end subroutine test_optval_iint8 + function foo_logical(x) result(z) + logical, intent(in), optional :: x + logical :: z + z = optval(x, .false.) + endfunction foo_logical - function foo_int8(x) result(z) - integer(int8), intent(in), optional :: x - integer(int8) :: z - z = optval(x, 2_int8) - endfunction foo_int8 + subroutine test_optval_character(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + call check(error, foo_character("x") == "x") + if (allocated(error)) return + call check(error, foo_character() == "y") + end subroutine test_optval_character - subroutine test_optval_iint16 - print *, "test_optval_iint16" - call check(foo_int16(1_int16) == 1_int16) - call check(foo_int16() == 2_int16) - end subroutine test_optval_iint16 + function foo_character(x) result(z) + character(len=*), intent(in), optional :: x + character(len=:), allocatable :: z + z = optval(x, "y") + endfunction foo_character - function foo_int16(x) result(z) - integer(int16), intent(in), optional :: x - integer(int16) :: z - z = optval(x, 2_int16) - endfunction foo_int16 + subroutine test_optval_rsp_arr(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - subroutine test_optval_iint32 - print *, "test_optval_iint32" - call check(foo_int32(1_int32) == 1_int32) - call check(foo_int32() == 2_int32) - end subroutine test_optval_iint32 + call check(error, all(foo_sp_arr([1.0_sp, -1.0_sp]) == [1.0_sp, -1.0_sp])) + if (allocated(error)) return + call check(error, all(foo_sp_arr() == [2.0_sp, -2.0_sp])) + end subroutine test_optval_rsp_arr - function foo_int32(x) result(z) - integer(int32), intent(in), optional :: x - integer(int32) :: z - z = optval(x, 2_int32) - endfunction foo_int32 + function foo_sp_arr(x) result(z) + real(sp), dimension(2), intent(in), optional :: x + real(sp), dimension(2) :: z + z = optval(x, [2.0_sp, -2.0_sp]) + end function foo_sp_arr - subroutine test_optval_iint64 - print *, "test_optval_int64" - call check(foo_int64(1_int64) == 1_int64) - call check(foo_int64() == 2_int64) - end subroutine test_optval_iint64 + subroutine test_optval_rdp_arr(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + call check(error, all(foo_dp_arr([1.0_dp, -1.0_dp]) == [1.0_dp, -1.0_dp])) + if (allocated(error)) return + call check(error, all(foo_dp_arr() == [2.0_dp, -2.0_dp])) + end subroutine test_optval_rdp_arr - function foo_int64(x) result(z) - integer(int64), intent(in), optional :: x - integer(int64) :: z - z = optval(x, 2_int64) - endfunction foo_int64 + function foo_dp_arr(x) result(z) + real(dp), dimension(2), intent(in), optional :: x + real(dp), dimension(2) :: z + z = optval(x, [2.0_dp, -2.0_dp]) + end function foo_dp_arr - subroutine test_optval_logical - print *, "test_optval_logical" - call check(foo_logical(.true.)) - call check(.not.foo_logical()) - end subroutine test_optval_logical + subroutine test_optval_rqp_arr(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - function foo_logical(x) result(z) - logical, intent(in), optional :: x - logical :: z - z = optval(x, .false.) - endfunction foo_logical + call check(error, all(foo_qp_arr([1.0_qp, -1.0_qp]) == [1.0_qp, -1.0_qp])) + if (allocated(error)) return + call check(error, all(foo_qp_arr() == [2.0_qp, -2.0_qp])) + end subroutine test_optval_rqp_arr - subroutine test_optval_character - print *, "test_optval_character" - call check(foo_character("x") == "x") - call check(foo_character() == "y") - end subroutine test_optval_character + function foo_qp_arr(x) result(z) + real(qp), dimension(2), intent(in), optional :: x + real(qp), dimension(2) :: z + z = optval(x, [2.0_qp, -2.0_qp]) + end function foo_qp_arr - function foo_character(x) result(z) - character(len=*), intent(in), optional :: x - character(len=:), allocatable :: z - z = optval(x, "y") - endfunction foo_character + subroutine test_optval_csp_arr(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + complex(sp), dimension(2) :: z1, z2 + z1 = cmplx(1.0_sp, 2.0_sp, kind=sp)*[1.0_sp, -1.0_sp] + z2 = cmplx(2.0_sp, 2.0_sp, kind=sp)*[1.0_sp, -1.0_sp] + call check(error, all(foo_csp_arr(z1) == z1)) + if (allocated(error)) return + call check(error, all(foo_csp_arr() == z2)) + end subroutine test_optval_csp_arr - subroutine test_optval_rsp_arr - print *, "test_optval_rsp_arr" - call check(all(foo_sp_arr([1.0_sp, -1.0_sp]) == [1.0_sp, -1.0_sp])) - call check(all(foo_sp_arr() == [2.0_sp, -2.0_sp])) - end subroutine test_optval_rsp_arr + function foo_csp_arr(x) result(z) + complex(sp), dimension(2), intent(in), optional :: x + complex(sp), dimension(2) :: z + z = optval(x, cmplx(2.0_sp, 2.0_sp, kind=sp)*[1.0_sp, -1.0_sp]) + end function foo_csp_arr - function foo_sp_arr(x) result(z) - real(sp), dimension(2), intent(in), optional :: x - real(sp), dimension(2) :: z - z = optval(x, [2.0_sp, -2.0_sp]) - end function foo_sp_arr + subroutine test_optval_cdp_arr(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - subroutine test_optval_rdp_arr - print *, "test_optval_rdp_arr" - call check(all(foo_dp_arr([1.0_dp, -1.0_dp]) == [1.0_dp, -1.0_dp])) - call check(all(foo_dp_arr() == [2.0_dp, -2.0_dp])) - end subroutine test_optval_rdp_arr + complex(dp), dimension(2) :: z1, z2 + z1 = cmplx(1.0_dp, 2.0_dp, kind=dp)*[1.0_dp, -1.0_dp] + z2 = cmplx(2.0_dp, 2.0_dp, kind=dp)*[1.0_dp, -1.0_dp] + call check(error, all(foo_cdp_arr(z1) == z1)) + if (allocated(error)) return + call check(error, all(foo_cdp_arr() == z2)) + end subroutine test_optval_cdp_arr - function foo_dp_arr(x) result(z) - real(dp), dimension(2), intent(in), optional :: x - real(dp), dimension(2) :: z - z = optval(x, [2.0_dp, -2.0_dp]) - end function foo_dp_arr + function foo_cdp_arr(x) result(z) + complex(dp), dimension(2), intent(in), optional :: x + complex(dp), dimension(2) :: z + z = optval(x, cmplx(2.0_dp, 2.0_dp, kind=dp)*[1.0_dp, -1.0_dp]) + end function foo_cdp_arr - subroutine test_optval_rqp_arr - print *, "test_optval_qp_arr" - call check(all(foo_qp_arr([1.0_qp, -1.0_qp]) == [1.0_qp, -1.0_qp])) - call check(all(foo_qp_arr() == [2.0_qp, -2.0_qp])) - end subroutine test_optval_rqp_arr + subroutine test_optval_cqp_arr(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + complex(qp), dimension(2) :: z1, z2 + z1 = cmplx(1.0_qp, 2.0_qp, kind=qp)*[1.0_qp, -1.0_qp] + z2 = cmplx(2.0_qp, 2.0_qp, kind=qp)*[1.0_qp, -1.0_qp] + call check(error, all(foo_cqp_arr(z1) == z1)) + if (allocated(error)) return + call check(error, all(foo_cqp_arr() == z2)) + end subroutine test_optval_cqp_arr - function foo_qp_arr(x) result(z) - real(qp), dimension(2), intent(in), optional :: x - real(qp), dimension(2) :: z - z = optval(x, [2.0_qp, -2.0_qp]) - end function foo_qp_arr + function foo_cqp_arr(x) result(z) + complex(qp), dimension(2), intent(in), optional :: x + complex(qp), dimension(2) :: z + z = optval(x, cmplx(2.0_qp, 2.0_qp, kind=qp)*[1.0_qp, -1.0_qp]) + end function foo_cqp_arr - subroutine test_optval_csp_arr - complex(sp), dimension(2) :: z1, z2 - print *, "test_optval_csp_arr" - z1 = cmplx(1.0_sp, 2.0_sp, kind=sp)*[1.0_sp, -1.0_sp] - z2 = cmplx(2.0_sp, 2.0_sp, kind=sp)*[1.0_sp, -1.0_sp] - call check(all(foo_csp_arr(z1) == z1)) - call check(all(foo_csp_arr() == z2)) - end subroutine test_optval_csp_arr + subroutine test_optval_iint8_arr(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - function foo_csp_arr(x) result(z) - complex(sp), dimension(2), intent(in), optional :: x - complex(sp), dimension(2) :: z - z = optval(x, cmplx(2.0_sp, 2.0_sp, kind=sp)*[1.0_sp, -1.0_sp]) - end function foo_csp_arr + call check(error, all(foo_int8_arr([1_int8, -1_int8]) == [1_int8, -1_int8])) + if (allocated(error)) return + call check(error, all(foo_int8_arr() == [2_int8, -2_int8])) + end subroutine test_optval_iint8_arr - subroutine test_optval_cdp_arr - complex(dp), dimension(2) :: z1, z2 - print *, "test_optval_cdp_arr" - z1 = cmplx(1.0_dp, 2.0_dp, kind=dp)*[1.0_dp, -1.0_dp] - z2 = cmplx(2.0_dp, 2.0_dp, kind=dp)*[1.0_dp, -1.0_dp] - call check(all(foo_cdp_arr(z1) == z1)) - call check(all(foo_cdp_arr() == z2)) - end subroutine test_optval_cdp_arr + function foo_int8_arr(x) result(z) + integer(int8), dimension(2), intent(in), optional :: x + integer(int8), dimension(2) :: z + z = optval(x, [2_int8, -2_int8]) + end function foo_int8_arr - function foo_cdp_arr(x) result(z) - complex(dp), dimension(2), intent(in), optional :: x - complex(dp), dimension(2) :: z - z = optval(x, cmplx(2.0_dp, 2.0_dp, kind=dp)*[1.0_dp, -1.0_dp]) - end function foo_cdp_arr + subroutine test_optval_iint16_arr(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + call check(error, all(foo_int16_arr([1_int16, -1_int16]) == [1_int16, -1_int16])) + if (allocated(error)) return + call check(error, all(foo_int16_arr() == [2_int16, -2_int16])) + end subroutine test_optval_iint16_arr - subroutine test_optval_cqp_arr - complex(qp), dimension(2) :: z1, z2 - print *, "test_optval_cqp_arr" - z1 = cmplx(1.0_qp, 2.0_qp, kind=qp)*[1.0_qp, -1.0_qp] - z2 = cmplx(2.0_qp, 2.0_qp, kind=qp)*[1.0_qp, -1.0_qp] - call check(all(foo_cqp_arr(z1) == z1)) - call check(all(foo_cqp_arr() == z2)) - end subroutine test_optval_cqp_arr + function foo_int16_arr(x) result(z) + integer(int16), dimension(2), intent(in), optional :: x + integer(int16), dimension(2) :: z + z = optval(x, [2_int16, -2_int16]) + end function foo_int16_arr - function foo_cqp_arr(x) result(z) - complex(qp), dimension(2), intent(in), optional :: x - complex(qp), dimension(2) :: z - z = optval(x, cmplx(2.0_qp, 2.0_qp, kind=qp)*[1.0_qp, -1.0_qp]) - end function foo_cqp_arr + subroutine test_optval_iint32_arr(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - subroutine test_optval_iint8_arr - print *, "test_optval_int8_arr" - call check(all(foo_int8_arr([1_int8, -1_int8]) == [1_int8, -1_int8])) - call check(all(foo_int8_arr() == [2_int8, -2_int8])) - end subroutine test_optval_iint8_arr + call check(error, all(foo_int32_arr([1_int32, -1_int32]) == [1_int32, -1_int32])) + if (allocated(error)) return + call check(error, all(foo_int32_arr() == [2_int32, -2_int32])) + end subroutine test_optval_iint32_arr - function foo_int8_arr(x) result(z) - integer(int8), dimension(2), intent(in), optional :: x - integer(int8), dimension(2) :: z - z = optval(x, [2_int8, -2_int8]) - end function foo_int8_arr + function foo_int32_arr(x) result(z) + integer(int32), dimension(2), intent(in), optional :: x + integer(int32), dimension(2) :: z + z = optval(x, [2_int32, -2_int32]) + end function foo_int32_arr - subroutine test_optval_iint16_arr - print *, "test_optval_int16_arr" - call check(all(foo_int16_arr([1_int16, -1_int16]) == [1_int16, -1_int16])) - call check(all(foo_int16_arr() == [2_int16, -2_int16])) - end subroutine test_optval_iint16_arr + subroutine test_optval_iint64_arr(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + call check(error, all(foo_int64_arr([1_int64, -1_int64]) == [1_int64, -1_int64])) + if (allocated(error)) return + call check(error, all(foo_int64_arr() == [2_int64, -2_int64])) + end subroutine test_optval_iint64_arr - function foo_int16_arr(x) result(z) - integer(int16), dimension(2), intent(in), optional :: x - integer(int16), dimension(2) :: z - z = optval(x, [2_int16, -2_int16]) - end function foo_int16_arr + function foo_int64_arr(x) result(z) + integer(int64), dimension(2), intent(in), optional :: x + integer(int64), dimension(2) :: z + z = optval(x, [2_int64, -2_int64]) + end function foo_int64_arr - subroutine test_optval_iint32_arr - print *, "test_optval_int32_arr" - call check(all(foo_int32_arr([1_int32, -1_int32]) == [1_int32, -1_int32])) - call check(all(foo_int32_arr() == [2_int32, -2_int32])) - end subroutine test_optval_iint32_arr + subroutine test_optval_logical_arr(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - function foo_int32_arr(x) result(z) - integer(int32), dimension(2), intent(in), optional :: x - integer(int32), dimension(2) :: z - z = optval(x, [2_int32, -2_int32]) - end function foo_int32_arr + call check(error, all(foo_logical_arr())) + if (allocated(error)) return + call check(error, all(.not.foo_logical_arr())) + end subroutine test_optval_logical_arr - subroutine test_optval_iint64_arr - print *, "test_optval_int64_arr" - call check(all(foo_int64_arr([1_int64, -1_int64]) == [1_int64, -1_int64])) - call check(all(foo_int64_arr() == [2_int64, -2_int64])) - end subroutine test_optval_iint64_arr + function foo_logical_arr(x) result(z) + logical, dimension(2), intent(in), optional :: x + logical, dimension(2) :: z + z = optval(x, [.false., .false.]) + end function foo_logical_arr +end module test_optval - function foo_int64_arr(x) result(z) - integer(int64), dimension(2), intent(in), optional :: x - integer(int64), dimension(2) :: z - z = optval(x, [2_int64, -2_int64]) - end function foo_int64_arr +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_optval, only : collect_optval + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' - subroutine test_optval_logical_arr - print *, "test_optval_logical_arr" - call check(all(foo_logical_arr())) - call check(all(.not.foo_logical_arr())) - end subroutine test_optval_logical_arr + stat = 0 + testsuites = [ & + new_testsuite("optval", collect_optval) & + ] - function foo_logical_arr(x) result(z) - logical, dimension(2), intent(in), optional :: x - logical, dimension(2) :: z - z = optval(x, [.false., .false.]) - end function foo_logical_arr + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do -end program test_optval + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program From cbb8b37b00b5ad179d0dbbe271eacdbfd83c1b80 Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Tue, 24 Aug 2021 23:37:32 +0200 Subject: [PATCH 09/34] Rewrite string testsuites --- src/tests/string/test_string_assignment.f90 | 125 ++- .../string/test_string_derivedtype_io.f90 | 84 +- src/tests/string/test_string_functions.f90 | 723 +++++++++++------- src/tests/string/test_string_intrinsic.f90 | 575 +++++++++----- src/tests/string/test_string_match.f90 | 100 ++- src/tests/string/test_string_operator.f90 | 139 +++- src/tests/string/test_string_strip_chomp.f90 | 264 +++++-- src/tests/string/test_string_to_string.f90 | 195 +++-- 8 files changed, 1472 insertions(+), 733 deletions(-) diff --git a/src/tests/string/test_string_assignment.f90 b/src/tests/string/test_string_assignment.f90 index 9a65b2abb..a7bffa21d 100644 --- a/src/tests/string/test_string_assignment.f90 +++ b/src/tests/string/test_string_assignment.f90 @@ -1,72 +1,117 @@ ! SPDX-Identifier: MIT module test_string_assignment - use stdlib_error, only : check + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_kinds, only : int8, int16, int32, int64, lk, c_bool use stdlib_string_type, only : string_type, assignment(=), operator(==), len implicit none contains - subroutine test_assignment + !> Collect all exported unit tests + subroutine collect_string_assignment(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("assignment", test_assignment), & + new_unittest("constructor", test_constructor) & + ] + end subroutine collect_string_assignment + + subroutine test_assignment(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error type(string_type) :: string - call check(len(string) == 0) + call check(error, len(string) == 0) + if (allocated(error)) return string = "Sequence" - call check(len(string) == 8) + call check(error, len(string) == 8) end subroutine test_assignment - subroutine test_char_value - character(len=128) :: flc + subroutine test_constructor(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + character(len=128) :: flc - write(flc, '(g0)') -1026191 - call check(string_type(-1026191) == trim(flc)) + write(flc, '(g0)') -1026191 + call check(error, string_type(-1026191) == trim(flc)) + if (allocated(error)) return - write(flc, '(g0)') 124787 - call check(string_type(124787) == trim(flc)) + write(flc, '(g0)') 124787 + call check(error, string_type(124787) == trim(flc)) + if (allocated(error)) return - write(flc, '(g0)') -2_int8 - call check(string_type(-2_int8) == trim(flc)) + write(flc, '(g0)') -2_int8 + call check(error, string_type(-2_int8) == trim(flc)) + if (allocated(error)) return - write(flc, '(g0)') 5_int8 - call check(string_type(5_int8) == trim(flc)) + write(flc, '(g0)') 5_int8 + call check(error, string_type(5_int8) == trim(flc)) + if (allocated(error)) return - write(flc, '(g0)') -72_int16 - call check(string_type(-72_int16) == trim(flc)) + write(flc, '(g0)') -72_int16 + call check(error, string_type(-72_int16) == trim(flc)) + if (allocated(error)) return - write(flc, '(g0)') -8924889_int32 - call check(string_type(-8924889_int32) == trim(flc)) + write(flc, '(g0)') -8924889_int32 + call check(error, string_type(-8924889_int32) == trim(flc)) + if (allocated(error)) return - write(flc, '(g0)') 2378405_int32 - call check(string_type(2378405_int32) == trim(flc)) + write(flc, '(g0)') 2378405_int32 + call check(error, string_type(2378405_int32) == trim(flc)) + if (allocated(error)) return - write(flc, '(g0)') 921092378411_int64 - call check(string_type(921092378411_int64) == trim(flc)) + write(flc, '(g0)') 921092378411_int64 + call check(error, string_type(921092378411_int64) == trim(flc)) + if (allocated(error)) return - write(flc, '(g0)') -1272835761_int64 - call check(string_type(-1272835761_int64) == trim(flc)) + write(flc, '(g0)') -1272835761_int64 + call check(error, string_type(-1272835761_int64) == trim(flc)) + if (allocated(error)) return - write(flc, '(g0)') .true. - call check(string_type(.true.) == trim(flc)) + write(flc, '(g0)') .true. + call check(error, string_type(.true.) == trim(flc)) + if (allocated(error)) return - write(flc, '(g0)') .false. - call check(string_type(.false.) == trim(flc)) + write(flc, '(g0)') .false. + call check(error, string_type(.false.) == trim(flc)) + if (allocated(error)) return - write(flc, '(g0)') .false._c_bool - call check(string_type(.false._c_bool) == trim(flc)) + write(flc, '(g0)') .false._c_bool + call check(error, string_type(.false._c_bool) == trim(flc)) + if (allocated(error)) return - write(flc, '(g0)') .true._lk - call check(string_type(.true._lk) == trim(flc)) - end subroutine test_char_value + write(flc, '(g0)') .true._lk + call check(error, string_type(.true._lk) == trim(flc)) + end subroutine test_constructor end module test_string_assignment + program tester - use test_string_assignment + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_string_assignment, only : collect_string_assignment implicit none - - call test_assignment - call test_char_value - -end program tester - + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("string-assignment", collect_string_assignment) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program diff --git a/src/tests/string/test_string_derivedtype_io.f90 b/src/tests/string/test_string_derivedtype_io.f90 index 2deaee46e..ee1266b73 100644 --- a/src/tests/string/test_string_derivedtype_io.f90 +++ b/src/tests/string/test_string_derivedtype_io.f90 @@ -1,6 +1,6 @@ ! SPDX-Identifer: MIT module test_string_derivedtype_io - use stdlib_error, only : check + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_string_type, only : string_type, assignment(=), len, & write(formatted), read(formatted), write(unformatted), read(unformatted), & operator(==) @@ -8,7 +8,22 @@ module test_string_derivedtype_io contains - subroutine test_listdirected_io + !> Collect all exported unit tests + subroutine collect_string_derivedtype_io(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("listdirected_io", test_listdirected_io), & + new_unittest("formatted_io", test_formatted_io), & + new_unittest("unformatted_io", test_unformatted_io) & + ] + end subroutine collect_string_derivedtype_io + + subroutine test_listdirected_io(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string integer :: io, stat string = "Important saved value" @@ -23,18 +38,22 @@ subroutine test_listdirected_io read(io, *, iostat=stat) string close(io) - call check(stat == 0) - call check(len(string) == 21) - call check(string == "Important saved value") + call check(error, stat == 0) + if (allocated(error)) return + call check(error, len(string) == 21) + if (allocated(error)) return + call check(error, string == "Important saved value") end subroutine test_listdirected_io - subroutine test_formatted_io + subroutine test_formatted_io(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string integer :: io, stat string = "Important saved value" - !open(newunit=io, form="formatted", status="scratch") - open(newunit=io, form="formatted", file="scratch.txt") + open(newunit=io, form="formatted", status="scratch") write(io, '(dt)') string write(io, '(a)') ! Pad with a newline or we might run into EOF while reading @@ -44,12 +63,17 @@ subroutine test_formatted_io read(io, *, iostat=stat) string close(io) - call check(stat == 0) - call check(len(string) == 21) - call check(string == "Important saved value") + call check(error, stat == 0) + if (allocated(error)) return + call check(error, len(string) == 21) + if (allocated(error)) return + call check(error, string == "Important saved value") end subroutine test_formatted_io - subroutine test_unformatted_io + subroutine test_unformatted_io(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string integer :: io string = "Important saved value" @@ -63,18 +87,36 @@ subroutine test_unformatted_io read(io) string close(io) - call check(len(string) == 21) - call check(string == "Important saved value") + call check(error, len(string) == 21) + if (allocated(error)) return + call check(error, string == "Important saved value") end subroutine test_unformatted_io end module test_string_derivedtype_io + program tester - use test_string_derivedtype_io + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_string_derivedtype_io, only : collect_string_derivedtype_io implicit none - - call test_listdirected_io - call test_formatted_io - call test_unformatted_io - -end program tester + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("string-derivedtype-io", collect_string_derivedtype_io) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program diff --git a/src/tests/string/test_string_functions.f90 b/src/tests/string/test_string_functions.f90 index 8885e985b..56a9ad4f1 100644 --- a/src/tests/string/test_string_functions.f90 +++ b/src/tests/string/test_string_functions.f90 @@ -1,7 +1,7 @@ ! SPDX-Identifier: MIT module test_string_functions use, intrinsic :: iso_fortran_env, only : error_unit - use stdlib_error, only : check + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_string_type, only : string_type, assignment(=), operator(==), & to_lower, to_upper, to_title, to_sentence, reverse use stdlib_strings, only: slice, find, replace_all, padl, padr, count @@ -11,235 +11,340 @@ module test_string_functions contains - subroutine test_to_lower_string + + !> Collect all exported unit tests + subroutine collect_string_functions(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("to_lower_string", test_to_lower_string), & + new_unittest("to_upper_string", test_to_upper_string), & + new_unittest("to_title_string", test_to_title_string), & + new_unittest("to_sentence_string", test_to_sentence_string), & + new_unittest("reverse_string", test_reverse_string), & + new_unittest("slice_string", test_slice_string), & + new_unittest("slice_gen", test_slice_gen), & + new_unittest("find", test_find), & + new_unittest("replace_all", test_replace_all), & + new_unittest("padl", test_padl), & + new_unittest("padr", test_padr), & + new_unittest("count", test_count) & + ] + end subroutine collect_string_functions + + subroutine test_to_lower_string(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: test_string, compare_string test_string = "To_LoWEr !$%-az09AZ" compare_string = "to_lower !$%-az09az" - call check(to_lower(test_string) == compare_string) + call check(error, to_lower(test_string) == compare_string) end subroutine test_to_lower_string - subroutine test_to_upper_string + subroutine test_to_upper_string(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: test_string, compare_string test_string = "To_UpPeR !$%-az09AZ" compare_string = "TO_UPPER !$%-AZ09AZ" - call check(to_upper(test_string) == compare_string) + call check(error, to_upper(test_string) == compare_string) end subroutine test_to_upper_string - subroutine test_to_title_string + subroutine test_to_title_string(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: test_string, compare_string test_string = "tO_%t!TL3 7h1S p#ra$e" compare_string = "To_%T!Tl3 7h1s P#Ra$E" - call check(to_title(test_string) == compare_string) + call check(error, to_title(test_string) == compare_string) end subroutine test_to_title_string - - subroutine test_to_sentence_string + + subroutine test_to_sentence_string(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: test_string, compare_string test_string = "_#To seNtEncE !$%-az09AZ" compare_string = "_#To sentence !$%-az09az" - call check(to_sentence(test_string) == compare_string) + call check(error, to_sentence(test_string) == compare_string) end subroutine test_to_sentence_string - subroutine test_reverse_string + subroutine test_reverse_string(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: test_string, compare_string test_string = "_To ReVerSe !$%-az09AZ " compare_string = " ZA90za-%$! eSreVeR oT_" - call check(reverse(test_string) == compare_string) + call check(error, reverse(test_string) == compare_string) end subroutine test_reverse_string - subroutine test_slice_string + subroutine test_slice_string(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: test_string test_string = "abcdefghijklmnopqrstuvwxyz" ! Only one argument is given - ! Valid - call check(slice(test_string, first=10) == "jklmnopqrstuvwxyz", & - "slice, Valid arguments: first=10") ! last=+inf - call check(slice(test_string, last=10) == "abcdefghij", & - "slice, Valid arguments: last=10") ! first=-inf - call check(slice(test_string, stride=3) == "adgjmpsvy", & - "slice, Valid arguments: stride=3") ! first=-inf, last=+inf - call check(slice(test_string, stride=-3) == "zwtqnkheb", & - "slice, Valid arguments: stride=-3") ! first=+inf, last=-inf - - ! Invalid - call check(slice(test_string, first=27) == "", & - "slice, Invalid arguments: first=27") ! last=+inf - call check(slice(test_string, first=-10) == "abcdefghijklmnopqrstuvwxyz", & - "slice, Invalid arguments: first=-10") ! last=+inf - call check(slice(test_string, last=-2) == "", & - "slice, Invalid arguments: last=-2") ! first=-inf - call check(slice(test_string, last=30) == "abcdefghijklmnopqrstuvwxyz", & - "slice, Invalid arguments: last=30") ! first=-inf - call check(slice(test_string, stride=0) == "abcdefghijklmnopqrstuvwxyz", & - "slice, Invalid arguments: stride=0") ! stride=1 - + ! Valid + call check(error, slice(test_string, first=10) == "jklmnopqrstuvwxyz", & + "slice, Valid arguments: first=10") ! last=+inf + if (allocated(error)) return + call check(error, slice(test_string, last=10) == "abcdefghij", & + "slice, Valid arguments: last=10") ! first=-inf + if (allocated(error)) return + call check(error, slice(test_string, stride=3) == "adgjmpsvy", & + "slice, Valid arguments: stride=3") ! first=-inf, last=+inf + if (allocated(error)) return + call check(error, slice(test_string, stride=-3) == "zwtqnkheb", & + "slice, Valid arguments: stride=-3") ! first=+inf, last=-inf + if (allocated(error)) return + + ! Invalid + call check(error, slice(test_string, first=27) == "", & + "slice, Invalid arguments: first=27") ! last=+inf + if (allocated(error)) return + call check(error, slice(test_string, first=-10) == "abcdefghijklmnopqrstuvwxyz", & + "slice, Invalid arguments: first=-10") ! last=+inf + if (allocated(error)) return + call check(error, slice(test_string, last=-2) == "", & + "slice, Invalid arguments: last=-2") ! first=-inf + if (allocated(error)) return + call check(error, slice(test_string, last=30) == "abcdefghijklmnopqrstuvwxyz", & + "slice, Invalid arguments: last=30") ! first=-inf + if (allocated(error)) return + call check(error, slice(test_string, stride=0) == "abcdefghijklmnopqrstuvwxyz", & + "slice, Invalid arguments: stride=0") ! stride=1 + if (allocated(error)) return + ! Only two arguments are given - ! Valid - call check(slice(test_string, first=10, last=20) == "jklmnopqrst", & - "slice, Valid arguments: first=10, last=20") - call check(slice(test_string, first=7, last=2) == "gfedcb", & - "slice, Valid arguments: first=7, last=2") ! stride=-1 - call check(slice(test_string, first=10, stride=-2) == "jhfdb", & - "slice, Valid arguments: first=10, stride=-2") ! last=-inf - call check(slice(test_string, last=21, stride=-2) == "zxv", & - "slice, Valid arguments: last=21, stride=-2") ! first=+inf - - ! Atleast one argument is invalid - call check(slice(test_string, first=30, last=-3) == "zyxwvutsrqponmlkjihgfedcba", & - "slice, Invalid arguments: first=30, last=-3") - call check(slice(test_string, first=1, last=-20) == "a", & - "slice, Invalid arguments: first=1, last=-20") - call check(slice(test_string, first=7, last=-10) == "gfedcba", & - "slice, Invalid arguments: first=7, last=-10") - call check(slice(test_string, first=500, last=22) == "zyxwv", & - "slice, Invalid arguments: first=500, last=22") - call check(slice(test_string, first=50, last=27) == "", & - "slice, Invalid arguments: first=50, last=27") - call check(slice(test_string, first=-20, last=0) == "", & - "slice, Invalid arguments: first=-20, last=0") - call check(slice(test_string, last=-3, stride=-2) == "zxvtrpnljhfdb", & - "slice, Invalid arguments: last=-3, stride=-2") ! first=+inf - call check(slice(test_string, last=10, stride=0) == "abcdefghij", & - "slice, Invalid arguments: last=10, stride=0") ! stride=1 - call check(slice(test_string, first=-2, stride=-2) == "", & - "slice, Invalid arguments: first=-2, stride=-2") ! last=-inf - call check(slice(test_string, first=27, stride=2) == "", & - "slice, Invalid arguments: first=27, stride=2") ! last=+inf - call check(slice(test_string, last=27, stride=-1) == "", & - "slice, Invalid arguments: last=27, stride=-1") ! first=+inf + ! Valid + call check(error, slice(test_string, first=10, last=20) == "jklmnopqrst", & + "slice, Valid arguments: first=10, last=20") + if (allocated(error)) return + call check(error, slice(test_string, first=7, last=2) == "gfedcb", & + "slice, Valid arguments: first=7, last=2") ! stride=-1 + if (allocated(error)) return + call check(error, slice(test_string, first=10, stride=-2) == "jhfdb", & + "slice, Valid arguments: first=10, stride=-2") ! last=-inf + if (allocated(error)) return + call check(error, slice(test_string, last=21, stride=-2) == "zxv", & + "slice, Valid arguments: last=21, stride=-2") ! first=+inf + if (allocated(error)) return + + ! Atleast one argument is invalid + call check(error, slice(test_string, first=30, last=-3) == "zyxwvutsrqponmlkjihgfedcba", & + "slice, Invalid arguments: first=30, last=-3") + if (allocated(error)) return + call check(error, slice(test_string, first=1, last=-20) == "a", & + "slice, Invalid arguments: first=1, last=-20") + if (allocated(error)) return + call check(error, slice(test_string, first=7, last=-10) == "gfedcba", & + "slice, Invalid arguments: first=7, last=-10") + if (allocated(error)) return + call check(error, slice(test_string, first=500, last=22) == "zyxwv", & + "slice, Invalid arguments: first=500, last=22") + if (allocated(error)) return + call check(error, slice(test_string, first=50, last=27) == "", & + "slice, Invalid arguments: first=50, last=27") + if (allocated(error)) return + call check(error, slice(test_string, first=-20, last=0) == "", & + "slice, Invalid arguments: first=-20, last=0") + if (allocated(error)) return + call check(error, slice(test_string, last=-3, stride=-2) == "zxvtrpnljhfdb", & + "slice, Invalid arguments: last=-3, stride=-2") ! first=+inf + if (allocated(error)) return + call check(error, slice(test_string, last=10, stride=0) == "abcdefghij", & + "slice, Invalid arguments: last=10, stride=0") ! stride=1 + if (allocated(error)) return + call check(error, slice(test_string, first=-2, stride=-2) == "", & + "slice, Invalid arguments: first=-2, stride=-2") ! last=-inf + if (allocated(error)) return + call check(error, slice(test_string, first=27, stride=2) == "", & + "slice, Invalid arguments: first=27, stride=2") ! last=+inf + if (allocated(error)) return + call check(error, slice(test_string, last=27, stride=-1) == "", & + "slice, Invalid arguments: last=27, stride=-1") ! first=+inf + if (allocated(error)) return ! All three arguments are given - ! Valid - call check(slice(test_string, first=2, last=16, stride=3) == "behkn", & - "slice, Valid arguments: first=2, last=16, stride=3") - call check(slice(test_string, first=16, last=2, stride=-3) == "pmjgd", & - "slice, Valid arguments: first=16, last=2, stride=-3") - call check(slice(test_string, first=7, last=7, stride=-4) == "g", & - "slice, Valid arguments: first=7, last=7, stride=-4") - call check(slice(test_string, first=7, last=7, stride=3) == "g", & - "slice, Valid arguments: first=7, last=7, stride=3") - call check(slice(test_string, first=2, last=6, stride=-1) == "", & - "slice, Valid arguments: first=2, last=6, stride=-1") - call check(slice(test_string, first=20, last=10, stride=2) == "", & - "slice, Valid arguments: first=20, last=10, stride=2") - - ! Atleast one argument is invalid - call check(slice(test_string, first=20, last=30, stride=2) == "tvxz", & - "slice, Invalid arguments: first=20, last=30, stride=2") - call check(slice(test_string, first=-20, last=30, stride=2) == "acegikmoqsuwy", & - "slice, Invalid arguments: first=-20, last=30, stride=2") - call check(slice(test_string, first=26, last=30, stride=1) == "z", & - "slice, Invalid arguments: first=26, last=30, stride=1") - call check(slice(test_string, first=1, last=-20, stride=-1) == "a", & - "slice, Invalid arguments: first=1, last=-20, stride=-1") - call check(slice(test_string, first=26, last=20, stride=1) == "", & - "slice, Invalid arguments: first=26, last=20, stride=1") - call check(slice(test_string, first=1, last=20, stride=-1) == "", & - "slice, Invalid arguments: first=1, last=20, stride=-1") - + ! Valid + call check(error, slice(test_string, first=2, last=16, stride=3) == "behkn", & + "slice, Valid arguments: first=2, last=16, stride=3") + if (allocated(error)) return + call check(error, slice(test_string, first=16, last=2, stride=-3) == "pmjgd", & + "slice, Valid arguments: first=16, last=2, stride=-3") + if (allocated(error)) return + call check(error, slice(test_string, first=7, last=7, stride=-4) == "g", & + "slice, Valid arguments: first=7, last=7, stride=-4") + if (allocated(error)) return + call check(error, slice(test_string, first=7, last=7, stride=3) == "g", & + "slice, Valid arguments: first=7, last=7, stride=3") + if (allocated(error)) return + call check(error, slice(test_string, first=2, last=6, stride=-1) == "", & + "slice, Valid arguments: first=2, last=6, stride=-1") + if (allocated(error)) return + call check(error, slice(test_string, first=20, last=10, stride=2) == "", & + "slice, Valid arguments: first=20, last=10, stride=2") + if (allocated(error)) return + + ! Atleast one argument is invalid + call check(error, slice(test_string, first=20, last=30, stride=2) == "tvxz", & + "slice, Invalid arguments: first=20, last=30, stride=2") + if (allocated(error)) return + call check(error, slice(test_string, first=-20, last=30, stride=2) == "acegikmoqsuwy", & + "slice, Invalid arguments: first=-20, last=30, stride=2") + if (allocated(error)) return + call check(error, slice(test_string, first=26, last=30, stride=1) == "z", & + "slice, Invalid arguments: first=26, last=30, stride=1") + if (allocated(error)) return + call check(error, slice(test_string, first=1, last=-20, stride=-1) == "a", & + "slice, Invalid arguments: first=1, last=-20, stride=-1") + if (allocated(error)) return + call check(error, slice(test_string, first=26, last=20, stride=1) == "", & + "slice, Invalid arguments: first=26, last=20, stride=1") + if (allocated(error)) return + call check(error, slice(test_string, first=1, last=20, stride=-1) == "", & + "slice, Invalid arguments: first=1, last=20, stride=-1") + if (allocated(error)) return + test_string = "" ! Empty string input - call check(slice(test_string, first=-2, last=6) == "", & - "slice, Empty string: first=-2, last=6") - call check(slice(test_string, first=6, last=-2) == "", & - "slice, Empty string: first=6, last=-2") - call check(slice(test_string, first=-10) == "", & - "slice, Empty string: first=-10") ! last=+inf - call check(slice(test_string, last=10) == "", & - "slice, Empty string: last=10") ! first=-inf - call check(slice(test_string) == "", & - "slice, Empty string: no arguments provided") + call check(error, slice(test_string, first=-2, last=6) == "", & + "slice, Empty string: first=-2, last=6") + if (allocated(error)) return + call check(error, slice(test_string, first=6, last=-2) == "", & + "slice, Empty string: first=6, last=-2") + if (allocated(error)) return + call check(error, slice(test_string, first=-10) == "", & + "slice, Empty string: first=-10") ! last=+inf + if (allocated(error)) return + call check(error, slice(test_string, last=10) == "", & + "slice, Empty string: last=10") ! first=-inf + if (allocated(error)) return + call check(error, slice(test_string) == "", & + "slice, Empty string: no arguments provided") end subroutine test_slice_string - subroutine test_find + subroutine test_find(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: test_string_1, test_string_2, test_pattern_1, test_pattern_2 test_string_1 = "qwqwqwqwqwqwqw" test_string_2 = "abccbabccbabc" test_pattern_1 = "qwq" test_pattern_2 = "abccbabc" - call check(all(find([test_string_1, test_string_2], test_pattern_1, 4) == [7, 0]), & + call check(error, all(find([test_string_1, test_string_2], test_pattern_1, 4) == [7, 0]), & & 'find: [test_string_1, test_string_2], test_pattern_1, 4') - call check(all(find(test_string_1, [test_pattern_1, test_pattern_2], 3, .false.) == [9, 0]), & + if (allocated(error)) return + call check(error, all(find(test_string_1, [test_pattern_1, test_pattern_2], 3, .false.) == [9, 0]), & & 'find: test_string_1, [test_pattern_1, test_pattern_2], 3, .false.') - call check(find(test_string_1, test_pattern_1, 7) == 0, & + if (allocated(error)) return + call check(error, find(test_string_1, test_pattern_1, 7) == 0, & & 'find: test_string_1, test_pattern_1, 7') - call check(all(find([test_string_1, test_string_2, test_string_2], [test_pattern_1, & + if (allocated(error)) return + call check(error, all(find([test_string_1, test_string_2, test_string_2], [test_pattern_1, & & test_pattern_2, test_pattern_2], [7, 2, 2], [.true., .false., .true.]) == [0, 0, 6]), & & 'find: [test_string_1, test_string_2, test_string_2], [test_pattern_1, & & test_pattern_2, test_pattern_2], [7, 2, 2], [.true., .false., .true.]') - call check(find("qwqwqwqwqwqwqw", test_pattern_1) == 1, & + if (allocated(error)) return + call check(error, find("qwqwqwqwqwqwqw", test_pattern_1) == 1, & & 'find: "qwqwqwqwqwqwqw", test_pattern_1') - call check(all(find(test_string_1, ["qwq", "wqw"], 2) == [3, 4]), & + if (allocated(error)) return + call check(error, all(find(test_string_1, ["qwq", "wqw"], 2) == [3, 4]), & & 'find: test_string_1, ["qwq", "wqw"], 2') - call check(find("qwqwqwqwqwqwqw", "qwq", 2, .false.) == 5, & + if (allocated(error)) return + call check(error, find("qwqwqwqwqwqwqw", "qwq", 2, .false.) == 5, & & 'find: "qwqwqwqwqwqwqw", "qwq", 2, .false.') - call check(find("", "") == 0, & + if (allocated(error)) return + call check(error, find("", "") == 0, & & 'find: "", ""') - call check(find("", test_pattern_1) == 0, & + if (allocated(error)) return + call check(error, find("", test_pattern_1) == 0, & & 'find: "", test_pattern_1') - call check(find(test_string_1, "") == 0, & + if (allocated(error)) return + call check(error, find(test_string_1, "") == 0, & & 'find: test_string_1, ""') end subroutine test_find - subroutine test_slice_gen + subroutine test_slice_gen(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + character(len=*), parameter :: test = & & "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" integer :: i, j, k integer, parameter :: offset = 3 do i = 1 - offset, len(test) + offset - call check_slicer(test, first=i) + call check_slicer(error, test, first=i) + if (allocated(error)) return end do do i = 1 - offset, len(test) + offset - call check_slicer(test, last=i) + call check_slicer(error, test, last=i) + if (allocated(error)) return end do do i = -len(test) - offset, len(test) + offset - call check_slicer(test, stride=i) + call check_slicer(error, test, stride=i) + if (allocated(error)) return end do do i = 1 - offset, len(test) + offset do j = 1 - offset, len(test) + offset - call check_slicer(test, first=i, last=j) + call check_slicer(error, test, first=i, last=j) + if (allocated(error)) return end do end do do i = 1 - offset, len(test) + offset do j = -len(test) - offset, len(test) + offset - call check_slicer(test, first=i, stride=j) + call check_slicer(error, test, first=i, stride=j) + if (allocated(error)) return end do end do do i = 1 - offset, len(test) + offset do j = -len(test) - offset, len(test) + offset - call check_slicer(test, last=i, stride=j) + call check_slicer(error, test, last=i, stride=j) + if (allocated(error)) return end do end do do i = 1 - offset, len(test) + offset do j = 1 - offset, len(test) + offset do k = -len(test) - offset, len(test) + offset - call check_slicer(test, first=i, last=j, stride=k) + call check_slicer(error, test, first=i, last=j, stride=k) + if (allocated(error)) return end do end do end do end subroutine test_slice_gen - subroutine check_slicer(string, first, last, stride) + subroutine check_slicer(error, string, first, last, stride) + !> Error handling + type(error_type), allocatable, intent(out) :: error + character(len=*), intent(in) :: string integer, intent(in), optional :: first integer, intent(in), optional :: last @@ -267,7 +372,7 @@ subroutine check_slicer(string, first, last, stride) end if message = message // "Expected: '"//expected//"' but got '"//actual//"'" end if - call check(stat, message) + call check(error, stat, message) end subroutine check_slicer @@ -318,7 +423,10 @@ pure function carray_to_string(carray) result(string) string = transfer(carray, string) end function carray_to_string - subroutine test_replace_all + subroutine test_replace_all(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: test_string_1, test_pattern_1, test_replacement_1 type(string_type) :: test_string_2, test_pattern_2, test_replacement_2 test_string_1 = "mutate DNA sequence: GTTATCGTATGCCGTAATTAT" @@ -329,130 +437,174 @@ subroutine test_replace_all test_replacement_2 = "aga" ! all 3 as string_type - call check(replace_all(test_string_1, test_pattern_1, test_replacement_1) == & - & "mutate DNA sequence: GTATACGATAGCCGTAATATA", & - & "replace_all: all 3 string_type, test case 1") - call check(replace_all(test_string_2, test_pattern_2, test_replacement_2) == & - & "mutate DNA sequence: agaGAGCCTagaGagaG", & - & "replace_all: all 3 string_type, test case 2") - call check(replace_all(test_string_2, test_pattern_2, test_replacement_1) == & - & "mutate DNA sequence: ATAGAGCCTATAGATAG", & - & "replace_all: all 3 string_type, test case 3") - + call check(error, replace_all(test_string_1, test_pattern_1, test_replacement_1) == & + & "mutate DNA sequence: GTATACGATAGCCGTAATATA", & + & "replace_all: all 3 string_type, test case 1") + if (allocated(error)) return + call check(error, replace_all(test_string_2, test_pattern_2, test_replacement_2) == & + & "mutate DNA sequence: agaGAGCCTagaGagaG", & + & "replace_all: all 3 string_type, test case 2") + if (allocated(error)) return + call check(error, replace_all(test_string_2, test_pattern_2, test_replacement_1) == & + & "mutate DNA sequence: ATAGAGCCTATAGATAG", & + & "replace_all: all 3 string_type, test case 3") + if (allocated(error)) return + ! 2 as string_type and 1 as character scalar - call check(replace_all(test_string_1, "tat", test_replacement_1) == & - & "muATAe DNA sequence: GTTATCGTATGCCGTAATTAT", & - & "replace_all: 2 string_type & 1 character scalar, test case 1") - call check(replace_all(test_string_2, test_pattern_2, "GC") == & - & "mutate DNA sequence: GCGAGCCTGCGGCG", & - & "replace_all: 2 string_type & 1 character scalar, test case 2") - call check(replace_all("mutate DNA sequence: AGAGAGCCTAGAGAGAG", test_pattern_2, & - & test_replacement_2) == "mutate DNA sequence: agaGAGCCTagaGagaG", & - & "replace_all: 2 string_type & 1 character scalar, test case 3") - - + call check(error, replace_all(test_string_1, "tat", test_replacement_1) == & + & "muATAe DNA sequence: GTTATCGTATGCCGTAATTAT", & + & "replace_all: 2 string_type & 1 character scalar, test case 1") + if (allocated(error)) return + call check(error, replace_all(test_string_2, test_pattern_2, "GC") == & + & "mutate DNA sequence: GCGAGCCTGCGGCG", & + & "replace_all: 2 string_type & 1 character scalar, test case 2") + if (allocated(error)) return + call check(error, replace_all("mutate DNA sequence: AGAGAGCCTAGAGAGAG", test_pattern_2, & + & test_replacement_2) == "mutate DNA sequence: agaGAGCCTagaGagaG", & + & "replace_all: 2 string_type & 1 character scalar, test case 3") + if (allocated(error)) return + + ! 1 as string_type and 2 as character scalar - call check(replace_all(test_string_1, "TAT", "ATA") == & - & "mutate DNA sequence: GTATACGATAGCCGTAATATA", & - & "replace_all: 1 string_type & 2 character scalar, test case 1") - call check(replace_all("mutate DNA sequence: AGAGAGCCTAGAGAGAG", test_pattern_2, "GC") == & - & "mutate DNA sequence: GCGAGCCTGCGGCG", & - & "replace_all: 1 string_type & 2 character scalar, test case 2") - call check(replace_all("mutate DNA sequence: GTTATCGTATGCCGTAATTAT", "TA", & - & test_replacement_2) == "mutate DNA sequence: GTagaTCGagaTGCCGagaATagaT", & - & "replace_all: 1 string_type & 2 character scalar, test case 3") - call check(replace_all("mutate DNA sequence: GTTATCGTATGCCGTAATTAT", & - & test_pattern_1, "") == "mutate DNA sequence: GTCGGCCGTAAT", & - & "replace_all: 1 string_type & 2 character scalar, test case 4") - call check(replace_all(test_string_1, "", "anything here") == test_string_1, & - & "replace_all: 1 string_type & 2 character scalar, test case 5") - call check(replace_all("", test_pattern_2, "anything here") == "", & - & "replace_all: 1 string_type & 2 character scalar, test case 6") - + call check(error, replace_all(test_string_1, "TAT", "ATA") == & + & "mutate DNA sequence: GTATACGATAGCCGTAATATA", & + & "replace_all: 1 string_type & 2 character scalar, test case 1") + if (allocated(error)) return + call check(error, replace_all("mutate DNA sequence: AGAGAGCCTAGAGAGAG", test_pattern_2, "GC") == & + & "mutate DNA sequence: GCGAGCCTGCGGCG", & + & "replace_all: 1 string_type & 2 character scalar, test case 2") + if (allocated(error)) return + call check(error, replace_all("mutate DNA sequence: GTTATCGTATGCCGTAATTAT", "TA", & + & test_replacement_2) == "mutate DNA sequence: GTagaTCGagaTGCCGagaATagaT", & + & "replace_all: 1 string_type & 2 character scalar, test case 3") + if (allocated(error)) return + call check(error, replace_all("mutate DNA sequence: GTTATCGTATGCCGTAATTAT", & + & test_pattern_1, "") == "mutate DNA sequence: GTCGGCCGTAAT", & + & "replace_all: 1 string_type & 2 character scalar, test case 4") + if (allocated(error)) return + call check(error, replace_all(test_string_1, "", "anything here") == test_string_1, & + & "replace_all: 1 string_type & 2 character scalar, test case 5") + if (allocated(error)) return + call check(error, replace_all("", test_pattern_2, "anything here") == "", & + & "replace_all: 1 string_type & 2 character scalar, test case 6") + if (allocated(error)) return + ! all 3 as character scalar - call check(replace_all("mutate DNA sequence: GTTATCGTATGCCGTAATTAT", & - & "GT", "gct") == "mutate DNA sequence: gctTATCgctATGCCgctAATTAT", & - & "replace_all: all 3 character scalar, test case 1") - call check(replace_all("", "anything here", "anything here") == "", & - & "replace_all: all 3 character scalar, test case 2") + call check(error, replace_all("mutate DNA sequence: GTTATCGTATGCCGTAATTAT", & + & "GT", "gct") == "mutate DNA sequence: gctTATCgctATGCCgctAATTAT", & + & "replace_all: all 3 character scalar, test case 1") + if (allocated(error)) return + call check(error, replace_all("", "anything here", "anything here") == "", & + & "replace_all: all 3 character scalar, test case 2") end subroutine test_replace_all - subroutine test_padl + subroutine test_padl(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: test_string character(len=:), allocatable :: test_char test_string = "left pad this string" test_char = " left pad this string " - ! output_length > len(string) - call check(padl(test_string, 25, "#") == "#####left pad this string", & - & 'padl: output_length > len(string), test_case 1') - call check(padl(test_string, 22, "$") == "$$left pad this string", & - & 'padl: output_length > len(string), test_case 2') - call check(padl(test_string, 23) == " left pad this string", & - & 'padl: output_length > len(string), test_case 3') - call check(padl(test_char, 26) == " left pad this string ", & - & 'padl: output_length > len(string), test_case 4') - call check(padl(test_char, 26, "&") == "&& left pad this string ", & - & 'padl: output_length > len(string), test_case 5') - call check(padl("", 10, "!") == "!!!!!!!!!!", & - & 'padl: output_length > len(string), test_case 6') - - ! output_length <= len(string) - call check(padl(test_string, 18, "#") == "left pad this string", & - & 'padl: output_length <= len(string), test_case 1') - call check(padl(test_string, -4, "@") == "left pad this string", & - & 'padl: output_length <= len(string), test_case 2') - call check(padl(test_char, 20, "0") == " left pad this string ", & - & 'padl: output_length <= len(string), test_case 3') - call check(padl(test_char, 17) == " left pad this string ", & - & 'padl: output_length <= len(string), test_case 4') - call check(padl("", 0, "!") == "", & - & 'padl: output_length <= len(string), test_case 5') - call check(padl("", -12, "!") == "", & - & 'padl: output_length <= len(string), test_case 6') - + ! output_length > len(string) + call check(error, padl(test_string, 25, "#") == "#####left pad this string", & + & 'padl: output_length > len(string), test_case 1') + if (allocated(error)) return + call check(error, padl(test_string, 22, "$") == "$$left pad this string", & + & 'padl: output_length > len(string), test_case 2') + if (allocated(error)) return + call check(error, padl(test_string, 23) == " left pad this string", & + & 'padl: output_length > len(string), test_case 3') + if (allocated(error)) return + call check(error, padl(test_char, 26) == " left pad this string ", & + & 'padl: output_length > len(string), test_case 4') + if (allocated(error)) return + call check(error, padl(test_char, 26, "&") == "&& left pad this string ", & + & 'padl: output_length > len(string), test_case 5') + if (allocated(error)) return + call check(error, padl("", 10, "!") == "!!!!!!!!!!", & + & 'padl: output_length > len(string), test_case 6') + if (allocated(error)) return + + ! output_length <= len(string) + call check(error, padl(test_string, 18, "#") == "left pad this string", & + & 'padl: output_length <= len(string), test_case 1') + if (allocated(error)) return + call check(error, padl(test_string, -4, "@") == "left pad this string", & + & 'padl: output_length <= len(string), test_case 2') + if (allocated(error)) return + call check(error, padl(test_char, 20, "0") == " left pad this string ", & + & 'padl: output_length <= len(string), test_case 3') + if (allocated(error)) return + call check(error, padl(test_char, 17) == " left pad this string ", & + & 'padl: output_length <= len(string), test_case 4') + if (allocated(error)) return + call check(error, padl("", 0, "!") == "", & + & 'padl: output_length <= len(string), test_case 5') + if (allocated(error)) return + call check(error, padl("", -12, "!") == "", & + & 'padl: output_length <= len(string), test_case 6') + end subroutine test_padl - subroutine test_padr + subroutine test_padr(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: test_string character(len=:), allocatable :: test_char test_string = "right pad this string" test_char = " right pad this string " - ! output_length > len(string) - call check(padr(test_string, 25, "#") == "right pad this string####", & - & 'padr: output_length > len(string), test_case 1') - call check(padr(test_string, 22, "$") == "right pad this string$", & - & 'padr: output_length > len(string), test_case 2') - call check(padr(test_string, 24) == "right pad this string ", & - & 'padr: output_length > len(string), test_case 3') - call check(padr(test_char, 27) == " right pad this string ", & - & 'padr: output_length > len(string), test_case 4') - call check(padr(test_char, 27, "&") == " right pad this string &&", & - & 'padr: output_length > len(string), test_case 5') - call check(padr("", 10, "!") == "!!!!!!!!!!", & - & 'padr: output_length > len(string), test_case 6') - - ! output_length <= len(string) - call check(padr(test_string, 18, "#") == "right pad this string", & - & 'padr: output_length <= len(string), test_case 1') - call check(padr(test_string, -4, "@") == "right pad this string", & - & 'padr: output_length <= len(string), test_case 2') - call check(padr(test_char, 20, "0") == " right pad this string ", & - & 'padr: output_length <= len(string), test_case 3') - call check(padr(test_char, 17) == " right pad this string ", & - & 'padr: output_length <= len(string), test_case 4') - call check(padr("", 0, "!") == "", & - & 'padr: output_length <= len(string), test_case 5') - call check(padr("", -12, "!") == "", & - & 'padr: output_length <= len(string), test_case 6') - + ! output_length > len(string) + call check(error, padr(test_string, 25, "#") == "right pad this string####", & + & 'padr: output_length > len(string), test_case 1') + if (allocated(error)) return + call check(error, padr(test_string, 22, "$") == "right pad this string$", & + & 'padr: output_length > len(string), test_case 2') + if (allocated(error)) return + call check(error, padr(test_string, 24) == "right pad this string ", & + & 'padr: output_length > len(string), test_case 3') + if (allocated(error)) return + call check(error, padr(test_char, 27) == " right pad this string ", & + & 'padr: output_length > len(string), test_case 4') + if (allocated(error)) return + call check(error, padr(test_char, 27, "&") == " right pad this string &&", & + & 'padr: output_length > len(string), test_case 5') + if (allocated(error)) return + call check(error, padr("", 10, "!") == "!!!!!!!!!!", & + & 'padr: output_length > len(string), test_case 6') + if (allocated(error)) return + + ! output_length <= len(string) + call check(error, padr(test_string, 18, "#") == "right pad this string", & + & 'padr: output_length <= len(string), test_case 1') + if (allocated(error)) return + call check(error, padr(test_string, -4, "@") == "right pad this string", & + & 'padr: output_length <= len(string), test_case 2') + if (allocated(error)) return + call check(error, padr(test_char, 20, "0") == " right pad this string ", & + & 'padr: output_length <= len(string), test_case 3') + if (allocated(error)) return + call check(error, padr(test_char, 17) == " right pad this string ", & + & 'padr: output_length <= len(string), test_case 4') + if (allocated(error)) return + call check(error, padr("", 0, "!") == "", & + & 'padr: output_length <= len(string), test_case 5') + if (allocated(error)) return + call check(error, padr("", -12, "!") == "", & + & 'padr: output_length <= len(string), test_case 6') + end subroutine test_padr - subroutine test_count + subroutine test_count(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: test_string_1, test_string_2, test_pattern_1, test_pattern_2 test_string_1 = "DNA sequence: AGAGAGAGTCCTGTCGAGA" test_string_2 = "DNA sequence: GTCCTGTCCTGTCAGA" @@ -460,38 +612,50 @@ subroutine test_count test_pattern_2 = "GTCCTGTC" ! all 2 as string_type - call check(all(count([test_string_1, test_string_2], test_pattern_1) == [4, 1]), & - & 'count: all 2 as string_type, test case 1') - call check(all(count(test_string_1, [test_pattern_1, test_pattern_2], .false.) == [3, 1]), & - & 'count: all 2 as string_type, test case 2') - call check(count(test_string_2, test_pattern_1, .false.) == 1, & - & 'count: all 2 as string_type, test case 3') - call check(all(count([test_string_2, test_string_2, test_string_1], & - & [test_pattern_2, test_pattern_2, test_pattern_1], [.true., .false., .false.]) == & - & [2, 1, 3]), 'count: all 2 as string_type, test case 4') - call check(all(count([[test_string_1, test_string_2], [test_string_1, test_string_2]], & - & [[test_pattern_1, test_pattern_2], [test_pattern_2, test_pattern_1]], .true.) == & - & [[4, 2], [1, 1]]), 'count: all 2 as string_type, test case 5') - + call check(error, all(count([test_string_1, test_string_2], test_pattern_1) == [4, 1]), & + & 'count: all 2 as string_type, test case 1') + if (allocated(error)) return + call check(error, all(count(test_string_1, [test_pattern_1, test_pattern_2], .false.) == [3, 1]), & + & 'count: all 2 as string_type, test case 2') + if (allocated(error)) return + call check(error, count(test_string_2, test_pattern_1, .false.) == 1, & + & 'count: all 2 as string_type, test case 3') + if (allocated(error)) return + call check(error, all(count([test_string_2, test_string_2, test_string_1], & + & [test_pattern_2, test_pattern_2, test_pattern_1], [.true., .false., .false.]) == & + & [2, 1, 3]), 'count: all 2 as string_type, test case 4') + if (allocated(error)) return + call check(error, all(count([[test_string_1, test_string_2], [test_string_1, test_string_2]], & + & [[test_pattern_1, test_pattern_2], [test_pattern_2, test_pattern_1]], .true.) == & + & [[4, 2], [1, 1]]), 'count: all 2 as string_type, test case 5') + if (allocated(error)) return + ! 1 string_type and 1 character scalar - call check(all(count(test_string_1, ["AGA", "GTC"], [.true., .false.]) == [4, 2]), & - & 'count: 1 string_type and 1 character scalar, test case 1') - call check(all(count([test_string_1, test_string_2], ["CTC", "GTC"], [.true., .false.]) == & - & [0, 3]), 'count: 1 string_type and 1 character scalar, test case 2') - call check(all(count(["AGAGAGAGTCCTGTCGAGA", "AGAGAGAGTCCTGTCGAGA"], & - & test_pattern_1, [.false., .true.]) == [3, 4]), & - & 'count: 1 string_type and 1 character scalar, test case 3') - call check(count(test_string_1, "GAG") == 4, & - & 'count: 1 string_type and 1 character scalar, test case 4') - call check(count("DNA sequence: GTCCTGTCCTGTCAGA", test_pattern_2, .false.) == 1, & - & 'count: 1 string_type and 1 character scalar, test case 5') - + call check(error, all(count(test_string_1, ["AGA", "GTC"], [.true., .false.]) == [4, 2]), & + & 'count: 1 string_type and 1 character scalar, test case 1') + if (allocated(error)) return + call check(error, all(count([test_string_1, test_string_2], ["CTC", "GTC"], [.true., .false.]) == & + & [0, 3]), 'count: 1 string_type and 1 character scalar, test case 2') + if (allocated(error)) return + call check(error, all(count(["AGAGAGAGTCCTGTCGAGA", "AGAGAGAGTCCTGTCGAGA"], & + & test_pattern_1, [.false., .true.]) == [3, 4]), & + & 'count: 1 string_type and 1 character scalar, test case 3') + if (allocated(error)) return + call check(error, count(test_string_1, "GAG") == 4, & + & 'count: 1 string_type and 1 character scalar, test case 4') + if (allocated(error)) return + call check(error, count("DNA sequence: GTCCTGTCCTGTCAGA", test_pattern_2, .false.) == 1, & + & 'count: 1 string_type and 1 character scalar, test case 5') + if (allocated(error)) return + ! all 2 character scalar - call check(all(count("", ["mango", "trees"], .true.) == [0, 0]), & - & 'count: all 2 character scalar, test case 1') - call check(count("", "", .true.) == 0, 'count: all 2 character scalar, test case 2') - call check(all(count(["mango", "trees"], "", .true.) == [0, 0]), & - & 'count: all 2 character scalar, test case 3') + call check(error, all(count("", ["mango", "trees"], .true.) == [0, 0]), & + & 'count: all 2 character scalar, test case 1') + if (allocated(error)) return + call check(error, count("", "", .true.) == 0, 'count: all 2 character scalar, test case 2') + if (allocated(error)) return + call check(error, all(count(["mango", "trees"], "", .true.) == [0, 0]), & + & 'count: all 2 character scalar, test case 3') end subroutine test_count @@ -499,20 +663,27 @@ end module test_string_functions program tester - use test_string_functions + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_string_functions, only : collect_string_functions implicit none - - call test_to_lower_string - call test_to_upper_string - call test_to_title_string - call test_to_sentence_string - call test_reverse_string - call test_slice_string - call test_slice_gen - call test_find - call test_replace_all - call test_padl - call test_padr - call test_count - -end program tester + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("string-functions", collect_string_functions) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program diff --git a/src/tests/string/test_string_intrinsic.f90 b/src/tests/string/test_string_intrinsic.f90 index e546a73ff..dab46f243 100644 --- a/src/tests/string/test_string_intrinsic.f90 +++ b/src/tests/string/test_string_intrinsic.f90 @@ -1,22 +1,24 @@ ! SPDX-Identifer: MIT module test_string_intrinsic - use stdlib_error, only : check + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_string_type implicit none abstract interface !> Actual tester working on a string type and a fixed length character !> representing the same character sequence - subroutine check1_interface(str1, chr1) - import :: string_type + subroutine check1_interface(error, str1, chr1) + import :: string_type, error_type + type(error_type), allocatable, intent(out) :: error type(string_type), intent(in) :: str1 character(len=*), intent(in) :: chr1 end subroutine check1_interface !> Actual tester working on two pairs of string type and fixed length !> character representing the same character sequences - subroutine check2_interface(str1, chr1, str2, chr2) - import :: string_type + subroutine check2_interface(error, str1, chr1, str2, chr2) + import :: string_type, error_type + type(error_type), allocatable, intent(out) :: error type(string_type), intent(in) :: str1, str2 character(len=*), intent(in) :: chr1, chr2 end subroutine check2_interface @@ -24,466 +26,667 @@ end subroutine check2_interface contains + + !> Collect all exported unit tests + subroutine collect_string_intrinsic(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("lgt", test_lgt), & + new_unittest("llt", test_llt), & + new_unittest("lge", test_lge), & + new_unittest("lle", test_lle), & + new_unittest("trim", test_trim), & + new_unittest("len", test_len), & + new_unittest("len_trim", test_len_trim), & + new_unittest("adjustl", test_adjustl), & + new_unittest("adjustr", test_adjustr), & + new_unittest("scan", test_scan), & + new_unittest("verify", test_verify), & + new_unittest("repeat", test_repeat), & + new_unittest("index", test_index), & + new_unittest("char", test_char), & + new_unittest("ichar", test_ichar), & + new_unittest("iachar", test_iachar) & + ] + end subroutine collect_string_intrinsic + !> Generate then checker both for the string type created from the character !> sequence by the contructor and the assignment operation - subroutine check1(chr1, checker) + subroutine check1(error, chr1, checker) + !> Error handling + type(error_type), allocatable, intent(out) :: error character(len=*), intent(in) :: chr1 procedure(check1_interface) :: checker - call constructor_check1(chr1, checker) - call assignment_check1(chr1, checker) + call constructor_check1(error, chr1, checker) + if (allocated(error)) return + call assignment_check1(error, chr1, checker) end subroutine check1 !> Run the actual checker with a string type generated by the custom constructor - subroutine constructor_check1(chr1, checker) + subroutine constructor_check1(error, chr1, checker) + !> Error handling + type(error_type), allocatable, intent(out) :: error character(len=*), intent(in) :: chr1 procedure(check1_interface) :: checker - call checker(string_type(chr1), chr1) + call checker(error, string_type(chr1), chr1) end subroutine constructor_check1 !> Run the actual checker with a string type generated by assignment - subroutine assignment_check1(chr1, checker) + subroutine assignment_check1(error, chr1, checker) + !> Error handling + type(error_type), allocatable, intent(out) :: error character(len=*), intent(in) :: chr1 type(string_type) :: str1 procedure(check1_interface) :: checker str1 = chr1 - call checker(str1, chr1) + call checker(error, str1, chr1) end subroutine assignment_check1 !> Generate then checker both for the string type created from the character !> sequence by the contructor and the assignment operation as well as the !> mixed assigment and constructor setup - subroutine check2(chr1, chr2, checker) + subroutine check2(error, chr1, chr2, checker) + !> Error handling + type(error_type), allocatable, intent(out) :: error character(len=*), intent(in) :: chr1, chr2 procedure(check2_interface) :: checker - call constructor_check2(chr1, chr2, checker) - call assignment_check2(chr1, chr2, checker) - call mixed_check2(chr1, chr2, checker) + call constructor_check2(error, chr1, chr2, checker) + if (allocated(error)) return + call assignment_check2(error, chr1, chr2, checker) + if (allocated(error)) return + call mixed_check2(error, chr1, chr2, checker) end subroutine check2 !> Run the actual checker with both string types generated by the custom constructor - subroutine constructor_check2(chr1, chr2, checker) + subroutine constructor_check2(error, chr1, chr2, checker) + !> Error handling + type(error_type), allocatable, intent(out) :: error character(len=*), intent(in) :: chr1, chr2 procedure(check2_interface) :: checker - call checker(string_type(chr1), chr1, string_type(chr2), chr2) + call checker(error, string_type(chr1), chr1, string_type(chr2), chr2) end subroutine constructor_check2 !> Run the actual checker with one string type generated by the custom constructor !> and the other by assignment - subroutine mixed_check2(chr1, chr2, checker) + subroutine mixed_check2(error, chr1, chr2, checker) + !> Error handling + type(error_type), allocatable, intent(out) :: error character(len=*), intent(in) :: chr1, chr2 type(string_type) :: str1, str2 procedure(check2_interface) :: checker str1 = chr1 str2 = chr2 - call checker(str1, chr1, string_type(chr2), chr2) - call checker(string_type(chr1), chr1, str2, chr2) + call checker(error, str1, chr1, string_type(chr2), chr2) + if (allocated(error)) return + call checker(error, string_type(chr1), chr1, str2, chr2) end subroutine mixed_check2 !> Run the actual checker with both string types generated by assignment - subroutine assignment_check2(chr1, chr2, checker) + subroutine assignment_check2(error, chr1, chr2, checker) + !> Error handling + type(error_type), allocatable, intent(out) :: error character(len=*), intent(in) :: chr1, chr2 type(string_type) :: str1, str2 procedure(check2_interface) :: checker str1 = chr1 str2 = chr2 - call checker(str1, chr1, str2, chr2) + call checker(error, str1, chr1, str2, chr2) end subroutine assignment_check2 !> Generator for checking the lexical comparison - subroutine gen_lgt(str1, chr1, str2, chr2) + subroutine gen_lgt(error, str1, chr1, str2, chr2) + !> Error handling + type(error_type), allocatable, intent(out) :: error type(string_type), intent(in) :: str1, str2 character(len=*), intent(in) :: chr1, chr2 - call check(lgt(str1, str2) .eqv. lgt(chr1, chr2)) - call check(lgt(str1, chr2) .eqv. lgt(chr1, chr2)) - call check(lgt(chr1, str2) .eqv. lgt(chr1, chr2)) + call check(error, lgt(str1, str2) .eqv. lgt(chr1, chr2)) + if (allocated(error)) return + call check(error, lgt(str1, chr2) .eqv. lgt(chr1, chr2)) + if (allocated(error)) return + call check(error, lgt(chr1, str2) .eqv. lgt(chr1, chr2)) end subroutine gen_lgt - subroutine test_lgt + subroutine test_lgt(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string logical :: res string = "bcd" res = lgt(string, "abc") - call check(res .eqv. .true.) + call check(error, res .eqv. .true.) + if (allocated(error)) return res = lgt(string, "bcd") - call check(res .eqv. .false.) + call check(error, res .eqv. .false.) + if (allocated(error)) return res = lgt(string, "cde") - call check(res .eqv. .false.) - - call check2("bcd", "abc", gen_lgt) - call check2("bcd", "bcd", gen_lgt) - call check2("bcd", "cde", gen_lgt) + call check(error, res .eqv. .false.) + if (allocated(error)) return + + call check2(error, "bcd", "abc", gen_lgt) + if (allocated(error)) return + call check2(error, "bcd", "bcd", gen_lgt) + if (allocated(error)) return + call check2(error, "bcd", "cde", gen_lgt) end subroutine test_lgt !> Generator for checking the lexical comparison - subroutine gen_llt(str1, chr1, str2, chr2) + subroutine gen_llt(error, str1, chr1, str2, chr2) + !> Error handling + type(error_type), allocatable, intent(out) :: error type(string_type), intent(in) :: str1, str2 character(len=*), intent(in) :: chr1, chr2 - call check(llt(str1, str2) .eqv. llt(chr1, chr2)) - call check(llt(str1, chr2) .eqv. llt(chr1, chr2)) - call check(llt(chr1, str2) .eqv. llt(chr1, chr2)) + call check(error, llt(str1, str2) .eqv. llt(chr1, chr2)) + if (allocated(error)) return + call check(error, llt(str1, chr2) .eqv. llt(chr1, chr2)) + if (allocated(error)) return + call check(error, llt(chr1, str2) .eqv. llt(chr1, chr2)) end subroutine gen_llt - subroutine test_llt + subroutine test_llt(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string logical :: res string = "bcd" res = llt(string, "abc") - call check(res .eqv. .false.) + call check(error, res .eqv. .false.) + if (allocated(error)) return res = llt(string, "bcd") - call check(res .eqv. .false.) + call check(error, res .eqv. .false.) + if (allocated(error)) return res = llt(string, "cde") - call check(res .eqv. .true.) - - call check2("bcd", "abc", gen_llt) - call check2("bcd", "bcd", gen_llt) - call check2("bcd", "cde", gen_llt) + call check(error, res .eqv. .true.) + if (allocated(error)) return + + call check2(error, "bcd", "abc", gen_llt) + if (allocated(error)) return + call check2(error, "bcd", "bcd", gen_llt) + if (allocated(error)) return + call check2(error, "bcd", "cde", gen_llt) end subroutine test_llt !> Generator for checking the lexical comparison - subroutine gen_lge(str1, chr1, str2, chr2) + subroutine gen_lge(error, str1, chr1, str2, chr2) + !> Error handling + type(error_type), allocatable, intent(out) :: error type(string_type), intent(in) :: str1, str2 character(len=*), intent(in) :: chr1, chr2 - call check(lge(str1, str2) .eqv. lge(chr1, chr2)) - call check(lge(str1, chr2) .eqv. lge(chr1, chr2)) - call check(lge(chr1, str2) .eqv. lge(chr1, chr2)) + call check(error, lge(str1, str2) .eqv. lge(chr1, chr2)) + if (allocated(error)) return + call check(error, lge(str1, chr2) .eqv. lge(chr1, chr2)) + if (allocated(error)) return + call check(error, lge(chr1, str2) .eqv. lge(chr1, chr2)) end subroutine gen_lge - subroutine test_lge + subroutine test_lge(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string logical :: res string = "bcd" res = lge(string, "abc") - call check(res .eqv. .true.) + call check(error, res .eqv. .true.) + if (allocated(error)) return res = lge(string, "bcd") - call check(res .eqv. .true.) + call check(error, res .eqv. .true.) + if (allocated(error)) return res = lge(string, "cde") - call check(res .eqv. .false.) - - call check2("bcd", "abc", gen_lge) - call check2("bcd", "bcd", gen_lge) - call check2("bcd", "cde", gen_lge) + call check(error, res .eqv. .false.) + if (allocated(error)) return + + call check2(error, "bcd", "abc", gen_lge) + if (allocated(error)) return + call check2(error, "bcd", "bcd", gen_lge) + if (allocated(error)) return + call check2(error, "bcd", "cde", gen_lge) end subroutine test_lge !> Generator for checking the lexical comparison - subroutine gen_lle(str1, chr1, str2, chr2) + subroutine gen_lle(error, str1, chr1, str2, chr2) + !> Error handling + type(error_type), allocatable, intent(out) :: error type(string_type), intent(in) :: str1, str2 character(len=*), intent(in) :: chr1, chr2 - call check(lle(str1, str2) .eqv. lle(chr1, chr2)) - call check(lle(str1, chr2) .eqv. lle(chr1, chr2)) - call check(lle(chr1, str2) .eqv. lle(chr1, chr2)) + call check(error, lle(str1, str2) .eqv. lle(chr1, chr2)) + if (allocated(error)) return + call check(error, lle(str1, chr2) .eqv. lle(chr1, chr2)) + if (allocated(error)) return + call check(error, lle(chr1, str2) .eqv. lle(chr1, chr2)) end subroutine gen_lle - subroutine test_lle + subroutine test_lle(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string logical :: res string = "bcd" res = lle(string, "abc") - call check(res .eqv. .false.) + call check(error, res .eqv. .false.) + if (allocated(error)) return res = lle(string, "bcd") - call check(res .eqv. .true.) + call check(error, res .eqv. .true.) + if (allocated(error)) return res = lle(string, "cde") - call check(res .eqv. .true.) - - call check2("bcd", "abc", gen_lle) - call check2("bcd", "bcd", gen_lle) - call check2("bcd", "cde", gen_lle) + call check(error, res .eqv. .true.) + if (allocated(error)) return + + call check2(error, "bcd", "abc", gen_lle) + if (allocated(error)) return + call check2(error, "bcd", "bcd", gen_lle) + if (allocated(error)) return + call check2(error, "bcd", "cde", gen_lle) end subroutine test_lle !> Generator for checking the trimming of whitespace - subroutine gen_trim(str1, chr1) + subroutine gen_trim(error, str1, chr1) + !> Error handling + type(error_type), allocatable, intent(out) :: error type(string_type), intent(in) :: str1 character(len=*), intent(in) :: chr1 - call check(len(trim(str1)) == len(trim(chr1))) + call check(error, len(trim(str1)) == len(trim(chr1))) end subroutine gen_trim - subroutine test_trim + subroutine test_trim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string, trimmed_str string = "Whitespace " trimmed_str = trim(string) - call check(len(trimmed_str) == 10) - - call check1(" Whitespace ", gen_trim) - call check1(" W h i t e s p a ce ", gen_trim) - call check1("SPACE SPACE", gen_trim) - call check1(" ", gen_trim) + call check(error, len(trimmed_str) == 10) + if (allocated(error)) return + + call check1(error, " Whitespace ", gen_trim) + if (allocated(error)) return + call check1(error, " W h i t e s p a ce ", gen_trim) + if (allocated(error)) return + call check1(error, "SPACE SPACE", gen_trim) + if (allocated(error)) return + call check1(error, " ", gen_trim) end subroutine test_trim !> Generator for checking the length of the character sequence - subroutine gen_len(str1, chr1) + subroutine gen_len(error, str1, chr1) + !> Error handling + type(error_type), allocatable, intent(out) :: error type(string_type), intent(in) :: str1 character(len=*), intent(in) :: chr1 - call check(len(str1) == len(chr1)) + call check(error, len(str1) == len(chr1)) end subroutine gen_len - subroutine test_len + subroutine test_len(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string integer :: length string = "Some longer sentence for this example." length = len(string) - call check(length == 38) + call check(error, length == 38) + if (allocated(error)) return string = "Whitespace " length = len(string) - call check(length == 38) - - call check1("Example string", gen_len) - call check1("S P A C E D S T R I N G", gen_len) - call check1("With trailing whitespace ", gen_len) - call check1(" centered ", gen_len) + call check(error, length == 38) + if (allocated(error)) return + + call check1(error, "Example string", gen_len) + if (allocated(error)) return + call check1(error, "S P A C E D S T R I N G", gen_len) + if (allocated(error)) return + call check1(error, "With trailing whitespace ", gen_len) + if (allocated(error)) return + call check1(error, " centered ", gen_len) end subroutine test_len !> Generator for checking the length of the character sequence without whitespace - subroutine gen_len_trim(str1, chr1) + subroutine gen_len_trim(error, str1, chr1) + !> Error handling + type(error_type), allocatable, intent(out) :: error type(string_type), intent(in) :: str1 character(len=*), intent(in) :: chr1 - call check(len_trim(str1) == len_trim(chr1)) + call check(error, len_trim(str1) == len_trim(chr1)) end subroutine gen_len_trim - subroutine test_len_trim + subroutine test_len_trim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string integer :: length string = "Some longer sentence for this example." length = len_trim(string) - call check(length == 38) + call check(error, length == 38) + if (allocated(error)) return string = "Whitespace " length = len_trim(string) - call check(length == 10) - - call check1("Example string", gen_len_trim) - call check1("S P A C E D S T R I N G", gen_len_trim) - call check1("With trailing whitespace ", gen_len_trim) - call check1(" centered ", gen_len_trim) + call check(error, length == 10) + if (allocated(error)) return + + call check1(error, "Example string", gen_len_trim) + if (allocated(error)) return + call check1(error, "S P A C E D S T R I N G", gen_len_trim) + if (allocated(error)) return + call check1(error, "With trailing whitespace ", gen_len_trim) + if (allocated(error)) return + call check1(error, " centered ", gen_len_trim) end subroutine test_len_trim !> Generator for checking the left adjustment of the character sequence - subroutine gen_adjustl(str1, chr1) + subroutine gen_adjustl(error, str1, chr1) + !> Error handling + type(error_type), allocatable, intent(out) :: error type(string_type), intent(in) :: str1 character(len=*), intent(in) :: chr1 - call check(adjustl(str1) == adjustl(chr1)) + call check(error, adjustl(str1) == adjustl(chr1)) end subroutine gen_adjustl - subroutine test_adjustl + subroutine test_adjustl(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string string = " Whitespace" string = adjustl(string) - call check(char(string) == "Whitespace ") + call check(error, char(string) == "Whitespace ") + if (allocated(error)) return - call check1(" B L A N K S ", gen_adjustl) + call check1(error, " B L A N K S ", gen_adjustl) end subroutine test_adjustl !> Generator for checking the right adjustment of the character sequence - subroutine gen_adjustr(str1, chr1) + subroutine gen_adjustr(error, str1, chr1) + !> Error handling + type(error_type), allocatable, intent(out) :: error type(string_type), intent(in) :: str1 character(len=*), intent(in) :: chr1 - call check(adjustr(str1) == adjustr(chr1)) + call check(error, adjustr(str1) == adjustr(chr1)) end subroutine gen_adjustr - subroutine test_adjustr + subroutine test_adjustr(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string string = "Whitespace " string = adjustr(string) - call check(char(string) == " Whitespace") + call check(error, char(string) == " Whitespace") + if (allocated(error)) return - call check1(" B L A N K S ", gen_adjustr) + call check1(error, " B L A N K S ", gen_adjustr) end subroutine test_adjustr !> Generator for checking the presence of a character set in a character sequence - subroutine gen_scan(str1, chr1, str2, chr2) + subroutine gen_scan(error, str1, chr1, str2, chr2) + !> Error handling + type(error_type), allocatable, intent(out) :: error type(string_type), intent(in) :: str1, str2 character(len=*), intent(in) :: chr1, chr2 - call check(scan(str1, str2) == scan(chr1, chr2)) - call check(scan(str1, chr2) == scan(chr1, chr2)) - call check(scan(chr1, str2) == scan(chr1, chr2)) - call check(scan(str1, str2, back=.true.) == scan(chr1, chr2, back=.true.)) - call check(scan(str1, chr2, back=.true.) == scan(chr1, chr2, back=.true.)) - call check(scan(chr1, str2, back=.true.) == scan(chr1, chr2, back=.true.)) + call check(error, scan(str1, str2) == scan(chr1, chr2)) + if (allocated(error)) return + call check(error, scan(str1, chr2) == scan(chr1, chr2)) + if (allocated(error)) return + call check(error, scan(chr1, str2) == scan(chr1, chr2)) + if (allocated(error)) return + call check(error, scan(str1, str2, back=.true.) == scan(chr1, chr2, back=.true.)) + if (allocated(error)) return + call check(error, scan(str1, chr2, back=.true.) == scan(chr1, chr2, back=.true.)) + if (allocated(error)) return + call check(error, scan(chr1, str2, back=.true.) == scan(chr1, chr2, back=.true.)) end subroutine gen_scan - subroutine test_scan + subroutine test_scan(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string integer :: pos string = "fortran" pos = scan(string, "ao") - call check(pos == 2) + call check(error, pos == 2) + if (allocated(error)) return pos = scan(string, "ao", .true.) - call check(pos == 6) + call check(error, pos == 6) + if (allocated(error)) return pos = scan(string, "c++") - call check(pos == 0) + call check(error, pos == 0) + if (allocated(error)) return - call check2("fortran", "ao", gen_scan) - call check2("c++", "fortran", gen_scan) + call check2(error, "fortran", "ao", gen_scan) + if (allocated(error)) return + call check2(error, "c++", "fortran", gen_scan) end subroutine test_scan !> Generator for checking the absence of a character set in a character sequence - subroutine gen_verify(str1, chr1, str2, chr2) + subroutine gen_verify(error, str1, chr1, str2, chr2) + !> Error handling + type(error_type), allocatable, intent(out) :: error type(string_type), intent(in) :: str1, str2 character(len=*), intent(in) :: chr1, chr2 - call check(verify(str1, str2) == verify(chr1, chr2)) - call check(verify(str1, chr2) == verify(chr1, chr2)) - call check(verify(chr1, str2) == verify(chr1, chr2)) - call check(verify(str1, str2, back=.true.) == verify(chr1, chr2, back=.true.)) - call check(verify(str1, chr2, back=.true.) == verify(chr1, chr2, back=.true.)) - call check(verify(chr1, str2, back=.true.) == verify(chr1, chr2, back=.true.)) + call check(error, verify(str1, str2) == verify(chr1, chr2)) + if (allocated(error)) return + call check(error, verify(str1, chr2) == verify(chr1, chr2)) + if (allocated(error)) return + call check(error, verify(chr1, str2) == verify(chr1, chr2)) + if (allocated(error)) return + call check(error, verify(str1, str2, back=.true.) == verify(chr1, chr2, back=.true.)) + if (allocated(error)) return + call check(error, verify(str1, chr2, back=.true.) == verify(chr1, chr2, back=.true.)) + if (allocated(error)) return + call check(error, verify(chr1, str2, back=.true.) == verify(chr1, chr2, back=.true.)) end subroutine gen_verify - subroutine test_verify + subroutine test_verify(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string integer :: pos string = "fortran" pos = verify(string, "ao") - call check(pos == 1) + call check(error, pos == 1) + if (allocated(error)) return pos = verify(string, "fo") - call check(pos == 3) + call check(error, pos == 3) + if (allocated(error)) return pos = verify(string, "c++") - call check(pos == 1) + call check(error, pos == 1) + if (allocated(error)) return pos = verify(string, "c++", back=.true.) - call check(pos == 7) + call check(error, pos == 7) + if (allocated(error)) return pos = verify(string, string) - call check(pos == 0) + call check(error, pos == 0) + if (allocated(error)) return - call check2("fortran", "ao", gen_verify) - call check2("c++", "fortran", gen_verify) + call check2(error, "fortran", "ao", gen_verify) + if (allocated(error)) return + call check2(error, "c++", "fortran", gen_verify) end subroutine test_verify !> Generator for the repeatition of a character sequence - subroutine gen_repeat(str1, chr1) + subroutine gen_repeat(error, str1, chr1) + !> Error handling + type(error_type), allocatable, intent(out) :: error type(string_type), intent(in) :: str1 character(len=*), intent(in) :: chr1 integer :: i do i = 12, 3, -2 - call check(repeat(str1, i) == repeat(chr1, i)) + call check(error, repeat(str1, i) == repeat(chr1, i)) + if (allocated(error)) return end do end subroutine gen_repeat - subroutine test_repeat + subroutine test_repeat(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string string = "What? " string = repeat(string, 3) - call check(string == "What? What? What? ") + call check(error, string == "What? What? What? ") + if (allocated(error)) return - call check1("!!1!", gen_repeat) - call check1("This sentence is repeated multiple times. ", gen_repeat) + call check1(error, "!!1!", gen_repeat) + if (allocated(error)) return + call check1(error, "This sentence is repeated multiple times. ", gen_repeat) end subroutine test_repeat !> Generator for checking the substring search in a character string - subroutine gen_index(str1, chr1, str2, chr2) + subroutine gen_index(error, str1, chr1, str2, chr2) + !> Error handling + type(error_type), allocatable, intent(out) :: error type(string_type), intent(in) :: str1, str2 character(len=*), intent(in) :: chr1, chr2 - call check(index(str1, str2) == index(chr1, chr2)) - call check(index(str1, chr2) == index(chr1, chr2)) - call check(index(chr1, str2) == index(chr1, chr2)) - call check(index(str1, str2, back=.true.) == index(chr1, chr2, back=.true.)) - call check(index(str1, chr2, back=.true.) == index(chr1, chr2, back=.true.)) - call check(index(chr1, str2, back=.true.) == index(chr1, chr2, back=.true.)) + call check(error, index(str1, str2) == index(chr1, chr2)) + if (allocated(error)) return + call check(error, index(str1, chr2) == index(chr1, chr2)) + if (allocated(error)) return + call check(error, index(chr1, str2) == index(chr1, chr2)) + if (allocated(error)) return + call check(error, index(str1, str2, back=.true.) == index(chr1, chr2, back=.true.)) + if (allocated(error)) return + call check(error, index(str1, chr2, back=.true.) == index(chr1, chr2, back=.true.)) + if (allocated(error)) return + call check(error, index(chr1, str2, back=.true.) == index(chr1, chr2, back=.true.)) end subroutine gen_index - subroutine test_index + subroutine test_index(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string integer :: pos string = "Search this string for this expression" pos = index(string, "this") - call check(pos == 8) + call check(error, pos == 8) + if (allocated(error)) return pos = index(string, "this", back=.true.) - call check(pos == 24) + call check(error, pos == 24) + if (allocated(error)) return pos = index(string, "This") - call check(pos == 0) + call check(error, pos == 0) + if (allocated(error)) return - call check2("Search this string for this expression", "this", gen_index) - call check2("Search this string for this expression", "This", gen_index) + call check2(error, "Search this string for this expression", "this", gen_index) + if (allocated(error)) return + call check2(error, "Search this string for this expression", "This", gen_index) end subroutine test_index - subroutine test_char + subroutine test_char(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string character(len=:), allocatable :: dlc character(len=1), allocatable :: chars(:) string = "Character sequence" dlc = char(string) - call check(dlc == "Character sequence") + call check(error, dlc == "Character sequence") + if (allocated(error)) return dlc = char(string, 3) - call check(dlc == "a") + call check(error, dlc == "a") + if (allocated(error)) return chars = char(string, [3, 5, 8, 12, 14, 15, 18]) - call check(all(chars == ["a", "a", "e", "e", "u", "e", "e"])) + call check(error, all(chars == ["a", "a", "e", "e", "u", "e", "e"])) + if (allocated(error)) return string = "Fortran" dlc = char(string, 1, 4) - call check(dlc == "Fort") + call check(error, dlc == "Fort") end subroutine test_char - subroutine test_ichar + subroutine test_ichar(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string integer :: code string = "Fortran" code = ichar(string) - call check(code == ichar("F")) + call check(error, code == ichar("F")) end subroutine test_ichar - subroutine test_iachar + subroutine test_iachar(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string integer :: code string = "Fortran" code = iachar(string) - call check(code == iachar("F")) + call check(error, code == iachar("F")) end subroutine test_iachar end module test_string_intrinsic + program tester - use test_string_intrinsic + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_string_intrinsic, only : collect_string_intrinsic implicit none - - call test_lgt - call test_llt - call test_lge - call test_lle - call test_trim - call test_len - call test_len_trim - call test_adjustl - call test_adjustr - call test_scan - call test_verify - call test_repeat - call test_index - call test_char - call test_ichar - call test_iachar - -end program tester + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("string-intrinsic", collect_string_intrinsic) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program diff --git a/src/tests/string/test_string_match.f90 b/src/tests/string/test_string_match.f90 index dd2c4b8c2..182d9270e 100644 --- a/src/tests/string/test_string_match.f90 +++ b/src/tests/string/test_string_match.f90 @@ -1,14 +1,27 @@ ! SPDX-Identifier: MIT -module test_match +module test_string_match + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_ascii, only : reverse - use stdlib_error, only : check use stdlib_strings, only : starts_with, ends_with use stdlib_string_type, only : string_type implicit none contains - subroutine check_starts_with(string, substring) + + !> Collect all exported unit tests + subroutine collect_string_match(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("starts_with", test_starts_with), & + new_unittest("ends_with", test_ends_with) & + ] + end subroutine collect_string_match + + subroutine check_starts_with(error, string, substring) + type(error_type), allocatable, intent(out) :: error character(len=*), intent(in) :: string character(len=*), intent(in) :: substring logical :: match @@ -21,20 +34,28 @@ subroutine check_starts_with(string, substring) message = "Incorrectly found that '"//string//"' starts with '"//substring//"'" end if - call check(starts_with(string, substring) .eqv. match, message) - call check(starts_with(string_type(string), substring) .eqv. match, message) - call check(starts_with(string, string_type(substring)) .eqv. match, message) - call check(starts_with(string_type(string), string_type(substring)) .eqv. match, message) + call check(error, starts_with(string, substring) .eqv. match, message) + if (allocated(error)) return + call check(error, starts_with(string_type(string), substring) .eqv. match, message) + if (allocated(error)) return + call check(error, starts_with(string, string_type(substring)) .eqv. match, message) + if (allocated(error)) return + call check(error, starts_with(string_type(string), string_type(substring)) .eqv. match, message) end subroutine check_starts_with - subroutine test_starts_with - call check_starts_with("pattern", "pat") - call check_starts_with("pat", "pattern") - call check_starts_with("pattern", "ern") - call check_starts_with("ern", "pattern") + subroutine test_starts_with(error) + type(error_type), allocatable, intent(out) :: error + call check_starts_with(error, "pattern", "pat") + if (allocated(error)) return + call check_starts_with(error, "pat", "pattern") + if (allocated(error)) return + call check_starts_with(error, "pattern", "ern") + if (allocated(error)) return + call check_starts_with(error, "ern", "pattern") end subroutine test_starts_with - subroutine check_ends_with(string, substring) + subroutine check_ends_with(error, string, substring) + type(error_type), allocatable, intent(out) :: error character(len=*), intent(in) :: string character(len=*), intent(in) :: substring logical :: match @@ -47,26 +68,51 @@ subroutine check_ends_with(string, substring) message = "Incorrectly found that '"//string//"' ends with '"//substring//"'" end if - call check(ends_with(string, substring) .eqv. match, message) - call check(ends_with(string_type(string), substring) .eqv. match, message) - call check(ends_with(string, string_type(substring)) .eqv. match, message) - call check(ends_with(string_type(string), string_type(substring)) .eqv. match, message) + call check(error, ends_with(string, substring) .eqv. match, message) + if (allocated(error)) return + call check(error, ends_with(string_type(string), substring) .eqv. match, message) + if (allocated(error)) return + call check(error, ends_with(string, string_type(substring)) .eqv. match, message) + if (allocated(error)) return + call check(error, ends_with(string_type(string), string_type(substring)) .eqv. match, message) end subroutine check_ends_with - subroutine test_ends_with - call check_ends_with("pattern", "pat") - call check_ends_with("pat", "pattern") - call check_ends_with("pattern", "ern") - call check_ends_with("ern", "pattern") + subroutine test_ends_with(error) + type(error_type), allocatable, intent(out) :: error + call check_ends_with(error, "pattern", "pat") + if (allocated(error)) return + call check_ends_with(error, "pat", "pattern") + if (allocated(error)) return + call check_ends_with(error, "pattern", "ern") + if (allocated(error)) return + call check_ends_with(error, "ern", "pattern") end subroutine test_ends_with -end module test_match +end module test_string_match + program tester - use test_match + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_string_match, only : collect_string_match implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("string-match", collect_string_match) & + ] - call test_starts_with - call test_ends_with + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do -end program tester + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program diff --git a/src/tests/string/test_string_operator.f90 b/src/tests/string/test_string_operator.f90 index f46c03121..f45029486 100644 --- a/src/tests/string/test_string_operator.f90 +++ b/src/tests/string/test_string_operator.f90 @@ -1,6 +1,6 @@ ! SPDX-Identifer: MIT module test_string_operator - use stdlib_error, only : check + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_string_type, only : string_type, assignment(=), len, & operator(>), operator(<), operator(>=), operator(<=), & operator(/=), operator(==), operator(//) @@ -8,116 +8,179 @@ module test_string_operator contains - subroutine test_gt + + !> Collect all exported unit tests + subroutine collect_string_operator(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("gt", test_gt), & + new_unittest("lt", test_lt), & + new_unittest("ge", test_ge), & + new_unittest("le", test_le), & + new_unittest("eq", test_eq), & + new_unittest("ne", test_ne), & + new_unittest("concat", test_concat) & + ] + end subroutine collect_string_operator + + subroutine test_gt(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string logical :: res string = "bcd" res = string > "abc" - call check(res .eqv. .true.) + call check(error, res .eqv. .true.) + if (allocated(error)) return res = string > "bcd" - call check(res .eqv. .false.) + call check(error, res .eqv. .false.) + if (allocated(error)) return res = string > "cde" - call check(res .eqv. .false.) + call check(error, res .eqv. .false.) end subroutine test_gt - subroutine test_lt + subroutine test_lt(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string logical :: res string = "bcd" res = string < "abc" - call check(res .eqv. .false.) + call check(error, res .eqv. .false.) + if (allocated(error)) return res = string < "bcd" - call check(res .eqv. .false.) + call check(error, res .eqv. .false.) + if (allocated(error)) return res = string < "cde" - call check(res .eqv. .true.) + call check(error, res .eqv. .true.) end subroutine test_lt - subroutine test_ge + subroutine test_ge(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string logical :: res string = "bcd" res = string >= "abc" - call check(res .eqv. .true.) + call check(error, res .eqv. .true.) + if (allocated(error)) return res = string >= "bcd" - call check(res .eqv. .true.) + call check(error, res .eqv. .true.) + if (allocated(error)) return res = string >= "cde" - call check(res .eqv. .false.) + call check(error, res .eqv. .false.) end subroutine test_ge - subroutine test_le + subroutine test_le(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string logical :: res string = "bcd" res = string <= "abc" - call check(res .eqv. .false.) + call check(error, res .eqv. .false.) + if (allocated(error)) return res = string <= "bcd" - call check(res .eqv. .true.) + call check(error, res .eqv. .true.) + if (allocated(error)) return res = string <= "cde" - call check(res .eqv. .true.) + call check(error, res .eqv. .true.) end subroutine test_le - subroutine test_eq + subroutine test_eq(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string logical :: res string = "bcd" res = string == "abc" - call check(res .eqv. .false.) + call check(error, res .eqv. .false.) + if (allocated(error)) return res = string == "bcd" - call check(res .eqv. .true.) + call check(error, res .eqv. .true.) + if (allocated(error)) return res = string == "cde" - call check(res .eqv. .false.) + call check(error, res .eqv. .false.) end subroutine test_eq - subroutine test_ne + subroutine test_ne(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string logical :: res string = "bcd" res = string /= "abc" - call check(res .eqv. .true.) + call check(error, res .eqv. .true.) + if (allocated(error)) return res = string /= "bcd" - call check(res .eqv. .false.) + call check(error, res .eqv. .false.) + if (allocated(error)) return res = string /= "cde" - call check(res .eqv. .true.) + call check(error, res .eqv. .true.) end subroutine test_ne - subroutine test_concat + subroutine test_concat(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(string_type) :: string string = "Hello, " string = string // "World!" - call check(len(string) == 13) + call check(error, len(string) == 13) end subroutine test_concat end module test_string_operator + program tester - use test_string_operator + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_string_operator, only : collect_string_operator implicit none - - call test_gt - call test_lt - call test_ge - call test_le - call test_eq - call test_ne - call test_concat - -end program tester + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("string-operator", collect_string_operator) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program diff --git a/src/tests/string/test_string_strip_chomp.f90 b/src/tests/string/test_string_strip_chomp.f90 index 5a0585bb7..f0a1dd1e3 100644 --- a/src/tests/string/test_string_strip_chomp.f90 +++ b/src/tests/string/test_string_strip_chomp.f90 @@ -1,110 +1,216 @@ ! SPDX-Identifier: MIT module test_strip_chomp use stdlib_ascii, only : TAB, VT, NUL, LF, CR, FF - use stdlib_error, only : check + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_strings, only : strip, chomp use stdlib_string_type, only : string_type, operator(==), operator(//) implicit none contains - subroutine test_strip_char - call check(strip(" hello ") == "hello") - call check(strip(TAB//"goodbye"//CR//LF) == "goodbye") - call check(strip(NUL//TAB//LF//VT//FF//CR) == NUL) - call check(strip(" "//TAB//LF//VT//FF//CR) == "") - call check(strip(" ! ")//"!" == "!!") - call check(strip("Hello") == "Hello") + + !> Collect all exported unit tests + subroutine collect_strip_chomp(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("strip_char", test_strip_char), & + new_unittest("strip_string", test_strip_string), & + new_unittest("chomp_char", test_chomp_char), & + new_unittest("chomp_string", test_chomp_string), & + new_unittest("chomp_set_char", test_chomp_set_char), & + new_unittest("chomp_set_string", test_chomp_set_string), & + new_unittest("chomp_substring_char", test_chomp_substring_char), & + new_unittest("chomp_substring_string", test_chomp_substring_string) & + ] + end subroutine collect_strip_chomp + + subroutine test_strip_char(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, strip(" hello ") == "hello") + if (allocated(error)) return + call check(error, strip(TAB//"goodbye"//CR//LF) == "goodbye") + if (allocated(error)) return + call check(error, strip(NUL//TAB//LF//VT//FF//CR) == NUL) + if (allocated(error)) return + call check(error, strip(" "//TAB//LF//VT//FF//CR) == "") + if (allocated(error)) return + call check(error, strip(" ! ")//"!" == "!!") + if (allocated(error)) return + call check(error, strip("Hello") == "Hello") end subroutine test_strip_char - subroutine test_strip_string - call check(strip(string_type(" hello ")) == "hello") - call check(strip(string_type(TAB//"goodbye"//CR//LF)) == "goodbye") - call check(strip(string_type(NUL//TAB//LF//VT//FF//CR)) == NUL) - call check(strip(string_type(" "//TAB//LF//VT//FF//CR)) == "") - call check(strip(string_type(" ! "))//"!" == "!!") - call check(strip(string_type("Hello")) == "Hello") + subroutine test_strip_string(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, strip(string_type(" hello ")) == "hello") + if (allocated(error)) return + call check(error, strip(string_type(TAB//"goodbye"//CR//LF)) == "goodbye") + if (allocated(error)) return + call check(error, strip(string_type(NUL//TAB//LF//VT//FF//CR)) == NUL) + if (allocated(error)) return + call check(error, strip(string_type(" "//TAB//LF//VT//FF//CR)) == "") + if (allocated(error)) return + call check(error, strip(string_type(" ! "))//"!" == "!!") + if (allocated(error)) return + call check(error, strip(string_type("Hello")) == "Hello") end subroutine test_strip_string - subroutine test_chomp_char - call check(chomp("hello") == "hello") - call check(chomp("hello"//LF) == "hello", "1") - call check(chomp("hello"//CR//LF) == "hello", "2") - call check(chomp("hello"//LF//CR) == "hello", "3") - call check(chomp("hello"//CR) == "hello", "4") - call check(chomp("hello "//LF//" there") == "hello "//LF//" there") - call check(chomp("hello"//CR//LF//CR//LF) == "hello") - call check(chomp("hello"//CR//LF//CR//CR//LF) == "hello") - call check(chomp(NUL//TAB//LF//VT//FF//CR) == NUL) - call check(chomp(" "//TAB//LF//VT//FF//CR) == "") - call check(chomp(" ! ")//"!" == " !!") + subroutine test_chomp_char(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, chomp("hello") == "hello") + if (allocated(error)) return + call check(error, chomp("hello"//LF) == "hello", "1") + if (allocated(error)) return + call check(error, chomp("hello"//CR//LF) == "hello", "2") + if (allocated(error)) return + call check(error, chomp("hello"//LF//CR) == "hello", "3") + if (allocated(error)) return + call check(error, chomp("hello"//CR) == "hello", "4") + if (allocated(error)) return + call check(error, chomp("hello "//LF//" there") == "hello "//LF//" there") + if (allocated(error)) return + call check(error, chomp("hello"//CR//LF//CR//LF) == "hello") + if (allocated(error)) return + call check(error, chomp("hello"//CR//LF//CR//CR//LF) == "hello") + if (allocated(error)) return + call check(error, chomp(NUL//TAB//LF//VT//FF//CR) == NUL) + if (allocated(error)) return + call check(error, chomp(" "//TAB//LF//VT//FF//CR) == "") + if (allocated(error)) return + call check(error, chomp(" ! ")//"!" == " !!") end subroutine test_chomp_char - subroutine test_chomp_string - call check(chomp(string_type("hello")) == "hello") - call check(chomp(string_type("hello"//LF)) == "hello") - call check(chomp(string_type("hello"//CR//LF)) == "hello") - call check(chomp(string_type("hello"//LF//CR)) == "hello") - call check(chomp(string_type("hello"//CR)) == "hello") - call check(chomp(string_type("hello "//LF//" there")) == "hello "//LF//" there") - call check(chomp(string_type("hello"//CR//LF//CR//LF)) == "hello") - call check(chomp(string_type("hello"//CR//LF//CR//CR//LF)) == "hello") - call check(chomp(string_type(NUL//TAB//LF//VT//FF//CR)) == NUL) - call check(chomp(string_type(" "//TAB//LF//VT//FF//CR)) == "") - call check(chomp(string_type(" ! "))//"!" == " !!") + subroutine test_chomp_string(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, chomp(string_type("hello")) == "hello") + if (allocated(error)) return + call check(error, chomp(string_type("hello"//LF)) == "hello") + if (allocated(error)) return + call check(error, chomp(string_type("hello"//CR//LF)) == "hello") + if (allocated(error)) return + call check(error, chomp(string_type("hello"//LF//CR)) == "hello") + if (allocated(error)) return + call check(error, chomp(string_type("hello"//CR)) == "hello") + if (allocated(error)) return + call check(error, chomp(string_type("hello "//LF//" there")) == "hello "//LF//" there") + if (allocated(error)) return + call check(error, chomp(string_type("hello"//CR//LF//CR//LF)) == "hello") + if (allocated(error)) return + call check(error, chomp(string_type("hello"//CR//LF//CR//CR//LF)) == "hello") + if (allocated(error)) return + call check(error, chomp(string_type(NUL//TAB//LF//VT//FF//CR)) == NUL) + if (allocated(error)) return + call check(error, chomp(string_type(" "//TAB//LF//VT//FF//CR)) == "") + if (allocated(error)) return + call check(error, chomp(string_type(" ! "))//"!" == " !!") end subroutine test_chomp_string - subroutine test_chomp_set_char - call check(chomp("hello", ["l", "o"]) == "he") - call check(chomp("hello", set=["l", "o"]) == "he") + subroutine test_chomp_set_char(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, chomp("hello", ["l", "o"]) == "he") + if (allocated(error)) return + call check(error, chomp("hello", set=["l", "o"]) == "he") end subroutine test_chomp_set_char - subroutine test_chomp_set_string - call check(chomp(string_type("hello"), ["l", "o"]) == "he") - call check(chomp(string_type("hello"), set=["l", "o"]) == "he") - call check(chomp("hellooooo", ["o", "o"]) == "hell") - call check(chomp("hellooooo", set=["o", "o"]) == "hell") + subroutine test_chomp_set_string(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, chomp(string_type("hello"), ["l", "o"]) == "he") + if (allocated(error)) return + call check(error, chomp(string_type("hello"), set=["l", "o"]) == "he") + if (allocated(error)) return + call check(error, chomp("hellooooo", ["o", "o"]) == "hell") + if (allocated(error)) return + call check(error, chomp("hellooooo", set=["o", "o"]) == "hell") end subroutine test_chomp_set_string - subroutine test_chomp_substring_char - call check(chomp("hello", "") == "hello") - call check(chomp("hello", substring="") == "hello") - call check(chomp("hello", "lo") == "hel") - call check(chomp("hello", substring="lo") == "hel") - call check(chomp("hellooooo", "oo") == "hello") - call check(chomp("hellooooo", substring="oo") == "hello") + subroutine test_chomp_substring_char(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, chomp("hello", "") == "hello") + if (allocated(error)) return + call check(error, chomp("hello", substring="") == "hello") + if (allocated(error)) return + call check(error, chomp("hello", "lo") == "hel") + if (allocated(error)) return + call check(error, chomp("hello", substring="lo") == "hel") + if (allocated(error)) return + call check(error, chomp("hellooooo", "oo") == "hello") + if (allocated(error)) return + call check(error, chomp("hellooooo", substring="oo") == "hello") end subroutine test_chomp_substring_char - subroutine test_chomp_substring_string - call check(chomp(string_type("hello"), "") == "hello") - call check(chomp(string_type("hello"), substring="") == "hello") - call check(chomp(string_type("hello"), "lo") == "hel") - call check(chomp(string_type("hello"), substring="lo") == "hel") - call check(chomp("hello", string_type("lo")) == "hel") - call check(chomp("hello", substring=string_type("lo")) == "hel") - call check(chomp(string_type("hello"), string_type("lo")) == "hel") - call check(chomp(string_type("hello"), substring=string_type("lo")) == "hel") - call check(chomp(string_type("hellooooo"), "oo") == "hello") - call check(chomp(string_type("hellooooo"), substring="oo") == "hello") - call check(chomp("hellooooo", string_type("oo")) == "hello") - call check(chomp("hellooooo", substring=string_type("oo")) == "hello") - call check(chomp(string_type("hellooooo"), string_type("oo")) == "hello") - call check(chomp(string_type("hellooooo"), substring=string_type("oo")) == "hello") + subroutine test_chomp_substring_string(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, chomp(string_type("hello"), "") == "hello") + if (allocated(error)) return + call check(error, chomp(string_type("hello"), substring="") == "hello") + if (allocated(error)) return + call check(error, chomp(string_type("hello"), "lo") == "hel") + if (allocated(error)) return + call check(error, chomp(string_type("hello"), substring="lo") == "hel") + if (allocated(error)) return + call check(error, chomp("hello", string_type("lo")) == "hel") + if (allocated(error)) return + call check(error, chomp("hello", substring=string_type("lo")) == "hel") + if (allocated(error)) return + call check(error, chomp(string_type("hello"), string_type("lo")) == "hel") + if (allocated(error)) return + call check(error, chomp(string_type("hello"), substring=string_type("lo")) == "hel") + if (allocated(error)) return + call check(error, chomp(string_type("hellooooo"), "oo") == "hello") + if (allocated(error)) return + call check(error, chomp(string_type("hellooooo"), substring="oo") == "hello") + if (allocated(error)) return + call check(error, chomp("hellooooo", string_type("oo")) == "hello") + if (allocated(error)) return + call check(error, chomp("hellooooo", substring=string_type("oo")) == "hello") + if (allocated(error)) return + call check(error, chomp(string_type("hellooooo"), string_type("oo")) == "hello") + if (allocated(error)) return + call check(error, chomp(string_type("hellooooo"), substring=string_type("oo")) == "hello") end subroutine test_chomp_substring_string end module test_strip_chomp + program tester - use test_strip_chomp + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_strip_chomp, only : collect_strip_chomp implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("strip-chomp", collect_strip_chomp) & + ] - call test_strip_char - call test_strip_string - call test_chomp_char - call test_chomp_string - call test_chomp_set_char - call test_chomp_set_string - call test_chomp_substring_char - call test_chomp_substring_string + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do -end program tester + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program diff --git a/src/tests/string/test_string_to_string.f90 b/src/tests/string/test_string_to_string.f90 index 15bfb7531..53843c4c6 100644 --- a/src/tests/string/test_string_to_string.f90 +++ b/src/tests/string/test_string_to_string.f90 @@ -1,14 +1,29 @@ ! SPDX-Identifier: MIT module test_string_to_string - + use stdlib_strings, only: to_string, starts_with - use stdlib_error, only: check + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_optval, only: optval implicit none contains - subroutine check_formatter(actual, expected, description, partial) + + !> Collect all exported unit tests + subroutine collect_string_to_string(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("to_string-complex", test_to_string_complex), & + new_unittest("to_string-integer", test_to_string_integer), & + new_unittest("to_string-logical", test_to_string_logical), & + new_unittest("to_string-real", test_to_string_real) & + ] + end subroutine collect_string_to_string + + subroutine check_formatter(error, actual, expected, description, partial) + type(error_type), allocatable, intent(out) :: error character(len=*), intent(in) :: actual, expected, description logical, intent(in), optional :: partial logical :: stat @@ -27,87 +42,135 @@ subroutine check_formatter(actual, expected, description, partial) print '(" - ", a, /, " Result: ''", a, "''")', description, actual end if - call check(stat, msg) + call check(error, stat, msg) end subroutine check_formatter - subroutine test_to_string_complex - call check_formatter(to_string((1, 1)), "(1.0", & - & "Default formatter for complex number", partial=.true.) - call check_formatter(to_string((1, 1), '(F6.2)'), "( 1.00, 1.00)", & - & "Formatter for complex number") - call check_formatter(to_string((-1, -1), 'F6.2'), "( -1.00, -1.00)", & - & "Formatter for negative complex number") - call check_formatter(to_string((1, 1), 'SP,F6.2'), "( +1.00, +1.00)", & - & "Formatter with sign control descriptor for complex number") - call check_formatter(to_string((1, 1), 'F6.2') // to_string((2, 2), '(F7.3)'), & - & "( 1.00, 1.00)( 2.000, 2.000)", & - & "Multiple formatters for complex numbers") + subroutine test_to_string_complex(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check_formatter(error, to_string((1, 1)), "(1.0", & + & "Default formatter for complex number", partial=.true.) + if (allocated(error)) return + call check_formatter(error, to_string((1, 1), '(F6.2)'), "( 1.00, 1.00)", & + & "Formatter for complex number") + if (allocated(error)) return + call check_formatter(error, to_string((-1, -1), 'F6.2'), "( -1.00, -1.00)", & + & "Formatter for negative complex number") + if (allocated(error)) return + call check_formatter(error, to_string((1, 1), 'SP,F6.2'), "( +1.00, +1.00)", & + & "Formatter with sign control descriptor for complex number") + if (allocated(error)) return + call check_formatter(error, to_string((1, 1), 'F6.2') // to_string((2, 2), '(F7.3)'), & + & "( 1.00, 1.00)( 2.000, 2.000)", & + & "Multiple formatters for complex numbers") end subroutine test_to_string_complex - subroutine test_to_string_integer - call check_formatter(to_string(100), "100", & - & "Default formatter for integer number") - call check_formatter(to_string(100, 'I6'), " 100", & - & "Formatter for integer number") - call check_formatter(to_string(100, 'I0.6'), "000100", & - & "Formatter with zero padding for integer number") - call check_formatter(to_string(100, 'I6') // to_string(1000, '(I7)'), & - & " 100 1000", "Multiple formatters for integers") - call check_formatter(to_string(34, 'B8'), " 100010", & - & "Binary formatter for integer number") - call check_formatter(to_string(34, 'O0.3'), "042", & - & "Octal formatter with zero padding for integer number") - call check_formatter(to_string(34, 'Z3'), " 22", & - & "Hexadecimal formatter for integer number") + subroutine test_to_string_integer(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check_formatter(error, to_string(100), "100", & + & "Default formatter for integer number") + if (allocated(error)) return + call check_formatter(error, to_string(100, 'I6'), " 100", & + & "Formatter for integer number") + if (allocated(error)) return + call check_formatter(error, to_string(100, 'I0.6'), "000100", & + & "Formatter with zero padding for integer number") + if (allocated(error)) return + call check_formatter(error, to_string(100, 'I6') // to_string(1000, '(I7)'), & + & " 100 1000", "Multiple formatters for integers") + if (allocated(error)) return + call check_formatter(error, to_string(34, 'B8'), " 100010", & + & "Binary formatter for integer number") + if (allocated(error)) return + call check_formatter(error, to_string(34, 'O0.3'), "042", & + & "Octal formatter with zero padding for integer number") + if (allocated(error)) return + call check_formatter(error, to_string(34, 'Z3'), " 22", & + & "Hexadecimal formatter for integer number") end subroutine test_to_string_integer - subroutine test_to_string_real - call check_formatter(to_string(100.), "100.0", & - & "Default formatter for real number", partial=.true.) - call check_formatter(to_string(100., 'F6.2'), "100.00", & - & "Formatter for real number") - call check_formatter(to_string(289., 'E7.2'), ".29E+03", & - & "Exponential formatter with rounding for real number") - call check_formatter(to_string(128., 'ES8.2'), "1.28E+02", & - & "Exponential formatter for real number") - - ! Wrong demonstration - call check_formatter(to_string(-100., 'F6.2'), "*", & - & "Too narrow formatter for signed real number", partial=.true.) - call check_formatter(to_string(1000., 'F6.3'), "*", & - & "Too narrow formatter for real number", partial=.true.) - call check_formatter(to_string(1000., '7.3'), "[*]", & - & "Invalid formatter for real number", partial=.true.) + subroutine test_to_string_real(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check_formatter(error, to_string(100.), "100.0", & + & "Default formatter for real number", partial=.true.) + if (allocated(error)) return + call check_formatter(error, to_string(100., 'F6.2'), "100.00", & + & "Formatter for real number") + if (allocated(error)) return + call check_formatter(error, to_string(289., 'E7.2'), ".29E+03", & + & "Exponential formatter with rounding for real number") + if (allocated(error)) return + call check_formatter(error, to_string(128., 'ES8.2'), "1.28E+02", & + & "Exponential formatter for real number") + if (allocated(error)) return + + ! Wrong demonstration + call check_formatter(error, to_string(-100., 'F6.2'), "*", & + & "Too narrow formatter for signed real number", partial=.true.) + if (allocated(error)) return + call check_formatter(error, to_string(1000., 'F6.3'), "*", & + & "Too narrow formatter for real number", partial=.true.) + if (allocated(error)) return + call check_formatter(error, to_string(1000., '7.3'), "[*]", & + & "Invalid formatter for real number", partial=.true.) + if (allocated(error)) return end subroutine test_to_string_real - subroutine test_to_string_logical - call check_formatter(to_string(.true.), "T", & - & "Default formatter for logcal value") - call check_formatter(to_string(.true., 'L2'), " T", & - & "Formatter for logical value") - call check_formatter(to_string(.false., 'L2') // to_string(.true., '(L5)'), & - & " F T", "Multiple formatters for logical values") + subroutine test_to_string_logical(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - ! Wrong demonstration - call check_formatter(to_string(.false., '1x'), "[*]", & - & "Invalid formatter for logical value", partial=.true.) + call check_formatter(error, to_string(.true.), "T", & + & "Default formatter for logcal value") + if (allocated(error)) return + call check_formatter(error, to_string(.true., 'L2'), " T", & + & "Formatter for logical value") + if (allocated(error)) return + call check_formatter(error, to_string(.false., 'L2') // to_string(.true., '(L5)'), & + & " F T", "Multiple formatters for logical values") + if (allocated(error)) return + + ! Wrong demonstration + call check_formatter(error, to_string(.false., '1x'), "[*]", & + & "Invalid formatter for logical value", partial=.true.) end subroutine test_to_string_logical end module test_string_to_string + program tester - use test_string_to_string + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_string_to_string, only : collect_string_to_string implicit none - - call test_to_string_complex - call test_to_string_integer - call test_to_string_logical - call test_to_string_real - -end program tester + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("string-to_string", collect_string_to_string) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program From dec1f12dd4c2fca00ea39d28937954a6b7fed74d Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Tue, 24 Aug 2021 23:50:08 +0200 Subject: [PATCH 10/34] Fix test conditions for stdlib_bitset_large tests --- .../bitsets/test_stdlib_bitset_large.f90 | 26 +++++++------------ 1 file changed, 9 insertions(+), 17 deletions(-) diff --git a/src/tests/bitsets/test_stdlib_bitset_large.f90 b/src/tests/bitsets/test_stdlib_bitset_large.f90 index dd6a9f899..4e96735a3 100644 --- a/src/tests/bitsets/test_stdlib_bitset_large.f90 +++ b/src/tests/bitsets/test_stdlib_bitset_large.f90 @@ -206,7 +206,7 @@ subroutine test_io(error) call set3 % read_bitset(unit) call set5 % read_bitset(unit) call set4 % read_bitset(unit) - call check(error, set4 /= set0 .or. set5 /= set1 .or. set3 /= set2, & + call check(error, set4 == set0 .and. set5 == set1 .and. set3 == set2, & 'transfer to and from units using bitset literals failed.') if (.not.allocated(error)) then @@ -223,7 +223,7 @@ subroutine test_io(error) call set13 % read_bitset(unit) call set15 % read_bitset(unit) call set14 % read_bitset(unit) - call check(error, set14 /= set10 .or. set15 /= set11 .or. set3 /= set12, & + call check(error, set14 == set10 .and. set15 == set11 .and. set3 == set12, & 'transfer to and from units using bitset literals for bits > 64 failed.') end if if (.not.allocated(error)) then @@ -237,7 +237,7 @@ subroutine test_io(error) call set3 % read_bitset(unit, advance='no') call set4 % read_bitset(unit, advance='no') call set5 % read_bitset(unit) - call check(error, set5 /= set0 .or. set4 /= set1 .or. set3 /= set2, & + call check(error, set5 == set0 .and. set4 == set1 .and. set3 == set2, & 'transfer to and from units using bitset literals with advance == "no" failed.') end if if (.not.allocated(error)) then @@ -251,7 +251,7 @@ subroutine test_io(error) call set13 % read_bitset(unit, advance='no') call set14 % read_bitset(unit, advance='no') call set15 % read_bitset(unit) - call check(error, set15 /= set10 .or. set14 /= set11 .or. set13 /= set12, & + call check(error, set15 == set10 .and. set14 == set11 .and. set13 == set12, & 'transfer to and from units using bitset literals for bitss > 64 with advance == "no" failed.') end if @@ -267,7 +267,7 @@ subroutine test_io(error) call set5 % input(unit) call set4 % input(unit) call set3 % input(unit) - call check(error, set3 /= set0 .or. set4 /= set1 .or. set5 /= set2, & + call check(error, set3 == set0 .and. set4 == set1 .and. set5 == set2, & 'transfer to and from units using output and input failed.') close( unit ) @@ -282,7 +282,7 @@ subroutine test_io(error) call set5 % input(unit) call set4 % input(unit) call set3 % input(unit) - call check(error, set3 /= set0 .or. set4 /= set1 .or. set5 /= set2, & + call check(error, set3 == set0 .and. set4 == set1 .and. set5 == set2, & 'transfer to and from units using stream output and input failed.') close( unit ) @@ -297,7 +297,7 @@ subroutine test_io(error) call set15 % input(unit) call set14 % input(unit) call set13 % input(unit) - call check(error, set13 /= set10 .or. set14 /= set11 .or. set15 /= set12, & + call check(error, set13 == set10 .and. set14 == set11 .and. set15 == set12, & 'transfer to and from units using output and input failed for bits . 64.') close(unit) if (allocated(error)) return @@ -311,7 +311,7 @@ subroutine test_io(error) call set15 % input(unit) call set14 % input(unit) call set13 % input(unit) - call check(error, set13 /= set10 .or. set14 /= set11 .or. set15 /= set12, & + call check(error, set13 == set10 .and. set14 == set11 .and. set15 == set12, & 'transfer to and from units using stream output and input failed for bits . 64.') close(unit) if (allocated(error)) return @@ -594,32 +594,24 @@ subroutine test_bitset_inquiry(error) if (allocated(error)) return end do - write(*,*) 'As expected set0 had no bits set.' - do i=0, set1 % bits() - 1 call check(error, set1 % test(i), & 'against expectations set0 has at least 1 bit unset.') if (allocated(error)) return end do - write(*,*) 'As expected set1 had all bits set.' - do i=0, set0 % bits() - 1 call check(error, set0 % value(i), 0, & 'against expectations set0 has at least 1 bit set.') if (allocated(error)) return end do - write(*,*) 'As expected set0 had no bits set.' - do i=0, set1 % bits() - 1 call check(error, set1 % value(i), 1, & 'against expectations set0 has at least 1 bit unset.') if (allocated(error)) return end do - write(*,*) 'As expected set1 had all bits set.' - call check(error, set0 % bits() == 33, & 'set0 unexpectedly does not have 33 bits.') if (allocated(error)) return @@ -750,7 +742,7 @@ subroutine test_bit_operations(error) call set11 % init( 166_bits_kind ) call set11 % not() - call check(error, .not. set11 % all(), & + call check(error, set11 % all(), & 'set11 is not all set.') if (allocated(error)) return From 5a0a0086e919b581e8eb7c69b78286982cb4bbfc Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Thu, 26 Aug 2021 11:04:26 +0200 Subject: [PATCH 11/34] Add test_mean_f03 + update makefile --- src/tests/stats/CMakeLists.txt | 1 + src/tests/stats/Makefile.manual | 1 + src/tests/stats/test_mean_f03.f90 | 55 ------ src/tests/stats/test_mean_f03.fypp | 302 +++++++++++++++++++++++++++++ 4 files changed, 304 insertions(+), 55 deletions(-) delete mode 100644 src/tests/stats/test_mean_f03.f90 create mode 100644 src/tests/stats/test_mean_f03.fypp diff --git a/src/tests/stats/CMakeLists.txt b/src/tests/stats/CMakeLists.txt index ce27497b0..22b857759 100644 --- a/src/tests/stats/CMakeLists.txt +++ b/src/tests/stats/CMakeLists.txt @@ -3,6 +3,7 @@ # Create a list of the files to be preprocessed set(fppFiles test_mean.fypp + test_mean_f03.fypp test_median.fypp ) diff --git a/src/tests/stats/Makefile.manual b/src/tests/stats/Makefile.manual index 55a21c5f4..56ccb95b4 100644 --- a/src/tests/stats/Makefile.manual +++ b/src/tests/stats/Makefile.manual @@ -1,4 +1,5 @@ SRCFYPP =\ + test_mean.fypp \ test_median.fypp SRCGEN = $(SRCFYPP:.fypp=.f90) diff --git a/src/tests/stats/test_mean_f03.f90 b/src/tests/stats/test_mean_f03.f90 deleted file mode 100644 index 6ff8d997e..000000000 --- a/src/tests/stats/test_mean_f03.f90 +++ /dev/null @@ -1,55 +0,0 @@ -program test_mean -use stdlib_error, only: check -use stdlib_kinds, only: sp, dp, int32 -use stdlib_io, only: loadtxt -use stdlib_stats, only: mean -implicit none - -real(dp), parameter :: dptol =10 * epsilon(1._dp) - -real(dp), allocatable :: d(:, :) -real(dp), allocatable :: d8(:, :, :, :, :, :, :, :) -complex(dp), allocatable :: cd8(:, :, :, :, :, :, :, :) - - -!dp -call loadtxt("array3.dat", d) - -call check( mean(d) - sum(d)/real(size(d), dp) < dptol) -call check( sum( abs( mean(d,1) - sum(d,1)/real(size(d,1), dp) )) < dptol) -call check( sum( abs( mean(d,2) - sum(d,2)/real(size(d,2), dp) )) < dptol) - -!dp rank 8 -allocate(d8(size(d,1), size(d,2), 3, 4, 5, 6, 7, 8), source=0.0_dp) -d8(:, :, 1, 4, 5 ,6 ,7 ,8)=d; -d8(:, :, 2, 4, 5 ,6 ,7 ,8)=d * 1.5_dp; -d8(:, :, 3, 4, 5 ,6 ,7 ,8)=d * 4._dp; - -call check( mean(d8) - sum(d8)/real(size(d8), dp) < dptol) - -call check( sum( abs( mean(d8,1) - sum(d8,1)/real(size(d8,1), dp) )) < dptol) -call check( sum( abs( mean(d8,2) - sum(d8,2)/real(size(d8,2), dp) )) < dptol) -call check( sum( abs( mean(d8,3) - sum(d8,3)/real(size(d8,3), dp) )) < dptol) -call check( sum( abs( mean(d8,4) - sum(d8,4)/real(size(d8,4), dp) )) < dptol) -call check( sum( abs( mean(d8,5) - sum(d8,5)/real(size(d8,5), dp) )) < dptol) -call check( sum( abs( mean(d8,6) - sum(d8,6)/real(size(d8,6), dp) )) < dptol) -call check( sum( abs( mean(d8,7) - sum(d8,7)/real(size(d8,7), dp) )) < dptol) -call check( sum( abs( mean(d8,8) - sum(d8,8)/real(size(d8,8), dp) )) < dptol) - -!cdp rank 8 -allocate(cd8(size(d,1), size(d,2), 3, 4, 5, 6, 7, 8)) -cd8 = cmplx(1._dp, 1._dp, kind=dp)*d8 - -call check( abs(mean(cd8) - sum(cd8)/real(size(cd8), dp)) < dptol) - -call check( sum( abs( mean(cd8,1) - sum(cd8,1)/real(size(cd8,1), dp) )) < dptol) -call check( sum( abs( mean(cd8,2) - sum(cd8,2)/real(size(cd8,2), dp) )) < dptol) -call check( sum( abs( mean(cd8,3) - sum(cd8,3)/real(size(cd8,3), dp) )) < dptol) -call check( sum( abs( mean(cd8,4) - sum(cd8,4)/real(size(cd8,4), dp) )) < dptol) -call check( sum( abs( mean(cd8,5) - sum(cd8,5)/real(size(cd8,5), dp) )) < dptol) -call check( sum( abs( mean(cd8,6) - sum(cd8,6)/real(size(cd8,6), dp) )) < dptol) -call check( sum( abs( mean(cd8,7) - sum(cd8,7)/real(size(cd8,7), dp) )) < dptol) -call check( sum( abs( mean(cd8,8) - sum(cd8,8)/real(size(cd8,8), dp) )) < dptol) -contains - -end program diff --git a/src/tests/stats/test_mean_f03.fypp b/src/tests/stats/test_mean_f03.fypp new file mode 100644 index 000000000..d040bba38 --- /dev/null +++ b/src/tests/stats/test_mean_f03.fypp @@ -0,0 +1,302 @@ +#:include "common.fypp" +#:set IR_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES + +#:set NRANK = 4 + +module test_stats_meanf03 + use stdlib_test, only : new_unittest, unittest_type, error_type, check + use stdlib_stats, only: mean + use stdlib_kinds, only : int8, int16, int32, int64, sp, dp, qp + use, intrinsic :: ieee_arithmetic, only : ieee_is_nan + implicit none + private + + public :: collect_stats_meanf03 + + real(sp), parameter :: sptol = 1000 * epsilon(1._sp) + real(dp), parameter :: dptol = 2000 * epsilon(1._dp) + real(qp), parameter :: qptol = 2000 * epsilon(1._qp) + + #:for k1,t1 in IR_KINDS_TYPES + ${t1}$ , parameter :: d1_${k1}$(18) = [-10, 2, 3, 4, -6, 6, -7, 8, 9, 4, 1, -20, 9, 10, 14, 15, 40, 30] + ${t1}$ :: d8_${k1}$(2, 3, 4, 2, 3, 4, 2, 3) = reshape(d1_${k1}$, [2, 3, 4, 2, 3, 4, 2, 3], [${t1}$:: 3]) + #:endfor + + #:for k1,t1 in CMPLX_KINDS_TYPES + ${t1}$ , parameter :: d1_c${k1}$(18) = d1_${k1}$ + ${t1}$ :: d8_c${k1}$(2, 3, 4, 2, 3, 4, 2, 3) = reshape(d1_c${k1}$, [2, 3, 4, 2, 3, 4, 2, 3], [${t1}$:: 3]) + #:endfor + +contains + + !> Collect all exported unit tests + subroutine collect_stats_meanf03(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("test_stats_meanf03_all_int8", test_stats_meanf03_all_int8) & + #:for k1,t1 in IR_KINDS_TYPES + ,new_unittest("test_stats_meanf03_all_${k1}$", test_stats_meanf03_all_${k1}$) & + , new_unittest("test_stats_meanf03_all_optmask_${k1}$", test_stats_meanf03_all_optmask_${k1}$) & + , new_unittest("test_stats_meanf03_${k1}$", test_stats_meanf03_${k1}$) & + , new_unittest("test_stats_meanf03_optmask_${k1}$", test_stats_meanf03_optmask_${k1}$) & + , new_unittest("test_stats_meanf03_mask_all_${k1}$", test_stats_meanf03_mask_all_${k1}$) & + , new_unittest("test_stats_meanf03_mask_${k1}$", test_stats_meanf03_mask_${k1}$) & + #:endfor + #:for k1,t1 in CMPLX_KINDS_TYPES + ,new_unittest("test_stats_meanf03_all_c${k1}$", test_stats_meanf03_all_c${k1}$) & + , new_unittest("test_stats_meanf03_all_optmask_c${k1}$", test_stats_meanf03_all_optmask_c${k1}$) & + , new_unittest("test_stats_meanf03_c${k1}$", test_stats_meanf03_c${k1}$) & + , new_unittest("test_stats_meanf03_optmask_c${k1}$", test_stats_meanf03_optmask_c${k1}$) & + , new_unittest("test_stats_meanf03_mask_all_c${k1}$", test_stats_meanf03_mask_all_c${k1}$) & + , new_unittest("test_stats_meanf03_mask_c${k1}$", test_stats_meanf03_mask_c${k1}$) & + #:endfor + ] + end subroutine collect_stats_meanf03 + + #:for k1,t1 in INT_KINDS_TYPES + subroutine test_stats_meanf03_all_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, mean(d8_${k1}$), sum(real(d8_${k1}$, dp))/real(size(d8_${k1}$), dp)& + , 'mean(d8_${k1}$): uncorrect answer'& + , thr = dptol) + if (allocated(error)) return + end subroutine + + subroutine test_stats_meanf03_all_optmask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(mean(d8_${k1}$, .false.))& + , 'mean(d8_${k1}$, .false.): uncorrect answer') + if (allocated(error)) return + end subroutine + + subroutine test_stats_meanf03_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + #:for dim in range(1, 9) + call check(error& + , sum(abs(mean(d8_${k1}$, ${dim}$) -& + sum(real(d8_${k1}$, dp), ${dim}$)/real(size(d8_${k1}$, ${dim}$), dp))) < dptol& + , 'mean(d8_${k1}$, ${dim}$): uncorrect answer'& + ) + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_meanf03_optmask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(mean(d1_${k1}$, 1, .false.))& + , 'mean(d1_${k1}$, 1, .false.): uncorrect answer'& + ) + if (allocated(error)) return + + #:for dim in range(1, 9) + call check(error, any(ieee_is_nan(mean(d8_${k1}$, ${dim}$, .false.)))& + , 'mean(d8_${k1}$, ${dim}$, .false.): uncorrect answer') + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_meanf03_mask_all_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, mean(d8_${k1}$, d8_${k1}$ > 0)& + , sum(real(d8_${k1}$, dp), d8_${k1}$ > 0)/real(count(d8_${k1}$ > 0), dp)& + , 'mean(d8_${k1}$, d8_${k1}$ > 0): uncorrect answer'& + , thr = dptol) + if (allocated(error)) return + end subroutine + + subroutine test_stats_meanf03_mask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + #:for dim in range(1, 9) + call check(error& + , sum(abs(mean(d8_${k1}$, ${dim}$, d8_${k1}$ > 0) -& + sum(real(d8_${k1}$, dp), ${dim}$, d8_${k1}$ > 0)/real(count(d8_${k1}$ > 0, ${dim}$), dp))) < dptol& + , 'mean(d8_${k1}$, ${dim}$, d8_${k1}$ > 0): uncorrect answer'& + ) + if (allocated(error)) return + #:endfor + end subroutine + #:endfor + + #:for k1,t1 in REAL_KINDS_TYPES + subroutine test_stats_meanf03_all_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, mean(d8_${k1}$), sum(d8_${k1}$)/real(size(d8_${k1}$), ${k1}$)& + , 'mean(d8_${k1}$): uncorrect answer'& + , thr = ${k1}$tol) + if (allocated(error)) return + end subroutine + + subroutine test_stats_meanf03_all_optmask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(mean(d8_${k1}$, .false.))& + , 'mean(d8_${k1}$, .false.): uncorrect answer') + if (allocated(error)) return + end subroutine + + subroutine test_stats_meanf03_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + #:for dim in range(1, 9) + call check(error& + , sum(abs(mean(d8_${k1}$, ${dim}$) -& + sum(d8_${k1}$, ${dim}$)/real(size(d8_${k1}$, ${dim}$), ${k1}$))) < ${k1}$tol& + , 'mean(d8_${k1}$, ${dim}$): uncorrect answer'& + ) + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_meanf03_optmask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + #:for dim in range(1, 9) + call check(error, any(ieee_is_nan(mean(d8_${k1}$, ${dim}$, .false.)))& + , 'mean(d8_${k1}$, ${dim}$, .false.): uncorrect answer') + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_meanf03_mask_all_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, mean(d8_${k1}$, d8_${k1}$ > 0)& + , sum(d8_${k1}$, d8_${k1}$ > 0)/real(count(d8_${k1}$ > 0), ${k1}$)& + , 'mean(d8_${k1}$, d8_${k1}$ > 0): uncorrect answer'& + , thr = ${k1}$tol) + if (allocated(error)) return + end subroutine + + subroutine test_stats_meanf03_mask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + #:for dim in range(1, 9) + call check(error& + , sum(abs(mean(d8_${k1}$, ${dim}$, d8_${k1}$ > 0) -& + sum(d8_${k1}$, ${dim}$, d8_${k1}$ > 0)/real(count(d8_${k1}$ > 0, ${dim}$), ${k1}$))) < ${k1}$tol& + , 'mean(d8_${k1}$, ${dim}$, d8_${k1}$ > 0): uncorrect answer'& + ) + if (allocated(error)) return + #:endfor + end subroutine + #:endfor + + #:for k1,t1 in CMPLX_KINDS_TYPES + subroutine test_stats_meanf03_all_c${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, mean(d8_c${k1}$), sum(d8_c${k1}$)/real(size(d8_c${k1}$), ${k1}$)& + , 'mean(d8_c${k1}$): uncorrect answer'& + , thr = ${k1}$tol) + if (allocated(error)) return + end subroutine + + subroutine test_stats_meanf03_all_optmask_c${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(real(mean(d8_c${k1}$, .false.)))& + , 'mean(d8_c${k1}$, .false.): uncorrect answer') + if (allocated(error)) return + end subroutine + + subroutine test_stats_meanf03_c${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + #:for dim in range(1, 9) + call check(error& + , sum(abs(mean(d8_c${k1}$, ${dim}$) -& + sum(d8_c${k1}$, ${dim}$)/real(size(d8_c${k1}$, ${dim}$), ${k1}$))) < ${k1}$tol& + , 'mean(d8_c${k1}$, ${dim}$): uncorrect answer'& + ) + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_meanf03_optmask_c${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + #:for dim in range(1, 9) + call check(error, any(ieee_is_nan(real(mean(d8_c${k1}$, ${dim}$, .false.))))& + , 'mean(d8_c${k1}$, ${dim}$, .false.): uncorrect answer') + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_meanf03_mask_all_c${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, mean(d8_c${k1}$, d8_c${k1}$%re > 0)& + , sum(d8_c${k1}$, d8_c${k1}$%re > 0)/real(count(d8_c${k1}$%re > 0), ${k1}$)& + , 'mean(d8_c${k1}$, d8_c${k1}$%re > 0): uncorrect answer'& + , thr = ${k1}$tol) + if (allocated(error)) return + end subroutine + + subroutine test_stats_meanf03_mask_c${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + #:for dim in range(1, 9) + call check(error& + , sum(abs(mean(d8_c${k1}$, ${dim}$, d8_c${k1}$%re > 0) -& + sum(d8_c${k1}$, ${dim}$, d8_c${k1}$%re > 0)/real(count(d8_c${k1}$%re > 0, ${dim}$), ${k1}$))) < ${k1}$tol& + , 'mean(d8_c${k1}$, ${dim}$, d8_c${k1}$%re > 0): uncorrect answer'& + ) + if (allocated(error)) return + #:endfor + end subroutine + #:endfor + +end module test_stats_meanf03 + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_stats_meanf03, only : collect_stats_meanf03 + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("stats_meanf03", collect_stats_meanf03) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program From a211e6cc5bc67d966cadf4cdfacf2cf16a28f5ae Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Thu, 26 Aug 2021 13:34:46 +0200 Subject: [PATCH 12/34] Rewrite test_median.fypp --- src/tests/stats/test_median.fypp | 759 ++++++++++++++++++++++--------- 1 file changed, 541 insertions(+), 218 deletions(-) diff --git a/src/tests/stats/test_median.fypp b/src/tests/stats/test_median.fypp index 09962da27..e1c51b292 100644 --- a/src/tests/stats/test_median.fypp +++ b/src/tests/stats/test_median.fypp @@ -1,234 +1,557 @@ #:include "common.fypp" #:set IR_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES -program test_median - use stdlib_error, only: check - use stdlib_kinds, only: sp, dp, qp, & - int8, int16, int32, int64 - use stdlib_stats, only: median, mean - use, intrinsic :: ieee_arithmetic, only : ieee_is_nan, ieee_value, ieee_quiet_nan + +#:set NRANK = 3 + +module test_stats_median + use stdlib_test, only : new_unittest, unittest_type, error_type, check + use stdlib_stats, only: median + use stdlib_kinds, only : int8, int16, int32, int64, sp, dp, qp + use, intrinsic :: ieee_arithmetic, only : ieee_is_nan implicit none + private + + public :: collect_stats_median + real(sp), parameter :: sptol = 1000 * epsilon(1._sp) real(dp), parameter :: dptol = 2000 * epsilon(1._dp) real(qp), parameter :: qptol = 2000 * epsilon(1._qp) #:for k1,t1 in IR_KINDS_TYPES - call test_median_${k1}$() + ${t1}$ , parameter :: d1_${k1}$(12) = [${t1}$ :: 10, 2, -3, -4, 6, -6, 7, -8, 9, 0, 1, 20] + ${t1}$ :: d2_${k1}$(3, 4) = reshape(d1_${k1}$, [3, 4]) + ${t1}$ :: d3_${k1}$(2, 3, 2) = reshape(d1_${k1}$, [2, 3, 2]) + ${t1}$ , parameter :: d1odd_${k1}$(13) = [${t1}$ :: d1_${k1}$, 20] + ${t1}$ :: d2odd_${k1}$(3, 5) = reshape(d1odd_${k1}$, [3, 5], [${t1}$ :: 0]) + ${t1}$ :: d3odd_${k1}$(1, 3, 5) = reshape(d1odd_${k1}$, [1, 3, 5], [${t1}$ :: 0]) #:endfor + contains -#:for k1,t1 in INT_KINDS_TYPES -subroutine test_median_${k1}$() - ${t1}$, allocatable :: d0(:), d1(:), d2(:,:), d3(:,:,:) - - allocate(d0(0)) - !check just to be sure that the setup of d0 is correct - call check(size(d0) == 0, 'test_median_${k1}$: should be of size 0') - - d1 = [10, 2, -3, -4, 6, -6, 7, -8, 9, 0, 1, 20] - call check(mod(size(d1), 2) == 0, 'test_median_${k1}$: should be an even number') - - d2 = reshape(d1, [3, 4]) - call check(mod(size(d2), 2) == 0, 'test_median_${k1}$: should be an even number') - - d3 = reshape(d1, [2, 3, 2]) - call check(mod(size(d3), 2) == 0, 'test_median_${k1}$: should be an even number') - - !median_all - call check( ieee_is_nan(median(d0)), '${k1}$ median(d0)' ) - call check( ieee_is_nan(median(d0, .false.)), '${k1}$ median(d0, .false.)' ) - call check( ieee_is_nan(median(d1, .false.)), '${k1}$ median(d1, .false.)' ) - call check( ieee_is_nan(median(d2, .false.)), '${k1}$ median(d2, .false.)' ) - call check( ieee_is_nan(median(d3, .false.)), '${k1}$ median(d3, .false.)' ) - - call check( abs(median(d1) - 1.5_dp) < dptol, '${k1}$ median(d1), even') - call check( abs(median(d2) - 1.5_dp) < dptol, '${k1}$ median(d2), even') - call check( abs(median(d3) - 1.5_dp) < dptol, '${k1}$ median(d3), even') - - !median - call check( ieee_is_nan(median(d0, 1)), '${k1}$ median(d0, 1)' ) - call check( ieee_is_nan(median(d0, 1, .false.)), '${k1}$ median(d0, 1, .false.)' ) - call check( ieee_is_nan(median(d1, 1, .false.)), '${k1}$ median(d1, 1, .false.)' ) - call check( any(ieee_is_nan(median(d2, 1, .false.))), '${k1}$ median(d2, 1, .false.)' ) - call check( any(ieee_is_nan(median(d2, 2, .false.))), '${k1}$ median(d2, 2, .false.)' ) - call check( any(ieee_is_nan(median(d3, 1, .false.))), '${k1}$ median(d3, 1, .false.)' ) - call check( any(ieee_is_nan(median(d3, 2, .false.))), '${k1}$ median(d3, 2, .false.)' ) - call check( any(ieee_is_nan(median(d3, 3, .false.))), '${k1}$ median(d3, 3, .false.)' ) - - call check( abs(median(d1, 1) - 1.5_dp) < dptol, '${k1}$ median(d1, 1), even') - call check( sum(abs(median(d2, 1) - [2._dp, -4._dp, 7._dp, 1._dp])) < dptol, & - '${k1}$ median(d2, 1)') - call check( sum(abs(median(d2, 2) - [3.5_dp, 1.5_dp, 3._dp])) < dptol, & - '${k1}$ median(d2, 2)') - - !median_mask_all - call check( ieee_is_nan(median(d0, d0 > 0)), '${k1}$ median(d0, d0 > 0)' ) - call check( ieee_is_nan(median(d1, d1 > huge(d1))), '${k1}$ median(d1, d1 > huge(d1))' ) - call check( ieee_is_nan(median(d2, d2 > huge(d2))), '${k1}$ median(d2, d2 > huge(d2))' ) - call check( ieee_is_nan(median(d3, d3 > huge(d3))), '${k1}$ median(d3, d3 > huge(d3))' ) - call check( (median(d1, d1 > 0) - 7._dp) < dptol, '${k1}$ median(d1, d1 > 0)' ) - call check( (median(d2, d2 > 0) - 7._dp) < dptol, '${k1}$ median(d2, d2 > 0)' ) - call check( (median(d3, d3 > 0) - 7._dp) < dptol, '${k1}$ median(d3, d3 > 0)' ) - - !median mask - call check( ieee_is_nan(median(d0, 1, d0 > 0)), '${k1}$ median(d0, 1, d0 > 0)' ) - call check( ieee_is_nan(median(d1, 1, d1 > huge(d1))), '${k1}$ median(d1, 1, d1 > huge(d1))' ) - call check( any(ieee_is_nan(median(d2, 1, d2 > huge(d2)))), '${k1}$ median(d2, 1, d2 > huge(d2))' ) - call check( any(ieee_is_nan(median(d3, 1, d3 > huge(d3)))), '${k1}$ median(d3, 1, d3 > huge(d3))' ) - call check( (median(d1, 1, d1 > 0) - 7._dp) < dptol, '${k1}$ median(d1, 1, d1 >0)') - call check( sum(abs( (median(d2, 1, d2 > 0) - [ 6._dp, 6._dp, 8._dp, 10.5_dp] ) )) & - < dptol, '${k1}$ median(d2, 1, d2 > 0 )') - call check( sum(abs( (median(d2, 2, d2 > 0) - [ 8.5_dp, 2._dp, 14.5_dp] ) )) & - < dptol, '${k1}$ median(d2, 2, d2 > 0 )') - call check( any(ieee_is_nan(median(d3, 1, d3 > 0))), '${k1}$ median(d3, 1, d3 > 0)') - - !odd number - d1 = [d1, 20_${k1}$] - call check(mod(size(d1), 2) == 1, 'test_median_${k1}$: should be an odd number') - - call check( abs(median(d1) - 2._dp) < dptol, '${k1}$ median(d1), odd') - - d2 = reshape(d1, [3, 5], pad = [0_${k1}$]) - call check(mod(size(d2), 2) == 1, 'test_median_${k1}$: should be an odd number') - call check( abs(median(d2) - 1._dp) < dptol, '${k1}$ median(d2), odd') - - d3 = reshape(d1, [1, 3, 5], pad = [0_${k1}$]) - call check(mod(size(d3), 2) == 1, 'test_median_${k1}$: should be an odd number') - call check( abs(median(d3) - 1._dp) < dptol, '${k1}$ median(d3), odd') - - call check( abs(median(d1, 1) - 2._dp) < dptol, '${k1}$ median(d1, 1)') - call check( sum(abs(median(d2, 1) - [2._dp, -4._dp, 7._dp, 1._dp, 0._dp])) < dptol, & - '${k1}$ median(d2, 1), odd') - call check( sum(abs(median(d2, 2) - [7._dp, 1._dp, 0._dp])) < dptol, & - '${k1}$ median(d2, 2), odd') - -end subroutine -#:endfor - -#:for k1,t1 in REAL_KINDS_TYPES -subroutine test_median_${k1}$() - ${t1}$, allocatable :: d0(:), d1(:), d2(:,:), d3(:,:,:) - ${t1}$, allocatable :: tmp1(:) - - allocate(d0(0)) - !check just to be sure that the setup of d0 is correct - call check(size(d0) == 0, 'test_median_${k1}$: should be of size 0') - - d1 = [10., 2., -3., -4., 6., -6., 7., -8., 9., 0., 1., 20.] - call check(mod(size(d1), 2) == 0, 'test_median_${k1}$: should be an even number') - - d2 = reshape(d1, [3, 4]) - call check(mod(size(d2), 2) == 0, 'test_median_${k1}$: should be an even number') - - d3 = reshape(d1, [2, 3, 2]) - call check(mod(size(d3), 2) == 0, 'test_median_${k1}$: should be an even number') - - !median_all - call check( ieee_is_nan(median(d0)), '${k1}$ median(d0)' ) - call check( ieee_is_nan(median(d0, .false.)), '${k1}$ median(d0, .false.)' ) - call check( ieee_is_nan(median(d1, .false.)), '${k1}$ median(d1, .false.)' ) - call check( ieee_is_nan(median(d2, .false.)), '${k1}$ median(d2, .false.)' ) - call check( ieee_is_nan(median(d3, .false.)), '${k1}$ median(d3, .false.)' ) - - call check( abs(median(d1) - 1.5_${k1}$) < ${k1}$tol, '${k1}$ median(d1), even') - call check( abs(median(d2) - 1.5_${k1}$) < ${k1}$tol, '${k1}$ median(d2), even') - call check( abs(median(d3) - 1.5_${k1}$) < ${k1}$tol, '${k1}$ median(d3), even') - - !median - call check( ieee_is_nan(median(d0, 1)), '${k1}$ median(d0, 1)' ) - call check( ieee_is_nan(median(d0, 1, .false.)), '${k1}$ median(d0, 1, .false.)' ) - call check( ieee_is_nan(median(d1, 1, .false.)), '${k1}$ median(d1, 1, .false.)' ) - call check( any(ieee_is_nan(median(d2, 1, .false.))), '${k1}$ median(d2, 1, .false.)' ) - call check( any(ieee_is_nan(median(d2, 2, .false.))), '${k1}$ median(d2, 2, .false.)' ) - call check( any(ieee_is_nan(median(d3, 1, .false.))), '${k1}$ median(d3, 1, .false.)' ) - call check( any(ieee_is_nan(median(d3, 2, .false.))), '${k1}$ median(d3, 2, .false.)' ) - call check( any(ieee_is_nan(median(d3, 3, .false.))), '${k1}$ median(d3, 3, .false.)' ) - - call check( abs(median(d1, 1) - 1.5_${k1}$) < ${k1}$tol, '${k1}$ median(d1, 1), even') - call check( sum(abs(median(d2, 1) - [2._${k1}$, -4._${k1}$, 7._${k1}$, 1._${k1}$])) < ${k1}$tol, & - '${k1}$ median(d2, 1)') - call check( sum(abs(median(d2, 2) - [3.5_${k1}$, 1.5_${k1}$, 3._${k1}$])) < ${k1}$tol, & - '${k1}$ median(d2, 2)') - - !median_mask_all - call check( ieee_is_nan(median(d0, d0 > 0)), '${k1}$ median(d0, d0 > 0)' ) - call check( ieee_is_nan(median(d1, d1 > huge(d1))), '${k1}$ median(d1, d1 > huge(d1))' ) - call check( ieee_is_nan(median(d2, d2 > huge(d2))), '${k1}$ median(d2, d2 > huge(d2))' ) - call check( ieee_is_nan(median(d3, d3 > huge(d3))), '${k1}$ median(d3, d3 > huge(d3))' ) - call check( (median(d1, d1 > 0) - 7._${k1}$) < ${k1}$tol, '${k1}$ median(d1, d1 > 0)' ) - call check( (median(d2, d2 > 0) - 7._${k1}$) < ${k1}$tol, '${k1}$ median(d2, d2 > 0)' ) - call check( (median(d3, d3 > 0) - 7._${k1}$) < ${k1}$tol, '${k1}$ median(d3, d3 > 0)' ) - - !median mask - call check( ieee_is_nan(median(d0, 1, d0 > 0)), '${k1}$ median(d0, 1, d0 > 0)' ) - call check( ieee_is_nan(median(d1, 1, d1 > huge(d1))), '${k1}$ median(d1, 1, d1 > huge(d1))' ) - call check( any(ieee_is_nan(median(d2, 1, d2 > huge(d2)))), '${k1}$ median(d2, 1, d2 > huge(d2))' ) - call check( any(ieee_is_nan(median(d3, 1, d3 > huge(d3)))), '${k1}$ median(d3, 1, d3 > huge(d3))' ) - call check( (median(d1, 1, d1 > 0) - 7._${k1}$) < ${k1}$tol, '${k1}$ median(d1, 1, d1 >0)') - call check( sum(abs( (median(d2, 1, d2 > 0) - [ 6._${k1}$, 6._${k1}$, 8._${k1}$, 10.5_${k1}$] ) )) & - < ${k1}$tol, '${k1}$ median(d2, 1, d2 > 0 )') - call check( sum(abs( (median(d2, 2, d2 > 0) - [ 8.5_${k1}$, 2._${k1}$, 14.5_${k1}$] ) )) & - < ${k1}$tol, '${k1}$ median(d2, 2, d2 > 0 )') - call check( any(ieee_is_nan(median(d3, 1, d3 > 0))), '${k1}$ median(d3, 1, d3 > 0)') - - !odd number - d1 = [d1, 20._${k1}$] - call check(mod(size(d1), 2) == 1, 'test_median_${k1}$: should be an odd number') - - call check( abs(median(d1) - 2._${k1}$) < ${k1}$tol, '${k1}$ median(d1), odd') - - d2 = reshape(d1, [3, 5], pad = [0._${k1}$]) - call check(mod(size(d2), 2) == 1, 'test_median_${k1}$: should be an odd number') - call check( abs(median(d2) - 1._${k1}$) < ${k1}$tol, '${k1}$ median(d2), odd') - - d3 = reshape(d1, [1, 3, 5], pad = [0._${k1}$]) - call check(mod(size(d3), 2) == 1, 'test_median_${k1}$: should be an odd number') - call check( abs(median(d3) - 1._${k1}$) < ${k1}$tol, '${k1}$ median(d3), odd') - - call check( abs(median(d1, 1) - 2._${k1}$) < ${k1}$tol, '${k1}$ median(d1, 1)') - call check( sum(abs(median(d2, 1) - [2._${k1}$, -4._${k1}$, 7._${k1}$, 1._${k1}$, 0._${k1}$])) < ${k1}$tol, & - '${k1}$ median(d2, 1), odd') - call check( sum(abs(median(d2, 2) - [7._${k1}$, 1._${k1}$, 0._${k1}$])) < ${k1}$tol, & - '${k1}$ median(d2, 2), odd') - - !check IEEE NaN values in array - d1(1) = ieee_value(1._${k1}$, ieee_quiet_nan) - d2(1, 1) = ieee_value(1._${k1}$, ieee_quiet_nan) - d3(1, 1, 1) = ieee_value(1._${k1}$, ieee_quiet_nan) - - !median_all - call check( ieee_is_nan(median(d1)), '${k1}$ median(d1), should be NaN') - call check( ieee_is_nan(median(d2)), '${k1}$ median(d2), should be NaN') - call check( ieee_is_nan(median(d3)), '${k1}$ median(d3), should be NaN') - - !median - call check( any(ieee_is_nan(median(d2, 1))), '${k1}$ median(d2, 1) should contain at least 1 NaN' ) - call check( any(ieee_is_nan(median(d2, 2))), '${k1}$ median(d2, 2) should contain at least 1 NaN' ) - - call check( any(ieee_is_nan(median(d3, 1))), '${k1}$ median(d3, 1) should contain at least 1 NaN' ) - call check( any(ieee_is_nan(median(d3, 2))), '${k1}$ median(d3, 2) should contain at least 1 NaN' ) - call check( any(ieee_is_nan(median(d3, 3))), '${k1}$ median(d3, 3) should contain at least 1 NaN' ) - - !median_mask_all - call check( ieee_is_nan(median(d1, d1 > 0)), '${k1}$ median(d1, d1 > 0) should be NaN' ) - call check( ieee_is_nan(median(d2, d2 > 0)), '${k1}$ median(d2, d2 > 0) should be NaN' ) - call check( ieee_is_nan(median(d3, d3 > 0)), '${k1}$ median(d3, d3 > 0) should be NaN' ) - - !median mask - call check( ieee_is_nan(median(d1, 1, d1 .ne. 0)), '${k1}$ median(d1, 1, d1.ne.0) should return NaN') - - tmp1 = median(d2, 1, d2 .ne. 0) - call check( any(ieee_is_nan(tmp1)), '${k1}$ median(d2, 1, d2 .ne. 0 ) should contain at least 1 NaN') - call check( tmp1(2) == -4._${k1}$, '${k1}$ tmp1(2) == -4') - call check( any(ieee_is_nan(median(d2, 2, d2 .ne. 0))), & - '${k1}$ median(d2, 2, d2 .ne. 0 ) should contain at least 1 NaN') - - call check( any(ieee_is_nan(median(d3, 1, d3 .ne. 0))), & - '${k1}$ median(d3, 1, d3 .ne. 0 ) should contain at least 1 NaN') - -end subroutine -#:endfor + !> Collect all exported unit tests + subroutine collect_stats_median(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("test_stats_median_size_int8", test_stats_median_size_int8) & + #:for k1,t1 in IR_KINDS_TYPES + , new_unittest("test_stats_median_size_${k1}$", test_stats_median_size_${k1}$) & + , new_unittest("test_stats_median_odd_size_${k1}$", test_stats_median_odd_size_${k1}$) & + , new_unittest("test_stats_median_all_${k1}$", test_stats_median_all_${k1}$) & + , new_unittest("test_stats_median_all_odd_${k1}$", test_stats_median_all_odd_${k1}$) & + , new_unittest("test_stats_median_all_optmask_${k1}$", test_stats_median_all_optmask_${k1}$) & + , new_unittest("test_stats_median_${k1}$", test_stats_median_${k1}$) & + , new_unittest("test_stats_median_odd_${k1}$", test_stats_median_odd_${k1}$) & + , new_unittest("test_stats_median_optmask_${k1}$", test_stats_median_optmask_${k1}$) & + , new_unittest("test_stats_median_mask_all_${k1}$", test_stats_median_mask_all_${k1}$) & + , new_unittest("test_stats_median_mask_${k1}$", test_stats_median_mask_${k1}$) & + #:endfor + ] + end subroutine collect_stats_median + + #:for k1,t1 in INT_KINDS_TYPES + subroutine test_stats_median_size_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + ${t1}$, allocatable :: d0(:) + + allocate(d0(0)) + !check just to be sure that the setup of d0 is correct + call check(error, size(d0), 0, 'size(d0): should be of size 0') + + #:for rank in range(1, NRANK + 1) + call check(error, mod(size(d${rank}$_${k1}$), 2), 0& + , 'mod(size(d${rank}$_${k1}$), 2): should be an even number'& + ) + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_median_odd_size_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + #:for rank in range(1, NRANK + 1) + call check(error, mod(size(d${rank}$odd_${k1}$), 2), 1& + , 'mod(size(d${rank}$)_${k1}$, 2): should be an odd number'& + ) + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_median_all_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + ${t1}$, allocatable :: d0(:) + + allocate(d0(0)) + call check(error, ieee_is_nan(median(d0)), 'median(d0): should be NaN' ) + if (allocated(error)) return + + #:for rank in range(1, NRANK + 1) + call check(error, median(d${rank}$_${k1}$), 1.5_dp& + , 'median(d${rank}$_${k1}$): uncorrect answer'& + , thr = dptol) + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_median_all_odd_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, median(d1odd_${k1}$), 2._dp& + , 'median(d1odd_${k1}$): uncorrect answer'& + , thr = dptol) + if (allocated(error)) return + + call check(error, median(d2odd_${k1}$), 1._dp& + , 'median(d2odd_${k1}$): uncorrect answer'& + , thr = dptol) + if (allocated(error)) return + + call check(error, median(d2odd_${k1}$), 1._dp& + , 'median(d2odd_${k1}$): uncorrect answer'& + , thr = dptol) + if (allocated(error)) return + + end subroutine + + subroutine test_stats_median_all_optmask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + ${t1}$, allocatable :: d0_${k1}$(:) + + allocate(d0_${k1}$(0)) + + #:for rank in range(0, NRANK + 1) + call check(error, ieee_is_nan(median(d${rank}$_${k1}$, .false.))& + , 'median(d${rank}$_${k1}$, .false.): uncorrect answer') + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_median_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + ${t1}$, allocatable :: d0(:) + + allocate(d0(0)) + + call check(error, ieee_is_nan(median(d0, 1)), 'median(d0, 1): should return NaN' ) + + call check(error& + , abs(median(d1_${k1}$, 1) - 1.5_dp) < dptol& + , 'median(d1_${k1}$, 1): uncorrect answer'& + ) + if (allocated(error)) return + + call check(error& + , sum(abs(median(d2_${k1}$, 1) - [2._dp, -4._dp, 7._dp, 1._dp])) < dptol& + , 'median(d2_${k1}$, 1): uncorrect answer') + if (allocated(error)) return + + call check(error& + , sum(abs(median(d2_${k1}$, 2) - [3.5_dp, 1.5_dp, 3._dp])) < dptol& + ,'median(d2_${k1}$, 2): uncorrect answer') + if (allocated(error)) return + + end subroutine + + subroutine test_stats_median_odd_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error& + , abs(median(d1odd_${k1}$, 1) - 2._dp) < dptol& + , 'median(d1odd_${k1}$, 1): wrong answer') + if (allocated(error)) return + + call check(error& + , sum(abs(median(d2odd_${k1}$, 1) - [2._dp, -4._dp, 7._dp, 1._dp, 0._dp])) < dptol& + , 'median(d2odd_${k1}$, 1): wrong answer') + if (allocated(error)) return + + call check(error& + , sum(abs(median(d2odd_${k1}$, 2) - [7._dp, 1._dp, 0._dp])) < dptol& + , 'median(d2odd_${k1}$, 2): wrong answer') + if (allocated(error)) return + + end subroutine + + subroutine test_stats_median_optmask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + ${t1}$, allocatable :: d0(:) + + allocate(d0(0)) + + call check(error, ieee_is_nan(median(d0, 1, .false.))& + , 'median(d0, 1, .false.): uncorrect answer'& + ) + if (allocated(error)) return + + call check(error, ieee_is_nan(median(d1_${k1}$, 1, .false.))& + , 'median(d1_${k1}$, 1, .false.): uncorrect answer'& + ) + if (allocated(error)) return + + #:for rank in range(2, NRANK+1) + #:for dim in range(1, rank+1) + call check(error, any(ieee_is_nan(median(d${rank}$_${k1}$, ${dim}$, .false.)))& + , 'median(d${rank}$_${k1}$, ${dim}$, .false.): uncorrect answer') + if (allocated(error)) return + #:endfor + #:endfor + end subroutine + + subroutine test_stats_median_mask_all_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + ${t1}$, allocatable :: d0(:) + + allocate(d0(0)) + + call check(error, ieee_is_nan(median(d0, d0 > 0))& + , 'median(d0, d0 > 0): should be NaN' ) + if (allocated(error)) return + + #:for rank in range(1, NRANK+1) + call check(error& + , ieee_is_nan(median(d${rank}$_${k1}$, d${rank}$_${k1}$ > huge(d${rank}$_${k1}$)))& + , 'median(d${rank}$_${k1}$, d${rank}$_${k1}$ > huge(d${rank}$_${k1}$))' ) + if (allocated(error)) return + #:endfor + + #:for rank in range(1, NRANK+1) + call check(error& + , (median(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0) - 7._dp) < dptol& + , 'median(d${rank}$_${k1}$, d${rank}$_${k1}$> 0)' ) + if (allocated(error)) return + #:endfor + + end subroutine + + subroutine test_stats_median_mask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + ${t1}$, allocatable :: d0(:) + + allocate(d0(0)) + + call check(error& + , ieee_is_nan(median(d0, 1, d0 > 0))& + , 'median(d0, 1, d0 > 0): uncorrect answer' ) + if (allocated(error)) return + + call check(error& + , ieee_is_nan(median(d1_${k1}$, 1, d1_${k1}$ > huge(d1_${k1}$)))& + , 'median(d1_${k1}$, 1_${k1}$, d1_${k1}$ > huge(d1_${k1}$)): answer should be IEEE NaN' ) + if (allocated(error)) return + + #:for rank in range(2, NRANK+1) + call check(error& + , any(ieee_is_nan(median(d${rank}$_${k1}$, 1, d${rank}$_${k1}$ > huge(d${rank}$_${k1}$))))& + , 'median(d${rank}$_${k1}$, 1_${k1}$, d${rank}$_${k1}$ > huge(d${rank}$_${k1}$)): answer should be IEEE NaN' ) + if (allocated(error)) return + #:endfor + + call check(error& + , (median(d1_${k1}$, 1, d1_${k1}$ > 0) - 7._dp) < dptol& + , 'median(d1_${k1}$, 1, d1_${k1}$ >0): uncorrect answer') + if (allocated(error)) return + + call check(error& + , sum(abs( (median(d2_${k1}$, 1, d2_${k1}$ > 0) - [ 6._dp, 6._dp, 8._dp, 10.5_dp] ) )) & + < dptol& + , 'median(d2_${k1}$, 1, d2_${k1}$ > 0): uncorrect answer') + if (allocated(error)) return + + call check(error& + , sum(abs((median(d2_${k1}$, 2, d2_${k1}$ > 0) - [ 8.5_dp, 2._dp, 14.5_dp] )))& + < dptol& + , 'median(d2_${k1}$, 2, d2_${k1}$ > 0)') + if (allocated(error)) return + + call check(error& + , any(ieee_is_nan(median(d3_${k1}$, 1, d3_${k1}$ > 0)))& + , 'median(d3_${k1}$, 1, d3_${k1}$ > 0): should contain at least 1 IEEE NaN') + + end subroutine + #:endfor + + #:for k1,t1 in REAL_KINDS_TYPES + subroutine test_stats_median_size_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + ${t1}$, allocatable :: d0(:) + + allocate(d0(0)) + !check just to be sure that the setup of d0 is correct + call check(error, size(d0), 0, 'size(d0): should be of size 0') + + #:for rank in range(1, NRANK + 1) + call check(error, mod(size(d${rank}$_${k1}$), 2), 0& + , 'mod(size(d${rank}$_${k1}$), 2): should be an even number'& + ) + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_median_odd_size_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + #:for rank in range(1, NRANK + 1) + call check(error, mod(size(d${rank}$odd_${k1}$), 2), 1& + , 'mod(size(d${rank}$_${k1}$), 2): should be an odd number'& + ) + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_median_all_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + ${t1}$, allocatable :: d0(:) + + allocate(d0(0)) + call check(error, ieee_is_nan(median(d0)), 'median(d0): should be NaN' ) + if (allocated(error)) return + + #:for rank in range(1, NRANK + 1) + 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 + + subroutine test_stats_median_all_odd_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, median(d1odd_${k1}$), 2._${k1}$& + , 'median(d1odd_${k1}$): uncorrect answer'& + , thr = ${k1}$tol) + if (allocated(error)) return + + call check(error, median(d2odd_${k1}$), 1._${k1}$& + , 'median(d2odd_${k1}$): uncorrect answer'& + , thr = ${k1}$tol) + if (allocated(error)) return + + call check(error, median(d2odd_${k1}$), 1._${k1}$& + , 'median(d2odd_${k1}$): uncorrect answer'& + , thr = ${k1}$tol) + if (allocated(error)) return + + end subroutine + + subroutine test_stats_median_all_optmask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + ${t1}$, allocatable :: d0_${k1}$(:) + + allocate(d0_${k1}$(0)) + + #:for rank in range(0, NRANK + 1) + call check(error, ieee_is_nan(median(d${rank}$_${k1}$, .false.))& + , 'median(d${rank}$_${k1}$, .false.): uncorrect answer') + if (allocated(error)) return + #:endfor + end subroutine + + subroutine test_stats_median_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + ${t1}$, allocatable :: d0(:) + + allocate(d0(0)) + + call check(error, ieee_is_nan(median(d0, 1)), 'median(d0, 1): should return NaN' ) + + call check(error& + , abs(median(d1_${k1}$, 1) - 1.5_${k1}$) < ${k1}$tol& + , 'median(d1_${k1}$, 1): uncorrect answer'& + ) + if (allocated(error)) return + + call check(error& + , sum(abs(median(d2_${k1}$, 1) - [2._${k1}$, -4._${k1}$, 7._${k1}$, 1._${k1}$])) < ${k1}$tol& + , 'median(d2_${k1}$, 1): uncorrect answer') + if (allocated(error)) return + + call check(error& + , sum(abs(median(d2_${k1}$, 2) - [3.5_${k1}$, 1.5_${k1}$, 3._${k1}$])) < ${k1}$tol& + ,'median(d2_${k1}$, 2): uncorrect answer') + if (allocated(error)) return + + end subroutine + + subroutine test_stats_median_odd_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error& + , abs(median(d1odd_${k1}$, 1) - 2._${k1}$) < ${k1}$tol& + , 'median(d1odd_${k1}$, 1): wrong answer') + if (allocated(error)) return + + call check(error& + , sum(abs(median(d2odd_${k1}$, 1) - [2._${k1}$, -4._${k1}$, 7._${k1}$, 1._${k1}$, 0._${k1}$])) < ${k1}$tol& + , 'median(d2odd_${k1}$, 1): wrong answer') + if (allocated(error)) return + + call check(error& + , sum(abs(median(d2odd_${k1}$, 2) - [7._${k1}$, 1._${k1}$, 0._${k1}$])) < ${k1}$tol& + , 'median(d2odd_${k1}$, 2): wrong answer') + if (allocated(error)) return + + end subroutine + + subroutine test_stats_median_optmask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + ${t1}$, allocatable :: d0(:) + + allocate(d0(0)) + + call check(error, ieee_is_nan(median(d0, 1, .false.))& + , 'median(d0, 1, .false.): uncorrect answer'& + ) + if (allocated(error)) return + + call check(error, ieee_is_nan(median(d1_${k1}$, 1, .false.))& + , 'median(d1_${k1}$, 1, .false.): uncorrect answer'& + ) + if (allocated(error)) return + + #:for rank in range(2, NRANK+1) + #:for dim in range(1, rank+1) + call check(error, any(ieee_is_nan(median(d${rank}$_${k1}$, ${dim}$, .false.)))& + , 'median(d${rank}$_${k1}$, ${dim}$, .false.): uncorrect answer') + if (allocated(error)) return + #:endfor + #:endfor + end subroutine + + subroutine test_stats_median_mask_all_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + ${t1}$, allocatable :: d0(:) + + allocate(d0(0)) + + call check(error, ieee_is_nan(median(d0, d0 > 0))& + , 'median(d0, d0 > 0): should be NaN' ) + if (allocated(error)) return + + #:for rank in range(1, NRANK+1) + call check(error& + , ieee_is_nan(median(d${rank}$_${k1}$, d${rank}$_${k1}$ > huge(d${rank}$_${k1}$)))& + , 'median(d${rank}$_${k1}$, d${rank}$_${k1}$ > huge(d${rank}$_${k1}$))' ) + if (allocated(error)) return + #:endfor + + #:for rank in range(1, NRANK+1) + call check(error& + , (median(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0) - 7._${k1}$) < ${k1}$tol& + , 'median(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0)' ) + if (allocated(error)) return + #:endfor + + end subroutine + + subroutine test_stats_median_mask_${k1}$(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + ${t1}$, allocatable :: d0(:) + + allocate(d0(0)) + + call check(error& + , ieee_is_nan(median(d0, 1, d0 > 0))& + , 'median(d0, 1, d0 > 0): uncorrect answer' ) + if (allocated(error)) return + + call check(error& + , ieee_is_nan(median(d1_${k1}$, 1, d1_${k1}$ > huge(d1_${k1}$)))& + , 'median(d1_${k1}$, 1, d1_${k1}$ > huge(d1_${k1}$)): answer should be IEEE NaN' ) + if (allocated(error)) return + + #:for rank in range(2, NRANK+1) + call check(error& + , any(ieee_is_nan(median(d${rank}$_${k1}$, 1, d${rank}$_${k1}$ > huge(d${rank}$_${k1}$))))& + , 'median(d${rank}$_${k1}$, 1, d${rank}$_${k1}$ > huge(d${rank}$_${k1}$)): answer should be IEEE NaN' ) + if (allocated(error)) return + #:endfor + + call check(error& + , (median(d1_${k1}$, 1, d1_${k1}$ > 0) - 7._${k1}$) < ${k1}$tol& + , 'median(d1_${k1}$, 1, d1_${k1}$ >0): uncorrect answer') + if (allocated(error)) return + + call check(error& + , sum(abs( (median(d2_${k1}$, 1, d2_${k1}$ > 0) - [ 6._${k1}$, 6._${k1}$, 8._${k1}$, 10.5_${k1}$] ) )) & + < ${k1}$tol& + , 'median(d2_${k1}$, 1, d2_${k1}$ > 0): uncorrect answer') + if (allocated(error)) return + + call check(error& + , sum(abs((median(d2_${k1}$, 2, d2_${k1}$ > 0) - [ 8.5_${k1}$, 2._${k1}$, 14.5_${k1}$] )))& + < ${k1}$tol& + , 'median(d2_${k1}$, 2, d2_${k1}$ > 0)') + if (allocated(error)) return + + call check(error& + , any(ieee_is_nan(median(d3_${k1}$, 1, d3_${k1}$ > 0)))& + , 'median(d3_${k1}$, 1, d3_${k1}$ > 0): should contain at least 1 IEEE NaN') + + end subroutine + + #:endfor + +end module test_stats_median + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_stats_median, only : collect_stats_median + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + testsuites = [ & + new_testsuite("stats_median", collect_stats_median) & + ] + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if end program From 280f451d20ae32769e4c51499fb4ce28e9757406 Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Thu, 26 Aug 2021 23:16:54 +0200 Subject: [PATCH 13/34] Rewrite tests for quadrature modules --- src/tests/quadrature/test_gauss.f90 | 144 ++++++++++-- src/tests/quadrature/test_simps.f90 | 350 ++++++++++++++++------------ src/tests/quadrature/test_trapz.f90 | 186 +++++++++------ 3 files changed, 445 insertions(+), 235 deletions(-) diff --git a/src/tests/quadrature/test_gauss.f90 b/src/tests/quadrature/test_gauss.f90 index 244550437..4606293f8 100644 --- a/src/tests/quadrature/test_gauss.f90 +++ b/src/tests/quadrature/test_gauss.f90 @@ -1,16 +1,34 @@ -program test_gauss_ +module test_gauss use stdlib_kinds, only: dp - use stdlib_error, only: check + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_quadrature , only: gauss_legendre, gauss_legendre_lobatto implicit none - call test_gauss - call test_gauss_lobatto contains - subroutine test_gauss + !> Collect all exported unit tests + subroutine collect_gauss(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("gauss-analytic", test_gauss_analytic), & + new_unittest("gauss-5", test_gauss_5), & + new_unittest("gauss-32", test_gauss_32), & + new_unittest("gauss-64", test_gauss_64), & + new_unittest("gauss-lobatto-analytic", test_gauss_lobatto_analytic), & + new_unittest("gauss-lobatto-5", test_gauss_lobatto_5), & + new_unittest("gauss-lobatto-32", test_gauss_lobatto_32), & + new_unittest("gauss-lobatto-64", test_gauss_lobatto_64) & + ] + end subroutine + + subroutine test_gauss_analytic(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i real(dp) :: analytic, numeric @@ -23,10 +41,19 @@ subroutine test_gauss call gauss_legendre(x,w) numeric = sum(x**2 * w) !print *, i, numeric - call check(abs(numeric-analytic) < 2*epsilon(analytic)) + call check(error, abs(numeric-analytic) < 2*epsilon(analytic)) + if (allocated(error)) return end block end do + end subroutine + + subroutine test_gauss_5(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: i + ! test the values of nodes and weights i = 5 block @@ -44,10 +71,19 @@ subroutine test_gauss wref(4)=0.47862867049936647_dp wref(5)=0.23692688505618909_dp - call check (all(abs(x-xref) < 2*epsilon(x(1)))) - call check (all(abs(w-wref) < 2*epsilon(w(1)))) + call check(error, all(abs(x-xref) < 2*epsilon(x(1)))) + if (allocated(error)) return + call check(error, all(abs(w-wref) < 2*epsilon(w(1)))) end block + end subroutine + + subroutine test_gauss_32(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: i + i = 32 block real(dp), dimension(i) :: x,w,xref,wref @@ -120,10 +156,19 @@ subroutine test_gauss wref(31)=0.016274394730905671_dp wref(32)=0.0070186100094700966_dp - call check (all(abs(x-xref) < 2*epsilon(x(1)))) - call check (all(abs(w-wref) < 2*epsilon(w(1)))) + call check(error, all(abs(x-xref) < 2*epsilon(x(1)))) + if (allocated(error)) return + call check(error, all(abs(w-wref) < 2*epsilon(w(1)))) end block + end subroutine + + subroutine test_gauss_64(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: i + i = 64 block @@ -262,15 +307,19 @@ subroutine test_gauss wref(63)=0.0041470332605624676_dp wref(64)=0.0017832807216964329_dp - call check (all(abs(x-xref) < 2*epsilon(x(1)))) - call check (all(abs(w-wref) < 2*epsilon(w(1)))) + call check(error, all(abs(x-xref) < 2*epsilon(x(1)))) + if (allocated(error)) return + call check(error, all(abs(w-wref) < 2*epsilon(w(1)))) end block end subroutine - subroutine test_gauss_lobatto + subroutine test_gauss_lobatto_analytic(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: i real(dp) :: analytic, numeric @@ -283,10 +332,19 @@ subroutine test_gauss_lobatto call gauss_legendre_lobatto(x,w) numeric = sum(x**2 * w) !print *, i, numeric - call check(abs(numeric-analytic) < 2*epsilon(analytic)) + call check(error, abs(numeric-analytic) < 2*epsilon(analytic)) + if (allocated(error)) return end block end do + end subroutine + + subroutine test_gauss_lobatto_5(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: i + ! test the values of nodes and weights i = 5 @@ -308,10 +366,19 @@ subroutine test_gauss_lobatto wref(5)=0.10000000000000000_dp - call check (all(abs(x-xref) < 2*epsilon(x(1)))) - call check (all(abs(w-wref) < 2*epsilon(w(1)))) + call check(error, all(abs(x-xref) < 2*epsilon(x(1)))) + if (allocated(error)) return + call check(error, all(abs(w-wref) < 2*epsilon(w(1)))) end block + end subroutine + + subroutine test_gauss_lobatto_32(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: i + i = 32 block real(dp), dimension(i) :: x,w,xref,wref @@ -383,10 +450,19 @@ subroutine test_gauss_lobatto wref(31)=0.012398106501373844_dp wref(32)=0.0020161290322580645_dp - call check (all(abs(x-xref) < 2*epsilon(x(1)))) - call check (all(abs(w-wref) < 2*epsilon(w(1)))) + call check(error, all(abs(x-xref) < 2*epsilon(x(1)))) + if (allocated(error)) return + call check(error, all(abs(w-wref) < 2*epsilon(w(1)))) end block + end subroutine + + subroutine test_gauss_lobatto_64(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: i + i = 64 block @@ -524,10 +600,38 @@ subroutine test_gauss_lobatto wref(63)=0.0030560082449124904_dp wref(64)=0.00049603174603174603_dp - call check (all(abs(x-xref) < 2*epsilon(x(1)))) - call check (all(abs(w-wref) < 2*epsilon(w(1)))) + call check(error, all(abs(x-xref) < 2*epsilon(x(1)))) + if (allocated(error)) return + call check(error, all(abs(w-wref) < 2*epsilon(w(1)))) end block end subroutine +end module + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_gauss, only : collect_gauss + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("gauss", collect_gauss) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if end program diff --git a/src/tests/quadrature/test_simps.f90 b/src/tests/quadrature/test_simps.f90 index f8335180f..2ae3c390a 100644 --- a/src/tests/quadrature/test_simps.f90 +++ b/src/tests/quadrature/test_simps.f90 @@ -1,6 +1,6 @@ -program test_simps +module test_simps use stdlib_kinds, only: sp, dp, qp - use stdlib_error, only: check + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_quadrature, only: simps, simps_weights implicit none @@ -9,33 +9,40 @@ program test_simps real(dp), parameter :: tol_dp = 1000 * epsilon(1.0_dp) real(qp), parameter :: tol_qp = 1000 *epsilon(1.0_sp) - call test_simps_sp - call test_simps_dp - call test_simps_qp - - call test_simps_weights_sp - call test_simps_weights_dp - call test_simps_weights_qp - - call test_simps_zero_sp - call test_simps_zero_dp - call test_simps_zero_qp - - call test_simps_even_sp - call test_simps_even_dp - call test_simps_even_qp - - call test_simps_weights_even_sp - call test_simps_weights_even_dp - call test_simps_weights_even_qp - - call test_simps_six_sp - call test_simps_six_dp - call test_simps_six_qp contains - subroutine test_simps_sp + !> Collect all exported unit tests + subroutine collect_simps(testsuite) + !> Collection of tests + 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) & + ] + end subroutine collect_simps + + subroutine test_simps_sp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 13 real(sp), dimension(n) :: y real(sp), dimension(n) :: x @@ -43,29 +50,30 @@ subroutine test_simps_sp real(sp) :: ans integer :: i - print *, "test_simps_sp" y = [(real(i-1, sp)**2, i = 1, n)] val = simps(y, 1.0_sp) ans = 576.0_sp - print *, " dx=1", val, ans - call check(abs(val - ans) < tol_sp) + call check(error, val, ans, thr=tol_sp) + if (allocated(error)) return val = simps(y, 0.5_sp) ans = 288.0_sp - print *, " dx=0.5", val, ans - call check(abs(val - ans) < tol_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 - print *, " x=0,0.25,0.5,...", val, ans - call check(abs(val - ans) < tol_sp) + call check(error, val, ans, thr=tol_sp) end subroutine test_simps_sp - subroutine test_simps_dp + 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 @@ -73,29 +81,30 @@ subroutine test_simps_dp real(dp) :: ans integer :: i - print *, "test_simps_dp" y = [(real(i-1, dp)**2, i = 1, n)] val = simps(y, 1.0_dp) ans = 576.0_dp - print *, " dx=1", val, ans - call check(abs(val - ans) < tol_dp) + call check(error, val, ans, thr=tol_dp) + if (allocated(error)) return val = simps(y, 0.5_dp) ans = 288.0_dp - print *, " dx=0.5", val, ans - call check(abs(val - ans) < tol_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 - print *, " x=0,0.25,0.5,...", val, ans - call check(abs(val - ans) < tol_dp) + call check(error, val, ans, thr=tol_dp) end subroutine test_simps_dp - subroutine test_simps_qp + subroutine test_simps_qp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 13 real(qp), dimension(n) :: y real(qp), dimension(n) :: x @@ -103,29 +112,30 @@ subroutine test_simps_qp real(qp) :: ans integer :: i - print *, "test_simps_qp" y = [(real(i-1, qp)**2, i = 1, n)] val = simps(y, 1.0_qp) ans = 576.0_qp - print *, " dx=1", val, ans - call check(abs(val - ans) < tol_qp) + call check(error, val, ans, thr=tol_qp) + if (allocated(error)) return val = simps(y, 0.5_qp) ans = 288.0_qp - print *, " dx=0.5", val, ans - call check(abs(val - ans) < tol_qp) + call check(error, val, ans, thr=tol_qp) + if (allocated(error)) return x = [(0.25_qp*(i-1), i = 1, n)] val = simps(y, x) ans = 144.0_qp - print *, " x=0,0.25,0.5,...", val, ans - call check(abs(val - ans) < tol_qp) + call check(error, val, ans, thr=tol_qp) end subroutine test_simps_qp - subroutine test_simps_weights_sp + subroutine test_simps_weights_sp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 17 real(sp), dimension(n) :: y real(sp), dimension(n) :: x @@ -134,7 +144,6 @@ subroutine test_simps_weights_sp real(sp) :: val real(sp) :: ans - print *, "test_simps_weights_sp" y = [(real(i-1, sp), i = 1, n)] @@ -142,12 +151,14 @@ subroutine test_simps_weights_sp w = simps_weights(x) val = sum(w*y) ans = simps(y, x) - print *, " ", val, ans - call check(abs(val - ans) < tol_sp) + call check(error, val, ans, thr=tol_sp) end subroutine test_simps_weights_sp - subroutine test_simps_weights_dp + 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 @@ -156,7 +167,6 @@ subroutine test_simps_weights_dp real(dp) :: val real(dp) :: ans - print *, "test_simps_weights_dp" y = [(real(i-1, dp), i = 1, n)] @@ -164,12 +174,14 @@ subroutine test_simps_weights_dp w = simps_weights(x) val = sum(w*y) ans = simps(y, x) - print *, " ", val, ans - call check(abs(val - ans) < tol_dp) + call check(error, val, ans, thr=tol_dp) end subroutine test_simps_weights_dp - subroutine test_simps_weights_qp + subroutine test_simps_weights_qp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 17 real(qp), dimension(n) :: y real(qp), dimension(n) :: x @@ -178,7 +190,6 @@ subroutine test_simps_weights_qp real(qp) :: val real(qp) :: ans - print *, "test_simps_weights_qp" y = [(real(i-1, qp), i = 1, n)] @@ -186,48 +197,65 @@ subroutine test_simps_weights_qp w = simps_weights(x) val = sum(w*y) ans = simps(y, x) - print *, " ", val, ans - call check(abs(val - ans) < tol_qp) + call check(error, val, ans, thr=tol_qp) end subroutine test_simps_weights_qp - subroutine test_simps_zero_sp + subroutine test_simps_zero_sp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(sp), dimension(0) :: a - print *, "test_simps_zero_sp" - call check(abs(simps(a, 1.0_sp)) < epsilon(0.0_sp)) - call check(abs(simps([1.0_sp], 1.0_sp)) < epsilon(0.0_sp)) - call check(abs(simps(a, a)) < epsilon(0.0_sp)) - call check(abs(simps([1.0_sp], [1.0_sp])) < epsilon(0.0_sp)) + 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 + subroutine test_simps_zero_dp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(dp), dimension(0) :: a - print *, "test_simps_zero_dp" - call check(abs(simps(a, 1.0_dp)) < epsilon(0.0_dp)) - call check(abs(simps([1.0_dp], 1.0_dp)) < epsilon(0.0_dp)) - call check(abs(simps(a, a)) < epsilon(0.0_dp)) - call check(abs(simps([1.0_dp], [1.0_dp])) < epsilon(0.0_dp)) + call check(error, abs(simps(a, 1.0_dp)) < epsilon(0.0_dp)) + 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 + subroutine test_simps_zero_qp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(qp), dimension(0) :: a - print *, "test_simps_zero_qp" - call check(abs(simps(a, 1.0_qp)) < epsilon(0.0_qp)) - call check(abs(simps([1.0_qp], 1.0_qp)) < epsilon(0.0_qp)) - call check(abs(simps(a, a)) < epsilon(0.0_qp)) - call check(abs(simps([1.0_qp], [1.0_qp])) < epsilon(0.0_qp)) + 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)) end subroutine test_simps_zero_qp - subroutine test_simps_even_sp + 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 @@ -236,33 +264,34 @@ subroutine test_simps_even_sp integer :: i integer :: even - print *, "test_simps_even_sp" y = [(3.0_sp*real(i-1, sp)**2, i = 1, n)] do even = -1, 1 - print *, "even=", even val = simps(y, 1.0_sp) ans = 1000.0_sp - print *, " dx=1", val, ans - call check(abs(val - ans) < tol_sp) + call check(error, val, ans, thr=tol_sp) + if (allocated(error)) return val = simps(y, 0.5_sp) ans = 500.0_sp - print *, " dx=0.5", val, ans - call check(abs(val - ans) < tol_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 - print *, " x=0,0.25,0.5,...", val, ans - call check(abs(val - ans) < tol_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 + 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 @@ -270,29 +299,30 @@ subroutine test_simps_even_dp real(dp) :: ans integer :: i - print *, "test_simps_even_dp" y = [(3.0_dp*real(i-1, dp)**2, i = 1, n)] val = simps(y, 1.0_dp) ans = 1000.0_dp - print *, " dx=1", val, ans - call check(abs(val - ans) < tol_dp) + call check(error, val, ans, thr=tol_dp) + if (allocated(error)) return val = simps(y, 0.5_dp) ans = 500.0_dp - print *, " dx=0.5", val, ans - call check(abs(val - ans) < tol_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 = 250.0_dp - print *, " x=0,0.25,0.5,...", val, ans - call check(abs(val - ans) < tol_dp) + call check(error, val, ans, thr=tol_dp) end subroutine test_simps_even_dp - subroutine test_simps_even_qp + subroutine test_simps_even_qp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 11 real(qp), dimension(n) :: y real(qp), dimension(n) :: x @@ -301,33 +331,34 @@ subroutine test_simps_even_qp integer :: i integer :: even - print *, "test_simps_even_qp" y = [(3.0_qp*real(i-1, qp)**2, i = 1, n)] do even = -1, 1 - print *, " even=", even val = simps(y, 1.0_qp) ans = 1000.0_qp - print *, " dx=1", val, ans - call check(abs(val - ans) < tol_qp) + call check(error, val, ans, thr=tol_qp) + if (allocated(error)) return val = simps(y, 0.5_qp) ans = 500.0_qp - print *, " dx=0.5", val, ans - call check(abs(val - ans) < tol_qp) + call check(error, val, ans, thr=tol_qp) + if (allocated(error)) return x = [(0.25_qp*(i-1), i = 1, n)] val = simps(y, x) ans = 250.0_qp - print *, " x=0,0.25,0.5,...", val, ans - call check(abs(val - ans) < tol_qp) + call check(error, val, ans, thr=tol_qp) + if (allocated(error)) return end do end subroutine test_simps_even_qp - subroutine test_simps_weights_even_sp + subroutine test_simps_weights_even_sp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 16 real(sp), dimension(n) :: y real(sp), dimension(n) :: x @@ -337,7 +368,6 @@ subroutine test_simps_weights_even_sp real(sp) :: ans integer :: even - print *, "test_simps_weights_even_sp" y = [(real(i-1, sp), i = 1, n)] x = y @@ -346,13 +376,16 @@ subroutine test_simps_weights_even_sp w = simps_weights(x) val = sum(w*y) ans = simps(y, x) - print *, " even=", even, val, ans - call check(abs(val - ans) < tol_sp) + 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 + 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 @@ -362,7 +395,6 @@ subroutine test_simps_weights_even_dp real(dp) :: ans integer :: even - print *, "test_simps_weights_even_dp" y = [(real(i-1, dp), i = 1, n)] x = y @@ -371,13 +403,16 @@ subroutine test_simps_weights_even_dp w = simps_weights(x) val = sum(w*y) ans = simps(y, x) - print *, " even=", even, val, ans - call check(abs(val - ans) < tol_dp) + 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 + subroutine test_simps_weights_even_qp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 16 real(qp), dimension(n) :: y real(qp), dimension(n) :: x @@ -387,7 +422,6 @@ subroutine test_simps_weights_even_qp real(qp) :: ans integer :: even - print *, "test_simps_weights_even_qp" y = [(real(i-1, qp), i = 1, n)] @@ -397,13 +431,16 @@ subroutine test_simps_weights_even_qp w = simps_weights(x) val = sum(w*y) ans = simps(y, x) - print *, " even=", even, val, ans - call check(abs(val - ans) < tol_qp) + call check(error, val, ans, thr=tol_qp) + if (allocated(error)) return end do end subroutine test_simps_weights_even_qp - subroutine test_simps_six_sp + 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 @@ -412,33 +449,34 @@ subroutine test_simps_six_sp integer :: i integer :: even - print *, "test_simps_six_sp" y = [(3.0_sp*real(i-1, sp)**2, i = 1, n)] do even = -1, 1 - print *, "even=", even val = simps(y, 1.0_sp) ans = 125.0_sp - print *, " dx=1", val, ans - call check(abs(val - ans) < tol_sp) + call check(error, val, ans, thr=tol_sp) + if (allocated(error)) return val = simps(y, 0.5_sp) ans = 62.5_sp - print *, " dx=0.5", val, ans - call check(abs(val - ans) < tol_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 - print *, " x=0,0.25,0.5,...", val, ans - call check(abs(val - ans) < tol_sp) + call check(error, val, ans, thr=tol_sp) + if (allocated(error)) return end do end subroutine test_simps_six_sp - subroutine test_simps_six_dp + 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 @@ -446,29 +484,30 @@ subroutine test_simps_six_dp real(dp) :: ans integer :: i - print *, "test_simps_six_dp" y = [(3.0_dp*real(i-1, dp)**2, i = 1, n)] val = simps(y, 1.0_dp) ans = 125.0_dp - print *, " dx=1", val, ans - call check(abs(val - ans) < tol_dp) + call check(error, val, ans, thr=tol_dp) + if (allocated(error)) return val = simps(y, 0.5_dp) ans = 62.5_dp - print *, " dx=0.5", val, ans - call check(abs(val - ans) < tol_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 - print *, " x=0,0.25,0.5,...", val, ans - call check(abs(val - ans) < tol_dp) + call check(error, val, ans, thr=tol_dp) end subroutine test_simps_six_dp - subroutine test_simps_six_qp + subroutine test_simps_six_qp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 6 real(qp), dimension(n) :: y real(qp), dimension(n) :: x @@ -477,29 +516,54 @@ subroutine test_simps_six_qp integer :: i integer :: even - print *, "test_simps_six_qp" y = [(3.0_qp*real(i-1, qp)**2, i = 1, n)] do even = -1, 1 - print *, " even=", even val = simps(y, 1.0_qp) ans = 125.0_qp - print *, " dx=1", val, ans - call check(abs(val - ans) < tol_qp) + call check(error, val, ans, thr=tol_qp) + if (allocated(error)) return val = simps(y, 0.5_qp) ans = 62.5_qp - print *, " dx=0.5", val, ans - call check(abs(val - ans) < tol_qp) + call check(error, val, ans, thr=tol_qp) + if (allocated(error)) return x = [(0.25_qp*(i-1), i = 1, n)] val = simps(y, x) ans = 31.25_qp - print *, " x=0,0.25,0.5,...", val, ans - call check(abs(val - ans) < tol_qp) + call check(error, val, ans, thr=tol_qp) + if (allocated(error)) return end do end subroutine test_simps_six_qp +end module + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_simps, only : collect_simps + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("simps", collect_simps) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if end program diff --git a/src/tests/quadrature/test_trapz.f90 b/src/tests/quadrature/test_trapz.f90 index a533f2a9f..7b449ea13 100644 --- a/src/tests/quadrature/test_trapz.f90 +++ b/src/tests/quadrature/test_trapz.f90 @@ -1,25 +1,34 @@ -program test_trapz +module test_trapz use stdlib_kinds, only: sp, dp, qp - use stdlib_error, only: check + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_quadrature, only: trapz, trapz_weights implicit none - call test_trapz_sp - call test_trapz_dp - call test_trapz_qp - - call test_trapz_weights_sp - call test_trapz_weights_dp - call test_trapz_weights_qp - - call test_trapz_zero_sp - call test_trapz_zero_dp - call test_trapz_zero_qp - contains - subroutine test_trapz_sp + !> Collect all exported unit tests + subroutine collect_trapz(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("trapz_sp", test_trapz_sp), & + new_unittest("trapz_dp", test_trapz_dp), & + new_unittest("trapz_qp", test_trapz_qp), & + new_unittest("trapz_weights_sp", test_trapz_weights_sp), & + new_unittest("trapz_weights_dp", test_trapz_weights_dp), & + new_unittest("trapz_weights_qp", test_trapz_weights_qp), & + new_unittest("trapz_zero_sp", test_trapz_zero_sp), & + new_unittest("trapz_zero_dp", test_trapz_zero_dp), & + new_unittest("trapz_zero_qp", test_trapz_zero_qp) & + ] + end subroutine collect_trapz + + subroutine test_trapz_sp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 17 real(sp), dimension(n) :: y real(sp), dimension(n) :: x @@ -27,30 +36,31 @@ subroutine test_trapz_sp real(sp) :: ans integer :: i - print *, "test_trapz_sp" - y = [(real(i-1, sp), i = 1, n)] val = trapz(y, 1.0_sp) ans = 128.0_sp - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) val = trapz(y, 0.5_sp) ans = 64.0_sp - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) x = [((i-1)*4.0_sp/real(n-1, sp), i = 1, n)] val = trapz(y, x) ans = 32.0_sp - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) x = y**2 val = trapz(y, x) ans = 2728.0_sp - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) end subroutine test_trapz_sp - subroutine test_trapz_dp + subroutine test_trapz_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 @@ -58,31 +68,32 @@ subroutine test_trapz_dp real(dp) :: ans integer :: i - print *, "test_trapz_dp" - y = [(real(i-1, dp), i = 1, n)] val = trapz(y, 1.0_dp) ans = 128.0_dp - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) val = trapz(y, 0.5_dp) ans = 64.0_dp - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) x = [((i-1)*4.0_dp/real(n-1, dp), i = 1, n)] val = trapz(y, x) ans = 32.0_dp - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) x = y**2 val = trapz(y, x) ans = 2728.0_dp - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) end subroutine test_trapz_dp - subroutine test_trapz_qp + subroutine test_trapz_qp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 17 real(qp), dimension(n) :: y real(qp), dimension(n) :: x @@ -90,31 +101,32 @@ subroutine test_trapz_qp real(qp) :: ans integer :: i - print *, "test_trapz_qp" - y = [(real(i-1, qp), i = 1, n)] val = trapz(y, 1.0_qp) ans = 128.0_qp - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) val = trapz(y, 0.5_qp) ans = 64.0_qp - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) x = [((i-1)*4.0_qp/real(n-1, qp), i = 1, n)] val = trapz(y, x) ans = 32.0_qp - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) x = y**2 val = trapz(y, x) ans = 2728.0_qp - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) end subroutine test_trapz_qp - subroutine test_trapz_weights_sp + subroutine test_trapz_weights_sp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 17 real(sp), dimension(n) :: y real(sp), dimension(n) :: x @@ -123,26 +135,27 @@ subroutine test_trapz_weights_sp real(sp) :: val real(sp) :: ans - print *, "test_trapz_weights_sp" - y = [(real(i-1, sp), i = 1, n)] x = y w = trapz_weights(x) val = dot_product(w, y) ans = trapz(y, x) - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) x = y**2 w = trapz_weights(x) val = dot_product(w, y) ans = trapz(y, x) - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) end subroutine test_trapz_weights_sp - subroutine test_trapz_weights_dp + subroutine test_trapz_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 @@ -151,26 +164,27 @@ subroutine test_trapz_weights_dp real(dp) :: val real(dp) :: ans - print *, "test_trapz_weights_dp" - y = [(real(i-1, dp), i = 1, n)] x = y w = trapz_weights(x) val = dot_product(w, y) ans = trapz(y, x) - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) x = y**2 w = trapz_weights(x) val = dot_product(w, y) ans = trapz(y, x) - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) end subroutine test_trapz_weights_dp - subroutine test_trapz_weights_qp + subroutine test_trapz_weights_qp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 17 real(qp), dimension(n) :: y real(qp), dimension(n) :: x @@ -179,58 +193,86 @@ subroutine test_trapz_weights_qp real(qp) :: val real(qp) :: ans - print *, "test_trapz_weights_qp" - y = [(real(i-1, qp), i = 1, n)] x = y w = trapz_weights(x) val = dot_product(w, y) ans = trapz(y, x) - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) x = y**2 w = trapz_weights(x) val = dot_product(w, y) ans = trapz(y, x) - call check(abs(val - ans) < epsilon(ans)) + call check(error, abs(val - ans) < epsilon(ans)) end subroutine test_trapz_weights_qp - subroutine test_trapz_zero_sp - real(sp), dimension(0) :: a + subroutine test_trapz_zero_sp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - print *, "test_trapz_zero_sp" + real(sp), dimension(0) :: a - call check(abs(trapz(a, 1.0_sp)) < epsilon(0.0_sp)) - call check(abs(trapz([1.0_sp], 1.0_sp)) < epsilon(0.0_sp)) - call check(abs(trapz(a, a)) < epsilon(0.0_sp)) - call check(abs(trapz([1.0_sp], [1.0_sp])) < epsilon(0.0_sp)) + call check(error, abs(trapz(a, 1.0_sp)) < epsilon(0.0_sp)) + call check(error, abs(trapz([1.0_sp], 1.0_sp)) < epsilon(0.0_sp)) + call check(error, abs(trapz(a, a)) < epsilon(0.0_sp)) + call check(error, abs(trapz([1.0_sp], [1.0_sp])) < epsilon(0.0_sp)) end subroutine test_trapz_zero_sp - subroutine test_trapz_zero_dp - real(dp), dimension(0) :: a + subroutine test_trapz_zero_dp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - print *, "test_trapz_zero_dp" + real(dp), dimension(0) :: a - call check(abs(trapz(a, 1.0_dp)) < epsilon(0.0_dp)) - call check(abs(trapz([1.0_dp], 1.0_dp)) < epsilon(0.0_dp)) - call check(abs(trapz(a, a)) < epsilon(0.0_dp)) - call check(abs(trapz([1.0_dp], [1.0_dp])) < epsilon(0.0_dp)) + call check(error, abs(trapz(a, 1.0_dp)) < epsilon(0.0_dp)) + call check(error, abs(trapz([1.0_dp], 1.0_dp)) < epsilon(0.0_dp)) + call check(error, abs(trapz(a, a)) < epsilon(0.0_dp)) + call check(error, abs(trapz([1.0_dp], [1.0_dp])) < epsilon(0.0_dp)) end subroutine test_trapz_zero_dp - subroutine test_trapz_zero_qp - real(qp), dimension(0) :: a + subroutine test_trapz_zero_qp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - print *, "test_trapz_zero_qp" + real(qp), dimension(0) :: a - call check(abs(trapz(a, 1.0_qp)) < epsilon(0.0_qp)) - call check(abs(trapz([1.0_qp], 1.0_qp)) < epsilon(0.0_qp)) - call check(abs(trapz(a, a)) < epsilon(0.0_qp)) - call check(abs(trapz([1.0_qp], [1.0_qp])) < epsilon(0.0_qp)) + call check(error, abs(trapz(a, 1.0_qp)) < epsilon(0.0_qp)) + call check(error, abs(trapz([1.0_qp], 1.0_qp)) < epsilon(0.0_qp)) + call check(error, abs(trapz(a, a)) < epsilon(0.0_qp)) + call check(error, abs(trapz([1.0_qp], [1.0_qp])) < epsilon(0.0_qp)) end subroutine test_trapz_zero_qp -end program test_trapz +end module test_trapz + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_trapz, only : collect_trapz + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("trapz", collect_trapz) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program From c525c96973590db076c712327d3e7448c63fb587 Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Fri, 27 Aug 2021 00:16:34 +0200 Subject: [PATCH 14/34] Rewrite rawmoment tests --- src/tests/stats/test_rawmoment.f90 | 470 ++++++++++++++++------------- 1 file changed, 258 insertions(+), 212 deletions(-) diff --git a/src/tests/stats/test_rawmoment.f90 b/src/tests/stats/test_rawmoment.f90 index d20eef307..96eb995c7 100644 --- a/src/tests/stats/test_rawmoment.f90 +++ b/src/tests/stats/test_rawmoment.f90 @@ -1,5 +1,5 @@ -program test_rawmoment - use stdlib_error, only: check +module test_rawmoment + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_kinds, only: sp, dp, int32 use stdlib_stats, only: mean, moment use,intrinsic :: ieee_arithmetic, only : ieee_is_nan @@ -9,32 +9,43 @@ program test_rawmoment real(sp), parameter :: sptol = 1000 * epsilon(1._sp) real(dp), parameter :: dptol = 1000 * epsilon(1._dp) - real(dp) :: d1(5) = [1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp] - real(dp) :: d(4, 3) = reshape([1._dp, 3._dp, 5._dp, 7._dp,& + real(dp), parameter :: d1(5) = [1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp] + real(dp), parameter :: d(4, 3) = reshape([1._dp, 3._dp, 5._dp, 7._dp,& 2._dp, 4._dp, 6._dp, 8._dp,& 9._dp, 10._dp, 11._dp, 12._dp], [4, 3]) - complex(sp) :: cs1(5) = [ cmplx(0.57706_sp, 0.00000_sp),& + complex(sp), parameter :: cs1(5) = [ cmplx(0.57706_sp, 0.00000_sp),& cmplx(0.00000_sp, 1.44065_sp),& cmplx(1.26401_sp, 0.00000_sp),& cmplx(0.00000_sp, 0.88833_sp),& cmplx(1.14352_sp, 0.00000_sp)] - complex(sp) :: cs(5,3) + complex(sp), parameter :: cs(5,3) = reshape([cs1, cs1*3.0_sp, cs1*1.5_sp], shape(cs)) - call test_sp(real(d1,sp), real(d,sp)) - call test_int32(int(d1, int32), int(d, int32)) - - cs(:,1) = cs1 - cs(:,2) = cs1*3_sp - cs(:,3) = cs1*1.5_sp - call test_csp(cs1, cs) contains - subroutine test_sp(x1, x2) - real(sp), intent(in) :: x1(:), x2(:, :) + + + !> Collect all exported unit tests + subroutine collect_rawmoment(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("sp", test_sp), & + new_unittest("int32", test_int32), & + new_unittest("csp", test_csp) & + ] + end subroutine collect_rawmoment + + subroutine test_sp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp), parameter :: x1(5) = d1 + real(sp), parameter :: x2(4, 3) = d integer :: order real(sp), allocatable :: x3(:, :, :) @@ -49,51 +60,51 @@ subroutine test_sp(x1, x2) !1dim print*,' test_sp_1dim', order - call check( abs(moment(x1, order, center = 0.) - mean(x1)) < sptol) - call check( abs(moment(x1, order, 1, center = 0.) - mean(x1)) < sptol) + call check(error, abs(moment(x1, order, center = 0.) - mean(x1)) < sptol) + call check(error, abs(moment(x1, order, 1, center = 0.) - mean(x1)) < sptol) print*,' test_sp_1dim_mask', order - call check( ieee_is_nan(moment(x1, order, center = 0., mask = .false.))) - call check( ieee_is_nan(moment(x1, order, dim = 1, center = 0., mask = .false.))) + call check(error, ieee_is_nan(moment(x1, order, center = 0., mask = .false.))) + call check(error, ieee_is_nan(moment(x1, order, dim = 1, center = 0., mask = .false.))) print*,' test_sp_1dim_mask_array', order - call check( abs(moment(x1, order, center = 0., mask = (x1 < 5)) -& + call check(error, abs(moment(x1, order, center = 0., mask = (x1 < 5)) -& mean(x1, mask = (x1 < 5)) ) < sptol) - call check( abs(moment(x1, order, dim = 1, center = 0., mask = (x1 < 5)) -& + call check(error, abs(moment(x1, order, dim = 1, center = 0., mask = (x1 < 5)) -& mean(x1, dim = 1, mask = (x1 < 5))) < sptol) !2dim print*,' test_sp_2dim', order - call check( abs(moment(x2, order, center = 0.) - mean(x2)) < sptol) - call check( all( abs( moment(x2, order, dim = 1, center = 0.) -& + call check(error, abs(moment(x2, order, center = 0.) - mean(x2)) < sptol) + call check(error, all( abs( moment(x2, order, dim = 1, center = 0.) -& mean(x2, dim = 1)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = 0.) -& + call check(error, all( abs( moment(x2, order, dim = 2, center = 0.) -& mean(x2, dim = 2)) < sptol)) - call check( all( abs( moment(x2, order, dim = 1, center = zero2_1) -& + call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -& mean(x2, dim = 1)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = zero2_2) -& + call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) -& mean(x2, dim = 2)) < sptol)) print*,' test_sp_2dim_mask', order - call check( ieee_is_nan(moment(x2, order, center = 0., mask = .false.))) - call check( any(ieee_is_nan(moment(x2, order, dim = 1, center = zero2_1,& + call check(error, ieee_is_nan(moment(x2, order, center = 0., mask = .false.))) + call check(error, any(ieee_is_nan(moment(x2, order, dim = 1, center = zero2_1,& mask = .false.)))) - call check( any(ieee_is_nan(moment(x2, order, dim = 2, center = zero2_2,& + call check(error, any(ieee_is_nan(moment(x2, order, dim = 2, center = zero2_2,& mask = .false.)))) print*,' test_sp_2dim_mask_array', order - call check( abs(moment(x2, order, center = 0., mask = (x2 < 11)) -& + call check(error, abs(moment(x2, order, center = 0., mask = (x2 < 11)) -& mean(x2, x2 < 11)) < sptol) - call check( all( abs( moment(x2, order, dim = 1, center = 0.,& + call check(error, all( abs( moment(x2, order, dim = 1, center = 0.,& mask = (x2 < 11)) -& mean(x2, 1, x2 < 11)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = 0.,& + call check(error, all( abs( moment(x2, order, dim = 2, center = 0.,& mask = (x2 < 11)) -& mean(x2, 2, x2 < 11)) < sptol)) - call check( all( abs( moment(x2, order, dim = 1, center = zero2_1,& + call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,& mask = (x2 < 11)) -& mean(x2, 1, x2 < 11)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = zero2_2,& + call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2,& mask = (x2 < 11)) -& mean(x2, 2, x2 < 11)) < sptol)) @@ -111,48 +122,48 @@ subroutine test_sp(x1, x2) zero3_3 = 0 print*,' test_sp_3dim', order - call check( abs(moment(x3, order, center = 0.) - mean(x3)) < sptol) - call check( all( abs( moment(x3, order, dim = 1, center = 0._sp) -& + call check(error, abs(moment(x3, order, center = 0.) - mean(x3)) < sptol) + call check(error, all( abs( moment(x3, order, dim = 1, center = 0._sp) -& mean(x3, 1)) < sptol)) - call check( all( abs( moment(x3, order, dim = 2, center = 0._sp) -& + call check(error, all( abs( moment(x3, order, dim = 2, center = 0._sp) -& mean(x3, 2)) < sptol)) - call check( all( abs( moment(x3, order, dim = 3, center = 0._sp) -& + call check(error, all( abs( moment(x3, order, dim = 3, center = 0._sp) -& mean(x3, 3)) < sptol)) - call check( all( abs( moment(x3, order, dim = 1, center = zero3_1) -& + call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1) -& mean(x3, 1)) < sptol)) - call check( all( abs( moment(x3, order, dim = 2, center = zero3_2) -& + call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2) -& mean(x3, 2)) < sptol)) - call check( all( abs( moment(x3, order, dim = 3, center = zero3_3) -& + call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3) -& mean(x3, 3)) < sptol)) print*,' test_sp_3dim_mask', order - call check( ieee_is_nan(moment(x3, order, center = 0., mask = .false.))) - call check( any(ieee_is_nan(moment(x3, order, dim = 1, center = zero3_1,& + call check(error, ieee_is_nan(moment(x3, order, center = 0., mask = .false.))) + call check(error, any(ieee_is_nan(moment(x3, order, dim = 1, center = zero3_1,& mask = .false.)))) - call check( any(ieee_is_nan(moment(x3, order, dim = 2, center = zero3_2,& + call check(error, any(ieee_is_nan(moment(x3, order, dim = 2, center = zero3_2,& mask = .false.)))) - call check( any(ieee_is_nan(moment(x3, order, dim = 3, center = zero3_3,& + call check(error, any(ieee_is_nan(moment(x3, order, dim = 3, center = zero3_3,& mask = .false.)))) print*,' test_sp_3dim_mask_array', order - call check( abs(moment(x3, order, center = 0., mask = (x3 < 11)) -& + call check(error, abs(moment(x3, order, center = 0., mask = (x3 < 11)) -& mean(x3, x3 < 11)) < sptol) - call check( all( abs( moment(x3, order, dim = 1, center = 0.,& + call check(error, all( abs( moment(x3, order, dim = 1, center = 0.,& mask = (x3 < 45)) -& mean(x3, 1, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 2, center = 0.,& + call check(error, all( abs( moment(x3, order, dim = 2, center = 0.,& mask = (x3 < 45)) -& mean(x3, 2, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 3, center = 0.,& + call check(error, all( abs( moment(x3, order, dim = 3, center = 0.,& mask = (x3 < 45)) -& mean(x3, 3, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 1, center = zero3_1,& + call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1,& mask = (x3 < 45)) -& mean(x3, 1, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 2, center = zero3_2,& + call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2,& mask = (x3 < 45)) -& mean(x3, 2, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 3, center = zero3_3,& + call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3,& mask = (x3 < 45)) -& mean(x3, 3, x3 < 45)) < sptol )) @@ -161,105 +172,109 @@ subroutine test_sp(x1, x2) !1dim print*,' test_sp_1dim', order - call check( abs(moment(x1, order, center = 0.) - mean(x1**2)) < sptol) - call check( abs(moment(x1, order, 1, center = 0.) - mean(x1**2, 1)) < sptol) + call check(error, abs(moment(x1, order, center = 0.) - mean(x1**2)) < sptol) + call check(error, abs(moment(x1, order, 1, center = 0.) - mean(x1**2, 1)) < sptol) print*,' test_sp_1dim_mask', order - call check( ieee_is_nan(moment(x1, order, center = 0., mask = .false.))) - call check( ieee_is_nan(moment(x1, order, dim = 1, center = 0., mask = .false.))) + call check(error, ieee_is_nan(moment(x1, order, center = 0., mask = .false.))) + call check(error, ieee_is_nan(moment(x1, order, dim = 1, center = 0., mask = .false.))) print*,' test_sp_1dim_mask_array', order - call check( abs(moment(x1, order, center = 0., mask = (x1 < 5)) -& + call check(error, abs(moment(x1, order, center = 0., mask = (x1 < 5)) -& mean(x1**2, x1 < 5)) < sptol) - call check( abs(moment(x1, order, dim = 1, center = 0., mask = (x1 < 5)) -& + call check(error, abs(moment(x1, order, dim = 1, center = 0., mask = (x1 < 5)) -& mean(x1**2, 1, x1 < 5)) < sptol) !2dim print*,' test_sp_2dim', order - call check( abs(moment(x2, order, center = 0.) - mean(x2**2)) < sptol) - call check( all( abs( moment(x2, order, dim = 1, center = 0.) -& + call check(error, abs(moment(x2, order, center = 0.) - mean(x2**2)) < sptol) + call check(error, all( abs( moment(x2, order, dim = 1, center = 0.) -& mean(x2**2, 1)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = 0.) - & + call check(error, all( abs( moment(x2, order, dim = 2, center = 0.) - & mean(x2**2, 2)) < sptol)) - call check( all( abs( moment(x2, order, dim = 1, center = zero2_1) -& + call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -& mean(x2**2, 1)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = zero2_2) - & + call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) - & mean(x2**2, 2)) < sptol)) print*,' test_sp_2dim_mask', order - call check( ieee_is_nan(moment(x2, order, center = 0., mask = .false.))) - call check( any(ieee_is_nan(moment(x2, order, dim = 1, center = zero2_1, & + call check(error, ieee_is_nan(moment(x2, order, center = 0., mask = .false.))) + call check(error, any(ieee_is_nan(moment(x2, order, dim = 1, center = zero2_1, & mask = .false.)))) - call check( any(ieee_is_nan(moment(x2, order, dim = 2, center = zero2_2, & + call check(error, any(ieee_is_nan(moment(x2, order, dim = 2, center = zero2_2, & mask = .false.)))) print*,' test_sp_2dim_mask_array', order - call check( abs(moment(x2, order, center = 0., mask = (x2 < 11)) -& + call check(error, abs(moment(x2, order, center = 0., mask = (x2 < 11)) -& mean(x2**2, x2 < 11)) < sptol) - call check( all( abs( moment(x2, order, dim = 1, center = 0.,& + call check(error, all( abs( moment(x2, order, dim = 1, center = 0.,& mask = (x2 < 11)) -& mean(x2**2, 1, x2 < 11)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = 0.,& + call check(error, all( abs( moment(x2, order, dim = 2, center = 0.,& mask = (x2 < 11)) -& mean(x2**2, 2, x2 < 11)) < sptol)) - call check( all( abs( moment(x2, order, dim = 1, center = zero2_1,& + call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,& mask = (x2 < 11)) -& mean(x2**2, 1, x2 < 11)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = zero2_2,& + call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2,& mask = (x2 < 11)) -& mean(x2**2, 2, x2 < 11)) < sptol)) !3dim print*,' test_sp_3dim', order - call check( abs(moment(x3, order, center = 0.) - mean(x3**2)) < sptol) - call check( all( abs( moment(x3, order, dim = 1, center = 0.) -& + call check(error, abs(moment(x3, order, center = 0.) - mean(x3**2)) < sptol) + call check(error, all( abs( moment(x3, order, dim = 1, center = 0.) -& mean(x3**2, 1)) < sptol)) - call check( all( abs( moment(x3, order, dim = 2, center = 0.) -& + call check(error, all( abs( moment(x3, order, dim = 2, center = 0.) -& mean(x3**2, 2)) < sptol)) - call check( all( abs( moment(x3, order, dim = 3, center = 0.) -& + call check(error, all( abs( moment(x3, order, dim = 3, center = 0.) -& mean(x3**2, 3)) < sptol)) - call check( all( abs( moment(x3, order, dim = 1, center = zero3_1) -& + call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1) -& mean(x3**2, 1)) < sptol)) - call check( all( abs( moment(x3, order, dim = 2, center = zero3_2) -& + call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2) -& mean(x3**2, 2)) < sptol)) - call check( all( abs( moment(x3, order, dim = 3, center = zero3_3) -& + call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3) -& mean(x3**2, 3)) < sptol)) print*,' test_sp_3dim_mask', order - call check( ieee_is_nan(moment(x3, order, center = 0., mask = .false.))) - call check( any(ieee_is_nan(moment(x3, order, dim = 1, center = zero3_1,& + call check(error, ieee_is_nan(moment(x3, order, center = 0., mask = .false.))) + call check(error, any(ieee_is_nan(moment(x3, order, dim = 1, center = zero3_1,& mask = .false.)))) - call check( any(ieee_is_nan(moment(x3, order, dim = 2, center = zero3_2,& + call check(error, any(ieee_is_nan(moment(x3, order, dim = 2, center = zero3_2,& mask = .false.)))) - call check( any(ieee_is_nan(moment(x3, order, dim = 3, center = zero3_3,& + call check(error, any(ieee_is_nan(moment(x3, order, dim = 3, center = zero3_3,& mask = .false.)))) print*,' test_sp_3dim_mask_array', order - call check( abs(moment(x3, order, center = 0., mask = (x3 < 11)) -& + call check(error, abs(moment(x3, order, center = 0., mask = (x3 < 11)) -& mean(x3**2, x3 < 11)) < sptol) - call check( all( abs( moment(x3, order, dim = 1, center = 0.,& + call check(error, all( abs( moment(x3, order, dim = 1, center = 0.,& mask = (x3 < 45)) -& mean(x3**2, 1, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 2, center = 0.,& + call check(error, all( abs( moment(x3, order, dim = 2, center = 0.,& mask = (x3 < 45)) -& mean(x3**2, 2, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 3, center = 0.,& + call check(error, all( abs( moment(x3, order, dim = 3, center = 0.,& mask = (x3 < 45)) -& mean(x3**2, 3, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 1, center = zero3_1,& + call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1,& mask = (x3 < 45)) -& mean(x3**2, 1, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 2, center = zero3_2,& + call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2,& mask = (x3 < 45)) -& mean(x3**2, 2, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 3, center = zero3_3,& + call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3,& mask = (x3 < 45)) -& mean(x3**2, 3, x3 < 45)) < sptol )) end subroutine - subroutine test_int32(x1, x2) - integer(int32), intent(in) :: x1(:), x2(:, :) + subroutine test_int32(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(int32), parameter :: x1(5) = d1 + integer(int32), parameter :: x2(4, 3) = d integer :: order integer(int32), allocatable :: x3(:, :, :) @@ -274,52 +289,52 @@ subroutine test_int32(x1, x2) !1dim print*,' test_sp_1dim', order - call check( abs(moment(x1, order, center = 0._dp) - mean(x1)) < sptol) - call check( abs(moment(x1, order, 1, center = 0._dp) - mean(x1)) < sptol) + call check(error, abs(moment(x1, order, center = 0._dp) - mean(x1)) < sptol) + call check(error, abs(moment(x1, order, 1, center = 0._dp) - mean(x1)) < sptol) print*,' test_sp_1dim_mask', order - call check( ieee_is_nan(moment(x1, order, center = 0._dp, mask = .false.))) - call check( ieee_is_nan(moment(x1, order, dim = 1, center = 0._dp,& + call check(error, ieee_is_nan(moment(x1, order, center = 0._dp, mask = .false.))) + call check(error, ieee_is_nan(moment(x1, order, dim = 1, center = 0._dp,& mask = .false.))) print*,' test_sp_1dim_mask_array', order - call check( abs(moment(x1, order, center = 0._dp, mask = (x1 < 5)) -& + call check(error, abs(moment(x1, order, center = 0._dp, mask = (x1 < 5)) -& mean(x1, mask = (x1 < 5)) ) < sptol) - call check( abs(moment(x1, order, dim = 1, center = 0._dp, mask = (x1 < 5)) -& + call check(error, abs(moment(x1, order, dim = 1, center = 0._dp, mask = (x1 < 5)) -& mean(x1, dim = 1, mask = (x1 < 5))) < sptol) !2dim print*,' test_sp_2dim', order - call check( abs(moment(x2, order, center = 0._dp) - mean(x2)) < sptol) - call check( all( abs( moment(x2, order, dim = 1, center = 0._dp) -& + call check(error, abs(moment(x2, order, center = 0._dp) - mean(x2)) < sptol) + call check(error, all( abs( moment(x2, order, dim = 1, center = 0._dp) -& mean(x2, dim = 1)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = 0._dp) -& + call check(error, all( abs( moment(x2, order, dim = 2, center = 0._dp) -& mean(x2, dim = 2)) < sptol)) - call check( all( abs( moment(x2, order, dim = 1, center = zero2_1) -& + call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -& mean(x2, dim = 1)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = zero2_2) -& + call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) -& mean(x2, dim = 2)) < sptol)) print*,' test_sp_2dim_mask', order - call check( ieee_is_nan(moment(x2, order, center = 0._dp, mask = .false.))) - call check( any(ieee_is_nan(moment(x2, order, dim = 1, center = zero2_1,& + call check(error, ieee_is_nan(moment(x2, order, center = 0._dp, mask = .false.))) + call check(error, any(ieee_is_nan(moment(x2, order, dim = 1, center = zero2_1,& mask = .false.)))) - call check( any(ieee_is_nan(moment(x2, order, dim = 2, center = zero2_2,& + call check(error, any(ieee_is_nan(moment(x2, order, dim = 2, center = zero2_2,& mask = .false.)))) print*,' test_sp_2dim_mask_array', order - call check( abs(moment(x2, order, center = 0._dp, mask = (x2 < 11)) -& + call check(error, abs(moment(x2, order, center = 0._dp, mask = (x2 < 11)) -& mean(x2, x2 < 11)) < sptol) - call check( all( abs( moment(x2, order, dim = 1, center = 0._dp,& + call check(error, all( abs( moment(x2, order, dim = 1, center = 0._dp,& mask = (x2 < 11)) -& mean(x2, 1, x2 < 11)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = 0._dp,& + call check(error, all( abs( moment(x2, order, dim = 2, center = 0._dp,& mask = (x2 < 11)) -& mean(x2, 2, x2 < 11)) < sptol)) - call check( all( abs( moment(x2, order, dim = 1, center = zero2_1,& + call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,& mask = (x2 < 11)) -& mean(x2, 1, x2 < 11)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = zero2_2,& + call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2,& mask = (x2 < 11)) -& mean(x2, 2, x2 < 11)) < sptol)) @@ -337,48 +352,48 @@ subroutine test_int32(x1, x2) zero3_3 = 0 print*,' test_sp_3dim', order - call check( abs(moment(x3, order, center = 0._dp) - mean(x3)) < sptol) - call check( all( abs( moment(x3, order, dim = 1, center = 0._dp) -& + call check(error, abs(moment(x3, order, center = 0._dp) - mean(x3)) < sptol) + call check(error, all( abs( moment(x3, order, dim = 1, center = 0._dp) -& mean(x3, 1)) < sptol)) - call check( all( abs( moment(x3, order, dim = 2, center = 0._dp) -& + call check(error, all( abs( moment(x3, order, dim = 2, center = 0._dp) -& mean(x3, 2)) < sptol)) - call check( all( abs( moment(x3, order, dim = 3, center = 0._dp) -& + call check(error, all( abs( moment(x3, order, dim = 3, center = 0._dp) -& mean(x3, 3)) < sptol)) - call check( all( abs( moment(x3, order, dim = 1, center = zero3_1) -& + call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1) -& mean(x3, 1)) < sptol)) - call check( all( abs( moment(x3, order, dim = 2, center = zero3_2) -& + call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2) -& mean(x3, 2)) < sptol)) - call check( all( abs( moment(x3, order, dim = 3, center = zero3_3) -& + call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3) -& mean(x3, 3)) < sptol)) print*,' test_sp_3dim_mask', order - call check( ieee_is_nan(moment(x3, order, center = 0._dp, mask = .false.))) - call check( any(ieee_is_nan(moment(x3, order, dim = 1, center = zero3_1,& + call check(error, ieee_is_nan(moment(x3, order, center = 0._dp, mask = .false.))) + call check(error, any(ieee_is_nan(moment(x3, order, dim = 1, center = zero3_1,& mask = .false.)))) - call check( any(ieee_is_nan(moment(x3, order, dim = 2, center = zero3_2,& + call check(error, any(ieee_is_nan(moment(x3, order, dim = 2, center = zero3_2,& mask = .false.)))) - call check( any(ieee_is_nan(moment(x3, order, dim = 3, center = zero3_3,& + call check(error, any(ieee_is_nan(moment(x3, order, dim = 3, center = zero3_3,& mask = .false.)))) print*,' test_sp_3dim_mask_array', order - call check( abs(moment(x3, order, center = 0._dp, mask = (x3 < 11)) -& + call check(error, abs(moment(x3, order, center = 0._dp, mask = (x3 < 11)) -& mean(x3, x3 < 11)) < sptol) - call check( all( abs( moment(x3, order, dim = 1, center = 0._dp,& + call check(error, all( abs( moment(x3, order, dim = 1, center = 0._dp,& mask = (x3 < 45)) -& mean(x3, 1, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 2, center = 0._dp,& + call check(error, all( abs( moment(x3, order, dim = 2, center = 0._dp,& mask = (x3 < 45)) -& mean(x3, 2, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 3, center = 0._dp,& + call check(error, all( abs( moment(x3, order, dim = 3, center = 0._dp,& mask = (x3 < 45)) -& mean(x3, 3, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 1, center = zero3_1,& + call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1,& mask = (x3 < 45)) -& mean(x3, 1, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 2, center = zero3_2,& + call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2,& mask = (x3 < 45)) -& mean(x3, 2, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 3, center = zero3_3,& + call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3,& mask = (x3 < 45)) -& mean(x3, 3, x3 < 45)) < sptol )) @@ -387,116 +402,120 @@ subroutine test_int32(x1, x2) !1dim print*,' test_sp_1dim', order - call check( abs(moment(x1, order, center = 0._dp) - mean(x1**2)) < sptol) - call check( abs(moment(x1, order, 1, center = 0._dp) - mean(x1**2, 1)) < sptol) + call check(error, abs(moment(x1, order, center = 0._dp) - mean(x1**2)) < sptol) + call check(error, abs(moment(x1, order, 1, center = 0._dp) - mean(x1**2, 1)) < sptol) print*,' test_sp_1dim_mask', order - call check( ieee_is_nan(moment(x1, order, center = 0._dp, mask = .false.))) - call check( ieee_is_nan(moment(x1, order, dim = 1, center = 0._dp,& + call check(error, ieee_is_nan(moment(x1, order, center = 0._dp, mask = .false.))) + call check(error, ieee_is_nan(moment(x1, order, dim = 1, center = 0._dp,& mask = .false.))) print*,' test_sp_1dim_mask_array', order - call check( abs(moment(x1, order, center = 0._dp, mask = (x1 < 5)) -& + call check(error, abs(moment(x1, order, center = 0._dp, mask = (x1 < 5)) -& mean(x1**2, x1 < 5)) < sptol) - call check( abs(moment(x1, order, dim = 1, center = 0._dp, mask = (x1 < 5)) -& + call check(error, abs(moment(x1, order, dim = 1, center = 0._dp, mask = (x1 < 5)) -& mean(x1**2, 1, x1 < 5)) < sptol) !2dim print*,' test_sp_2dim', order - call check( abs(moment(x2, order, center = 0._dp) - mean(x2**2)) < sptol) - call check( all( abs( moment(x2, order, dim = 1, center = 0._dp) -& + call check(error, abs(moment(x2, order, center = 0._dp) - mean(x2**2)) < sptol) + call check(error, all( abs( moment(x2, order, dim = 1, center = 0._dp) -& mean(x2**2, 1)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = 0._dp) -& + call check(error, all( abs( moment(x2, order, dim = 2, center = 0._dp) -& mean(x2**2, 2)) < sptol)) - call check( all( abs( moment(x2, order, dim = 1, center = zero2_1) -& + call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -& mean(x2**2, 1)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = zero2_2) -& + call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) -& mean(x2**2, 2)) < sptol)) print*,' test_sp_2dim_mask', order - call check( ieee_is_nan(moment(x2, order, center = 0._dp, mask = .false.))) - call check( any(ieee_is_nan(moment(x2, order, dim = 1, center = 0._dp,& + call check(error, ieee_is_nan(moment(x2, order, center = 0._dp, mask = .false.))) + call check(error, any(ieee_is_nan(moment(x2, order, dim = 1, center = 0._dp,& mask = .false.)))) - call check( any(ieee_is_nan(moment(x2, order, dim = 2, center = 0._dp,& + call check(error, any(ieee_is_nan(moment(x2, order, dim = 2, center = 0._dp,& mask = .false.)))) - call check( any(ieee_is_nan(moment(x2, order, dim = 1, center = zero2_1,& + call check(error, any(ieee_is_nan(moment(x2, order, dim = 1, center = zero2_1,& mask = .false.)))) - call check( any(ieee_is_nan(moment(x2, order, dim = 2, center = zero2_2,& + call check(error, any(ieee_is_nan(moment(x2, order, dim = 2, center = zero2_2,& mask = .false.)))) print*,' test_sp_2dim_mask_array', order - call check( abs(moment(x2, order, center = 0._dp, mask = (x2 < 11)) -& + call check(error, abs(moment(x2, order, center = 0._dp, mask = (x2 < 11)) -& mean(x2**2, x2 < 11)) < sptol) - call check( all( abs( moment(x2, order, dim = 1, center = 0._dp,& + call check(error, all( abs( moment(x2, order, dim = 1, center = 0._dp,& mask = (x2 < 11)) -& mean(x2**2, 1, x2 < 11)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = 0._dp,& + call check(error, all( abs( moment(x2, order, dim = 2, center = 0._dp,& mask = (x2 < 11)) -& mean(x2**2, 2, x2 < 11)) < sptol)) - call check( all( abs( moment(x2, order, dim = 1, center = zero2_1,& + call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,& mask = (x2 < 11)) -& mean(x2**2, 1, x2 < 11)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = zero2_2,& + call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2,& mask = (x2 < 11)) -& mean(x2**2, 2, x2 < 11)) < sptol)) !3dim print*,' test_sp_3dim', order - call check( abs(moment(x3, order, center = 0._dp) - mean(x3**2)) < sptol) - call check( all( abs( moment(x3, order, dim = 1, center = 0._dp) -& + call check(error, abs(moment(x3, order, center = 0._dp) - mean(x3**2)) < sptol) + call check(error, all( abs( moment(x3, order, dim = 1, center = 0._dp) -& mean(x3**2, 1)) < sptol)) - call check( all( abs( moment(x3, order, dim = 2, center = 0._dp) -& + call check(error, all( abs( moment(x3, order, dim = 2, center = 0._dp) -& mean(x3**2, 2)) < sptol)) - call check( all( abs( moment(x3, order, dim = 3, center = 0._dp) -& + call check(error, all( abs( moment(x3, order, dim = 3, center = 0._dp) -& mean(x3**2, 3)) < sptol)) - call check( all( abs( moment(x3, order, dim = 1, center = zero3_1) -& + call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1) -& mean(x3**2, 1)) < sptol)) - call check( all( abs( moment(x3, order, dim = 2, center = zero3_2) -& + call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2) -& mean(x3**2, 2)) < sptol)) - call check( all( abs( moment(x3, order, dim = 3, center = zero3_3) -& + call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3) -& mean(x3**2, 3)) < sptol)) print*,' test_sp_3dim_mask', order - call check( ieee_is_nan(moment(x3, order, center = 0._dp, mask = .false.))) - call check( any(ieee_is_nan(moment(x3, order, dim = 1, center = 0._dp,& + call check(error, ieee_is_nan(moment(x3, order, center = 0._dp, mask = .false.))) + call check(error, any(ieee_is_nan(moment(x3, order, dim = 1, center = 0._dp,& mask = .false.)))) - call check( any(ieee_is_nan(moment(x3, order, dim = 2, center = 0._dp,& + call check(error, any(ieee_is_nan(moment(x3, order, dim = 2, center = 0._dp,& mask = .false.)))) - call check( any(ieee_is_nan(moment(x3, order, dim = 3, center = 0._dp,& + call check(error, any(ieee_is_nan(moment(x3, order, dim = 3, center = 0._dp,& mask = .false.)))) - call check( any(ieee_is_nan(moment(x3, order, dim = 1, center = zero3_1,& + call check(error, any(ieee_is_nan(moment(x3, order, dim = 1, center = zero3_1,& mask = .false.)))) - call check( any(ieee_is_nan(moment(x3, order, dim = 2, center = zero3_2,& + call check(error, any(ieee_is_nan(moment(x3, order, dim = 2, center = zero3_2,& mask = .false.)))) - call check( any(ieee_is_nan(moment(x3, order, dim = 3, center = zero3_3,& + call check(error, any(ieee_is_nan(moment(x3, order, dim = 3, center = zero3_3,& mask = .false.)))) print*,' test_sp_3dim_mask_array', order - call check( abs(moment(x3, order, center = 0._dp, mask = (x3 < 11)) -& + call check(error, abs(moment(x3, order, center = 0._dp, mask = (x3 < 11)) -& mean(x3**2, x3 < 11)) < sptol) - call check( all( abs( moment(x3, order, dim = 1, center = 0._dp,& + call check(error, all( abs( moment(x3, order, dim = 1, center = 0._dp,& mask = (x3 < 45)) -& mean(x3**2, 1, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 2, center = 0._dp,& + call check(error, all( abs( moment(x3, order, dim = 2, center = 0._dp,& mask = (x3 < 45)) -& mean(x3**2, 2, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 3, center = 0._dp,& + call check(error, all( abs( moment(x3, order, dim = 3, center = 0._dp,& mask = (x3 < 45)) -& mean(x3**2, 3, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 1, center = zero3_1,& + call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1,& mask = (x3 < 45)) -& mean(x3**2, 1, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 2, center = zero3_2,& + call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2,& mask = (x3 < 45)) -& mean(x3**2, 2, x3 < 45)) < sptol )) - call check( all( abs( moment(x3, order, dim = 3, center = zero3_3,& + call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3,& mask = (x3 < 45)) -& mean(x3**2, 3, x3 < 45)) < sptol )) end subroutine - subroutine test_csp(x1, x2) - complex(sp), intent(in) :: x1(:), x2(:, :) + subroutine test_csp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp), parameter :: x1(5) = cs1 + complex(sp), parameter :: x2(5, 3) = cs integer :: order complex(sp), allocatable :: zero2_1(:), zero2_2(:) @@ -509,59 +528,59 @@ subroutine test_csp(x1, x2) !1dim print*,' test_sp_1dim', order - call check( abs(moment(x1, order, center = (0., 0.)) - mean(x1)) < sptol) - call check( abs(moment(x1, order, 1, center = (0., 0.)) - mean(x1, 1)) < sptol) + call check(error, abs(moment(x1, order, center = (0., 0.)) - mean(x1)) < sptol) + call check(error, abs(moment(x1, order, 1, center = (0., 0.)) - mean(x1, 1)) < sptol) print*,' test_sp_1dim_mask', order - call check( ieee_is_nan(abs(moment(x1, order, center = (0., 0.),& + call check(error, ieee_is_nan(abs(moment(x1, order, center = (0., 0.),& mask = .false.)))) - call check( ieee_is_nan(abs(moment(x1, order, dim = 1, center = (0., 0.),& + call check(error, ieee_is_nan(abs(moment(x1, order, dim = 1, center = (0., 0.),& mask = .false.)))) print*,' test_sp_1dim_mask_array', order - call check( abs(moment(x1, order, center = (0., 0.), mask = (aimag(x1) == 0)) -& + call check(error, abs(moment(x1, order, center = (0., 0.), mask = (aimag(x1) == 0)) -& mean(x1, aimag(x1) == 0)) < sptol) - call check( abs(moment(x1, order, dim = 1, center = (0., 0.),& + call check(error, abs(moment(x1, order, dim = 1, center = (0., 0.),& mask = (aimag(x1) == 0)) -& mean(x1, 1, aimag(x1) == 0)) < sptol) !2dim print*,' test_sp_2dim', order - call check( abs(moment(x2, order, center = (0., 0.)) - mean(x2)) < sptol) - call check( all( abs( moment(x2, order, dim = 1, center = (0., 0.)) -& + call check(error, abs(moment(x2, order, center = (0., 0.)) - mean(x2)) < sptol) + call check(error, all( abs( moment(x2, order, dim = 1, center = (0., 0.)) -& mean(x2, 1)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = (0., 0.)) -& + call check(error, all( abs( moment(x2, order, dim = 2, center = (0., 0.)) -& mean(x2, 2)) < sptol)) - call check( all( abs( moment(x2, order, dim = 1, center = zero2_1) -& + call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -& mean(x2, 1)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = zero2_2) -& + call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) -& mean(x2, 2)) < sptol)) print*,' test_sp_2dim_mask', order - call check( ieee_is_nan(abs(moment(x2, order, center = (0., 0.),& + call check(error, ieee_is_nan(abs(moment(x2, order, center = (0., 0.),& mask = .false.)))) - call check( any(ieee_is_nan(abs(moment(x2, order, dim = 1, center = (0., 0.),& + call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 1, center = (0., 0.),& mask = .false.))))) - call check( any(ieee_is_nan(abs(moment(x2, order, dim = 2, center = (0., 0.),& + call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 2, center = (0., 0.),& mask = .false.))))) - call check( any(ieee_is_nan(abs(moment(x2, order, dim = 1, center = zero2_1,& + call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 1, center = zero2_1,& mask = .false.))))) - call check( any(ieee_is_nan(abs(moment(x2, order, dim = 2, center = zero2_2,& + call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 2, center = zero2_2,& mask = .false.))))) print*,' test_sp_2dim_mask_array', order - call check( abs(moment(x2, order, center = (0., 0.), mask = (aimag(x2) == 0)) -& + call check(error, abs(moment(x2, order, center = (0., 0.), mask = (aimag(x2) == 0)) -& mean(x2, aimag(x2) == 0)) < sptol) - call check( all( abs( moment(x2, order, dim = 1, center = (0., 0.),& + call check(error, all( abs( moment(x2, order, dim = 1, center = (0., 0.),& mask = (aimag(x2) == 0)) -& mean(x2, 1, aimag(x2) == 0)) < sptol)) - call check( any(ieee_is_nan( abs( moment(x2, order,& + call check(error, any(ieee_is_nan( abs( moment(x2, order,& dim = 2, center = (0., 0.), mask = (aimag(x2) == 0)) -& mean(x2, 2, aimag(x2) == 0))))) - call check( all( abs( moment(x2, order, dim = 1, center = zero2_1,& + call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,& mask = (aimag(x2) == 0)) -& mean(x2, 1, aimag(x2) == 0)) < sptol)) - call check( any(ieee_is_nan( abs( moment(x2, order,& + call check(error, any(ieee_is_nan( abs( moment(x2, order,& dim = 2, center = zero2_2, mask = (aimag(x2) == 0)) -& mean(x2, 2, aimag(x2) == 0))))) @@ -569,56 +588,83 @@ subroutine test_csp(x1, x2) !1dim print*,' test_sp_1dim', order - call check( abs(moment(x1, order, center = (0., 0.)) - mean(x1**2)) < sptol) - call check( abs(moment(x1, order, 1, center = (0., 0.)) -& + call check(error, abs(moment(x1, order, center = (0., 0.)) - mean(x1**2)) < sptol) + call check(error, abs(moment(x1, order, 1, center = (0., 0.)) -& mean(x1**2, 1)) < sptol) print*,' test_sp_1dim_mask', order - call check( ieee_is_nan(abs(moment(x1, order, center = (0., 0.),& + call check(error, ieee_is_nan(abs(moment(x1, order, center = (0., 0.),& mask = .false.)))) - call check( ieee_is_nan(abs(moment(x1, order, dim = 1, center = (0., 0.),& + call check(error, ieee_is_nan(abs(moment(x1, order, dim = 1, center = (0., 0.),& mask = .false.)))) print*,' test_sp_1dim_mask_array', order - call check( abs(moment(x1, order, center = (0., 0.), mask = (aimag(x1) == 0)) -& + call check(error, abs(moment(x1, order, center = (0., 0.), mask = (aimag(x1) == 0)) -& mean(x1**2, aimag(x1) == 0)) < sptol) - call check( abs(moment(x1, order, dim = 1, center = (0., 0.),& + call check(error, abs(moment(x1, order, dim = 1, center = (0., 0.),& mask = (aimag(x1) == 0)) -& mean(x1**2, 1, aimag(x1) == 0)) < sptol) !2dim print*,' test_sp_2dim', order - call check( abs(moment(x2, order, center = (0., 0.)) - mean(x2**2)) < sptol) - call check( all( abs( moment(x2, order, dim = 1, center = (0., 0.)) -& + call check(error, abs(moment(x2, order, center = (0., 0.)) - mean(x2**2)) < sptol) + call check(error, all( abs( moment(x2, order, dim = 1, center = (0., 0.)) -& mean(x2**2, 1)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = (0., 0.)) -& + call check(error, all( abs( moment(x2, order, dim = 2, center = (0., 0.)) -& mean(x2**2, 2)) < sptol)) - call check( all( abs( moment(x2, order, dim = 1, center = zero2_1) -& + call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -& mean(x2**2, 1)) < sptol)) - call check( all( abs( moment(x2, order, dim = 2, center = zero2_2) -& + call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) -& mean(x2**2, 2)) < sptol)) print*,' test_sp_2dim_mask', order - call check( ieee_is_nan(abs(moment(x2, order, center = (0., 0.),& + call check(error, ieee_is_nan(abs(moment(x2, order, center = (0., 0.),& mask = .false.)))) - call check( any(ieee_is_nan(abs(moment(x2, order, dim = 1, center = (0., 0.),& + call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 1, center = (0., 0.),& mask = .false.))))) - call check( any(ieee_is_nan(abs(moment(x2, order, dim = 2, center = (0., 0.),& + call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 2, center = (0., 0.),& mask = .false.))))) - call check( any(ieee_is_nan(abs(moment(x2, order, dim = 1, center = zero2_1,& + call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 1, center = zero2_1,& mask = .false.))))) - call check( any(ieee_is_nan(abs(moment(x2, order, dim = 2, center = zero2_2,& + call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 2, center = zero2_2,& mask = .false.))))) print*,' test_sp_2dim_mask_array', order - call check( abs(moment(x2, order, center = (0., 0.), mask = (aimag(x2) == 0)) -& + call check(error, abs(moment(x2, order, center = (0., 0.), mask = (aimag(x2) == 0)) -& mean(x2**2, aimag(x2) == 0)) < sptol) - call check( all( abs( moment(x2, order, dim = 1, center = zero2_1,& + call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,& mask = (aimag(x2)==0)) -& mean(x2**2, 1, aimag(x2)==0)) < sptol)) - call check( all( abs( moment(x2, order, dim = 1, center = zero2_1,& + call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,& mask = (aimag(x2)==0)) -& mean(x2**2, 1, aimag(x2)==0)) < sptol)) end subroutine +end module + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_rawmoment, only : collect_rawmoment + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("rawmoment", collect_rawmoment) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if end program From 83d321cac5b9e085828966cc0bf69300524af2fa Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Fri, 27 Aug 2021 10:04:50 +0200 Subject: [PATCH 15/34] Rewrite variance tests --- src/tests/stats/test_var.f90 | 894 +++++++++++++++++++++++------------ 1 file changed, 581 insertions(+), 313 deletions(-) diff --git a/src/tests/stats/test_var.f90 b/src/tests/stats/test_var.f90 index 3a647c160..1c89c9bdd 100644 --- a/src/tests/stats/test_var.f90 +++ b/src/tests/stats/test_var.f90 @@ -1,5 +1,5 @@ -program test_var - use stdlib_error, only: check +module test_var + use stdlib_test, only : new_unittest, unittest_type, error_type, check use stdlib_kinds, only: sp, dp, int32, int64 use stdlib_stats, only: var use,intrinsic :: ieee_arithmetic, only : ieee_is_nan @@ -9,178 +9,293 @@ program test_var real(sp), parameter :: sptol = 1000 * epsilon(1._sp) real(dp), parameter :: dptol = 1000 * epsilon(1._dp) - integer(int32) :: i321(5) = [1, 2, 3, 4, 5] - integer(int64) :: i641(5) = [1, 2, 3, 4, 5] + integer(int32), parameter :: i321(5) = [1, 2, 3, 4, 5] + integer(int64), parameter :: i641(5) = [1, 2, 3, 4, 5] - integer(int32), allocatable :: i32(:,:), i323(:, :, :) - integer(int64), allocatable :: i64(:,:), i643(:, :, :) + real(sp), parameter :: s1(5) = [1.0_sp, 2.0_sp, 3.0_sp, 4.0_sp, 5.0_sp] + real(dp), parameter :: d1(5) = [1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp] - real(sp) :: s1(5) = [1.0_sp, 2.0_sp, 3.0_sp, 4.0_sp, 5.0_sp] - real(dp) :: d1(5) = [1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp] - - real(sp), allocatable :: s(:, :), s3(:, :, :) - real(dp), allocatable :: d3(:, :, :) - real(dp) :: d(4, 3) = reshape([1._dp, 3._dp, 5._dp, 7._dp,& + real(dp), parameter :: d(4, 3) = reshape([1._dp, 3._dp, 5._dp, 7._dp,& 2._dp, 4._dp, 6._dp, 8._dp,& 9._dp, 10._dp, 11._dp, 12._dp], [4, 3]) - - - complex(sp) :: cs1(5) = [ cmplx(0.57706_sp, 0.00000_sp),& - cmplx(0.00000_sp, 1.44065_sp),& - cmplx(1.26401_sp, 0.00000_sp),& - cmplx(0.00000_sp, 0.88833_sp),& - cmplx(1.14352_sp, 0.00000_sp)] - complex(dp) :: cd1(5) = [ cmplx(0.57706_dp, 0.00000_dp,kind=dp),& + real(dp), parameter :: d3(4, 3, 3) = reshape([d, d*2, d*4], shape(d3)) + real(sp), parameter :: s(4, 3) = d + real(sp), parameter :: s3(4, 3, 3) = reshape([s, s*2, s*4], shape(s3)) + + integer(int32), parameter :: i32(4, 3) = d + integer(int32), parameter :: i323(4, 3, 3) = d3 + integer(int64), parameter :: i64(4, 3) = d + integer(int64), parameter :: i643(4, 3, 3) = d3 + + complex(sp), parameter :: cs1(5) = [ cmplx(0.57706_sp, 0.00000_sp, sp),& + cmplx(0.00000_sp, 1.44065_sp, sp),& + cmplx(1.26401_sp, 0.00000_sp, sp),& + cmplx(0.00000_sp, 0.88833_sp, sp),& + cmplx(1.14352_sp, 0.00000_sp, sp)] + complex(dp), parameter :: cd1(5) = [ cmplx(0.57706_dp, 0.00000_dp,kind=dp),& cmplx(0.00000_dp, 1.44065_dp,kind=dp),& cmplx(1.26401_dp, 0.00000_dp,kind=dp),& cmplx(0.00000_dp, 0.88833_dp,kind=dp),& cmplx(1.14352_dp, 0.00000_dp,kind=dp)] - complex(sp) :: cs(5,3) - complex(dp) :: cd(5,3) - - - !sp - !1dim - print*,' test_sp_1dim' - call check( abs(var(s1) - 2.5) < sptol) - call check( abs(var(s1, dim=1) - 2.5) < sptol) - - print*,' test_sp_1dim_mask' - call check( ieee_is_nan(var(s1, .false.))) - call check( ieee_is_nan(var(s1, 1, .false.))) - - print*,' test_sp_1dim_mask_array' - call check( abs(var(s1, s1 < 5) - 5./3.) < sptol) - call check( ieee_is_nan((var(s1, s1 < 0.)))) - call check( ieee_is_nan((var(s1, s1 == 1.)))) - call check( abs(var(s1, 1, s1 < 5) - 5./3.) < sptol) - - !2dim - print*,' test_sp_2dim' - s = d - call check( abs(var(s) - 13) < sptol) - call check( all( abs( var(s, 1) - [20. / 3., 20. / 3., 5. / 3.]) < sptol)) - call check( all( abs( var(s, 2) - [19.0, 43. / 3., 31. / 3. , 7.0]) < sptol)) - - print*,' test_sp_2dim_mask' - call check( ieee_is_nan(var(s, .false.))) - call check( any(ieee_is_nan(var(s, 1, .false.)))) - call check( any(ieee_is_nan(var(s, 2, .false.)))) - - print*,' test_sp_2dim_mask_array' - call check( abs(var(s, s < 11) - 27.5 / 3.) < sptol) - call check( all( abs( var(s, 1, s < 11) - [20. / 3., 20. / 3., 0.5]) < sptol)) - call check( all( abs( var(s, 2, s < 11) - [19.0, 43. / 3., 0.5 , 0.5]) < sptol)) - - - !3dim - allocate(s3(size(s,1),size(s,2),3)) - s3(:,:,1)=s; - s3(:,:,2)=s*2; - s3(:,:,3)=s*4; - - print*,' test_sp_3dim' - call check( abs(var(s3) - 153.4) < sptol) - call check( all( abs( var(s3, 1) -& + complex(sp), parameter :: cs(5,3) = reshape([cs1, cs1*3.0_sp, cs1*1.5_sp], shape(cs)) + complex(dp), parameter :: cd(5,3) = reshape([cd1, cd1*3.0_dp, cd1*1.5_dp], shape(cd)) + +contains + + + !> Collect all exported unit tests + subroutine collect_var(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("sp_1dim", test_sp_1dim), & + new_unittest("sp_1dim_mask", test_sp_1dim_mask), & + new_unittest("sp_2dim", test_sp_2dim), & + new_unittest("sp_2dim_mask", test_sp_2dim_mask), & + new_unittest("sp_2dim_mask_array", test_sp_2dim_mask_array), & + new_unittest("sp_3dim", test_sp_3dim), & + new_unittest("sp_3dim_mask", test_sp_3dim_mask), & + new_unittest("sp_3dim_mask_array", test_sp_3dim_mask_array), & + new_unittest("dp_1dim", test_dp_1dim), & + new_unittest("dp_1dim_mask", test_dp_1dim_mask), & + new_unittest("dp_1dim_mask_array", test_dp_1dim_mask_array), & + new_unittest("dp_2dim", test_dp_2dim), & + new_unittest("dp_2dim_mask", test_dp_2dim_mask), & + new_unittest("dp_2dim_mask_array", test_dp_2dim_mask_array), & + new_unittest("dp_3dim", test_dp_3dim), & + new_unittest("dp_3dim_mask", test_dp_3dim_mask), & + new_unittest("dp_3dim_mask_array", test_dp_3dim_mask_array), & + new_unittest("int32_1dim", test_int32_1dim), & + new_unittest("int32_1dim_mask", test_int32_1dim_mask), & + new_unittest("int32_1dim_mask_array", test_int32_1dim_mask_array), & + new_unittest("int32_2dim", test_int32_2dim), & + new_unittest("int32_2dim_mask", test_int32_2dim_mask), & + new_unittest("int32_2dim_mask_array", test_int32_2dim_mask_array), & + new_unittest("int32_3dim", test_int32_3dim), & + new_unittest("int32_3dim_mask", test_int32_3dim_mask), & + new_unittest("int32_3dim_mask_array", test_int32_3dim_mask_array), & + new_unittest("int64_1dim", test_int64_1dim), & + new_unittest("int64_1dim_mask", test_int64_1dim_mask), & + new_unittest("int641_1dim_mask_array", test_int641_1dim_mask_array), & + new_unittest("int64_2dim", test_int64_2dim), & + new_unittest("int64_2dim_mask", test_int64_2dim_mask), & + new_unittest("int64_2dim_mask_array", test_int64_2dim_mask_array), & + new_unittest("int64_3dim", test_int64_3dim), & + new_unittest("int64_3dim_mask", test_int64_3dim_mask), & + new_unittest("int64_3dim_mask_array", test_int64_3dim_mask_array), & + new_unittest("csp_1dim", test_csp_1dim), & + new_unittest("csp_1dim_mask", test_csp_1dim_mask), & + new_unittest("csp_1dim_mask_array", test_csp_1dim_mask_array), & + new_unittest("csp_2dim", test_csp_2dim), & + new_unittest("csp_2dim_mask", test_csp_2dim_mask), & + new_unittest("csp_2dim_mask_array", test_csp_2dim_mask_array), & + new_unittest("cdp_1dim", test_cdp_1dim), & + new_unittest("cdp_1dim_mask", test_cdp_1dim_mask), & + new_unittest("cdp_1dim_mask_array", test_cdp_1dim_mask_array), & + new_unittest("cdp_2dim", test_cdp_2dim), & + new_unittest("cdp_2dim_mask", test_cdp_2dim_mask), & + new_unittest("cdp_2dim_mask_array", test_cdp_2dim_mask_array) & + ] + end subroutine collect_var + + subroutine test_sp_1dim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(s1) - 2.5) < sptol) + call check(error, abs(var(s1, dim=1) - 2.5) < sptol) + + end subroutine test_sp_1dim + + subroutine test_sp_1dim_mask(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(var(s1, .false.))) + call check(error, ieee_is_nan(var(s1, 1, .false.))) + + end subroutine test_sp_1dim_mask + + subroutine test_sp_1dim_mask_array(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(s1, s1 < 5) - 5./3.) < sptol) + call check(error, ieee_is_nan((var(s1, s1 < 0.)))) + call check(error, ieee_is_nan((var(s1, s1 == 1.)))) + call check(error, abs(var(s1, 1, s1 < 5) - 5./3.) < sptol) + + end subroutine test_sp_1dim_mask_array + + subroutine test_sp_2dim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(s) - 13) < sptol) + call check(error, all( abs( var(s, 1) - [20. / 3., 20. / 3., 5. / 3.]) < sptol)) + call check(error, all( abs( var(s, 2) - [19.0, 43. / 3., 31. / 3. , 7.0]) < sptol)) + + end subroutine test_sp_2dim + + subroutine test_sp_2dim_mask(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(var(s, .false.))) + call check(error, any(ieee_is_nan(var(s, 1, .false.)))) + call check(error, any(ieee_is_nan(var(s, 2, .false.)))) + + end subroutine test_sp_2dim_mask + + subroutine test_sp_2dim_mask_array(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(s, s < 11) - 27.5 / 3.) < sptol) + call check(error, all( abs( var(s, 1, s < 11) - [20. / 3., 20. / 3., 0.5]) < sptol)) + call check(error, all( abs( var(s, 2, s < 11) - [19.0, 43. / 3., 0.5 , 0.5]) < sptol)) + + end subroutine test_sp_2dim_mask_array + + subroutine test_sp_3dim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(s3) - 153.4) < sptol) + call check(error, all( abs( var(s3, 1) -& reshape([20. / 3., 20. / 3., 5. / 3.,& 4* 20. / 3., 4* 20. / 3., 4* 5. / 3.,& 16* 20. / 3., 16* 20. / 3., 16* 5. / 3.],& [size(s3,2), size(s3,3)]))& < sptol)) - call check( all( abs( var(s3, 2) -& + call check(error, all( abs( var(s3, 2) -& reshape([19.0, 43. / 3., 31. / 3. , 7.0,& 4* 19.0, 4* 43. / 3., 4* 31. / 3. , 4* 7.0,& 16* 19.0, 16* 43. / 3., 16* 31. / 3. , 16* 7.0],& [size(s3,1), size(s3,3)] ))& < sptol)) - call check( all(abs( var(s3, 3) -& + call check(error, all(abs( var(s3, 3) -& reshape([ 7./3., 21., 175./3.,& 343./3., 28./3., 112./3.,& 84., 448./3., 189.,& 700./3., 847./3., 336.], [size(s3,1), size(s3,2)] ))& < sptol)) - print*,' test_sp_3dim_mask' - call check( ieee_is_nan(var(s3, .false.))) - call check( any(ieee_is_nan(var(s3, 1, .false.)))) - call check( any(ieee_is_nan(var(s3, 2, .false.)))) - call check( any(ieee_is_nan(var(s3, 3, .false.)))) + end subroutine test_sp_3dim + + subroutine test_sp_3dim_mask(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - print*,' test_sp_3dim_mask_array' - call check( abs(var(s3, s3 < 11) - 8.2205877_sp) < sptol) - call check( all( abs( var(s3, 1, s3 < 45) -& + call check(error, ieee_is_nan(var(s3, .false.))) + call check(error, any(ieee_is_nan(var(s3, 1, .false.)))) + call check(error, any(ieee_is_nan(var(s3, 2, .false.)))) + call check(error, any(ieee_is_nan(var(s3, 3, .false.)))) + + end subroutine test_sp_3dim_mask + + subroutine test_sp_3dim_mask_array(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(s3, s3 < 11) - 8.2205877_sp) < sptol) + call check(error, all( abs( var(s3, 1, s3 < 45) -& reshape([20./3., 20./3., 5./3., 80./3., 80./3., 20./3.,& 320./3., 320./3., 16.],& [size(s3, 2), size(s3, 3)])) < sptol )) - call check( any( ieee_is_nan( var(s3, 2, s3 < 25)))) - call check( all( abs( var(s3, 3, s3 < 25) -& + call check(error, any( ieee_is_nan( var(s3, 2, s3 < 25)))) + call check(error, all( abs( var(s3, 3, s3 < 25) -& reshape([ 7./3., 21., 175./3.,& 24.5, 28./3., 112./3.,& 84., 32., 40.5,& 50., 60.5, 72.], [size(s3,1), size(s3,2)] ))& < sptol )) + end subroutine test_sp_3dim_mask_array + + subroutine test_dp_1dim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(d1) - 2.5) < dptol) + call check(error, abs(var(d1, 1) - 2.5) < dptol) + + end subroutine test_dp_1dim + + subroutine test_dp_1dim_mask(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(var(d1, .false.))) + call check(error, ieee_is_nan(var(d1, 1, .false.))) + + end subroutine test_dp_1dim_mask + + subroutine test_dp_1dim_mask_array(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(d1, d1 < 5) - 5._dp/3._dp) < dptol) + call check(error, ieee_is_nan((var(d1, d1 < 0.)))) + call check(error, ieee_is_nan((var(d1, d1 == 1.)))) + call check(error, abs(var(d1, 1, d1 < 5) - 5._dp/3._dp) < dptol) - !dp - !1dim - print*,' test_dp_1dim' - call check( abs(var(d1) - 2.5) < dptol) - call check( abs(var(d1, 1) - 2.5) < dptol) - - print*,' test_dp_1dim_mask' - call check( ieee_is_nan(var(d1, .false.))) - call check( ieee_is_nan(var(d1, 1, .false.))) - - print*,' test_dp_1dim_mask_array' - call check( abs(var(d1, d1 < 5) - 5._dp/3._dp) < dptol) - call check( ieee_is_nan((var(d1, d1 < 0.)))) - call check( ieee_is_nan((var(d1, d1 == 1.)))) - call check( abs(var(d1, 1, d1 < 5) - 5._dp/3._dp) < dptol) - - !2dim - print*,' test_dp_2dim' - call check( abs(var(d) - 13) < dptol) - call check( all( abs( var(d,1) -& - [20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp]) < dptol)) - call check( all( abs( var(d,2) -& - [19.0_dp, 43._dp/3._dp, 31._dp/3._dp, 7.0_dp]) < dptol)) - - print*,' test_dp_2dim_mask' - call check( ieee_is_nan(var(d, .false.))) - call check( any(ieee_is_nan(var(d, 1, .false.)))) - call check( any(ieee_is_nan(var(d, 2, .false.)))) - - print*,' test_dp_2dim_mask_array' - call check( abs(var(d, d < 11) - 27.5_dp / 3._dp) < dptol) - call check( all( abs( var(d, 1, d < 11) -& + end subroutine test_dp_1dim_mask_array + + subroutine test_dp_2dim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(d) - 13) < dptol) + call check(error, all( abs( var(d,1) -& + [20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp]) < dptol)) + call check(error, all( abs( var(d,2) -& + [19.0_dp, 43._dp/3._dp, 31._dp/3._dp, 7.0_dp]) < dptol)) + + end subroutine test_dp_2dim + + subroutine test_dp_2dim_mask(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(var(d, .false.))) + call check(error, any(ieee_is_nan(var(d, 1, .false.)))) + call check(error, any(ieee_is_nan(var(d, 2, .false.)))) + + end subroutine test_dp_2dim_mask + + subroutine test_dp_2dim_mask_array(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(d, d < 11) - 27.5_dp / 3._dp) < dptol) + call check(error, all( abs( var(d, 1, d < 11) -& [20._dp / 3._dp, 20._dp / 3._dp, 0.5_dp]) < dptol)) - call check( all( abs( var(d, 2, d < 11) -& + call check(error, all( abs( var(d, 2, d < 11) -& [19.0_dp, 43._dp / 3._dp, 0.5_dp, 0.5_dp]) < dptol)) - !3dim - allocate(d3(size(d,1),size(d,2),3)) - d3(:,:,1)=d; - d3(:,:,2)=d*2; - d3(:,:,3)=d*4; + end subroutine test_dp_2dim_mask_array - print*,' test_dp_3dim' - call check( abs(var(d3) - 153.4_dp) < dptol) - call check( all( abs( var(d3, 1) -& + subroutine test_dp_3dim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(d3) - 153.4_dp) < dptol) + call check(error, all( abs( var(d3, 1) -& reshape([20._dp / 3._dp, 20._dp / 3._dp, 5._dp / 3._dp,& 4* 20._dp / 3._dp, 4* 20._dp / 3._dp, 4* 5._dp / 3._dp,& 16* 20._dp / 3._dp, 16* 20._dp / 3._dp, 16* 5._dp / 3._dp],& [size(d3,2), size(d3,3)]))& < dptol)) - print*,' test_dp_3dim' - call check( all( abs( var(d3, 2) -& + call check(error, all( abs( var(d3, 2) -& reshape([19.0_dp, 43._dp / 3._dp, 31._dp / 3._dp , 7.0_dp,& 4* 19.0_dp, 4* 43._dp / 3._dp, 4* 31._dp / 3._dp , 4* 7.0_dp,& 16* 19.0_dp, 16* 43._dp / 3._dp, 16* 31._dp / 3._dp ,& 16* 7.0_dp],& [size(d3,1), size(d3,3)] ))& < dptol)) - print*,' test_dp_3dim' - call check( all(abs( var(d3, 3) -& + call check(error, all(abs( var(d3, 3) -& reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,& 343._dp/3._dp, 28._dp/3._dp, 112._dp/3._dp,& 84._dp, 448._dp/3._dp, 189._dp,& @@ -188,22 +303,32 @@ program test_var [size(d3,1), size(d3,2)] ))& < dptol)) - print*,' test_dp_3dim_mask' - call check( ieee_is_nan(var(d3, .false.))) - call check( any(ieee_is_nan(var(d3, 1, .false.)))) - call check( any(ieee_is_nan(var(d3, 2, .false.)))) - call check( any(ieee_is_nan(var(d3, 3, .false.)))) + end subroutine test_dp_3dim + + subroutine test_dp_3dim_mask(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(var(d3, .false.))) + call check(error, any(ieee_is_nan(var(d3, 1, .false.)))) + call check(error, any(ieee_is_nan(var(d3, 2, .false.)))) + call check(error, any(ieee_is_nan(var(d3, 3, .false.)))) + + end subroutine test_dp_3dim_mask - print*,' test_dp_3dim_mask_array' - call check( abs(var(d3, d3 < 25) - 46.041379310344823_dp) < dptol) - call check( all( abs( var(d3, 1, d3 < 45) -& + subroutine test_dp_3dim_mask_array(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(d3, d3 < 25) - 46.041379310344823_dp) < dptol) + call check(error, all( abs( var(d3, 1, d3 < 45) -& reshape([20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp,& 80._dp/3._dp, 80._dp/3._dp, 20._dp/3._dp,& 320._dp/3._dp, 320._dp/3._dp, 16._dp],& [size(d3, 2), size(d3, 3)]))& < dptol )) - call check( any( ieee_is_nan( var(d3, 2, d3 < 25)))) - call check( all( abs( var(d3, 3, d3 < 25) -& + call check(error, any( ieee_is_nan( var(d3, 2, d3 < 25)))) + call check(error, all( abs( var(d3, 3, d3 < 25) -& reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,& 24.5_dp, 28._dp/3._dp, 112._dp/3._dp,& 84._dp, 32._dp, 40.5_dp,& @@ -211,67 +336,90 @@ program test_var [size(d3,1), size(d3,2)] ))& < dptol )) + end subroutine test_dp_3dim_mask_array + subroutine test_int32_1dim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error - !int32 - !1dim - print*,' test_int32_1dim' - call check( abs(var(i321) - 2.5) < dptol) - call check( abs(var(i321, 1) - 2.5) < dptol) - - print*,' test_int32_1dim_mask' - call check( ieee_is_nan(var(i321, .false.))) - call check( ieee_is_nan(var(i321, 1, .false.))) - - print*,' test_int32_1dim_mask_array' - call check( abs(var(i321, i321 < 5) - 5._dp/3._dp) < dptol) - call check( ieee_is_nan((var(i321, i321 < 0)))) - call check( ieee_is_nan((var(i321, i321 == 1)))) - call check( abs(var(i321, 1, i321 < 5) - 5._dp/3._dp) < dptol) - - !2dim - print*,' test_int32_2dim' - i32 = d - call check( abs(var(i32) - 13) < dptol) - call check( all( abs( var(i32,1) -& - [20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp]) < dptol)) - call check( all( abs( var(i32,2) -& - [19.0_dp, 43._dp/3._dp, 31._dp/3._dp, 7.0_dp]) < dptol)) - - print*,' test_int32_2dim_mask' - call check( ieee_is_nan(var(i32, .false.))) - call check( any(ieee_is_nan(var(i32, 1, .false.)))) - call check( any(ieee_is_nan(var(i32, 2, .false.)))) - - print*,' test_int32_2dim_mask_array' - call check( abs(var(i32, i32 < 11) - 27.5_dp / 3._dp) < dptol) - call check( all( abs( var(i32, 1, i32 < 11) -& - [20._dp / 3._dp, 20._dp / 3._dp, 0.5_dp]) < dptol)) - call check( all( abs( var(i32, 2, i32 < 11) -& - [19.0_dp, 43._dp / 3._dp, 0.5_dp, 0.5_dp]) < dptol)) + call check(error, abs(var(i321) - 2.5) < dptol) + call check(error, abs(var(i321, 1) - 2.5) < dptol) - !3dim - allocate(i323(size(d,1),size(d,2),3)) - i323(:,:,1)=d; - i323(:,:,2)=d*2; - i323(:,:,3)=d*4; + end subroutine test_int32_1dim - print*,' test_int32_3dim' - call check( abs(var(i323) - 153.4_dp) < dptol) - call check( all( abs( var(i323, 1) -& + subroutine test_int32_1dim_mask(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(var(i321, .false.))) + call check(error, ieee_is_nan(var(i321, 1, .false.))) + + end subroutine test_int32_1dim_mask + + subroutine test_int32_1dim_mask_array(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(i321, i321 < 5) - 5._dp/3._dp) < dptol) + call check(error, ieee_is_nan((var(i321, i321 < 0)))) + call check(error, ieee_is_nan((var(i321, i321 == 1)))) + call check(error, abs(var(i321, 1, i321 < 5) - 5._dp/3._dp) < dptol) + + end subroutine test_int32_1dim_mask_array + + subroutine test_int32_2dim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(i32) - 13) < dptol) + call check(error, all( abs( var(i32,1) -& + [20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp]) < dptol)) + call check(error, all( abs( var(i32,2) -& + [19.0_dp, 43._dp/3._dp, 31._dp/3._dp, 7.0_dp]) < dptol)) + + end subroutine test_int32_2dim + + subroutine test_int32_2dim_mask(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(var(i32, .false.))) + call check(error, any(ieee_is_nan(var(i32, 1, .false.)))) + call check(error, any(ieee_is_nan(var(i32, 2, .false.)))) + + end subroutine test_int32_2dim_mask + + subroutine test_int32_2dim_mask_array(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(i32, i32 < 11) - 27.5_dp / 3._dp) < dptol) + call check(error, all( abs( var(i32, 1, i32 < 11) -& + [20._dp / 3._dp, 20._dp / 3._dp, 0.5_dp]) < dptol)) + call check(error, all( abs( var(i32, 2, i32 < 11) -& + [19.0_dp, 43._dp / 3._dp, 0.5_dp, 0.5_dp]) < dptol)) + + end subroutine test_int32_2dim_mask_array + + subroutine test_int32_3dim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(i323) - 153.4_dp) < dptol) + call check(error, all( abs( var(i323, 1) -& reshape([20._dp / 3._dp, 20._dp / 3._dp, 5._dp / 3._dp,& 4* 20._dp / 3._dp, 4* 20._dp / 3._dp, 4* 5._dp / 3._dp,& 16* 20._dp / 3._dp, 16* 20._dp / 3._dp, 16* 5._dp / 3._dp],& [size(i323,2), size(i323,3)]))& < dptol)) - call check( all( abs( var(i323, 2) -& + call check(error, all( abs( var(i323, 2) -& reshape([19.0_dp, 43._dp / 3._dp, 31._dp / 3._dp , 7.0_dp,& 4* 19.0_dp, 4* 43._dp / 3._dp, 4* 31._dp / 3._dp , 4* 7.0_dp,& 16* 19.0_dp, 16* 43._dp / 3._dp, 16* 31._dp / 3._dp ,& 16* 7.0_dp],& [size(i323,1), size(i323,3)] ))& < dptol)) - call check( all(abs( var(i323, 3) -& + call check(error, all(abs( var(i323, 3) -& reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,& 343._dp/3._dp, 28._dp/3._dp, 112._dp/3._dp,& 84._dp, 448._dp/3._dp, 189._dp,& @@ -279,22 +427,32 @@ program test_var [size(i323,1), size(i323,2)] ))& < dptol)) - print*,' test_int32_3dim_mask' - call check( ieee_is_nan(var(i323, .false.))) - call check( any(ieee_is_nan(var(i323, 1, .false.)))) - call check( any(ieee_is_nan(var(i323, 2, .false.)))) - call check( any(ieee_is_nan(var(i323, 3, .false.)))) + end subroutine test_int32_3dim + + subroutine test_int32_3dim_mask(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(var(i323, .false.))) + call check(error, any(ieee_is_nan(var(i323, 1, .false.)))) + call check(error, any(ieee_is_nan(var(i323, 2, .false.)))) + call check(error, any(ieee_is_nan(var(i323, 3, .false.)))) + + end subroutine test_int32_3dim_mask - print*,' test_int32_3dim_mask_array' - call check( abs(var(i323, i323 < 25) - 46.041379310344823_dp) < dptol) - call check( all( abs( var(i323, 1, i323 < 45) -& + subroutine test_int32_3dim_mask_array(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(i323, i323 < 25) - 46.041379310344823_dp) < dptol) + call check(error, all( abs( var(i323, 1, i323 < 45) -& reshape([20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp,& 80._dp/3._dp, 80._dp/3._dp, 20._dp/3._dp,& 320._dp/3._dp, 320._dp/3._dp, 16._dp],& [size(i323, 2), size(i323, 3)]))& < dptol )) - call check( any( ieee_is_nan( var(i323, 2, i323 < 25)))) - call check( all( abs( var(i323, 3, i323 < 25) -& + call check(error, any( ieee_is_nan( var(i323, 2, i323 < 25)))) + call check(error, all( abs( var(i323, 3, i323 < 25) -& reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,& 24.5_dp, 28._dp/3._dp, 112._dp/3._dp,& 84._dp, 32._dp, 40.5_dp,& @@ -302,66 +460,90 @@ program test_var [size(i323,1), size(i323,2)] ))& < dptol )) + end subroutine test_int32_3dim_mask_array - !int64 - !1dim - print*,' test_int64_1dim' - call check( abs(var(i641) - 2.5) < dptol) - call check( abs(var(i641, 1) - 2.5) < dptol) - - print*,' test_int64_1dim_mask' - call check( ieee_is_nan(var(i641, .false.))) - call check( ieee_is_nan(var(i641, 1, .false.))) - - print*,' test_int641_1dim_mask_array' - call check( abs(var(i641, i641 < 5) - 5._dp/3._dp) < dptol) - call check( ieee_is_nan((var(i641, i641 < 0)))) - call check( ieee_is_nan((var(i641, i641 == 1)))) - call check( abs(var(i641, 1, i641 < 5) - 5._dp/3._dp) < dptol) - - !2dim - print*,' test_int64_2dim' - i64 = d - call check( abs(var(i64) - 13) < dptol) - call check( all( abs( var(i64,1) -& - [20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp]) < dptol)) - call check( all( abs( var(i64,2) -& - [19.0_dp, 43._dp/3._dp, 31._dp/3._dp, 7.0_dp]) < dptol)) - - print*,' test_int64_2dim_mask' - call check( ieee_is_nan(var(i64, .false.))) - call check( any(ieee_is_nan(var(i64, 1, .false.)))) - call check( any(ieee_is_nan(var(i64, 2, .false.)))) - - print*,' test_int64_2dim_mask_array' - call check( abs(var(i64, i64 < 11) - 27.5_dp / 3._dp) < dptol) - call check( all( abs( var(i64, 1, i64 < 11) -& - [20._dp / 3._dp, 20._dp / 3._dp, 0.5_dp]) < dptol)) - call check( all( abs( var(i64, 2, i64 < 11) -& - [19.0_dp, 43._dp / 3._dp, 0.5_dp, 0.5_dp]) < dptol)) + subroutine test_int64_1dim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(i641) - 2.5) < dptol) + call check(error, abs(var(i641, 1) - 2.5) < dptol) + + end subroutine test_int64_1dim + + subroutine test_int64_1dim_mask(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(var(i641, .false.))) + call check(error, ieee_is_nan(var(i641, 1, .false.))) + + end subroutine test_int64_1dim_mask + + subroutine test_int641_1dim_mask_array(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(i641, i641 < 5) - 5._dp/3._dp) < dptol) + call check(error, ieee_is_nan((var(i641, i641 < 0)))) + call check(error, ieee_is_nan((var(i641, i641 == 1)))) + call check(error, abs(var(i641, 1, i641 < 5) - 5._dp/3._dp) < dptol) - !3dim - allocate(i643(size(d,1),size(d,2),3)) - i643(:,:,1)=d; - i643(:,:,2)=d*2; - i643(:,:,3)=d*4; + end subroutine test_int641_1dim_mask_array - print*,' test_int32_3dim' - call check( abs(var(i643) - 153.4_dp) < dptol) - call check( all( abs( var(i643, 1) -& + subroutine test_int64_2dim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(i64) - 13) < dptol) + call check(error, all( abs( var(i64,1) -& + [20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp]) < dptol)) + call check(error, all( abs( var(i64,2) -& + [19.0_dp, 43._dp/3._dp, 31._dp/3._dp, 7.0_dp]) < dptol)) + + end subroutine test_int64_2dim + + subroutine test_int64_2dim_mask(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(var(i64, .false.))) + call check(error, any(ieee_is_nan(var(i64, 1, .false.)))) + call check(error, any(ieee_is_nan(var(i64, 2, .false.)))) + + end subroutine test_int64_2dim_mask + + subroutine test_int64_2dim_mask_array(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(i64, i64 < 11) - 27.5_dp / 3._dp) < dptol) + call check(error, all( abs( var(i64, 1, i64 < 11) -& + [20._dp / 3._dp, 20._dp / 3._dp, 0.5_dp]) < dptol)) + call check(error, all( abs( var(i64, 2, i64 < 11) -& + [19.0_dp, 43._dp / 3._dp, 0.5_dp, 0.5_dp]) < dptol)) + + end subroutine test_int64_2dim_mask_array + + subroutine test_int64_3dim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(i643) - 153.4_dp) < dptol) + call check(error, all( abs( var(i643, 1) -& reshape([20._dp / 3._dp, 20._dp / 3._dp, 5._dp / 3._dp,& 4* 20._dp / 3._dp, 4* 20._dp / 3._dp, 4* 5._dp / 3._dp,& 16* 20._dp / 3._dp, 16* 20._dp / 3._dp, 16* 5._dp / 3._dp],& [size(i643,2), size(i643,3)]))& < dptol)) - call check( all( abs( var(i643, 2) -& + call check(error, all( abs( var(i643, 2) -& reshape([19.0_dp, 43._dp / 3._dp, 31._dp / 3._dp , 7.0_dp,& 4* 19.0_dp, 4* 43._dp / 3._dp, 4* 31._dp / 3._dp , 4* 7.0_dp,& 16* 19.0_dp, 16* 43._dp / 3._dp, 16* 31._dp / 3._dp ,& 16* 7.0_dp],& [size(i643,1), size(i643,3)] ))& < dptol)) - call check( all(abs( var(i643, 3) -& + call check(error, all(abs( var(i643, 3) -& reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,& 343._dp/3._dp, 28._dp/3._dp, 112._dp/3._dp,& 84._dp, 448._dp/3._dp, 189._dp,& @@ -369,22 +551,32 @@ program test_var [size(i643,1), size(i643,2)] ))& < dptol)) - print*,' test_int32_3dim_mask' - call check( ieee_is_nan(var(i643, .false.))) - call check( any(ieee_is_nan(var(i643, 1, .false.)))) - call check( any(ieee_is_nan(var(i643, 2, .false.)))) - call check( any(ieee_is_nan(var(i643, 3, .false.)))) + end subroutine test_int64_3dim + + subroutine test_int64_3dim_mask(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(var(i643, .false.))) + call check(error, any(ieee_is_nan(var(i643, 1, .false.)))) + call check(error, any(ieee_is_nan(var(i643, 2, .false.)))) + call check(error, any(ieee_is_nan(var(i643, 3, .false.)))) - print*,' test_int64_3dim_mask_array' - call check( abs(var(i643, i643 < 25) - 46.041379310344823_dp) < dptol) - call check( all( abs( var(i643, 1, i643 < 45) -& + end subroutine test_int64_3dim_mask + + subroutine test_int64_3dim_mask_array(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(i643, i643 < 25) - 46.041379310344823_dp) < dptol) + call check(error, all( abs( var(i643, 1, i643 < 45) -& reshape([20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp,& 80._dp/3._dp, 80._dp/3._dp, 20._dp/3._dp,& 320._dp/3._dp, 320._dp/3._dp, 16._dp],& [size(i643, 2), size(i643, 3)]))& < dptol )) - call check( any( ieee_is_nan( var(i643, 2, i643 < 25)))) - call check( all( abs( var(i643, 3, i643 < 25) -& + call check(error, any( ieee_is_nan( var(i643, 2, i643 < 25)))) + call check(error, all( abs( var(i643, 3, i643 < 25) -& reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,& 24.5_dp, 28._dp/3._dp, 112._dp/3._dp,& 84._dp, 32._dp, 40.5_dp,& @@ -392,72 +584,148 @@ program test_var [size(i643,1), size(i643,2)] ))& < dptol )) - !csp - !1dim - print*,' test_csp_1dim' - call check( abs(var(cs1) - (var(real(cs1)) + var(aimag(cs1)))) < sptol) - call check( abs(var(cs1, dim=1) - (var(real(cs1),1) + var(aimag(cs1), 1)) ) < sptol) - - print*,' test_csp_1dim_mask' - call check( ieee_is_nan(var(cs1, .false.))) - call check( ieee_is_nan(var(cs1, 1, .false.))) - - print*,' test_csp_1dim_mask_array' - call check( abs(var(cs1, aimag(cs1) == 0) - var(real(cs1), aimag(cs1) == 0)) < sptol) - call check( abs(var(cs1, 1, aimag(cs1) == 0) - var(real(cs1), 1, aimag(cs1) == 0)) < sptol) - - !2dim - cs(:,1) = cs1 - cs(:,2) = cs1*3_sp - cs(:,3) = cs1*1.5_sp - - print*,' test_csp_2dim' - call check( abs(var(cs) - (var(real(cs)) + var(aimag(cs)))) < sptol) - call check( all( abs( var(cs, 1) - (var(real(cs), 1) + var(aimag(cs), 1))) < sptol)) - call check( all( abs( var(cs, 2) - (var(real(cs), 2) + var(aimag(cs), 2))) < sptol)) - - print*,' test_csp_2dim_mask' - call check( ieee_is_nan(var(cs, .false.))) - call check( any(ieee_is_nan(var(cs, 1, .false.)))) - call check( any(ieee_is_nan(var(cs, 2, .false.)))) - - print*,' test_csp_2dim_mask_array' - call check( abs(var(cs, aimag(cs) == 0) - var(real(cs), aimag(cs) == 0)) < sptol) - call check( all( abs( var(cs, 1, aimag(cs) == 0) - var(real(cs), 1, aimag(cs) == 0)) < sptol)) - call check( any( ieee_is_nan( var(cs, 2, aimag(cs) == 0)))) - - !cdp - !1dim - print*,' test_cdp_1dim' - call check( abs(var(cd1) - (var(real(cd1)) + var(aimag(cd1)))) < dptol) - call check( abs(var(cd1, dim=1) - (var(real(cd1),1) + var(aimag(cd1), 1)) ) < dptol) - - print*,' test_cdp_1dim_mask' - call check( ieee_is_nan(var(cd1, .false.))) - call check( ieee_is_nan(var(cd1, 1, .false.))) - - print*,' test_cdp_1dim_mask_array' - call check( abs(var(cd1, aimag(cd1) == 0) - var(real(cd1), aimag(cd1) == 0)) < dptol) - call check( abs(var(cd1, 1, aimag(cd1) == 0) - var(real(cd1), 1, aimag(cd1) == 0)) < dptol) - - !2dim - cd(:,1) = cd1 - cd(:,2) = cd1*3_sp - cd(:,3) = cd1*1.5_sp - - print*,' test_cdp_2dim' - call check( abs(var(cd) - (var(real(cd)) + var(aimag(cd)))) < dptol) - call check( all( abs( var(cd, 1) - (var(real(cd), 1) + var(aimag(cd), 1))) < dptol)) - call check( all( abs( var(cd, 2) - (var(real(cd), 2) + var(aimag(cd), 2))) < dptol)) - - print*,' test_cdp_2dim_mask' - call check( ieee_is_nan(var(cd, .false.))) - call check( any(ieee_is_nan(var(cd, 1, .false.)))) - call check( any(ieee_is_nan(var(cd, 2, .false.)))) - - print*,' test_cdp_2dim_mask_array' - call check( abs(var(cd, aimag(cd) == 0) - var(real(cd), aimag(cd) == 0)) < dptol) - call check( all( abs( var(cd, 1, aimag(cd) == 0) - var(real(cd), 1, aimag(cd) == 0)) < dptol)) - call check( any( ieee_is_nan( var(cd, 2, aimag(cd) == 0)))) + end subroutine test_int64_3dim_mask_array + + subroutine test_csp_1dim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(cs1) - (var(real(cs1)) + var(aimag(cs1)))) < sptol) + call check(error, abs(var(cs1, dim=1) - (var(real(cs1),1) + var(aimag(cs1), 1)) ) < sptol) + + end subroutine test_csp_1dim + + subroutine test_csp_1dim_mask(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(var(cs1, .false.))) + call check(error, ieee_is_nan(var(cs1, 1, .false.))) + + end subroutine test_csp_1dim_mask + + subroutine test_csp_1dim_mask_array(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(cs1, aimag(cs1) == 0) - var(real(cs1), aimag(cs1) == 0)) < sptol) + call check(error, abs(var(cs1, 1, aimag(cs1) == 0) - var(real(cs1), 1, aimag(cs1) == 0)) < sptol) + + end subroutine test_csp_1dim_mask_array + + subroutine test_csp_2dim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(cs) - (var(real(cs)) + var(aimag(cs)))) < sptol) + call check(error, all( abs( var(cs, 1) - (var(real(cs), 1) + var(aimag(cs), 1))) < sptol)) + call check(error, all( abs( var(cs, 2) - (var(real(cs), 2) + var(aimag(cs), 2))) < sptol)) + + end subroutine test_csp_2dim + + subroutine test_csp_2dim_mask(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(var(cs, .false.))) + call check(error, any(ieee_is_nan(var(cs, 1, .false.)))) + call check(error, any(ieee_is_nan(var(cs, 2, .false.)))) + + end subroutine test_csp_2dim_mask + + + subroutine test_csp_2dim_mask_array(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(cs, aimag(cs) == 0) - var(real(cs), aimag(cs) == 0)) < sptol) + call check(error, all( abs( var(cs, 1, aimag(cs) == 0) - var(real(cs), 1, aimag(cs) == 0)) < sptol)) + call check(error, any( ieee_is_nan( var(cs, 2, aimag(cs) == 0)))) + + end subroutine test_csp_2dim_mask_array + + subroutine test_cdp_1dim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(cd1) - (var(real(cd1)) + var(aimag(cd1)))) < dptol) + call check(error, abs(var(cd1, dim=1) - (var(real(cd1),1) + var(aimag(cd1), 1)) ) < dptol) + + end subroutine test_cdp_1dim + + subroutine test_cdp_1dim_mask(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(var(cd1, .false.))) + call check(error, ieee_is_nan(var(cd1, 1, .false.))) + + end subroutine test_cdp_1dim_mask + + subroutine test_cdp_1dim_mask_array(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(cd1, aimag(cd1) == 0) - var(real(cd1), aimag(cd1) == 0)) < dptol) + call check(error, abs(var(cd1, 1, aimag(cd1) == 0) - var(real(cd1), 1, aimag(cd1) == 0)) < dptol) + + end subroutine test_cdp_1dim_mask_array + + subroutine test_cdp_2dim(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(cd) - (var(real(cd)) + var(aimag(cd)))) < dptol) + call check(error, all( abs( var(cd, 1) - (var(real(cd), 1) + var(aimag(cd), 1))) < dptol)) + call check(error, all( abs( var(cd, 2) - (var(real(cd), 2) + var(aimag(cd), 2))) < dptol)) + + end subroutine test_cdp_2dim + + subroutine test_cdp_2dim_mask(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, ieee_is_nan(var(cd, .false.))) + call check(error, any(ieee_is_nan(var(cd, 1, .false.)))) + call check(error, any(ieee_is_nan(var(cd, 2, .false.)))) + + end subroutine test_cdp_2dim_mask + + subroutine test_cdp_2dim_mask_array(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, abs(var(cd, aimag(cd) == 0) - var(real(cd), aimag(cd) == 0)) < dptol) + call check(error, all( abs( var(cd, 1, aimag(cd) == 0) - var(real(cd), 1, aimag(cd) == 0)) < dptol)) + call check(error, any( ieee_is_nan( var(cd, 2, aimag(cd) == 0)))) + + end subroutine test_cdp_2dim_mask_array + +end module + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_var, only : collect_var + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("var", collect_var) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if end program From c193450460caaba6800eff921e3c3f084bf69b70 Mon Sep 17 00:00:00 2001 From: Milan Curcic Date: Sun, 29 Aug 2021 14:29:28 -0400 Subject: [PATCH 16/34] Port test_open.f90 to test-drive --- src/tests/io/test_open.f90 | 255 ++++++++++++++++++++++++------------- 1 file changed, 164 insertions(+), 91 deletions(-) diff --git a/src/tests/io/test_open.f90 b/src/tests/io/test_open.f90 index c639c6119..1701fa9f5 100644 --- a/src/tests/io/test_open.f90 +++ b/src/tests/io/test_open.f90 @@ -1,99 +1,172 @@ -program test_open -use stdlib_io, only: open -use stdlib_error, only: check -implicit none +module test_open + use stdlib_io, only: open + use stdlib_test, only: new_unittest, unittest_type, error_type, check + implicit none -character(:), allocatable :: filename -integer :: io, u, a(3) - -! Text file -filename = get_outpath() // "/io_open.dat" - -! Test mode "w" -u = open(filename, "w") -write(u, *) 1, 2, 3 -close(u) - -! Test mode "r" -u = open(filename, "r") -read(u, *) a -call check(all(a == [1, 2, 3])) -close(u) - -! Test mode "a" -u = open(filename, "a") -write(u, *) 4, 5, 6 -close(u) -u = open(filename, "r") -read(u, *) a -call check(all(a == [1, 2, 3])) -read(u, *) a -call check(all(a == [4, 5, 6])) -close(u) - - - -! Stream file -filename = get_outpath() // "/io_open.stream" - -! Test mode "w" -u = open(filename, "wb") -write(u) 1, 2, 3 -close(u) - -! Test mode "r" -u = open(filename, "rb") -read(u) a -call check(all(a == [1, 2, 3])) -close(u) - -! Test mode "a" -u = open(filename, "ab") -write(u) 4, 5, 6 -close(u) -u = open(filename, "rb") -read(u) a -call check(all(a == [1, 2, 3])) -read(u) a -call check(all(a == [4, 5, 6])) -close(u) - - - -!0 and non-0 open -filename = get_outpath() // "/io_open.stream" - -u = open(filename, "rb", io) -call check(io == 0) -if (io == 0) close(u) - -u = open(filename, "ab", io) -call check(io == 0) -if (io == 0) close(u) - - -filename = get_outpath() // "/does_not_exist.error" - -u = open(filename, "a", io) -call check(io /= 0) + public :: collect_open +contains -u = open(filename, "r", io) -call check(io /= 0) + !> Collect all exported unit tests + subroutine collect_open(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + testsuite = [ & + new_unittest("io_read_write_text", test_io_read_write_text), & + new_unittest("io_read_write_stream", test_io_read_write_stream), & + new_unittest("io_open_error_flag", test_io_open_error_flag) & + ] -contains + end subroutine collect_open function get_outpath() result(outpath) - integer :: ierr - character(256) :: argv - character(:), allocatable :: outpath - - call get_command_argument(1, argv, status=ierr) - if (ierr==0) then - outpath = trim(argv) - else - outpath = '.' - endif + integer :: ierr + character(256) :: argv + character(:), allocatable :: outpath + + call get_command_argument(1, argv, status=ierr) + if (ierr == 0) then + outpath = trim(argv) + else + outpath = '.' + end if end function get_outpath -end program + + subroutine test_io_read_write_text(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + character(:), allocatable :: filename + integer :: u, a(3) + + ! Text file + filename = get_outpath() // "/io_open.dat" + + ! Test mode "w" + u = open(filename, "w") + write(u, *) 1, 2, 3 + close(u) + + ! Test mode "r" + u = open(filename, "r") + read(u, *) a + call check(error, all(a == [1, 2, 3])) + close(u) + if (allocated(error)) return + + ! Test mode "a" + u = open(filename, "a") + write(u, *) 4, 5, 6 + close(u) + u = open(filename, "r") + read(u, *) a + call check(error, all(a == [1, 2, 3])) + read(u, *) a + call check(error, all(a == [4, 5, 6])) + close(u) + if (allocated(error)) return + + end subroutine test_io_read_write_text + + + subroutine test_io_read_write_stream(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + character(:), allocatable :: filename + integer :: u, a(3) + + ! Stream file + filename = get_outpath() // "/io_open.stream" + + ! Test mode "w" + u = open(filename, "wb") + write(u) 1, 2, 3 + close(u) + + ! Test mode "r" + u = open(filename, "rb") + read(u) a + call check(error, all(a == [1, 2, 3])) + close(u) + if (allocated(error)) return + + ! Test mode "a" + u = open(filename, "ab") + write(u) 4, 5, 6 + close(u) + u = open(filename, "rb") + read(u) a + call check(error, all(a == [1, 2, 3])) + read(u) a + if (allocated(error)) return + call check(error, all(a == [4, 5, 6])) + close(u) + if (allocated(error)) return + + end subroutine test_io_read_write_stream + + + subroutine test_io_open_error_flag(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + character(:), allocatable :: filename + integer :: ierr, u, a(3) + + filename = get_outpath() // "/io_open.stream" + + ! Write to file first to ensure that it exists + u = open(filename, "wb") + write(u) 1, 2, 3 + close(u) + + u = open(filename, "rb", ierr) + call check(error, ierr == 0) + if (ierr == 0) close(u) + if (allocated(error)) return + + u = open(filename, "ab", ierr) + call check(error, ierr == 0) + if (ierr == 0) close(u) + if (allocated(error)) return + + filename = get_outpath() // "/does_not_exist.error" + + u = open(filename, "a", ierr) + call check(error, ierr /= 0) + if (allocated(error)) return + + u = open(filename, "r", ierr) + call check(error, ierr /= 0) + if (allocated(error)) return + + end subroutine test_io_open_error_flag + +end module test_open + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_open, only : collect_open + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("open", collect_open) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if + +end program tester \ No newline at end of file From 5824208ef926734abe83b68b912c136163ddac8c Mon Sep 17 00:00:00 2001 From: Milan Curcic Date: Sun, 29 Aug 2021 15:59:29 -0400 Subject: [PATCH 17/34] Port test_parse_mode.f90 to test-drive --- src/tests/io/test_parse_mode.f90 | 349 +++++++++++++++---------------- 1 file changed, 168 insertions(+), 181 deletions(-) diff --git a/src/tests/io/test_parse_mode.f90 b/src/tests/io/test_parse_mode.f90 index a94d96de4..9de3301f4 100644 --- a/src/tests/io/test_parse_mode.f90 +++ b/src/tests/io/test_parse_mode.f90 @@ -1,187 +1,174 @@ -program test_parse_mode -use stdlib_io, only: parse_mode -use stdlib_error, only: check -implicit none +module test_parse_mode + use stdlib_ascii, only: reverse + use stdlib_io, only: parse_mode + use stdlib_test, only: new_unittest, unittest_type, error_type, check + implicit none + + private + public :: collect_parse_mode + + character(3), parameter :: parse_modes_input(*) = [ & + " ", & + "r ", "w ", "a ", "x ", & + "rt ", "wt ", "at ", "xt ", & + "rb ", "wb ", "ab ", "xb ", & + "r+ ", "w+ ", "a+ ", "x+ ", & + "r+t", "w+t", "a+t", "x+t", & + "r+b", "w+b", "a+b", "x+b" & + ] + + character(3), parameter :: parse_modes_expected(*) = [ & + "r t", & + "r t", "w t", "a t", "x t", & + "r t", "w t", "a t", "x t", & + "r b", "w b", "a b", "x b", & + "r+t", "w+t", "a+t", "x+t", & + "r+t", "w+t", "a+t", "x+t", & + "r+b", "w+b", "a+b", "x+b" & + ] -call test_parse_mode_expected_order() +contains -call test_parse_mode_reverse_order() + !> Collect all exported unit tests + subroutine collect_parse_mode(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) -call test_parse_mode_random_order() + testsuite = [ & + new_unittest("parse_mode_expected_order", test_parse_mode_expected_order), & + new_unittest("parse_mode_reverse_order", test_parse_mode_reverse_order), & + new_unittest("parse_mode_random_order", test_parse_mode_random_order) & + !FIXME Is it possible to run tests with error stop? + !new_unittest("parse_mode_always_fail", test_parse_mode_always_fail) & + ] -!call test_parse_mode_always_fail() + end subroutine collect_parse_mode -contains - subroutine test_parse_mode_expected_order() - character(3) :: m - m = parse_mode("") - call check(m == "r t") - - m = parse_mode("r") - call check(m == "r t") - m = parse_mode("w") - call check(m == "w t") - m = parse_mode("a") - call check(m == "a t") - m = parse_mode("x") - call check(m == "x t") - - m = parse_mode("rt") - call check(m == "r t") - m = parse_mode("wt") - call check(m == "w t") - m = parse_mode("at") - call check(m == "a t") - m = parse_mode("xt") - call check(m == "x t") - - m = parse_mode("rb") - call check(m == "r b") - m = parse_mode("wb") - call check(m == "w b") - m = parse_mode("ab") - call check(m == "a b") - m = parse_mode("xb") - call check(m == "x b") - - m = parse_mode("r+") - call check(m == "r+t") - m = parse_mode("w+") - call check(m == "w+t") - m = parse_mode("a+") - call check(m == "a+t") - m = parse_mode("x+") - call check(m == "x+t") - - m = parse_mode("r+t") - call check(m == "r+t") - m = parse_mode("w+t") - call check(m == "w+t") - m = parse_mode("a+t") - call check(m == "a+t") - m = parse_mode("x+t") - call check(m == "x+t") - - m = parse_mode("r+b") - call check(m == "r+b") - m = parse_mode("w+b") - call check(m == "w+b") - m = parse_mode("a+b") - call check(m == "a+b") - m = parse_mode("x+b") - call check(m == "x+b") - - end subroutine - - subroutine test_parse_mode_reverse_order() - character(3) :: m - m = parse_mode("") - call check(m == "r t") - - m = parse_mode("tr") - call check(m == "r t") - m = parse_mode("tw") - call check(m == "w t") - m = parse_mode("ta") - call check(m == "a t") - m = parse_mode("tx") - call check(m == "x t") - - m = parse_mode("br") - call check(m == "r b") - m = parse_mode("bw") - call check(m == "w b") - m = parse_mode("ba") - call check(m == "a b") - m = parse_mode("bx") - call check(m == "x b") - - m = parse_mode("+r") - call check(m == "r+t") - m = parse_mode("+w") - call check(m == "w+t") - m = parse_mode("+a") - call check(m == "a+t") - m = parse_mode("+x") - call check(m == "x+t") - - m = parse_mode("t+r") - call check(m == "r+t") - m = parse_mode("t+w") - call check(m == "w+t") - m = parse_mode("t+a") - call check(m == "a+t") - m = parse_mode("t+x") - call check(m == "x+t") - - m = parse_mode("b+r") - call check(m == "r+b") - m = parse_mode("b+w") - call check(m == "w+b") - m = parse_mode("b+a") - call check(m == "a+b") - m = parse_mode("x+b") - call check(m == "x+b") - - end subroutine - - subroutine test_parse_mode_random_order() - character(3) :: m - m = parse_mode("") - call check(m == "r t") - - m = parse_mode("t r") - call check(m == "r t") - m = parse_mode(" tw ") - call check(m == "w t") - m = parse_mode("ta ") - call check(m == "a t") - m = parse_mode(" t x ") - call check(m == "x t") - - m = parse_mode("+ r ") - call check(m == "r+t") - m = parse_mode("w +") - call check(m == "w+t") - m = parse_mode(" a+") - call check(m == "a+t") - m = parse_mode(" x+ t ") - call check(m == "x+t") - - m = parse_mode("tr+ ") - call check(m == "r+t") - m = parse_mode("wt + ") - call check(m == "w+t") - m = parse_mode("a + t") - call check(m == "a+t") - m = parse_mode(" xt + ") - call check(m == "x+t") - - m = parse_mode(" + t") - call check(m == "r+t") - m = parse_mode(" +w b") - call check(m == "w+b") - m = parse_mode("a + b") - call check(m == "a+b") - m = parse_mode(" b + x ") - call check(m == "x+b") - - end subroutine - - subroutine test_parse_mode_always_fail() - character(3) :: m - - m = parse_mode("r+w") - call check(m /= "r t") - - m = parse_mode("tt") - call check(m /= "r t") - - m = parse_mode("bt") - call check(m /= "r t") - - end subroutine - - -end program + subroutine test_parse_mode_expected_order(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: n + + do n = 1, size(parse_modes_input) + call check(error, parse_mode(trim(parse_modes_input(n))) == & + parse_modes_expected(n)) + if (allocated(error)) return + end do + + end subroutine test_parse_mode_expected_order + + + subroutine test_parse_mode_reverse_order(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: n + + do n = 1, size(parse_modes_input) + call check(error, & + parse_mode(trim(reverse(parse_modes_input(n)))) == & + parse_modes_expected(n)) + if (allocated(error)) return + end do + + end subroutine test_parse_mode_reverse_order + + + subroutine test_parse_mode_random_order(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, parse_mode("t r") == "r t") + if (allocated(error)) return + + call check(error, parse_mode(" tw ") == "w t") + if (allocated(error)) return + + call check(error, parse_mode("ta ") == "a t") + if (allocated(error)) return + + call check(error, parse_mode(" t x ") == "x t") + if (allocated(error)) return + + call check(error, parse_mode("+ r ") == "r+t") + if (allocated(error)) return + + call check(error, parse_mode("w +") == "w+t") + if (allocated(error)) return + + call check(error, parse_mode(" a+") == "a+t") + if (allocated(error)) return + + call check(error, parse_mode(" x+ t ") == "x+t") + if (allocated(error)) return + + call check(error, parse_mode("tr+ ") == "r+t") + if (allocated(error)) return + + call check(error, parse_mode("wt + ") == "w+t") + if (allocated(error)) return + + call check(error, parse_mode("a + t") == "a+t") + if (allocated(error)) return + + call check(error, parse_mode(" xt + ") == "x+t") + if (allocated(error)) return + + call check(error, parse_mode(" + t") == "r+t") + if (allocated(error)) return + + call check(error, parse_mode(" +w b") == "w+b") + if (allocated(error)) return + + call check(error, parse_mode("a + b") == "a+b") + if (allocated(error)) return + + call check(error, parse_mode(" b + x ") == "x+b") + if (allocated(error)) return + + end subroutine test_parse_mode_random_order + + + subroutine test_parse_mode_always_fail(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, parse_mode("r+w") /= "r t") + if (allocated(error)) return + call check(error, parse_mode("tt") /= "r t") + if (allocated(error)) return + call check(error, parse_mode("bt") /= "r t") + if (allocated(error)) return + + end subroutine test_parse_mode_always_fail + +end module test_parse_mode + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_parse_mode, only : collect_parse_mode + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("parse_mode", collect_parse_mode) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if + +end program tester \ No newline at end of file From c7ae718fddab996f10fb976b2fdf55d2bf4a27b1 Mon Sep 17 00:00:00 2001 From: Milan Curcic Date: Sun, 29 Aug 2021 20:19:11 -0400 Subject: [PATCH 18/34] Add private attribute --- src/tests/io/test_open.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/tests/io/test_open.f90 b/src/tests/io/test_open.f90 index 1701fa9f5..4d939e127 100644 --- a/src/tests/io/test_open.f90 +++ b/src/tests/io/test_open.f90 @@ -3,6 +3,7 @@ module test_open use stdlib_test, only: new_unittest, unittest_type, error_type, check implicit none + private public :: collect_open contains From 917da6e22c3f1b3c9ee6e9b68105b1dc3932c444 Mon Sep 17 00:00:00 2001 From: Milan Curcic Date: Sun, 29 Aug 2021 20:19:25 -0400 Subject: [PATCH 19/34] Port test_savetxt.f90 to test-drive --- src/tests/io/test_savetxt.f90 | 282 ++++++++++++++++++++++------------ 1 file changed, 183 insertions(+), 99 deletions(-) diff --git a/src/tests/io/test_savetxt.f90 b/src/tests/io/test_savetxt.f90 index b7e1ef1bb..bac672a0a 100644 --- a/src/tests/io/test_savetxt.f90 +++ b/src/tests/io/test_savetxt.f90 @@ -1,119 +1,203 @@ -program test_savetxt -use stdlib_kinds, only: int32, sp, dp -use stdlib_io, only: loadtxt, savetxt -use stdlib_error, only: check -implicit none +module test_savetxt + use stdlib_kinds, only: int32, sp, dp + use stdlib_io, only: loadtxt, savetxt + use stdlib_test, only: new_unittest, unittest_type, error_type, check + implicit none + + private + public :: collect_savetxt +contains -character(:), allocatable :: outpath + !> Collect all exported unit tests + subroutine collect_savetxt(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) -outpath = get_outpath() // "/tmp.dat" + testsuite = [ & + new_unittest("iint32", test_iint32), & + new_unittest("rsp", test_rsp), & + new_unittest("rdp", test_rdp), & + new_unittest("csp", test_csp), & + new_unittest("cdp", test_cdp) & + ] -call test_iint32(outpath) -call test_rsp(outpath) -call test_rdp(outpath) -call test_csp(outpath) -call test_cdp(outpath) + end subroutine collect_savetxt -contains function get_outpath() result(outpath) - integer :: ierr - character(256) :: argv - character(:), allocatable :: outpath - - call get_command_argument(1, argv, status=ierr) - if (ierr==0) then - outpath = trim(argv) - else - outpath = '.' - endif + integer :: ierr + character(256) :: argv + character(:), allocatable :: outpath + + call get_command_argument(1, argv, status=ierr) + if (ierr == 0) then + outpath = trim(argv) + else + outpath = '.' + end if end function get_outpath - subroutine test_iint32(outpath) - character(*), intent(in) :: outpath - integer(int32) :: d(3, 2), e(2, 3) - integer(int32), allocatable :: d2(:, :) - d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) - call savetxt(outpath, d) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [3, 2])) - call check(all(abs(d-d2) == 0)) - - e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) - call savetxt(outpath, e) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [2, 3])) - call check(all(abs(e-d2) == 0)) + + subroutine test_iint32(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer(int32) :: d(3, 2), e(2, 3) + integer(int32), allocatable :: d2(:, :) + character(:), allocatable :: outpath + + outpath = get_outpath() // "/tmp_test_iint32.dat" + + d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [3, 2])) + if (allocated(error)) return + call check(error, all(abs(d-d2) == 0)) + if (allocated(error)) return + + e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [2, 3])) + if (allocated(error)) return + call check(error, all(abs(e-d2) == 0)) + if (allocated(error)) return end subroutine - subroutine test_rsp(outpath) - character(*), intent(in) :: outpath - real(sp) :: d(3, 2), e(2, 3) - real(sp), allocatable :: d2(:, :) - d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) - call savetxt(outpath, d) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [3, 2])) - call check(all(abs(d-d2) < epsilon(1._sp))) - - e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) - call savetxt(outpath, e) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [2, 3])) - call check(all(abs(e-d2) < epsilon(1._sp))) + subroutine test_rsp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(sp) :: d(3, 2), e(2, 3) + real(sp), allocatable :: d2(:, :) + character(:), allocatable :: outpath + + outpath = get_outpath() // "/tmp_test_rsp.dat" + + d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [3, 2])) + if (allocated(error)) return + call check(error, all(abs(d-d2) < epsilon(1._sp))) + if (allocated(error)) return + + e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [2, 3])) + if (allocated(error)) return + call check(error, all(abs(e-d2) < epsilon(1._sp))) + if (allocated(error)) return end subroutine test_rsp - subroutine test_rdp(outpath) - character(*), intent(in) :: outpath - real(dp) :: d(3, 2), e(2, 3) - real(dp), allocatable :: d2(:, :) - d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) - call savetxt(outpath, d) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [3, 2])) - call check(all(abs(d-d2) < epsilon(1._dp))) - - e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) - call savetxt(outpath, e) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [2, 3])) - call check(all(abs(e-d2) < epsilon(1._dp))) + subroutine test_rdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(dp) :: d(3, 2), e(2, 3) + real(dp), allocatable :: d2(:, :) + character(:), allocatable :: outpath + + outpath = get_outpath() // "/tmp_test_rdp.dat" + + d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [3, 2])) + if (allocated(error)) return + call check(error, all(abs(d-d2) < epsilon(1._dp))) + if (allocated(error)) return + + e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [2, 3])) + if (allocated(error)) return + call check(error, all(abs(e-d2) < epsilon(1._dp))) + if (allocated(error)) return end subroutine test_rdp - subroutine test_csp(outpath) - character(*), intent(in) :: outpath - complex(sp) :: d(3, 2), e(2, 3) - complex(sp), allocatable :: d2(:, :) - d = cmplx(1, 1,kind=sp)* reshape([1, 2, 3, 4, 5, 6], [3, 2]) - call savetxt(outpath, d) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [3, 2])) - call check(all(abs(d-d2) < epsilon(1._sp))) - - e = cmplx(1, 1,kind=sp)* reshape([1, 2, 3, 4, 5, 6], [2, 3]) - call savetxt(outpath, e) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [2, 3])) - call check(all(abs(e-d2) < epsilon(1._sp))) + + subroutine test_csp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + complex(sp) :: d(3, 2), e(2, 3) + complex(sp), allocatable :: d2(:, :) + character(:), allocatable :: outpath + + outpath = get_outpath() // "/tmp_test_csp.dat" + + d = cmplx(1, 1,kind=sp)* reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [3, 2])) + if (allocated(error)) return + call check(error, all(abs(d-d2) < epsilon(1._sp))) + if (allocated(error)) return + + e = cmplx(1, 1,kind=sp)* reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [2, 3])) + if (allocated(error)) return + call check(error, all(abs(e-d2) < epsilon(1._sp))) + if (allocated(error)) return end subroutine test_csp - subroutine test_cdp(outpath) - character(*), intent(in) :: outpath - complex(dp) :: d(3, 2), e(2, 3) - complex(dp), allocatable :: d2(:, :) - d = cmplx(1._dp, 1._dp,kind=dp)* reshape([1, 2, 3, 4, 5, 6], [3, 2]) - call savetxt(outpath, d) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [3, 2])) - call check(all(abs(d-d2) < epsilon(1._dp))) - - e = cmplx(1, 1,kind=dp)* reshape([1, 2, 3, 4, 5, 6], [2, 3]) - call savetxt(outpath, e) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [2, 3])) - call check(all(abs(e-d2) < epsilon(1._dp))) + + subroutine test_cdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + complex(dp) :: d(3, 2), e(2, 3) + complex(dp), allocatable :: d2(:, :) + character(:), allocatable :: outpath + + outpath = get_outpath() // "/tmp_test_cdp.dat" + + d = cmplx(1._dp, 1._dp,kind=dp)* reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [3, 2])) + if (allocated(error)) return + call check(error, all(abs(d-d2) < epsilon(1._dp))) + if (allocated(error)) return + + e = cmplx(1, 1,kind=dp)* reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [2, 3])) + if (allocated(error)) return + call check(error, all(abs(e-d2) < epsilon(1._dp))) + if (allocated(error)) return end subroutine test_cdp -end program test_savetxt +end module test_savetxt + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_savetxt, only : collect_savetxt + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("savetxt", collect_savetxt) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if + +end program tester From b92b60b24b11956fc02d1f72b0ad3bd9e12ee2ee Mon Sep 17 00:00:00 2001 From: Milan Curcic Date: Mon, 30 Aug 2021 13:55:08 -0400 Subject: [PATCH 20/34] Port test_savetxt_qp.f90 to test-drive --- src/tests/io/test_savetxt_qp.f90 | 158 +++++++++++++++++++++---------- 1 file changed, 107 insertions(+), 51 deletions(-) diff --git a/src/tests/io/test_savetxt_qp.f90 b/src/tests/io/test_savetxt_qp.f90 index c60fefa5a..91e27e407 100644 --- a/src/tests/io/test_savetxt_qp.f90 +++ b/src/tests/io/test_savetxt_qp.f90 @@ -1,63 +1,119 @@ -program test_savetxt_qp -use stdlib_kinds, only: qp -use stdlib_io, only: loadtxt, savetxt -use stdlib_error, only: check -implicit none +module test_savetxt_qp + use stdlib_kinds, only: qp + use stdlib_io, only: loadtxt, savetxt + use stdlib_test, only: new_unittest, unittest_type, error_type, check + implicit none -character(:), allocatable :: outpath + private + public :: collect_savetxt_qp +contains -outpath = get_outpath() // "/tmp_qp.dat" + !> Collect all exported unit tests + subroutine collect_savetxt_qp(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) -call test_rqp(outpath) -call test_cqp(outpath) + testsuite = [ & + new_unittest("rqp", test_rqp), & + new_unittest("cqp", test_cqp) & + ] + + end subroutine collect_savetxt_qp -contains function get_outpath() result(outpath) - integer :: ierr - character(256) :: argv - character(:), allocatable :: outpath - - call get_command_argument(1, argv, status=ierr) - if (ierr==0) then - outpath = trim(argv) - else - outpath = '.' - endif + integer :: ierr + character(256) :: argv + character(:), allocatable :: outpath + + call get_command_argument(1, argv, status=ierr) + if (ierr == 0) then + outpath = trim(argv) + else + outpath = '.' + end if end function get_outpath - subroutine test_rqp(outpath) - character(*), intent(in) :: outpath - real(qp) :: d(3, 2), e(2, 3) - real(qp), allocatable :: d2(:, :) - d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) - call savetxt(outpath, d) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [3, 2])) - call check(all(abs(d-d2) < epsilon(1._qp))) - - e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) - call savetxt(outpath, e) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [2, 3])) - call check(all(abs(e-d2) < epsilon(1._qp))) + + subroutine test_rqp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(qp) :: d(3, 2), e(2, 3) + real(qp), allocatable :: d2(:, :) + character(:), allocatable :: outpath + + outpath = get_outpath() // "/tmp_test_rqp.dat" + + d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [3, 2])) + if (allocated(error)) return + call check(error, all(abs(d-d2) < epsilon(1._qp))) + if (allocated(error)) return + + e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [2, 3])) + if (allocated(error)) return + call check(error, all(abs(e-d2) < epsilon(1._qp))) + if (allocated(error)) return end subroutine test_rqp - subroutine test_cqp(outpath) - character(*), intent(in) :: outpath - complex(qp) :: d(3, 2), e(2, 3) - complex(qp), allocatable :: d2(:, :) - d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) - call savetxt(outpath, d) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [3, 2])) - call check(all(abs(d-d2) < epsilon(1._qp))) - - e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) - call savetxt(outpath, e) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [2, 3])) - call check(all(abs(e-d2) < epsilon(1._qp))) + + subroutine test_cqp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + complex(qp) :: d(3, 2), e(2, 3) + complex(qp), allocatable :: d2(:, :) + character(:), allocatable :: outpath + + outpath = get_outpath() // "/tmp_test_cqp.dat" + + d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [3, 2])) + if (allocated(error)) return + call check(error, all(abs(d-d2) < epsilon(1._qp))) + if (allocated(error)) return + + e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [2, 3])) + if (allocated(error)) return + call check(error, all(abs(e-d2) < epsilon(1._qp))) + if (allocated(error)) return end subroutine test_cqp -end program test_savetxt_qp +end module test_savetxt_qp + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_savetxt_qp, only : collect_savetxt_qp + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("savetxt_qp", collect_savetxt_qp) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if + +end program tester From f0f3478bdb4fa55a89f53151d4f354b23069a9fc Mon Sep 17 00:00:00 2001 From: Milan Curcic Date: Mon, 30 Aug 2021 15:16:36 -0400 Subject: [PATCH 21/34] Port test_loadtxt.f90 to test-drive --- src/tests/io/test_loadtxt.f90 | 149 ++++++++++++++++++++++------------ 1 file changed, 99 insertions(+), 50 deletions(-) diff --git a/src/tests/io/test_loadtxt.f90 b/src/tests/io/test_loadtxt.f90 index 9fe7b0853..642e4d865 100644 --- a/src/tests/io/test_loadtxt.f90 +++ b/src/tests/io/test_loadtxt.f90 @@ -1,63 +1,112 @@ -program test_loadtxt -use stdlib_kinds, only: int32, sp, dp -use stdlib_io, only: loadtxt -use stdlib_error, only: error_stop -implicit none +module test_loadtxt + use stdlib_kinds, only: int32, sp, dp + use stdlib_io, only: loadtxt, savetxt + use stdlib_test, only: new_unittest, unittest_type, error_type, check + implicit none -integer(int32), allocatable :: i(:, :) -real(sp), allocatable :: s(:, :) -real(dp), allocatable :: d(:, :) -complex(dp), allocatable :: z(:, :) + private + public :: collect_loadtxt +contains -call loadtxt("array1.dat", i) -call print_array(i) + !> Collect all exported unit tests + subroutine collect_loadtxt(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) -call loadtxt("array1.dat", s) -call print_array(s) + testsuite = [ & + new_unittest("loadtxt_int32", test_loadtxt_int32), & + new_unittest("loadtxt_sp", test_loadtxt_sp), & + new_unittest("loadtxt_dp", test_loadtxt_sp) & + ] -call loadtxt("array1.dat", d) -call print_array(d) + end subroutine collect_loadtxt -call loadtxt("array2.dat", d) -call print_array(d) -call loadtxt("array3.dat", d) -call print_array(d) + subroutine test_loadtxt_int32(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer(int32), allocatable :: input(:,:), expected(:,:) -call loadtxt("array4.dat", d) -call print_array(d) + call loadtxt("array1.dat", input) + call savetxt("array1_new.dat", input) + call loadtxt("array1_new.dat", expected) + call check(error, all(input == expected)) + if (.not. allocated(error)) return -call loadtxt("array5.dat", z) -call print_array(z) + call loadtxt("array2.dat", input) + call savetxt("array2_new.dat", input) + call loadtxt("array2_new.dat", expected) + call check(error, all(input == expected)) + if (.not. allocated(error)) return -contains + end subroutine test_loadtxt_int32 + + + subroutine test_loadtxt_sp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(sp), allocatable :: input(:,:), expected(:,:) + + call loadtxt("array3.dat", input) + call savetxt("array3_new.dat", input) + call loadtxt("array3_new.dat", expected) + call check(error, all(input == expected)) + if (.not. allocated(error)) return + + call loadtxt("array4.dat", input) + call savetxt("array4_new.dat", input) + call loadtxt("array4_new.dat", expected) + call check(error, all(input == expected)) + if (.not. allocated(error)) return + + end subroutine test_loadtxt_sp + + + subroutine test_loadtxt_dp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(dp), allocatable :: input(:,:), expected(:,:) + + call loadtxt("array3.dat", input) + call savetxt("array3_new.dat", input) + call loadtxt("array3_new.dat", expected) + call check(error, all(input == expected)) + if (.not. allocated(error)) return + + call loadtxt("array4.dat", input) + call savetxt("array4_new.dat", input) + call loadtxt("array4_new.dat", expected) + call check(error, all(input == expected)) + if (.not. allocated(error)) return + + end subroutine test_loadtxt_dp + +end module test_loadtxt + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_loadtxt, only : collect_loadtxt + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("loadtxt", collect_loadtxt) & + ] -subroutine print_array(a) -class(*),intent(in) :: a(:, :) -integer :: i -print *, "Array, shape=(", size(a, 1), ",", size(a, 2), ")" - - select type(a) - type is(integer(int32)) - do i = 1, size(a, 1) - print *, a(i, :) - end do - type is(real(sp)) - do i = 1, size(a, 1) - print *, a(i, :) - end do - type is(real(dp)) - do i = 1, size(a, 1) - print *, a(i, :) - end do - type is(complex(dp)) - do i = 1, size(a, 1) - print *, a(i, :) + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) end do - class default - call error_stop('The proposed type is not supported') - end select -end subroutine + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if -end program +end program tester From 08f10c34c4cdd0a1665ad72c47faa36eefade833 Mon Sep 17 00:00:00 2001 From: Milan Curcic Date: Mon, 30 Aug 2021 15:19:38 -0400 Subject: [PATCH 22/34] Add complex data test to test_loadtxt.f90 --- src/tests/io/test_loadtxt.f90 | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/src/tests/io/test_loadtxt.f90 b/src/tests/io/test_loadtxt.f90 index 642e4d865..1fb657e3a 100644 --- a/src/tests/io/test_loadtxt.f90 +++ b/src/tests/io/test_loadtxt.f90 @@ -16,7 +16,8 @@ subroutine collect_loadtxt(testsuite) testsuite = [ & new_unittest("loadtxt_int32", test_loadtxt_int32), & new_unittest("loadtxt_sp", test_loadtxt_sp), & - new_unittest("loadtxt_dp", test_loadtxt_sp) & + new_unittest("loadtxt_dp", test_loadtxt_dp), & + new_unittest("loadtxt_complex", test_loadtxt_complex) & ] end subroutine collect_loadtxt @@ -81,6 +82,20 @@ subroutine test_loadtxt_dp(error) end subroutine test_loadtxt_dp + + subroutine test_loadtxt_complex(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + complex(dp), allocatable :: input(:,:), expected(:,:) + + call loadtxt("array5.dat", input) + call savetxt("array5_new.dat", input) + call loadtxt("array5_new.dat", expected) + call check(error, all(input == expected)) + if (.not. allocated(error)) return + + end subroutine test_loadtxt_complex + end module test_loadtxt From 2ef8724e21ed8930414fe1b52d0c65342578a46c Mon Sep 17 00:00:00 2001 From: Milan Curcic Date: Mon, 30 Aug 2021 15:23:52 -0400 Subject: [PATCH 23/34] Port test_loadtxt_qp.f90 to test-drive --- src/tests/io/test_loadtxt_qp.f90 | 80 +++++++++++++++++++++++--------- 1 file changed, 57 insertions(+), 23 deletions(-) diff --git a/src/tests/io/test_loadtxt_qp.f90 b/src/tests/io/test_loadtxt_qp.f90 index 6969b0727..20b37f3e9 100644 --- a/src/tests/io/test_loadtxt_qp.f90 +++ b/src/tests/io/test_loadtxt_qp.f90 @@ -1,30 +1,64 @@ -program test_loadtxt_qp -use stdlib_kinds, only: qp -use stdlib_io, only: loadtxt -implicit none +module test_loadtxt_qp + use stdlib_kinds, only: qp + use stdlib_io, only: loadtxt, savetxt + use stdlib_test, only: new_unittest, unittest_type, error_type, check + implicit none -real(qp), allocatable :: q(:, :) + private + public :: collect_loadtxt_qp +contains -call loadtxt("array4.dat", q) -call print_array(q) + !> Collect all exported unit tests + subroutine collect_loadtxt_qp(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) -contains + testsuite = [ & + new_unittest("loadtxt_qp", test_loadtxt_qp_) & + ] + + end subroutine collect_loadtxt_qp + + + subroutine test_loadtxt_qp_(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(qp), allocatable :: input(:,:), expected(:,:) + + call loadtxt("array4.dat", input) + call savetxt("array4_new.dat", input) + call loadtxt("array4_new.dat", expected) + call check(error, all(input == expected)) + if (.not. allocated(error)) return + + end subroutine test_loadtxt_qp_ + +end module test_loadtxt_qp + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_loadtxt_qp, only : collect_loadtxt_qp + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 -subroutine print_array(a) -class(*),intent(in) :: a(:, :) -integer :: i -print *, "Array, shape=(", size(a, 1), ",", size(a, 2), ")" + testsuites = [ & + new_testsuite("loadtxt_qp", collect_loadtxt_qp) & + ] - select type(a) - type is(real(qp)) - do i = 1, size(a, 1) - print *, a(i, :) - end do - class default - write(*,'(a)')'The proposed type is not supported' - error stop - end select + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do -end subroutine + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if -end program +end program tester From ff8bf75ad10c73fec7f18f88ca206621c5b201ec Mon Sep 17 00:00:00 2001 From: Milan Curcic Date: Mon, 30 Aug 2021 15:32:15 -0400 Subject: [PATCH 24/34] Fix indent in Makefile --- src/tests/io/Makefile.manual | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/tests/io/Makefile.manual b/src/tests/io/Makefile.manual index 3bbce9db7..2cf47dd51 100644 --- a/src/tests/io/Makefile.manual +++ b/src/tests/io/Makefile.manual @@ -1,9 +1,9 @@ PROGS_SRC = test_loadtxt.f90 \ - test_savetxt.f90 \ - test_loadtxt_qp.f90 \ - test_savetxt_qp.f90 \ - test_parse_mode.f90 \ - test_open.f90 + test_savetxt.f90 \ + test_loadtxt_qp.f90 \ + test_savetxt_qp.f90 \ + test_parse_mode.f90 \ + test_open.f90 CLEAN_FILES = tmp.dat tmp_qp.dat io_open.dat io_open.stream From b0aedd3e22d793a36efff701322cc5a824d4181f Mon Sep 17 00:00:00 2001 From: Milan Curcic Date: Mon, 30 Aug 2021 15:42:03 -0400 Subject: [PATCH 25/34] Clean all test artifacts in Makefile.manual --- src/tests/io/Makefile.manual | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tests/io/Makefile.manual b/src/tests/io/Makefile.manual index 2cf47dd51..1ef48e034 100644 --- a/src/tests/io/Makefile.manual +++ b/src/tests/io/Makefile.manual @@ -5,7 +5,7 @@ PROGS_SRC = test_loadtxt.f90 \ test_parse_mode.f90 \ test_open.f90 -CLEAN_FILES = tmp.dat tmp_qp.dat io_open.dat io_open.stream +CLEAN_FILES = tmp*.dat array*_new.dat io_open.dat io_open.stream include ../Makefile.manual.test.mk From 4e8894da816a974e7a144e8ec6e1a9f82ff5d969 Mon Sep 17 00:00:00 2001 From: milancurcic Date: Mon, 30 Aug 2021 22:04:56 -0400 Subject: [PATCH 26/34] Fix error handling in test_loadtxt --- src/tests/io/test_loadtxt.f90 | 14 +++++++------- src/tests/io/test_loadtxt_qp.f90 | 2 +- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/tests/io/test_loadtxt.f90 b/src/tests/io/test_loadtxt.f90 index 1fb657e3a..f2b4dfb20 100644 --- a/src/tests/io/test_loadtxt.f90 +++ b/src/tests/io/test_loadtxt.f90 @@ -32,13 +32,13 @@ subroutine test_loadtxt_int32(error) call savetxt("array1_new.dat", input) call loadtxt("array1_new.dat", expected) call check(error, all(input == expected)) - if (.not. allocated(error)) return + if (allocated(error)) return call loadtxt("array2.dat", input) call savetxt("array2_new.dat", input) call loadtxt("array2_new.dat", expected) call check(error, all(input == expected)) - if (.not. allocated(error)) return + if (allocated(error)) return end subroutine test_loadtxt_int32 @@ -52,13 +52,13 @@ subroutine test_loadtxt_sp(error) call savetxt("array3_new.dat", input) call loadtxt("array3_new.dat", expected) call check(error, all(input == expected)) - if (.not. allocated(error)) return + if (allocated(error)) return call loadtxt("array4.dat", input) call savetxt("array4_new.dat", input) call loadtxt("array4_new.dat", expected) call check(error, all(input == expected)) - if (.not. allocated(error)) return + if (allocated(error)) return end subroutine test_loadtxt_sp @@ -72,13 +72,13 @@ subroutine test_loadtxt_dp(error) call savetxt("array3_new.dat", input) call loadtxt("array3_new.dat", expected) call check(error, all(input == expected)) - if (.not. allocated(error)) return + if (allocated(error)) return call loadtxt("array4.dat", input) call savetxt("array4_new.dat", input) call loadtxt("array4_new.dat", expected) call check(error, all(input == expected)) - if (.not. allocated(error)) return + if (allocated(error)) return end subroutine test_loadtxt_dp @@ -92,7 +92,7 @@ subroutine test_loadtxt_complex(error) call savetxt("array5_new.dat", input) call loadtxt("array5_new.dat", expected) call check(error, all(input == expected)) - if (.not. allocated(error)) return + if (allocated(error)) return end subroutine test_loadtxt_complex diff --git a/src/tests/io/test_loadtxt_qp.f90 b/src/tests/io/test_loadtxt_qp.f90 index 20b37f3e9..2461a6016 100644 --- a/src/tests/io/test_loadtxt_qp.f90 +++ b/src/tests/io/test_loadtxt_qp.f90 @@ -29,7 +29,7 @@ subroutine test_loadtxt_qp_(error) call savetxt("array4_new.dat", input) call loadtxt("array4_new.dat", expected) call check(error, all(input == expected)) - if (.not. allocated(error)) return + if (allocated(error)) return end subroutine test_loadtxt_qp_ From c2acb910aff029006f53bbc93ed0f0a0370a1965 Mon Sep 17 00:00:00 2001 From: milancurcic Date: Tue, 31 Aug 2021 11:57:33 -0400 Subject: [PATCH 27/34] Don't reuse output file names between tests --- src/tests/io/test_loadtxt.f90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/tests/io/test_loadtxt.f90 b/src/tests/io/test_loadtxt.f90 index f2b4dfb20..bfaf589d7 100644 --- a/src/tests/io/test_loadtxt.f90 +++ b/src/tests/io/test_loadtxt.f90 @@ -49,14 +49,14 @@ subroutine test_loadtxt_sp(error) real(sp), allocatable :: input(:,:), expected(:,:) call loadtxt("array3.dat", input) - call savetxt("array3_new.dat", input) - call loadtxt("array3_new.dat", expected) + call savetxt("array3_sp.dat", input) + call loadtxt("array3_sp.dat", expected) call check(error, all(input == expected)) if (allocated(error)) return call loadtxt("array4.dat", input) - call savetxt("array4_new.dat", input) - call loadtxt("array4_new.dat", expected) + call savetxt("array4_sp.dat", input) + call loadtxt("array4_sp.dat", expected) call check(error, all(input == expected)) if (allocated(error)) return @@ -69,14 +69,14 @@ subroutine test_loadtxt_dp(error) real(dp), allocatable :: input(:,:), expected(:,:) call loadtxt("array3.dat", input) - call savetxt("array3_new.dat", input) - call loadtxt("array3_new.dat", expected) + call savetxt("array3_dp.dat", input) + call loadtxt("array3_dp.dat", expected) call check(error, all(input == expected)) if (allocated(error)) return call loadtxt("array4.dat", input) - call savetxt("array4_new.dat", input) - call loadtxt("array4_new.dat", expected) + call savetxt("array4_dp.dat", input) + call loadtxt("array4_dp.dat", expected) call check(error, all(input == expected)) if (allocated(error)) return From 85d6e58462259e4cc09abc7d5ba07465163bb6ba Mon Sep 17 00:00:00 2001 From: milancurcic Date: Tue, 31 Aug 2021 21:57:24 -0400 Subject: [PATCH 28/34] Use portable formats in savetxt and loadtxt --- src/stdlib_io.fypp | 31 +++++++++++++++++++++++++++++-- 1 file changed, 29 insertions(+), 2 deletions(-) diff --git a/src/stdlib_io.fypp b/src/stdlib_io.fypp index dcacaa644..db07d259f 100644 --- a/src/stdlib_io.fypp +++ b/src/stdlib_io.fypp @@ -19,6 +19,16 @@ module stdlib_io ! Private API that is exposed so that we can test it in tests public :: parse_mode + ! Format strings with edit descriptors for each type and kind + character(*), parameter :: & + FMT_INT = '(*(i0,1x))', & + FMT_REAL_SP = '(*(es15.8,1x))', & + FMT_REAL_DP = '(*(es23.16,1x))', & + FMT_REAL_QP = '(*(es42.35,1x))', & + FMT_COMPLEX_SP = '(*(es15.8,1x,es15.8))', & + FMT_COMPLEX_DP = '(*(es23.16,1x,es23.16))', & + FMT_COMPLEX_QP = '(*(es42.35,1x,es42.35))' + interface loadtxt !! version: experimental !! @@ -78,13 +88,22 @@ contains ! determine number of columns ncol = number_of_columns(s) + #:if 'complex' in t1 + ncol = ncol / 2 + #:endif ! determine number or rows nrow = number_of_rows_numeric(s) allocate(d(nrow, ncol)) do i = 1, nrow - read(s, *) d(i, :) + #:if 'real' in t1 + read(s, FMT_REAL_${k1}$) d(i, :) + #:elif 'complex' in t1 + read(s, FMT_COMPLEX_${k1}$) d(i, :) + #:else + read(s, *) d(i, :) + #:endif end do close(s) @@ -116,7 +135,15 @@ contains integer :: s, i s = open(filename, "w") do i = 1, size(d, 1) - write(s, *) d(i, :) + #:if 'real' in t1 + write(s, FMT_REAL_${k1}$) d(i, :) + #:elif 'complex' in t1 + write(s, FMT_COMPLEX_${k1}$) d(i, :) + #:elif 'integer' in t1 + write(s, FMT_INT) d(i, :) + #:else + write(s, *) d(i, :) + #:endif end do close(s) end subroutine savetxt_${t1[0]}$${k1}$ From 3890ea9dacc9d0840b520b3658a490f259d6449e Mon Sep 17 00:00:00 2001 From: milancurcic Date: Tue, 31 Aug 2021 22:05:02 -0400 Subject: [PATCH 29/34] Update tests for savetxt and loadtxt; compare exact values, not approximate; remove hardcoded test files --- src/tests/io/Makefile.manual | 2 +- src/tests/io/array1.dat | 4 -- src/tests/io/array2.dat | 4 -- src/tests/io/array3.dat | 16 ----- src/tests/io/array4.dat | 3 - src/tests/io/array5.dat | 2 - src/tests/io/test_loadtxt.f90 | 100 ++++++++++++++++++------------- src/tests/io/test_loadtxt_qp.f90 | 18 ++++-- src/tests/io/test_savetxt.f90 | 20 +++---- src/tests/io/test_savetxt_qp.f90 | 4 +- 10 files changed, 82 insertions(+), 91 deletions(-) delete mode 100644 src/tests/io/array1.dat delete mode 100644 src/tests/io/array2.dat delete mode 100644 src/tests/io/array3.dat delete mode 100644 src/tests/io/array4.dat delete mode 100644 src/tests/io/array5.dat diff --git a/src/tests/io/Makefile.manual b/src/tests/io/Makefile.manual index 1ef48e034..3b1ac220a 100644 --- a/src/tests/io/Makefile.manual +++ b/src/tests/io/Makefile.manual @@ -5,7 +5,7 @@ PROGS_SRC = test_loadtxt.f90 \ test_parse_mode.f90 \ test_open.f90 -CLEAN_FILES = tmp*.dat array*_new.dat io_open.dat io_open.stream +CLEAN_FILES = tmp*.dat io_open.dat io_open.stream include ../Makefile.manual.test.mk diff --git a/src/tests/io/array1.dat b/src/tests/io/array1.dat deleted file mode 100644 index 9ed9e364d..000000000 --- a/src/tests/io/array1.dat +++ /dev/null @@ -1,4 +0,0 @@ -1 2 -3 4 -5 6 -7 8 diff --git a/src/tests/io/array2.dat b/src/tests/io/array2.dat deleted file mode 100644 index 8136afcc4..000000000 --- a/src/tests/io/array2.dat +++ /dev/null @@ -1,4 +0,0 @@ -1 2 9 -3 4 10 -5 6 11 -7 8 12 diff --git a/src/tests/io/array3.dat b/src/tests/io/array3.dat deleted file mode 100644 index 13b583f89..000000000 --- a/src/tests/io/array3.dat +++ /dev/null @@ -1,16 +0,0 @@ -1.000000000000000021e-08 9.199998759392489944e+01 -1.024113254885563425e-08 9.199998731474968849e+01 -1.048233721895820948e-08 9.199998703587728244e+01 -1.072361403187881949e-08 9.199998675729767683e+01 -1.096496300919481796e-08 9.199998647900135040e+01 -1.120638417249036630e-08 9.199998620097916557e+01 -1.144787754335570897e-08 9.199998592322251056e+01 -1.168944314338753750e-08 9.199998564572304360e+01 -1.193108099418952317e-08 9.199998536847290609e+01 -1.217279111737088596e-08 9.199998509146449521e+01 -1.241457353454836993e-08 9.199998481469057765e+01 -1.265642826734443823e-08 9.199998453814424693e+01 -1.289835533738818635e-08 9.199998426181879552e+01 -1.314035476631514857e-08 9.199998398570787117e+01 -1.338242657576766519e-08 9.199998370980536322e+01 -1.362457078739434161e-08 9.199998343410533153e+01 diff --git a/src/tests/io/array4.dat b/src/tests/io/array4.dat deleted file mode 100644 index 988e9b6cb..000000000 --- a/src/tests/io/array4.dat +++ /dev/null @@ -1,3 +0,0 @@ - 1.56367173122998851E-010 4.51568171776229776E-007 4.96568621780730290E-006 5.01068666781180638E-005 5.01518671281225327E-004 5.01763629287519872E-003 5.58487648776459511E-002 0.32618374746711520 1.7639051761733842 9.4101331514118236 - 8.23481961129666271E-010 4.58239319656296504E-007 5.03239769660796763E-006 5.07739814661247314E-005 5.08189819161291786E-004 5.09287863145356859E-003 5.62489258981838380E-002 0.32831192218075922 1.7752234390209392 9.4703270222745211 - 2.02201163784892633E-009 4.70224616423489051E-007 5.15225066427989480E-006 5.19725111428439625E-005 5.20175115928484585E-004 5.22805802989171828E-003 5.69678499382489378E-002 0.33213537295325257 1.7955576815764616 9.5784705410250410 diff --git a/src/tests/io/array5.dat b/src/tests/io/array5.dat deleted file mode 100644 index 708698511..000000000 --- a/src/tests/io/array5.dat +++ /dev/null @@ -1,2 +0,0 @@ - (1.0000000000000000,0.0000000000000000) (3.0000000000000000,0.0000000000000000) (5.0000000000000000,0.0000000000000000) - (2.0000000000000000,0.0000000000000000) (4.0000000000000000,0.0000000000000000) (6.0000000000000000,0.0000000000000000) diff --git a/src/tests/io/test_loadtxt.f90 b/src/tests/io/test_loadtxt.f90 index bfaf589d7..f44686f61 100644 --- a/src/tests/io/test_loadtxt.f90 +++ b/src/tests/io/test_loadtxt.f90 @@ -27,18 +27,21 @@ subroutine test_loadtxt_int32(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(int32), allocatable :: input(:,:), expected(:,:) - - call loadtxt("array1.dat", input) - call savetxt("array1_new.dat", input) - call loadtxt("array1_new.dat", expected) - call check(error, all(input == expected)) - if (allocated(error)) return - - call loadtxt("array2.dat", input) - call savetxt("array2_new.dat", input) - call loadtxt("array2_new.dat", expected) - call check(error, all(input == expected)) - if (allocated(error)) return + real(sp), allocatable :: harvest(:,:) + integer :: n + + allocate(harvest(10,10)) + allocate(input(10,10)) + allocate(expected(10,10)) + + do n = 1, 100 + call random_number(harvest) + input = int(harvest * 100) + call savetxt('test_int32.txt', input) + call loadtxt('test_int32.txt', expected) + call check(error, all(input == expected)) + if (allocated(error)) return + end do end subroutine test_loadtxt_int32 @@ -47,18 +50,18 @@ subroutine test_loadtxt_sp(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(sp), allocatable :: input(:,:), expected(:,:) + integer :: n - call loadtxt("array3.dat", input) - call savetxt("array3_sp.dat", input) - call loadtxt("array3_sp.dat", expected) - call check(error, all(input == expected)) - if (allocated(error)) return + allocate(input(10,10)) + allocate(expected(10,10)) - call loadtxt("array4.dat", input) - call savetxt("array4_sp.dat", input) - call loadtxt("array4_sp.dat", expected) - call check(error, all(input == expected)) - if (allocated(error)) return + do n = 1, 100 + call random_number(input) + call savetxt('test_sp.txt', input) + call loadtxt('test_sp.txt', expected) + call check(error, all(input == expected)) + if (allocated(error)) return + end do end subroutine test_loadtxt_sp @@ -67,34 +70,45 @@ subroutine test_loadtxt_dp(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(dp), allocatable :: input(:,:), expected(:,:) + integer :: n - call loadtxt("array3.dat", input) - call savetxt("array3_dp.dat", input) - call loadtxt("array3_dp.dat", expected) - call check(error, all(input == expected)) - if (allocated(error)) return + allocate(input(10,10)) + allocate(expected(10,10)) - call loadtxt("array4.dat", input) - call savetxt("array4_dp.dat", input) - call loadtxt("array4_dp.dat", expected) - call check(error, all(input == expected)) - if (allocated(error)) return + do n = 1, 100 + call random_number(input) + call savetxt('test_dp.txt', input) + call loadtxt('test_dp.txt', expected) + call check(error, all(input == expected)) + if (allocated(error)) return + end do end subroutine test_loadtxt_dp subroutine test_loadtxt_complex(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - complex(dp), allocatable :: input(:,:), expected(:,:) - - call loadtxt("array5.dat", input) - call savetxt("array5_new.dat", input) - call loadtxt("array5_new.dat", expected) - call check(error, all(input == expected)) - if (allocated(error)) return - - end subroutine test_loadtxt_complex + !> Error handling + type(error_type), allocatable, intent(out) :: error + complex(dp), allocatable :: input(:,:), expected(:,:) + real(dp), allocatable :: re(:,:), im(:,:) + integer :: n + + allocate(re(10,10)) + allocate(im(10,10)) + allocate(input(10,10)) + allocate(expected(10,10)) + + do n = 1, 100 + call random_number(re) + call random_number(im) + input = cmplx(re, im) + call savetxt('test_complex.txt', input) + call loadtxt('test_complex.txt', expected) + call check(error, all(input == expected)) + if (allocated(error)) return + end do + + end subroutine test_loadtxt_complex end module test_loadtxt diff --git a/src/tests/io/test_loadtxt_qp.f90 b/src/tests/io/test_loadtxt_qp.f90 index 2461a6016..3436e15a0 100644 --- a/src/tests/io/test_loadtxt_qp.f90 +++ b/src/tests/io/test_loadtxt_qp.f90 @@ -24,12 +24,18 @@ subroutine test_loadtxt_qp_(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(qp), allocatable :: input(:,:), expected(:,:) - - call loadtxt("array4.dat", input) - call savetxt("array4_new.dat", input) - call loadtxt("array4_new.dat", expected) - call check(error, all(input == expected)) - if (allocated(error)) return + integer :: n + + allocate(input(10,10)) + allocate(expected(10,10)) + + do n = 1, 100 + call random_number(input) + call savetxt('test_qp.txt', input) + call loadtxt('test_qp.txt', expected) + call check(error, all(input == expected)) + if (allocated(error)) return + end do end subroutine test_loadtxt_qp_ diff --git a/src/tests/io/test_savetxt.f90 b/src/tests/io/test_savetxt.f90 index bac672a0a..0ea762593 100644 --- a/src/tests/io/test_savetxt.f90 +++ b/src/tests/io/test_savetxt.f90 @@ -52,7 +52,7 @@ subroutine test_iint32(error) call loadtxt(outpath, d2) call check(error, all(shape(d2) == [3, 2])) if (allocated(error)) return - call check(error, all(abs(d-d2) == 0)) + call check(error, all(d == d2)) if (allocated(error)) return e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) @@ -60,7 +60,7 @@ subroutine test_iint32(error) call loadtxt(outpath, d2) call check(error, all(shape(d2) == [2, 3])) if (allocated(error)) return - call check(error, all(abs(e-d2) == 0)) + call check(error, all(e == d2)) if (allocated(error)) return end subroutine @@ -79,7 +79,7 @@ subroutine test_rsp(error) call loadtxt(outpath, d2) call check(error, all(shape(d2) == [3, 2])) if (allocated(error)) return - call check(error, all(abs(d-d2) < epsilon(1._sp))) + call check(error, all(d == d2)) if (allocated(error)) return e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) @@ -87,7 +87,7 @@ subroutine test_rsp(error) call loadtxt(outpath, d2) call check(error, all(shape(d2) == [2, 3])) if (allocated(error)) return - call check(error, all(abs(e-d2) < epsilon(1._sp))) + call check(error, all(e == d2)) if (allocated(error)) return end subroutine test_rsp @@ -106,7 +106,7 @@ subroutine test_rdp(error) call loadtxt(outpath, d2) call check(error, all(shape(d2) == [3, 2])) if (allocated(error)) return - call check(error, all(abs(d-d2) < epsilon(1._dp))) + call check(error, all(d == d2)) if (allocated(error)) return e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) @@ -114,7 +114,7 @@ subroutine test_rdp(error) call loadtxt(outpath, d2) call check(error, all(shape(d2) == [2, 3])) if (allocated(error)) return - call check(error, all(abs(e-d2) < epsilon(1._dp))) + call check(error, all(e == d2)) if (allocated(error)) return end subroutine test_rdp @@ -133,7 +133,7 @@ subroutine test_csp(error) call loadtxt(outpath, d2) call check(error, all(shape(d2) == [3, 2])) if (allocated(error)) return - call check(error, all(abs(d-d2) < epsilon(1._sp))) + call check(error, all(d == d2)) if (allocated(error)) return e = cmplx(1, 1,kind=sp)* reshape([1, 2, 3, 4, 5, 6], [2, 3]) @@ -141,7 +141,7 @@ subroutine test_csp(error) call loadtxt(outpath, d2) call check(error, all(shape(d2) == [2, 3])) if (allocated(error)) return - call check(error, all(abs(e-d2) < epsilon(1._sp))) + call check(error, all(e == d2)) if (allocated(error)) return end subroutine test_csp @@ -160,7 +160,7 @@ subroutine test_cdp(error) call loadtxt(outpath, d2) call check(error, all(shape(d2) == [3, 2])) if (allocated(error)) return - call check(error, all(abs(d-d2) < epsilon(1._dp))) + call check(error, all(d == d2)) if (allocated(error)) return e = cmplx(1, 1,kind=dp)* reshape([1, 2, 3, 4, 5, 6], [2, 3]) @@ -168,7 +168,7 @@ subroutine test_cdp(error) call loadtxt(outpath, d2) call check(error, all(shape(d2) == [2, 3])) if (allocated(error)) return - call check(error, all(abs(e-d2) < epsilon(1._dp))) + call check(error, all(e == d2)) if (allocated(error)) return end subroutine test_cdp diff --git a/src/tests/io/test_savetxt_qp.f90 b/src/tests/io/test_savetxt_qp.f90 index 91e27e407..4007d93d7 100644 --- a/src/tests/io/test_savetxt_qp.f90 +++ b/src/tests/io/test_savetxt_qp.f90 @@ -49,7 +49,7 @@ subroutine test_rqp(error) call loadtxt(outpath, d2) call check(error, all(shape(d2) == [3, 2])) if (allocated(error)) return - call check(error, all(abs(d-d2) < epsilon(1._qp))) + call check(error, all(d == d2)) if (allocated(error)) return e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) @@ -57,7 +57,7 @@ subroutine test_rqp(error) call loadtxt(outpath, d2) call check(error, all(shape(d2) == [2, 3])) if (allocated(error)) return - call check(error, all(abs(e-d2) < epsilon(1._qp))) + call check(error, all(e == d2)) if (allocated(error)) return end subroutine test_rqp From 693b885d0cdbd7ce9810e81455c7c31230994e1f Mon Sep 17 00:00:00 2001 From: milancurcic Date: Tue, 31 Aug 2021 22:05:27 -0400 Subject: [PATCH 30/34] Remove unused variable --- src/tests/io/test_open.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tests/io/test_open.f90 b/src/tests/io/test_open.f90 index 4d939e127..c7752a491 100644 --- a/src/tests/io/test_open.f90 +++ b/src/tests/io/test_open.f90 @@ -111,7 +111,7 @@ subroutine test_io_open_error_flag(error) !> Error handling type(error_type), allocatable, intent(out) :: error character(:), allocatable :: filename - integer :: ierr, u, a(3) + integer :: ierr, u filename = get_outpath() // "/io_open.stream" From 87d6dc369b7b4037ec38a3e30e6f9d51d3e7857b Mon Sep 17 00:00:00 2001 From: Milan Curcic Date: Fri, 3 Sep 2021 16:05:07 -0400 Subject: [PATCH 31/34] Port stdlib_io tests to test-drive * Port test_open.f90 to test-drive * Port test_parse_mode.f90 to test-drive * Port test_savetxt.f90 to test-drive * Port test_savetxt_qp.f90 to test-drive * Port test_loadtxt.f90 to test-drive * Add complex data test to test_loadtxt.f90 * Port test_loadtxt_qp.f90 to test-drive * Clean all test artifacts in Makefile.manual * Fix error handling in test_loadtxt * Don't reuse output file names between tests --- README.md | 6 +- src/tests/io/Makefile.manual | 12 +- src/tests/io/test_loadtxt.f90 | 164 ++++++++++----- src/tests/io/test_loadtxt_qp.f90 | 80 +++++-- src/tests/io/test_open.f90 | 256 +++++++++++++++-------- src/tests/io/test_parse_mode.f90 | 349 +++++++++++++++---------------- src/tests/io/test_savetxt.f90 | 282 ++++++++++++++++--------- src/tests/io/test_savetxt_qp.f90 | 158 +++++++++----- 8 files changed, 803 insertions(+), 504 deletions(-) diff --git a/README.md b/README.md index 951084001..f75a2e24b 100644 --- a/README.md +++ b/README.md @@ -125,7 +125,7 @@ You can pass additional options to CMake to customize the build. Important options are - `-G Ninja` to use the Ninja backend instead of the default Make backend. Other build backends are available with a similar syntax. -- `-DCMAKE_INSTALL_PREFIX` is used to provide the install location for the library. +- `-DCMAKE_INSTALL_PREFIX` is used to provide the install location for the library. If not provided the defaults will depend on your operating system, [see here](https://cmake.org/cmake/help/latest/variable/CMAKE_INSTALL_PREFIX.html). - `-DCMAKE_MAXIMUM_RANK` the maximum array rank procedures should be generated for. The default value is chosen as 4. The maximum is 15 for Fortran 2003 compliant compilers, otherwise 7 for compilers not supporting Fortran 2003 completely yet. @@ -170,7 +170,7 @@ Alternatively, you can build using provided Makefiles: make -f Makefile.manual ``` -You can limit the maximum rank by setting ``-DMAXRANK=`` in the ``FYPPFLAGS`` environment variable: +You can limit the maximum rank by setting ``-DMAXRANK=`` in the ``FYPPFLAGS`` environment variable (which can reduce the compilation time): ```sh make -f Makefile.manual FYPPFLAGS=-DMAXRANK=4 @@ -196,7 +196,7 @@ target_link_libraries( ``` To make the installed stdlib project discoverable add the stdlib directory to the ``CMAKE_PREFIX_PATH``. -The usual install localtion of the package files is ``$PREFIX/lib/cmake/fortran_stdlib``. +The usual install location of the package files is ``$PREFIX/lib/cmake/fortran_stdlib``. For non-CMake build systems (like make) you can use the exported pkg-config file by setting ``PKG_CONFIG_PATH`` to include the directory containing the exported pc-file. The usual install location of the pc-file is ``$PREFIX/lib/pkgconfig``. diff --git a/src/tests/io/Makefile.manual b/src/tests/io/Makefile.manual index 3bbce9db7..1ef48e034 100644 --- a/src/tests/io/Makefile.manual +++ b/src/tests/io/Makefile.manual @@ -1,11 +1,11 @@ PROGS_SRC = test_loadtxt.f90 \ - test_savetxt.f90 \ - test_loadtxt_qp.f90 \ - test_savetxt_qp.f90 \ - test_parse_mode.f90 \ - test_open.f90 + test_savetxt.f90 \ + test_loadtxt_qp.f90 \ + test_savetxt_qp.f90 \ + test_parse_mode.f90 \ + test_open.f90 -CLEAN_FILES = tmp.dat tmp_qp.dat io_open.dat io_open.stream +CLEAN_FILES = tmp*.dat array*_new.dat io_open.dat io_open.stream include ../Makefile.manual.test.mk diff --git a/src/tests/io/test_loadtxt.f90 b/src/tests/io/test_loadtxt.f90 index 9fe7b0853..bfaf589d7 100644 --- a/src/tests/io/test_loadtxt.f90 +++ b/src/tests/io/test_loadtxt.f90 @@ -1,63 +1,127 @@ -program test_loadtxt -use stdlib_kinds, only: int32, sp, dp -use stdlib_io, only: loadtxt -use stdlib_error, only: error_stop -implicit none +module test_loadtxt + use stdlib_kinds, only: int32, sp, dp + use stdlib_io, only: loadtxt, savetxt + use stdlib_test, only: new_unittest, unittest_type, error_type, check + implicit none -integer(int32), allocatable :: i(:, :) -real(sp), allocatable :: s(:, :) -real(dp), allocatable :: d(:, :) -complex(dp), allocatable :: z(:, :) + private + public :: collect_loadtxt +contains -call loadtxt("array1.dat", i) -call print_array(i) + !> Collect all exported unit tests + subroutine collect_loadtxt(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) -call loadtxt("array1.dat", s) -call print_array(s) + testsuite = [ & + new_unittest("loadtxt_int32", test_loadtxt_int32), & + new_unittest("loadtxt_sp", test_loadtxt_sp), & + new_unittest("loadtxt_dp", test_loadtxt_dp), & + new_unittest("loadtxt_complex", test_loadtxt_complex) & + ] -call loadtxt("array1.dat", d) -call print_array(d) + end subroutine collect_loadtxt -call loadtxt("array2.dat", d) -call print_array(d) -call loadtxt("array3.dat", d) -call print_array(d) + subroutine test_loadtxt_int32(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer(int32), allocatable :: input(:,:), expected(:,:) -call loadtxt("array4.dat", d) -call print_array(d) + call loadtxt("array1.dat", input) + call savetxt("array1_new.dat", input) + call loadtxt("array1_new.dat", expected) + call check(error, all(input == expected)) + if (allocated(error)) return -call loadtxt("array5.dat", z) -call print_array(z) + call loadtxt("array2.dat", input) + call savetxt("array2_new.dat", input) + call loadtxt("array2_new.dat", expected) + call check(error, all(input == expected)) + if (allocated(error)) return -contains + end subroutine test_loadtxt_int32 + + + subroutine test_loadtxt_sp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(sp), allocatable :: input(:,:), expected(:,:) + + call loadtxt("array3.dat", input) + call savetxt("array3_sp.dat", input) + call loadtxt("array3_sp.dat", expected) + call check(error, all(input == expected)) + if (allocated(error)) return + + call loadtxt("array4.dat", input) + call savetxt("array4_sp.dat", input) + call loadtxt("array4_sp.dat", expected) + call check(error, all(input == expected)) + if (allocated(error)) return + + end subroutine test_loadtxt_sp + + + subroutine test_loadtxt_dp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(dp), allocatable :: input(:,:), expected(:,:) + + call loadtxt("array3.dat", input) + call savetxt("array3_dp.dat", input) + call loadtxt("array3_dp.dat", expected) + call check(error, all(input == expected)) + if (allocated(error)) return + + call loadtxt("array4.dat", input) + call savetxt("array4_dp.dat", input) + call loadtxt("array4_dp.dat", expected) + call check(error, all(input == expected)) + if (allocated(error)) return + + end subroutine test_loadtxt_dp + + + subroutine test_loadtxt_complex(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + complex(dp), allocatable :: input(:,:), expected(:,:) + + call loadtxt("array5.dat", input) + call savetxt("array5_new.dat", input) + call loadtxt("array5_new.dat", expected) + call check(error, all(input == expected)) + if (allocated(error)) return + + end subroutine test_loadtxt_complex + +end module test_loadtxt + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_loadtxt, only : collect_loadtxt + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("loadtxt", collect_loadtxt) & + ] -subroutine print_array(a) -class(*),intent(in) :: a(:, :) -integer :: i -print *, "Array, shape=(", size(a, 1), ",", size(a, 2), ")" - - select type(a) - type is(integer(int32)) - do i = 1, size(a, 1) - print *, a(i, :) - end do - type is(real(sp)) - do i = 1, size(a, 1) - print *, a(i, :) - end do - type is(real(dp)) - do i = 1, size(a, 1) - print *, a(i, :) - end do - type is(complex(dp)) - do i = 1, size(a, 1) - print *, a(i, :) + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) end do - class default - call error_stop('The proposed type is not supported') - end select -end subroutine + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if -end program +end program tester diff --git a/src/tests/io/test_loadtxt_qp.f90 b/src/tests/io/test_loadtxt_qp.f90 index 6969b0727..2461a6016 100644 --- a/src/tests/io/test_loadtxt_qp.f90 +++ b/src/tests/io/test_loadtxt_qp.f90 @@ -1,30 +1,64 @@ -program test_loadtxt_qp -use stdlib_kinds, only: qp -use stdlib_io, only: loadtxt -implicit none +module test_loadtxt_qp + use stdlib_kinds, only: qp + use stdlib_io, only: loadtxt, savetxt + use stdlib_test, only: new_unittest, unittest_type, error_type, check + implicit none -real(qp), allocatable :: q(:, :) + private + public :: collect_loadtxt_qp +contains -call loadtxt("array4.dat", q) -call print_array(q) + !> Collect all exported unit tests + subroutine collect_loadtxt_qp(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) -contains + testsuite = [ & + new_unittest("loadtxt_qp", test_loadtxt_qp_) & + ] + + end subroutine collect_loadtxt_qp + + + subroutine test_loadtxt_qp_(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(qp), allocatable :: input(:,:), expected(:,:) + + call loadtxt("array4.dat", input) + call savetxt("array4_new.dat", input) + call loadtxt("array4_new.dat", expected) + call check(error, all(input == expected)) + if (allocated(error)) return + + end subroutine test_loadtxt_qp_ + +end module test_loadtxt_qp + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_loadtxt_qp, only : collect_loadtxt_qp + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 -subroutine print_array(a) -class(*),intent(in) :: a(:, :) -integer :: i -print *, "Array, shape=(", size(a, 1), ",", size(a, 2), ")" + testsuites = [ & + new_testsuite("loadtxt_qp", collect_loadtxt_qp) & + ] - select type(a) - type is(real(qp)) - do i = 1, size(a, 1) - print *, a(i, :) - end do - class default - write(*,'(a)')'The proposed type is not supported' - error stop - end select + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do -end subroutine + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if -end program +end program tester diff --git a/src/tests/io/test_open.f90 b/src/tests/io/test_open.f90 index c639c6119..4d939e127 100644 --- a/src/tests/io/test_open.f90 +++ b/src/tests/io/test_open.f90 @@ -1,99 +1,173 @@ -program test_open -use stdlib_io, only: open -use stdlib_error, only: check -implicit none +module test_open + use stdlib_io, only: open + use stdlib_test, only: new_unittest, unittest_type, error_type, check + implicit none -character(:), allocatable :: filename -integer :: io, u, a(3) - -! Text file -filename = get_outpath() // "/io_open.dat" - -! Test mode "w" -u = open(filename, "w") -write(u, *) 1, 2, 3 -close(u) - -! Test mode "r" -u = open(filename, "r") -read(u, *) a -call check(all(a == [1, 2, 3])) -close(u) - -! Test mode "a" -u = open(filename, "a") -write(u, *) 4, 5, 6 -close(u) -u = open(filename, "r") -read(u, *) a -call check(all(a == [1, 2, 3])) -read(u, *) a -call check(all(a == [4, 5, 6])) -close(u) - - - -! Stream file -filename = get_outpath() // "/io_open.stream" - -! Test mode "w" -u = open(filename, "wb") -write(u) 1, 2, 3 -close(u) - -! Test mode "r" -u = open(filename, "rb") -read(u) a -call check(all(a == [1, 2, 3])) -close(u) - -! Test mode "a" -u = open(filename, "ab") -write(u) 4, 5, 6 -close(u) -u = open(filename, "rb") -read(u) a -call check(all(a == [1, 2, 3])) -read(u) a -call check(all(a == [4, 5, 6])) -close(u) - - - -!0 and non-0 open -filename = get_outpath() // "/io_open.stream" - -u = open(filename, "rb", io) -call check(io == 0) -if (io == 0) close(u) - -u = open(filename, "ab", io) -call check(io == 0) -if (io == 0) close(u) - - -filename = get_outpath() // "/does_not_exist.error" - -u = open(filename, "a", io) -call check(io /= 0) + private + public :: collect_open +contains -u = open(filename, "r", io) -call check(io /= 0) + !> Collect all exported unit tests + subroutine collect_open(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + testsuite = [ & + new_unittest("io_read_write_text", test_io_read_write_text), & + new_unittest("io_read_write_stream", test_io_read_write_stream), & + new_unittest("io_open_error_flag", test_io_open_error_flag) & + ] -contains + end subroutine collect_open function get_outpath() result(outpath) - integer :: ierr - character(256) :: argv - character(:), allocatable :: outpath - - call get_command_argument(1, argv, status=ierr) - if (ierr==0) then - outpath = trim(argv) - else - outpath = '.' - endif + integer :: ierr + character(256) :: argv + character(:), allocatable :: outpath + + call get_command_argument(1, argv, status=ierr) + if (ierr == 0) then + outpath = trim(argv) + else + outpath = '.' + end if end function get_outpath -end program + + subroutine test_io_read_write_text(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + character(:), allocatable :: filename + integer :: u, a(3) + + ! Text file + filename = get_outpath() // "/io_open.dat" + + ! Test mode "w" + u = open(filename, "w") + write(u, *) 1, 2, 3 + close(u) + + ! Test mode "r" + u = open(filename, "r") + read(u, *) a + call check(error, all(a == [1, 2, 3])) + close(u) + if (allocated(error)) return + + ! Test mode "a" + u = open(filename, "a") + write(u, *) 4, 5, 6 + close(u) + u = open(filename, "r") + read(u, *) a + call check(error, all(a == [1, 2, 3])) + read(u, *) a + call check(error, all(a == [4, 5, 6])) + close(u) + if (allocated(error)) return + + end subroutine test_io_read_write_text + + + subroutine test_io_read_write_stream(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + character(:), allocatable :: filename + integer :: u, a(3) + + ! Stream file + filename = get_outpath() // "/io_open.stream" + + ! Test mode "w" + u = open(filename, "wb") + write(u) 1, 2, 3 + close(u) + + ! Test mode "r" + u = open(filename, "rb") + read(u) a + call check(error, all(a == [1, 2, 3])) + close(u) + if (allocated(error)) return + + ! Test mode "a" + u = open(filename, "ab") + write(u) 4, 5, 6 + close(u) + u = open(filename, "rb") + read(u) a + call check(error, all(a == [1, 2, 3])) + read(u) a + if (allocated(error)) return + call check(error, all(a == [4, 5, 6])) + close(u) + if (allocated(error)) return + + end subroutine test_io_read_write_stream + + + subroutine test_io_open_error_flag(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + character(:), allocatable :: filename + integer :: ierr, u, a(3) + + filename = get_outpath() // "/io_open.stream" + + ! Write to file first to ensure that it exists + u = open(filename, "wb") + write(u) 1, 2, 3 + close(u) + + u = open(filename, "rb", ierr) + call check(error, ierr == 0) + if (ierr == 0) close(u) + if (allocated(error)) return + + u = open(filename, "ab", ierr) + call check(error, ierr == 0) + if (ierr == 0) close(u) + if (allocated(error)) return + + filename = get_outpath() // "/does_not_exist.error" + + u = open(filename, "a", ierr) + call check(error, ierr /= 0) + if (allocated(error)) return + + u = open(filename, "r", ierr) + call check(error, ierr /= 0) + if (allocated(error)) return + + end subroutine test_io_open_error_flag + +end module test_open + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_open, only : collect_open + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("open", collect_open) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if + +end program tester \ No newline at end of file diff --git a/src/tests/io/test_parse_mode.f90 b/src/tests/io/test_parse_mode.f90 index a94d96de4..9de3301f4 100644 --- a/src/tests/io/test_parse_mode.f90 +++ b/src/tests/io/test_parse_mode.f90 @@ -1,187 +1,174 @@ -program test_parse_mode -use stdlib_io, only: parse_mode -use stdlib_error, only: check -implicit none +module test_parse_mode + use stdlib_ascii, only: reverse + use stdlib_io, only: parse_mode + use stdlib_test, only: new_unittest, unittest_type, error_type, check + implicit none + + private + public :: collect_parse_mode + + character(3), parameter :: parse_modes_input(*) = [ & + " ", & + "r ", "w ", "a ", "x ", & + "rt ", "wt ", "at ", "xt ", & + "rb ", "wb ", "ab ", "xb ", & + "r+ ", "w+ ", "a+ ", "x+ ", & + "r+t", "w+t", "a+t", "x+t", & + "r+b", "w+b", "a+b", "x+b" & + ] + + character(3), parameter :: parse_modes_expected(*) = [ & + "r t", & + "r t", "w t", "a t", "x t", & + "r t", "w t", "a t", "x t", & + "r b", "w b", "a b", "x b", & + "r+t", "w+t", "a+t", "x+t", & + "r+t", "w+t", "a+t", "x+t", & + "r+b", "w+b", "a+b", "x+b" & + ] -call test_parse_mode_expected_order() +contains -call test_parse_mode_reverse_order() + !> Collect all exported unit tests + subroutine collect_parse_mode(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) -call test_parse_mode_random_order() + testsuite = [ & + new_unittest("parse_mode_expected_order", test_parse_mode_expected_order), & + new_unittest("parse_mode_reverse_order", test_parse_mode_reverse_order), & + new_unittest("parse_mode_random_order", test_parse_mode_random_order) & + !FIXME Is it possible to run tests with error stop? + !new_unittest("parse_mode_always_fail", test_parse_mode_always_fail) & + ] -!call test_parse_mode_always_fail() + end subroutine collect_parse_mode -contains - subroutine test_parse_mode_expected_order() - character(3) :: m - m = parse_mode("") - call check(m == "r t") - - m = parse_mode("r") - call check(m == "r t") - m = parse_mode("w") - call check(m == "w t") - m = parse_mode("a") - call check(m == "a t") - m = parse_mode("x") - call check(m == "x t") - - m = parse_mode("rt") - call check(m == "r t") - m = parse_mode("wt") - call check(m == "w t") - m = parse_mode("at") - call check(m == "a t") - m = parse_mode("xt") - call check(m == "x t") - - m = parse_mode("rb") - call check(m == "r b") - m = parse_mode("wb") - call check(m == "w b") - m = parse_mode("ab") - call check(m == "a b") - m = parse_mode("xb") - call check(m == "x b") - - m = parse_mode("r+") - call check(m == "r+t") - m = parse_mode("w+") - call check(m == "w+t") - m = parse_mode("a+") - call check(m == "a+t") - m = parse_mode("x+") - call check(m == "x+t") - - m = parse_mode("r+t") - call check(m == "r+t") - m = parse_mode("w+t") - call check(m == "w+t") - m = parse_mode("a+t") - call check(m == "a+t") - m = parse_mode("x+t") - call check(m == "x+t") - - m = parse_mode("r+b") - call check(m == "r+b") - m = parse_mode("w+b") - call check(m == "w+b") - m = parse_mode("a+b") - call check(m == "a+b") - m = parse_mode("x+b") - call check(m == "x+b") - - end subroutine - - subroutine test_parse_mode_reverse_order() - character(3) :: m - m = parse_mode("") - call check(m == "r t") - - m = parse_mode("tr") - call check(m == "r t") - m = parse_mode("tw") - call check(m == "w t") - m = parse_mode("ta") - call check(m == "a t") - m = parse_mode("tx") - call check(m == "x t") - - m = parse_mode("br") - call check(m == "r b") - m = parse_mode("bw") - call check(m == "w b") - m = parse_mode("ba") - call check(m == "a b") - m = parse_mode("bx") - call check(m == "x b") - - m = parse_mode("+r") - call check(m == "r+t") - m = parse_mode("+w") - call check(m == "w+t") - m = parse_mode("+a") - call check(m == "a+t") - m = parse_mode("+x") - call check(m == "x+t") - - m = parse_mode("t+r") - call check(m == "r+t") - m = parse_mode("t+w") - call check(m == "w+t") - m = parse_mode("t+a") - call check(m == "a+t") - m = parse_mode("t+x") - call check(m == "x+t") - - m = parse_mode("b+r") - call check(m == "r+b") - m = parse_mode("b+w") - call check(m == "w+b") - m = parse_mode("b+a") - call check(m == "a+b") - m = parse_mode("x+b") - call check(m == "x+b") - - end subroutine - - subroutine test_parse_mode_random_order() - character(3) :: m - m = parse_mode("") - call check(m == "r t") - - m = parse_mode("t r") - call check(m == "r t") - m = parse_mode(" tw ") - call check(m == "w t") - m = parse_mode("ta ") - call check(m == "a t") - m = parse_mode(" t x ") - call check(m == "x t") - - m = parse_mode("+ r ") - call check(m == "r+t") - m = parse_mode("w +") - call check(m == "w+t") - m = parse_mode(" a+") - call check(m == "a+t") - m = parse_mode(" x+ t ") - call check(m == "x+t") - - m = parse_mode("tr+ ") - call check(m == "r+t") - m = parse_mode("wt + ") - call check(m == "w+t") - m = parse_mode("a + t") - call check(m == "a+t") - m = parse_mode(" xt + ") - call check(m == "x+t") - - m = parse_mode(" + t") - call check(m == "r+t") - m = parse_mode(" +w b") - call check(m == "w+b") - m = parse_mode("a + b") - call check(m == "a+b") - m = parse_mode(" b + x ") - call check(m == "x+b") - - end subroutine - - subroutine test_parse_mode_always_fail() - character(3) :: m - - m = parse_mode("r+w") - call check(m /= "r t") - - m = parse_mode("tt") - call check(m /= "r t") - - m = parse_mode("bt") - call check(m /= "r t") - - end subroutine - - -end program + subroutine test_parse_mode_expected_order(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer :: n + + do n = 1, size(parse_modes_input) + call check(error, parse_mode(trim(parse_modes_input(n))) == & + parse_modes_expected(n)) + if (allocated(error)) return + end do + + end subroutine test_parse_mode_expected_order + + + subroutine test_parse_mode_reverse_order(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: n + + do n = 1, size(parse_modes_input) + call check(error, & + parse_mode(trim(reverse(parse_modes_input(n)))) == & + parse_modes_expected(n)) + if (allocated(error)) return + end do + + end subroutine test_parse_mode_reverse_order + + + subroutine test_parse_mode_random_order(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, parse_mode("t r") == "r t") + if (allocated(error)) return + + call check(error, parse_mode(" tw ") == "w t") + if (allocated(error)) return + + call check(error, parse_mode("ta ") == "a t") + if (allocated(error)) return + + call check(error, parse_mode(" t x ") == "x t") + if (allocated(error)) return + + call check(error, parse_mode("+ r ") == "r+t") + if (allocated(error)) return + + call check(error, parse_mode("w +") == "w+t") + if (allocated(error)) return + + call check(error, parse_mode(" a+") == "a+t") + if (allocated(error)) return + + call check(error, parse_mode(" x+ t ") == "x+t") + if (allocated(error)) return + + call check(error, parse_mode("tr+ ") == "r+t") + if (allocated(error)) return + + call check(error, parse_mode("wt + ") == "w+t") + if (allocated(error)) return + + call check(error, parse_mode("a + t") == "a+t") + if (allocated(error)) return + + call check(error, parse_mode(" xt + ") == "x+t") + if (allocated(error)) return + + call check(error, parse_mode(" + t") == "r+t") + if (allocated(error)) return + + call check(error, parse_mode(" +w b") == "w+b") + if (allocated(error)) return + + call check(error, parse_mode("a + b") == "a+b") + if (allocated(error)) return + + call check(error, parse_mode(" b + x ") == "x+b") + if (allocated(error)) return + + end subroutine test_parse_mode_random_order + + + subroutine test_parse_mode_always_fail(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, parse_mode("r+w") /= "r t") + if (allocated(error)) return + call check(error, parse_mode("tt") /= "r t") + if (allocated(error)) return + call check(error, parse_mode("bt") /= "r t") + if (allocated(error)) return + + end subroutine test_parse_mode_always_fail + +end module test_parse_mode + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_parse_mode, only : collect_parse_mode + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("parse_mode", collect_parse_mode) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if + +end program tester \ No newline at end of file diff --git a/src/tests/io/test_savetxt.f90 b/src/tests/io/test_savetxt.f90 index b7e1ef1bb..bac672a0a 100644 --- a/src/tests/io/test_savetxt.f90 +++ b/src/tests/io/test_savetxt.f90 @@ -1,119 +1,203 @@ -program test_savetxt -use stdlib_kinds, only: int32, sp, dp -use stdlib_io, only: loadtxt, savetxt -use stdlib_error, only: check -implicit none +module test_savetxt + use stdlib_kinds, only: int32, sp, dp + use stdlib_io, only: loadtxt, savetxt + use stdlib_test, only: new_unittest, unittest_type, error_type, check + implicit none + + private + public :: collect_savetxt +contains -character(:), allocatable :: outpath + !> Collect all exported unit tests + subroutine collect_savetxt(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) -outpath = get_outpath() // "/tmp.dat" + testsuite = [ & + new_unittest("iint32", test_iint32), & + new_unittest("rsp", test_rsp), & + new_unittest("rdp", test_rdp), & + new_unittest("csp", test_csp), & + new_unittest("cdp", test_cdp) & + ] -call test_iint32(outpath) -call test_rsp(outpath) -call test_rdp(outpath) -call test_csp(outpath) -call test_cdp(outpath) + end subroutine collect_savetxt -contains function get_outpath() result(outpath) - integer :: ierr - character(256) :: argv - character(:), allocatable :: outpath - - call get_command_argument(1, argv, status=ierr) - if (ierr==0) then - outpath = trim(argv) - else - outpath = '.' - endif + integer :: ierr + character(256) :: argv + character(:), allocatable :: outpath + + call get_command_argument(1, argv, status=ierr) + if (ierr == 0) then + outpath = trim(argv) + else + outpath = '.' + end if end function get_outpath - subroutine test_iint32(outpath) - character(*), intent(in) :: outpath - integer(int32) :: d(3, 2), e(2, 3) - integer(int32), allocatable :: d2(:, :) - d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) - call savetxt(outpath, d) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [3, 2])) - call check(all(abs(d-d2) == 0)) - - e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) - call savetxt(outpath, e) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [2, 3])) - call check(all(abs(e-d2) == 0)) + + subroutine test_iint32(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + integer(int32) :: d(3, 2), e(2, 3) + integer(int32), allocatable :: d2(:, :) + character(:), allocatable :: outpath + + outpath = get_outpath() // "/tmp_test_iint32.dat" + + d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [3, 2])) + if (allocated(error)) return + call check(error, all(abs(d-d2) == 0)) + if (allocated(error)) return + + e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [2, 3])) + if (allocated(error)) return + call check(error, all(abs(e-d2) == 0)) + if (allocated(error)) return end subroutine - subroutine test_rsp(outpath) - character(*), intent(in) :: outpath - real(sp) :: d(3, 2), e(2, 3) - real(sp), allocatable :: d2(:, :) - d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) - call savetxt(outpath, d) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [3, 2])) - call check(all(abs(d-d2) < epsilon(1._sp))) - - e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) - call savetxt(outpath, e) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [2, 3])) - call check(all(abs(e-d2) < epsilon(1._sp))) + subroutine test_rsp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(sp) :: d(3, 2), e(2, 3) + real(sp), allocatable :: d2(:, :) + character(:), allocatable :: outpath + + outpath = get_outpath() // "/tmp_test_rsp.dat" + + d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [3, 2])) + if (allocated(error)) return + call check(error, all(abs(d-d2) < epsilon(1._sp))) + if (allocated(error)) return + + e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [2, 3])) + if (allocated(error)) return + call check(error, all(abs(e-d2) < epsilon(1._sp))) + if (allocated(error)) return end subroutine test_rsp - subroutine test_rdp(outpath) - character(*), intent(in) :: outpath - real(dp) :: d(3, 2), e(2, 3) - real(dp), allocatable :: d2(:, :) - d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) - call savetxt(outpath, d) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [3, 2])) - call check(all(abs(d-d2) < epsilon(1._dp))) - - e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) - call savetxt(outpath, e) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [2, 3])) - call check(all(abs(e-d2) < epsilon(1._dp))) + subroutine test_rdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(dp) :: d(3, 2), e(2, 3) + real(dp), allocatable :: d2(:, :) + character(:), allocatable :: outpath + + outpath = get_outpath() // "/tmp_test_rdp.dat" + + d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [3, 2])) + if (allocated(error)) return + call check(error, all(abs(d-d2) < epsilon(1._dp))) + if (allocated(error)) return + + e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [2, 3])) + if (allocated(error)) return + call check(error, all(abs(e-d2) < epsilon(1._dp))) + if (allocated(error)) return end subroutine test_rdp - subroutine test_csp(outpath) - character(*), intent(in) :: outpath - complex(sp) :: d(3, 2), e(2, 3) - complex(sp), allocatable :: d2(:, :) - d = cmplx(1, 1,kind=sp)* reshape([1, 2, 3, 4, 5, 6], [3, 2]) - call savetxt(outpath, d) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [3, 2])) - call check(all(abs(d-d2) < epsilon(1._sp))) - - e = cmplx(1, 1,kind=sp)* reshape([1, 2, 3, 4, 5, 6], [2, 3]) - call savetxt(outpath, e) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [2, 3])) - call check(all(abs(e-d2) < epsilon(1._sp))) + + subroutine test_csp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + complex(sp) :: d(3, 2), e(2, 3) + complex(sp), allocatable :: d2(:, :) + character(:), allocatable :: outpath + + outpath = get_outpath() // "/tmp_test_csp.dat" + + d = cmplx(1, 1,kind=sp)* reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [3, 2])) + if (allocated(error)) return + call check(error, all(abs(d-d2) < epsilon(1._sp))) + if (allocated(error)) return + + e = cmplx(1, 1,kind=sp)* reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [2, 3])) + if (allocated(error)) return + call check(error, all(abs(e-d2) < epsilon(1._sp))) + if (allocated(error)) return end subroutine test_csp - subroutine test_cdp(outpath) - character(*), intent(in) :: outpath - complex(dp) :: d(3, 2), e(2, 3) - complex(dp), allocatable :: d2(:, :) - d = cmplx(1._dp, 1._dp,kind=dp)* reshape([1, 2, 3, 4, 5, 6], [3, 2]) - call savetxt(outpath, d) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [3, 2])) - call check(all(abs(d-d2) < epsilon(1._dp))) - - e = cmplx(1, 1,kind=dp)* reshape([1, 2, 3, 4, 5, 6], [2, 3]) - call savetxt(outpath, e) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [2, 3])) - call check(all(abs(e-d2) < epsilon(1._dp))) + + subroutine test_cdp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + complex(dp) :: d(3, 2), e(2, 3) + complex(dp), allocatable :: d2(:, :) + character(:), allocatable :: outpath + + outpath = get_outpath() // "/tmp_test_cdp.dat" + + d = cmplx(1._dp, 1._dp,kind=dp)* reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [3, 2])) + if (allocated(error)) return + call check(error, all(abs(d-d2) < epsilon(1._dp))) + if (allocated(error)) return + + e = cmplx(1, 1,kind=dp)* reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [2, 3])) + if (allocated(error)) return + call check(error, all(abs(e-d2) < epsilon(1._dp))) + if (allocated(error)) return end subroutine test_cdp -end program test_savetxt +end module test_savetxt + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_savetxt, only : collect_savetxt + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("savetxt", collect_savetxt) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if + +end program tester diff --git a/src/tests/io/test_savetxt_qp.f90 b/src/tests/io/test_savetxt_qp.f90 index c60fefa5a..91e27e407 100644 --- a/src/tests/io/test_savetxt_qp.f90 +++ b/src/tests/io/test_savetxt_qp.f90 @@ -1,63 +1,119 @@ -program test_savetxt_qp -use stdlib_kinds, only: qp -use stdlib_io, only: loadtxt, savetxt -use stdlib_error, only: check -implicit none +module test_savetxt_qp + use stdlib_kinds, only: qp + use stdlib_io, only: loadtxt, savetxt + use stdlib_test, only: new_unittest, unittest_type, error_type, check + implicit none -character(:), allocatable :: outpath + private + public :: collect_savetxt_qp +contains -outpath = get_outpath() // "/tmp_qp.dat" + !> Collect all exported unit tests + subroutine collect_savetxt_qp(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) -call test_rqp(outpath) -call test_cqp(outpath) + testsuite = [ & + new_unittest("rqp", test_rqp), & + new_unittest("cqp", test_cqp) & + ] + + end subroutine collect_savetxt_qp -contains function get_outpath() result(outpath) - integer :: ierr - character(256) :: argv - character(:), allocatable :: outpath - - call get_command_argument(1, argv, status=ierr) - if (ierr==0) then - outpath = trim(argv) - else - outpath = '.' - endif + integer :: ierr + character(256) :: argv + character(:), allocatable :: outpath + + call get_command_argument(1, argv, status=ierr) + if (ierr == 0) then + outpath = trim(argv) + else + outpath = '.' + end if end function get_outpath - subroutine test_rqp(outpath) - character(*), intent(in) :: outpath - real(qp) :: d(3, 2), e(2, 3) - real(qp), allocatable :: d2(:, :) - d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) - call savetxt(outpath, d) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [3, 2])) - call check(all(abs(d-d2) < epsilon(1._qp))) - - e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) - call savetxt(outpath, e) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [2, 3])) - call check(all(abs(e-d2) < epsilon(1._qp))) + + subroutine test_rqp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(qp) :: d(3, 2), e(2, 3) + real(qp), allocatable :: d2(:, :) + character(:), allocatable :: outpath + + outpath = get_outpath() // "/tmp_test_rqp.dat" + + d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [3, 2])) + if (allocated(error)) return + call check(error, all(abs(d-d2) < epsilon(1._qp))) + if (allocated(error)) return + + e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [2, 3])) + if (allocated(error)) return + call check(error, all(abs(e-d2) < epsilon(1._qp))) + if (allocated(error)) return end subroutine test_rqp - subroutine test_cqp(outpath) - character(*), intent(in) :: outpath - complex(qp) :: d(3, 2), e(2, 3) - complex(qp), allocatable :: d2(:, :) - d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) - call savetxt(outpath, d) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [3, 2])) - call check(all(abs(d-d2) < epsilon(1._qp))) - - e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) - call savetxt(outpath, e) - call loadtxt(outpath, d2) - call check(all(shape(d2) == [2, 3])) - call check(all(abs(e-d2) < epsilon(1._qp))) + + subroutine test_cqp(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + complex(qp) :: d(3, 2), e(2, 3) + complex(qp), allocatable :: d2(:, :) + character(:), allocatable :: outpath + + outpath = get_outpath() // "/tmp_test_cqp.dat" + + d = reshape([1, 2, 3, 4, 5, 6], [3, 2]) + call savetxt(outpath, d) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [3, 2])) + if (allocated(error)) return + call check(error, all(abs(d-d2) < epsilon(1._qp))) + if (allocated(error)) return + + e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) + call savetxt(outpath, e) + call loadtxt(outpath, d2) + call check(error, all(shape(d2) == [2, 3])) + if (allocated(error)) return + call check(error, all(abs(e-d2) < epsilon(1._qp))) + if (allocated(error)) return end subroutine test_cqp -end program test_savetxt_qp +end module test_savetxt_qp + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type + use test_savetxt_qp, only : collect_savetxt_qp + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("savetxt_qp", collect_savetxt_qp) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if + +end program tester From 843a7ccba73701a570662264d557fc6a2bb4b905 Mon Sep 17 00:00:00 2001 From: milancurcic Date: Sat, 4 Sep 2021 14:21:05 -0400 Subject: [PATCH 32/34] Update edit descriptors for savetxt and loadtxt; Small fix in number_of_rows() to make ifort happy --- src/stdlib_io.fypp | 38 +++++++++++++------------------------- 1 file changed, 13 insertions(+), 25 deletions(-) diff --git a/src/stdlib_io.fypp b/src/stdlib_io.fypp index db07d259f..e451b7c4d 100644 --- a/src/stdlib_io.fypp +++ b/src/stdlib_io.fypp @@ -22,12 +22,12 @@ module stdlib_io ! Format strings with edit descriptors for each type and kind character(*), parameter :: & FMT_INT = '(*(i0,1x))', & - FMT_REAL_SP = '(*(es15.8,1x))', & - FMT_REAL_DP = '(*(es23.16,1x))', & - FMT_REAL_QP = '(*(es42.35,1x))', & - FMT_COMPLEX_SP = '(*(es15.8,1x,es15.8))', & - FMT_COMPLEX_DP = '(*(es23.16,1x,es23.16))', & - FMT_COMPLEX_QP = '(*(es42.35,1x,es42.35))' + FMT_REAL_SP = '(*(es15.8e2,1x))', & + FMT_REAL_DP = '(*(es24.16e3,1x))', & + FMT_REAL_QP = '(*(es44.35e4,1x))', & + FMT_COMPLEX_SP = '(*(es15.8e2,1x,es15.8e2))', & + FMT_COMPLEX_DP = '(*(es24.16e3,1x,es24.16e3))', & + FMT_COMPLEX_QP = '(*(es44.35e4,1x,es44.35e4))' interface loadtxt !! version: experimental @@ -93,7 +93,7 @@ contains #:endif ! determine number or rows - nrow = number_of_rows_numeric(s) + nrow = number_of_rows(s) allocate(d(nrow, ncol)) do i = 1, nrow @@ -174,36 +174,24 @@ contains end function number_of_columns - integer function number_of_rows_numeric(s) result(nrows) + integer function number_of_rows(s) result(nrows) !! version: experimental !! - !! determine number or rows - integer,intent(in)::s + !! Determine the number or rows in a file + integer, intent(in)::s integer :: ios - real :: r - complex :: z - rewind(s) nrows = 0 do - read(s, *, iostat=ios) r + read(s, *, iostat=ios) if (ios /= 0) exit nrows = nrows + 1 end do rewind(s) - ! If there are no rows of real numbers, it may be that they are complex - if( nrows == 0) then - do - read(s, *, iostat=ios) z - if (ios /= 0) exit - nrows = nrows + 1 - end do - rewind(s) - end if - end function number_of_rows_numeric + end function number_of_rows integer function open(filename, mode, iostat) result(u) @@ -341,4 +329,4 @@ contains end function parse_mode -end module +end module stdlib_io From e026dc45cfd813e05214783e3ebc45e75dd7cb02 Mon Sep 17 00:00:00 2001 From: milancurcic Date: Sat, 4 Sep 2021 14:23:26 -0400 Subject: [PATCH 33/34] Tests loadtxt with tiny and huge numbers --- src/tests/io/test_loadtxt.f90 | 98 ++++++++++++++++++++++++++++++-- src/tests/io/test_loadtxt_qp.f90 | 47 ++++++++++++++- 2 files changed, 140 insertions(+), 5 deletions(-) diff --git a/src/tests/io/test_loadtxt.f90 b/src/tests/io/test_loadtxt.f90 index f44686f61..88805fae5 100644 --- a/src/tests/io/test_loadtxt.f90 +++ b/src/tests/io/test_loadtxt.f90 @@ -16,7 +16,11 @@ subroutine collect_loadtxt(testsuite) testsuite = [ & new_unittest("loadtxt_int32", test_loadtxt_int32), & new_unittest("loadtxt_sp", test_loadtxt_sp), & + new_unittest("loadtxt_sp_huge", test_loadtxt_sp_huge), & + new_unittest("loadtxt_sp_tiny", test_loadtxt_sp_tiny), & new_unittest("loadtxt_dp", test_loadtxt_dp), & + new_unittest("loadtxt_dp_huge", test_loadtxt_dp_huge), & + new_unittest("loadtxt_dp_tiny", test_loadtxt_dp_tiny), & new_unittest("loadtxt_complex", test_loadtxt_complex) & ] @@ -34,7 +38,7 @@ subroutine test_loadtxt_int32(error) allocate(input(10,10)) allocate(expected(10,10)) - do n = 1, 100 + do n = 1, 10 call random_number(harvest) input = int(harvest * 100) call savetxt('test_int32.txt', input) @@ -55,8 +59,9 @@ subroutine test_loadtxt_sp(error) allocate(input(10,10)) allocate(expected(10,10)) - do n = 1, 100 + do n = 1, 10 call random_number(input) + input = input - 0.5 call savetxt('test_sp.txt', input) call loadtxt('test_sp.txt', expected) call check(error, all(input == expected)) @@ -66,6 +71,48 @@ subroutine test_loadtxt_sp(error) end subroutine test_loadtxt_sp + subroutine test_loadtxt_sp_huge(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(sp), allocatable :: input(:,:), expected(:,:) + integer :: n + + allocate(input(10,10)) + allocate(expected(10,10)) + + do n = 1, 10 + call random_number(input) + input = (input - 0.5) * huge(input) + call savetxt('test_sp_huge.txt', input) + call loadtxt('test_sp_huge.txt', expected) + call check(error, all(input == expected)) + if (allocated(error)) return + end do + + end subroutine test_loadtxt_sp_huge + + + subroutine test_loadtxt_sp_tiny(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(sp), allocatable :: input(:,:), expected(:,:) + integer :: n + + allocate(input(10,10)) + allocate(expected(10,10)) + + do n = 1, 10 + call random_number(input) + input = (input - 0.5) * tiny(input) + call savetxt('test_sp_tiny.txt', input) + call loadtxt('test_sp_tiny.txt', expected) + call check(error, all(input == expected)) + if (allocated(error)) return + end do + + end subroutine test_loadtxt_sp_tiny + + subroutine test_loadtxt_dp(error) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -75,8 +122,9 @@ subroutine test_loadtxt_dp(error) allocate(input(10,10)) allocate(expected(10,10)) - do n = 1, 100 + do n = 1, 10 call random_number(input) + input = input - 0.5 call savetxt('test_dp.txt', input) call loadtxt('test_dp.txt', expected) call check(error, all(input == expected)) @@ -86,6 +134,48 @@ subroutine test_loadtxt_dp(error) end subroutine test_loadtxt_dp + subroutine test_loadtxt_dp_huge(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(dp), allocatable :: input(:,:), expected(:,:) + integer :: n + + allocate(input(10,10)) + allocate(expected(10,10)) + + do n = 1, 10 + call random_number(input) + input = (input - 0.5) * huge(input) + call savetxt('test_dp_huge.txt', input) + call loadtxt('test_dp_huge.txt', expected) + call check(error, all(input == expected)) + if (allocated(error)) return + end do + + end subroutine test_loadtxt_dp_huge + + + subroutine test_loadtxt_dp_tiny(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(dp), allocatable :: input(:,:), expected(:,:) + integer :: n + + allocate(input(10,10)) + allocate(expected(10,10)) + + do n = 1, 10 + call random_number(input) + input = (input - 0.5) * tiny(input) + call savetxt('test_dp_tiny.txt', input) + call loadtxt('test_dp_tiny.txt', expected) + call check(error, all(input == expected)) + if (allocated(error)) return + end do + + end subroutine test_loadtxt_dp_tiny + + subroutine test_loadtxt_complex(error) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -98,7 +188,7 @@ subroutine test_loadtxt_complex(error) allocate(input(10,10)) allocate(expected(10,10)) - do n = 1, 100 + do n = 1, 10 call random_number(re) call random_number(im) input = cmplx(re, im) diff --git a/src/tests/io/test_loadtxt_qp.f90 b/src/tests/io/test_loadtxt_qp.f90 index 3436e15a0..478149529 100644 --- a/src/tests/io/test_loadtxt_qp.f90 +++ b/src/tests/io/test_loadtxt_qp.f90 @@ -14,7 +14,9 @@ subroutine collect_loadtxt_qp(testsuite) type(unittest_type), allocatable, intent(out) :: testsuite(:) testsuite = [ & - new_unittest("loadtxt_qp", test_loadtxt_qp_) & + new_unittest("loadtxt_qp", test_loadtxt_qp_), & + new_unittest("loadtxt_qp_huge", test_loadtxt_qp_huge), & + new_unittest("loadtxt_qp_tiny", test_loadtxt_qp_tiny) & ] end subroutine collect_loadtxt_qp @@ -31,6 +33,7 @@ subroutine test_loadtxt_qp_(error) do n = 1, 100 call random_number(input) + input = input - 0.5 call savetxt('test_qp.txt', input) call loadtxt('test_qp.txt', expected) call check(error, all(input == expected)) @@ -39,6 +42,48 @@ subroutine test_loadtxt_qp_(error) end subroutine test_loadtxt_qp_ + + subroutine test_loadtxt_qp_huge(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(qp), allocatable :: input(:,:), expected(:,:) + integer :: n + + allocate(input(10,10)) + allocate(expected(10,10)) + + do n = 1, 10 + call random_number(input) + input = (input - 0.5) * huge(input) + call savetxt('test_qp_huge.txt', input) + call loadtxt('test_qp_huge.txt', expected) + call check(error, all(input == expected)) + if (allocated(error)) return + end do + + end subroutine test_loadtxt_qp_huge + + + subroutine test_loadtxt_qp_tiny(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(qp), allocatable :: input(:,:), expected(:,:) + integer :: n + + allocate(input(10,10)) + allocate(expected(10,10)) + + do n = 1, 10 + call random_number(input) + input = (input - 0.5) * tiny(input) + call savetxt('test_qp_tiny.txt', input) + call loadtxt('test_qp_tiny.txt', expected) + call check(error, all(input == expected)) + if (allocated(error)) return + end do + + end subroutine test_loadtxt_qp_tiny + end module test_loadtxt_qp From 18b0cd2fcfe9f3f6d07e8e2ef730a09ed9c6690f Mon Sep 17 00:00:00 2001 From: milancurcic Date: Sat, 4 Sep 2021 14:56:45 -0400 Subject: [PATCH 34/34] Compare arrays exactly in test_savetxt_qp.f90 --- src/tests/io/test_savetxt_qp.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tests/io/test_savetxt_qp.f90 b/src/tests/io/test_savetxt_qp.f90 index 4007d93d7..ac1c03ca6 100644 --- a/src/tests/io/test_savetxt_qp.f90 +++ b/src/tests/io/test_savetxt_qp.f90 @@ -76,7 +76,7 @@ subroutine test_cqp(error) call loadtxt(outpath, d2) call check(error, all(shape(d2) == [3, 2])) if (allocated(error)) return - call check(error, all(abs(d-d2) < epsilon(1._qp))) + call check(error, all(d == d2)) if (allocated(error)) return e = reshape([1, 2, 3, 4, 5, 6], [2, 3]) @@ -84,7 +84,7 @@ subroutine test_cqp(error) call loadtxt(outpath, d2) call check(error, all(shape(d2) == [2, 3])) if (allocated(error)) return - call check(error, all(abs(e-d2) < epsilon(1._qp))) + call check(error, all(e == d2)) if (allocated(error)) return end subroutine test_cqp