diff --git a/src/caffeine/assert/assert_m.F90 b/src/caffeine/assert/assert_m.F90 deleted file mode 100644 index efd36200..00000000 --- a/src/caffeine/assert/assert_m.F90 +++ /dev/null @@ -1,47 +0,0 @@ -! -! (c) 2019-2020 Guide Star Engineering, LLC -! This Software was developed for the US Nuclear Regulatory Commission (US NRC) under contract -! "Multi-Dimensional Physics Implementation into Fuel Analysis under Steady-state and Transients (FAST)", -! contract # NRC-HQ-60-17-C-0007 -! -module caffeine_assert_m - !! summary: Utility for runtime checking of logical assertions. - !! usage: error-terminate if the assertion fails: - !! - !! use assertions_m, only : assert - !! call assert( 2 > 1, "2 > 1") - !! - !! Turn off assertions in production code by setting USE_ASSERTIONS to .false. via the preprocessor. - !! This file's capitalized .F90 extension causes most Fortran compilers to preprocess this file so - !! that building as follows turns off assertion enforcement: - !! - !! fpm build --flag "-DUSE_ASSERTIONS=.false." - !! - !! Doing so may eliminate any associated runtime overhead by enabling optimizing compilers to ignore - !! the assertion procedure body during a dead-code-removal phase of optimization. - implicit none - private - public :: assert - -#ifndef USE_ASSERTIONS -# define USE_ASSERTIONS .true. -#endif - logical, parameter :: enforce_assertions=USE_ASSERTIONS - !! Turn off assertions as follows: fpm build --flag "-DUSE_ASSERTIONS=.false." - - interface - - module subroutine assert(assertion, description, diagnostic_data) - !! If assertion is .false., error-terminate with a character stop code that contains diagnostic_data if present - implicit none - logical, intent(in) :: assertion - !! Most assertions will be expressions such as i>0 - character(len=*), intent(in) :: description - !! A brief statement of what is being asserted such as "i>0" or "positive i" - class(*), intent(in), optional :: diagnostic_data - !! Data to include in an error ouptput: may be of an intrinsic type or a type that extends characterizable_t - end subroutine - - end interface - -end module diff --git a/src/caffeine/assert/assert_s.f90 b/src/caffeine/assert/assert_s.f90 deleted file mode 100644 index 5585e556..00000000 --- a/src/caffeine/assert/assert_s.f90 +++ /dev/null @@ -1,90 +0,0 @@ -! -! (c) 2019-2020 Guide Star Engineering, LLC -! This Software was developed for the US Nuclear Regulatory Commission (US NRC) under contract -! "Multi-Dimensional Physics Implementation into Fuel Analysis under Steady-state and Transients (FAST)", -! contract # NRC-HQ-60-17-C-0007 -! -submodule(caffeine_assert_m) caffeine_assert_s - use iso_c_binding, only: c_bool - implicit none - -contains - - module procedure assert - use caffeine_characterizable_m, only : characterizable_t - use prif, only: prif_error_stop, this_image => prif_this_image - - character(len=:), allocatable :: header, trailer - integer :: me - - toggle_assertions: & - if (enforce_assertions) then - - check_assertion: & - if (.not. assertion) then - - call this_image(image_index=me) - header = 'Assertion "' // description // '" failed on image ' // string(me) - - represent_diagnostics_as_string: & - if (.not. present(diagnostic_data)) then - - trailer = "(none provided)" - - else - - select type(diagnostic_data) - type is(character(len=*)) - trailer = diagnostic_data - type is(complex) - trailer = string(diagnostic_data) - type is(integer) - trailer = string(diagnostic_data) - type is(logical) - trailer = string(diagnostic_data) - type is(real) - trailer = string(diagnostic_data) - class is(characterizable_t) - trailer = diagnostic_data%as_character() - class default - trailer = "of unsupported type." - end select - - end if represent_diagnostics_as_string - - call prif_error_stop(.false._c_bool, stop_code_char=header // ' with diagnostic data "' // trailer // '"') - - end if check_assertion - - end if toggle_assertions - - contains - - pure function string(numeric) result(number_as_string) - !! Result is a string represention of the numeric argument - class(*), intent(in) :: numeric - integer, parameter :: max_len=128 - character(len=max_len) :: untrimmed_string - character(len=:), allocatable :: number_as_string - - select type(numeric) - type is(complex) - write(untrimmed_string, *) numeric - type is(integer) - write(untrimmed_string, *) numeric - type is(logical) - write(untrimmed_string, *) numeric - type is(real) - write(untrimmed_string, *) numeric - class default - call prif_error_stop(.false._c_bool, & - stop_code_char="Internal error in subroutine 'assert': unsupported type in function 'string'.") - end select - - number_as_string = trim(adjustl(untrimmed_string)) - - end function string - - end procedure - -end submodule diff --git a/src/caffeine/assert/characterizable_m.f90 b/src/caffeine/assert/characterizable_m.f90 deleted file mode 100644 index 66018a61..00000000 --- a/src/caffeine/assert/characterizable_m.f90 +++ /dev/null @@ -1,24 +0,0 @@ -module caffeine_characterizable_m - !! Define an abstract class that supports object representation in character form - implicit none - - private - public :: characterizable_t - - type, abstract :: characterizable_t - contains - procedure(as_character_i), deferred :: as_character - end type - - abstract interface - - pure function as_character_i(self) result(character_self) - import characterizable_t - implicit none - class(characterizable_t), intent(in) :: self - character(len=:), allocatable :: character_self - end function - - end interface - -end module diff --git a/src/caffeine/assert/intrinsic_array_m.F90 b/src/caffeine/assert/intrinsic_array_m.F90 deleted file mode 100644 index df6c2f43..00000000 --- a/src/caffeine/assert/intrinsic_array_m.F90 +++ /dev/null @@ -1,58 +0,0 @@ -module caffeine_intrinsic_array_m - !! Define an abstract class that supports object representation in character form - use caffeine_characterizable_m, only : characterizable_t - implicit none - - private - public :: intrinsic_array_t - - type, extends(characterizable_t) :: intrinsic_array_t - complex, allocatable :: complex_1D(:) - complex(kind(1.D0)), allocatable :: complex_double_1D(:) - integer, allocatable :: integer_1D(:) - logical, allocatable :: logical_1D(:) - real, allocatable :: real_1D(:) - double precision, allocatable :: double_precision_1D(:) - - complex, allocatable :: complex_2D(:,:) - complex(kind(1.D0)), allocatable :: complex_double_2D(:,:) - integer, allocatable :: integer_2D(:,:) - logical, allocatable :: logical_2D(:,:) - real, allocatable :: real_2D(:,:) - double precision, allocatable :: double_precision_2D(:,:) - - complex, allocatable :: complex_3D(:,:,:) - complex(kind(1.D0)), allocatable :: complex_double_3D(:,:,:) - integer, allocatable :: integer_3D(:,:,:) - logical, allocatable :: logical_3D(:,:,:) - real, allocatable :: real_3D(:,:,:) - double precision, allocatable :: double_precision_3D(:,:,:) - contains - procedure :: as_character - end type - - interface intrinsic_array_t - - pure module function construct(array) result(intrinsic_array) - implicit none -#ifndef NAGFOR - class(*), intent(in) :: array(..) -#else - class(*), intent(in) :: array(:) -#endif - type(intrinsic_array_t) intrinsic_array - end function - - end interface - - interface - - pure module function as_character(self) result(character_self) - implicit none - class(intrinsic_array_t), intent(in) :: self - character(len=:), allocatable :: character_self - end function - - end interface - -end module diff --git a/src/caffeine/assert/intrinsic_array_s.F90 b/src/caffeine/assert/intrinsic_array_s.F90 deleted file mode 100644 index 3ddc4409..00000000 --- a/src/caffeine/assert/intrinsic_array_s.F90 +++ /dev/null @@ -1,140 +0,0 @@ -submodule(caffeine_intrinsic_array_m) caffeine_intrinsic_array_s - use iso_c_binding, only: c_bool - use prif, only: prif_error_stop - implicit none - -contains - - module procedure construct - -#ifndef NAGFOR - select rank(array) - rank(1) -#endif - select type(array) - type is(complex) - intrinsic_array%complex_1D = array - type is(integer) - intrinsic_array%integer_1D = array - type is(logical) - intrinsic_array%logical_1D = array - type is(real) - intrinsic_array%real_1D = array - type is(double precision) - intrinsic_array%double_precision_1D = array - class default - call prif_error_stop(.false._c_bool, stop_code_char="intrinsic_array_t construct: unsupported rank-2 type") - end select -#ifndef NAGFOR - rank(2) - select type(array) - type is(complex) - intrinsic_array%complex_2D = array - type is(integer) - intrinsic_array%integer_2D = array - type is(logical) - intrinsic_array%logical_2D = array - type is(real) - intrinsic_array%real_2D = array - type is(double precision) - intrinsic_array%double_precision_2D = array - class default - call prif_error_stop(.false._c_bool, stop_code_char="intrinsic_array_t construct: unsupported rank-2 type") - end select - - rank(3) - select type(array) - type is(complex) - intrinsic_array%complex_3D = array - type is(integer) - intrinsic_array%integer_3D = array - type is(logical) - intrinsic_array%logical_3D = array - type is(real) - intrinsic_array%real_3D = array - type is(double precision) - intrinsic_array%double_precision_3D = array - class default - call prif_error_stop(.false._c_bool, stop_code_char="intrinsic_array_t construct: unsupported rank-3 type") - end select - - rank default - call prif_error_stop(.false._c_bool, stop_code_char="intrinsic_array_t construct: unsupported rank") - end select -#endif - - end procedure - - module procedure as_character - integer, parameter :: single_number_width=32 - - if (1 /= count( & - [ allocated(self%complex_1D), allocated(self%complex_double_1D), allocated(self%integer_1D), & - allocated(self%logical_1D), allocated(self%real_1D), & - allocated(self%complex_2D), allocated(self%complex_double_2D), allocated(self%integer_2D), & - allocated(self%logical_2D), allocated(self%real_2D), & - allocated(self%complex_3D), allocated(self%complex_double_3D), allocated(self%integer_3D), & - allocated(self%logical_3D), allocated(self%real_3D) & - ])) call prif_error_stop(.false._c_bool, & - stop_code_char="intrinsic_array_t as_character: ambiguous component allocation status.") - - if (allocated(self%complex_1D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%complex_1D)) - write(character_self, *) self%complex_1D - else if (allocated(self%complex_double_1D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_1D)) - write(character_self, *) self%complex_double_1D - else if (allocated(self%integer_1D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%integer_1D)) - write(character_self, *) self%integer_1D - else if (allocated(self%logical_1D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%logical_1D)) - write(character_self, *) self%logical_1D - else if (allocated(self%real_1D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%real_1D)) - write(character_self, *) self%real_1D - else if (allocated(self%double_precision_1D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_1D)) - write(character_self, *) self%double_precision_1D - else if (allocated(self%complex_2D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%complex_2D)) - write(character_self, *) self%complex_2D - else if (allocated(self%complex_double_2D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_2D)) - write(character_self, *) self%complex_double_2D - else if (allocated(self%integer_2D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%integer_2D)) - write(character_self, *) self%integer_2D - else if (allocated(self%logical_2D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%logical_1D)) - write(character_self, *) self%logical_2D - else if (allocated(self%real_2D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%real_2D)) - write(character_self, *) self%real_2D - else if (allocated(self%double_precision_2D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_2D)) - write(character_self, *) self%double_precision_2D - else if (allocated(self%complex_3D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%complex_3D)) - write(character_self, *) self%complex_3D - else if (allocated(self%complex_double_3D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_3D)) - write(character_self, *) self%complex_double_3D - else if (allocated(self%integer_3D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%integer_3D)) - write(character_self, *) self%integer_3D - else if (allocated(self%logical_3D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%logical_1D)) - write(character_self, *) self%logical_3D - else if (allocated(self%real_3D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%real_3D)) - write(character_self, *) self%real_3D - else if (allocated(self%double_precision_3D)) then - character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_3D)) - write(character_self, *) self%double_precision_3D - end if - - character_self = trim(adjustl(character_self)) - end procedure - -end submodule diff --git a/src/caffeine/caffeine_assert_s.F90 b/src/caffeine/caffeine_assert_s.F90 new file mode 100644 index 00000000..a0383977 --- /dev/null +++ b/src/caffeine/caffeine_assert_s.F90 @@ -0,0 +1,38 @@ +! Copyright (c), The Regents of the University of California +! Terms of use are as specified in LICENSE.txt +submodule(prif:prif_private_s) caffeine_assert_s + implicit none + +#if CAF_ASSERTIONS || !defined(CAF_ASSERTIONS) + logical, parameter :: assertions_=.true. +#else + logical, parameter :: assertions_=.false. +#endif + + !! Disable assertions by compiling with preprocessor setting: -DCAF_ASSERTIONS=0 + +contains + + module procedure assert + character(len=:), allocatable :: tail + + if (assertions_) then + if (.not. assertion) then + if (.not. present(diagnostics)) then + tail = "." + else + tail = " with diagnostics " + select type(diagnostics) + type is(character(len=*)) + tail = tail // diagnostics + class default + tail = tail // "of unsupported type." + end select + end if + + call prif_error_stop(.false._c_bool, stop_code_char='Assertion "'// description // '" failed' // tail) + end if + end if + end procedure + +end submodule caffeine_assert_s diff --git a/src/caffeine/collective_subroutines/co_max_s.f90 b/src/caffeine/collective_subroutines/co_max_s.f90 index 22aa2f54..ed8d52d3 100644 --- a/src/caffeine/collective_subroutines/co_max_s.f90 +++ b/src/caffeine/collective_subroutines/co_max_s.f90 @@ -4,7 +4,6 @@ use iso_c_binding, only : c_null_char, c_f_pointer, c_funloc, c_null_ptr use utilities_m, only : get_c_ptr, get_c_ptr_character, optional_value use caffeine_h_m, only : caf_co_max, caf_same_cfi_type, caf_numeric_type, caf_is_f_string - use caffeine_assert_m, only : assert implicit none diff --git a/src/caffeine/collective_subroutines/co_min_s.f90 b/src/caffeine/collective_subroutines/co_min_s.f90 index d7973770..8fea20e9 100644 --- a/src/caffeine/collective_subroutines/co_min_s.f90 +++ b/src/caffeine/collective_subroutines/co_min_s.f90 @@ -4,7 +4,6 @@ use iso_c_binding, only : c_null_char, c_f_pointer, c_funloc, c_null_ptr use utilities_m, only : get_c_ptr, get_c_ptr_character, optional_value use caffeine_h_m, only : caf_co_min, caf_same_cfi_type, caf_numeric_type, caf_is_f_string - use caffeine_assert_m, only : assert implicit none diff --git a/src/caffeine/collective_subroutines/co_reduce_s.f90 b/src/caffeine/collective_subroutines/co_reduce_s.f90 index 092888e9..46776a11 100644 --- a/src/caffeine/collective_subroutines/co_reduce_s.f90 +++ b/src/caffeine/collective_subroutines/co_reduce_s.f90 @@ -4,8 +4,6 @@ use iso_c_binding, only : & c_loc, c_null_ptr, c_funloc, c_associated, c_f_pointer, c_f_procpointer, c_char, c_int64_t, c_double, & c_float, c_int32_t - use caffeine_assert_m, only : assert - use caffeine_intrinsic_array_m, only : intrinsic_array_t use utilities_m, only : get_c_ptr, get_c_ptr_character, optional_value use caffeine_h_m, only : caf_co_reduce, caf_same_cfi_type, caf_elem_len, caf_is_f_string @@ -272,7 +270,7 @@ subroutine Coll_ReduceSub_c_char(arg1, arg2_and_out, count, cdata) bind(C) integer(c_int), pointer :: arglen=>null() associate(c_associated_args => [c_associated(arg1), c_associated(arg2_and_out), c_associated(cdata)]) - call assert(all(c_associated_args), "Coll_ReduceSub_c_char: all(c_associated_args)", intrinsic_array_t(c_associated_args)) + call assert(all(c_associated_args), "Coll_ReduceSub_c_char: all(c_associated_args)") end associate call c_f_pointer(cdata, arglen) diff --git a/src/caffeine/prif_private_s.f90 b/src/caffeine/prif_private_s.f90 index 13bfc809..cafde16e 100644 --- a/src/caffeine/prif_private_s.f90 +++ b/src/caffeine/prif_private_s.f90 @@ -7,6 +7,17 @@ type(prif_team_type), pointer :: current_team => null() type(c_ptr) :: non_symmetric_heap_mspace + interface + + pure module subroutine assert(assertion, description, diagnostics) + implicit none + logical, intent(in) :: assertion + character(len=*), intent(in) :: description + class(*), intent(in), optional :: diagnostics + end subroutine + + end interface + contains subroutine unimplemented(proc_name) diff --git a/src/caffeine/prif_queries_s.f90 b/src/caffeine/prif_queries_s.f90 index e385ed67..e3a75b8c 100644 --- a/src/caffeine/prif_queries_s.f90 +++ b/src/caffeine/prif_queries_s.f90 @@ -1,7 +1,6 @@ ! Copyright (c), The Regents of the University of California ! Terms of use are as specified in LICENSE.txt submodule(prif:prif_private_s) prif_queries_s - use caffeine_assert_m, only: assert use caffeine_h_m, only: caf_convert_base_addr implicit none diff --git a/test/caf_co_reduce_test.f90 b/test/caf_co_reduce_test.f90 index 31909d5f..19360655 100644 --- a/test/caf_co_reduce_test.f90 +++ b/test/caf_co_reduce_test.f90 @@ -1,7 +1,6 @@ module caf_co_reduce_test - use prif, only : prif_co_reduce, prif_num_images, prif_this_image + use prif, only : prif_co_reduce, prif_num_images, prif_this_image, prif_error_stop use veggies, only : result_t, test_item_t, assert_equals, describe, it, assert_that, assert_equals - use caffeine_assert_m, only : assert use iso_c_binding, only : c_bool, c_funloc, c_char, c_double, c_int64_t implicit none @@ -49,7 +48,11 @@ function alphabetically_1st_size1_string_array() result(result_) function alphabetize(lhs, rhs) result(first_alphabetically) character(len=*), intent(in) :: lhs, rhs character(len=:), allocatable :: first_alphabetically - call assert(len(lhs)==len(rhs), "co_reduce_s alphabetize: LHS/RHS length match", lhs//" , "//rhs) + + if (len(lhs).ne.len(rhs)) then + call prif_error_stop(quiet=.false._c_bool, & + stop_code_char="co_reduce_s alphabetize: LHS(" // lhs // ")/RHS(" // rhs // ") length don't match") + end if first_alphabetically = min(lhs,rhs) end function