From f4cb506bae82e48bd8b000560e29d73a33b716ef Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Fri, 27 Dec 2024 21:28:03 -0600 Subject: [PATCH 01/29] test(main): switch to julienne Test coverage: * prif_init * prif_allocate, prif_deallocate, prif_allocate_coarray, prif_deallocate_coarray * prif_co_broadcast, prif_co_max, prif_co_min, prif_co_sum, prif_co_reduce * prif_image_index, prif_num_images, prif_this_image_no_coarray * prif_put, prif_get * prif_sync_all * prif_team_type, prif_form_team, prif_change_team, prif_end_team --- test/a00_caffeinate_test.f90 | 42 ----- test/caf_allocate_test.f90 | 78 -------- test/caf_co_broadcast_test.f90 | 68 ------- test/caf_co_max_test.f90 | 145 --------------- test/caf_co_min_test.f90 | 147 --------------- test/caf_co_reduce_test.f90 | 249 ------------------------- test/caf_co_sum_test.f90 | 150 --------------- test/caf_coarray_inquiry_test.f90 | 52 ------ test/caf_error_stop_test.f90 | 76 -------- test/caf_image_index_test.f90 | 98 ---------- test/caf_num_images_test.f90 | 27 --- test/caf_rma_test.f90 | 229 ----------------------- test/caf_stop_test.f90 | 74 -------- test/caf_teams_test.f90 | 65 ------- test/caf_this_image_test.f90 | 33 ---- test/main.f90 | 174 +++++++++-------- test/prif_allocate_test_m.F90 | 157 ++++++++++++++++ test/prif_co_broadcast_test_m.F90 | 106 +++++++++++ test/prif_co_max_test_m.F90 | 210 +++++++++++++++++++++ test/prif_co_min_test_m.F90 | 210 +++++++++++++++++++++ test/prif_co_reduce_test_m.F90 | 299 ++++++++++++++++++++++++++++++ test/prif_co_sum_test_m.F90 | 202 ++++++++++++++++++++ test/prif_image_index_m.F90 | 143 ++++++++++++++ test/prif_init_test_m.F90 | 79 ++++++++ test/prif_num_images_test_m.F90 | 63 +++++++ test/prif_rma_test_m.F90 | 273 +++++++++++++++++++++++++++ test/prif_teams_test_m.F90 | 90 +++++++++ test/prif_this_image_test_m.F90 | 68 +++++++ 28 files changed, 1996 insertions(+), 1611 deletions(-) delete mode 100644 test/a00_caffeinate_test.f90 delete mode 100644 test/caf_allocate_test.f90 delete mode 100644 test/caf_co_broadcast_test.f90 delete mode 100644 test/caf_co_max_test.f90 delete mode 100644 test/caf_co_min_test.f90 delete mode 100644 test/caf_co_reduce_test.f90 delete mode 100644 test/caf_co_sum_test.f90 delete mode 100644 test/caf_coarray_inquiry_test.f90 delete mode 100644 test/caf_error_stop_test.f90 delete mode 100644 test/caf_image_index_test.f90 delete mode 100644 test/caf_num_images_test.f90 delete mode 100644 test/caf_rma_test.f90 delete mode 100644 test/caf_stop_test.f90 delete mode 100644 test/caf_teams_test.f90 delete mode 100644 test/caf_this_image_test.f90 create mode 100644 test/prif_allocate_test_m.F90 create mode 100644 test/prif_co_broadcast_test_m.F90 create mode 100644 test/prif_co_max_test_m.F90 create mode 100644 test/prif_co_min_test_m.F90 create mode 100644 test/prif_co_reduce_test_m.F90 create mode 100644 test/prif_co_sum_test_m.F90 create mode 100644 test/prif_image_index_m.F90 create mode 100644 test/prif_init_test_m.F90 create mode 100644 test/prif_num_images_test_m.F90 create mode 100644 test/prif_rma_test_m.F90 create mode 100644 test/prif_teams_test_m.F90 create mode 100644 test/prif_this_image_test_m.F90 diff --git a/test/a00_caffeinate_test.f90 b/test/a00_caffeinate_test.f90 deleted file mode 100644 index 45a83cd2b..000000000 --- a/test/a00_caffeinate_test.f90 +++ /dev/null @@ -1,42 +0,0 @@ -module a00_caffeinate_test - use prif, only : prif_init, PRIF_STAT_ALREADY_INIT - use veggies, only: test_item_t, describe, result_t, it, assert_that - - implicit none - private - public :: test_caffeinate - -contains - - function test_caffeinate() result(tests) - type(test_item_t) :: tests - - tests = describe( & - "A caffeinated beverage", & - [ it("is served: the prif_init() function completes successfully.", check_caffeination) & - , it("a subsequent prif_init call returns PRIF_STAT_ALREADY_INIT", & - check_subsequent_prif_init_call) & - ]) - end function - - function check_caffeination() result(result_) - type(result_t) :: result_ - - integer, parameter :: successful_initiation = 0 - integer :: init_exit_code - - call prif_init(init_exit_code) - result_ = assert_that(init_exit_code == successful_initiation) - end function - - function check_subsequent_prif_init_call() result(result_) - type(result_t) :: result_ - - integer :: stat - - call prif_init(stat) - call prif_init(stat) - result_ = assert_that(stat == PRIF_STAT_ALREADY_INIT) - end function - -end module a00_caffeinate_test diff --git a/test/caf_allocate_test.f90 b/test/caf_allocate_test.f90 deleted file mode 100644 index fa1a178c5..000000000 --- a/test/caf_allocate_test.f90 +++ /dev/null @@ -1,78 +0,0 @@ -module caf_allocate_test - use prif, only : & - prif_allocate_coarray, prif_deallocate_coarray, & - prif_allocate, prif_deallocate, & - prif_coarray_handle, prif_num_images - use veggies, only: result_t, test_item_t, assert_that, assert_equals, describe, it - use iso_c_binding, only: & - c_ptr, c_int, c_int64_t, c_size_t, c_funptr, c_null_funptr, & - c_f_pointer, c_null_ptr, c_loc, c_sizeof - - implicit none - private - public :: test_prif_allocate - -contains - function test_prif_allocate() result(tests) - type(test_item_t) :: tests - - tests = & - describe( & - "PRIF allocation can", & - [ it("allocate, use and deallocate an integer scalar coarray with a corank of 1", & - check_allocate_integer_scalar_coarray_with_corank1) & - , it("allocate, use and deallocate memory non-symmetrically", & - check_allocate_non_symmetric) & - ]) - end function - - function check_allocate_integer_scalar_coarray_with_corank1() result(result_) - type(result_t) :: result_ - - ! Allocate memory for an integer scalar single corank coarray, such as the following decl - ! integer :: coarr[*] - - integer(kind=c_int64_t), dimension(1) :: lcobounds, ucobounds - integer :: dummy_element, num_imgs - type(prif_coarray_handle) :: coarray_handle - type(c_ptr) :: allocated_memory - integer, pointer :: local_slice - - call prif_num_images(num_images=num_imgs) - lcobounds(1) = 1 - ucobounds(1) = num_imgs - - allocated_memory = c_null_ptr - local_slice => null() - result_ = assert_that(.not.associated(local_slice)) - - call prif_allocate_coarray( & - lcobounds, ucobounds, int(storage_size(dummy_element)/8, c_size_t), c_null_funptr, & - coarray_handle, allocated_memory) - - call c_f_pointer(allocated_memory, local_slice) - result_ = result_ .and. assert_that(associated(local_slice)) - - local_slice = 42 - result_ = result_ .and. assert_equals(42, local_slice) - - call prif_deallocate_coarray([coarray_handle]) - - end function - - function check_allocate_non_symmetric() result(result_) - type(result_t) :: result_ - - type(c_ptr) :: allocated_memory - integer(c_int), pointer :: local_slice - - call prif_allocate(sizeof(local_slice), allocated_memory) - call c_f_pointer(allocated_memory, local_slice) - - local_slice = 42 - result_ = assert_equals(42, local_slice) - - call prif_deallocate(c_loc(local_slice)) - end function - -end module caf_allocate_test diff --git a/test/caf_co_broadcast_test.f90 b/test/caf_co_broadcast_test.f90 deleted file mode 100644 index d7e6f7935..000000000 --- a/test/caf_co_broadcast_test.f90 +++ /dev/null @@ -1,68 +0,0 @@ -module caf_co_broadcast_test - use prif, only : prif_co_broadcast, prif_num_images, prif_this_image_no_coarray - use veggies, only : result_t, test_item_t, describe, it, assert_equals, assert_that - - implicit none - private - public :: test_prif_co_broadcast - - type object_t - integer i - logical fallacy - character(len=len("fooey")) actor - complex issues - end type - - interface operator(==) - module procedure equals - end interface - -contains - - function test_prif_co_broadcast() result(tests) - type(test_item_t) tests - - tests = describe( & - "The prif_co_broadcast subroutine", & - [ it("broadcasts a default integer scalar with no optional arguments present", broadcast_default_integer_scalar) & - ,it("broadcasts a derived type scalar with no allocatable components", broadcast_derived_type) & - ]) - end function - - logical pure function equals(lhs, rhs) - type(object_t), intent(in) :: lhs, rhs - equals = all([ & - lhs%i == rhs%i & - ,lhs%fallacy .eqv. rhs%fallacy & - ,lhs%actor == rhs%actor & - ,lhs%issues == rhs%issues & - ]) - end function - - function broadcast_default_integer_scalar() result(result_) - type(result_t) result_ - integer iPhone, me - integer, parameter :: source_value = 7779311, junk = -99 - - call prif_this_image_no_coarray(this_image=me) - iPhone = merge(source_value, junk, me==1) - call prif_co_broadcast(iPhone, source_image=1) - result_ = assert_equals(source_value, iPhone) - end function - - function broadcast_derived_type() result(result_) - type(result_t) result_ - type(object_t) object - integer :: me, ni - - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(num_images=ni) - object = object_t(me, .false., "gooey", me*(1.,0.)) - call prif_co_broadcast(object, source_image=ni) - associate(expected_object => object_t(ni, .false., "gooey", ni*(1.,0.))) - result_ = assert_that(expected_object == object, "co_broadcast derived type") - end associate - - end function - -end module caf_co_broadcast_test diff --git a/test/caf_co_max_test.f90 b/test/caf_co_max_test.f90 deleted file mode 100644 index 0d1a7c7f8..000000000 --- a/test/caf_co_max_test.f90 +++ /dev/null @@ -1,145 +0,0 @@ -module caf_co_max_test - use prif, only : prif_co_max, prif_this_image_no_coarray, prif_num_images - use veggies, only: result_t, test_item_t, assert_equals, describe, it, assert_that, assert_equals - - implicit none - private - public :: test_prif_co_max - -contains - function test_prif_co_max() result(tests) - type(test_item_t) tests - - tests = describe( & - "The prif_co_max subroutine computes the maximum", & - [ it("default integer scalar with stat argument present", max_default_integer_scalars) & - ,it("integer(c_int64_t) scalar with no optional arguments present", max_c_int64_scalars) & - ,it("default integer 1D array elements with no optional arguments present", max_default_integer_1D_array) & - ,it("default integer 7D array elements with stat argument present", max_default_integer_7D_array) & - ,it("default real scalars with stat argument present", max_default_real_scalars) & - ,it("double precision 2D array elements with no optional arguments present", max_double_precision_2D_array) & - ,it("reverse-alphabetizes length-5 default character scalars with no optional arguments", & - reverse_alphabetize_default_character_scalars) & - ,it("elements across images with 2D arrays of strings", max_elements_in_2D_string_arrays) & - ]) - end function - - function max_default_integer_scalars() result(result_) - type(result_t) result_ - integer i, status_, me - - status_ = -1 - call prif_this_image_no_coarray(this_image=me) - i = -me - call prif_co_max(i, stat=status_) - result_ = assert_equals(-1, i) .and. assert_equals(0, status_) - end function - - function max_c_int64_scalars() result(result_) - use iso_c_binding, only : c_int64_t - type(result_t) result_ - integer(c_int64_t) i - integer :: me, num_imgs - - call prif_this_image_no_coarray(this_image=me) - i = me - call prif_co_max(i) - call prif_num_images(num_images=num_imgs) - result_ = assert_equals(num_imgs, int(i)) - end function - - function max_default_integer_1D_array() result(result_) - type(result_t) result_ - integer i, me, num_imgs - integer, allocatable :: array(:) - - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(num_images=num_imgs) - associate(sequence_ => me*[(i, i=1, num_imgs)]) - array = sequence_ - call prif_co_max(array) - associate(max_sequence => num_imgs*[(i, i=1, num_imgs)]) - result_ = assert_that(all(max_sequence == array)) - end associate - end associate - end function - - function max_default_integer_7D_array() result(result_) - type(result_t) result_ - integer array(2,1,1, 1,1,1, 2), status_, me, num_imgs - - status_ = -1 - call prif_this_image_no_coarray(this_image=me) - array = 3 + me - call prif_co_max(array, stat=status_) - call prif_num_images(num_images=num_imgs) - result_ = assert_that(all(array == 3+num_imgs)) .and. assert_equals(0, status_) - end function - - function max_default_real_scalars() result(result_) - type(result_t) result_ - real scalar - real, parameter :: pi = 3.141592654 - integer status_, me - - status_ = -1 - call prif_this_image_no_coarray(this_image=me) - scalar = -pi*me - call prif_co_max(scalar, stat=status_) - result_ = assert_equals(-dble(pi), dble(scalar) ) .and. assert_equals(0, status_) - end function - - function max_double_precision_2D_array() result(result_) - type(result_t) result_ - double precision, allocatable :: array(:,:) - double precision, parameter :: tent(*,*) = dble(reshape(-[0,1,2,3,2,1], [3,2])) - integer :: me - - call prif_this_image_no_coarray(this_image=me) - array = tent*dble(me) - call prif_co_max(array) - result_ = assert_that(all(array==tent)) - end function - - function max_elements_in_2D_string_arrays() result(result_) - type(result_t) result_ - character(len=*), parameter :: script(*,*,*) = reshape( & - [ "To be ","or not " & ! images with odd image - , "to ","be. " & ! numbers get this slice - ! ---------------------- - , "that ","is " & ! images with even image - , "the ","question"], & ! numbers get this slice - [2,2,2]) - character(len=len(script)), dimension(size(script,1),size(script,2)) :: slice - integer me, ni - - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) - associate(slice_number => mod(me-1,size(script,3)) + 1) - slice = script(:,:,slice_number) - end associate - call prif_co_max(slice) - associate(expected => maxval(script(:,:,1:min(ni,size(script,3))), dim=3)) - result_ = assert_that(all(expected == slice),"all(expected == scramlet)") - end associate - end function - - function reverse_alphabetize_default_character_scalars() result(result_) - type(result_t) result_ - integer, parameter :: length = len("loddy") - character(len=*), parameter :: words(*) = [character(len=length):: "loddy","doddy","we","like","to","party"] - character(len=len(words)) :: my_word, expected_word - integer :: me, num_imgs - - call prif_this_image_no_coarray(this_image=me) - associate(periodic_index => 1 + mod(me-1,size(words))) - my_word = words(periodic_index) - call prif_co_max(my_word) - end associate - - call prif_num_images(num_imgs) - expected_word = maxval(words(1:min(num_imgs, size(words))), dim=1) - result_ = assert_equals(expected_word, my_word) - end function - -end module caf_co_max_test diff --git a/test/caf_co_min_test.f90 b/test/caf_co_min_test.f90 deleted file mode 100644 index 3e2fa87bf..000000000 --- a/test/caf_co_min_test.f90 +++ /dev/null @@ -1,147 +0,0 @@ -module caf_co_min_test - use prif, only : prif_co_min, prif_num_images, prif_this_image_no_coarray, prif_num_images - use veggies, only: result_t, test_item_t, assert_equals, describe, it, assert_that, assert_equals, succeed - - implicit none - private - public :: test_prif_co_min - -contains - function test_prif_co_min() result(tests) - type(test_item_t) tests - - tests = describe( & - "The prif_co_min subroutine computes the minimum", & - [ it("default integer scalar with stat argument present", min_default_integer_scalars) & - ,it("integer(c_int64_t) scalar with no optional arguments present", min_c_int64_scalars) & - ,it("default integer 1D array elements with no optional arguments present", min_default_integer_1D_array) & - ,it("default integer 7D array elements with stat argument present", min_default_integer_7D_array) & - ,it("default real scalars with stat argument present", min_default_real_scalars) & - ,it("double precision 2D array elements with no optional arguments present", min_double_precision_2D_array) & - ,it("length-5 string with no optional arguments", & - alphabetically_1st_scalar_string) & - ,it("elements across images with 2D arrays of strings", min_elements_in_2D_string_arrays) & - ]) - end function - - function min_default_integer_scalars() result(result_) - type(result_t) result_ - integer i, status_, me, num_imgs - - status_ = -1 - call prif_this_image_no_coarray(this_image=me) - i = -me - call prif_co_min(i, stat=status_) - call prif_num_images(num_images=num_imgs) - result_ = assert_equals(-num_imgs, i) .and. assert_equals(0, status_) - end function - - function min_c_int64_scalars() result(result_) - use iso_c_binding, only : c_int64_t - type(result_t) result_ - integer(c_int64_t) i - integer :: me - - call prif_this_image_no_coarray(this_image=me) - i = me - call prif_co_min(i) - result_ = assert_equals(1, int(i)) - end function - - function min_default_integer_1D_array() result(result_) - type(result_t) result_ - integer i, me, num_imgs - integer, allocatable :: array(:) - - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(num_images=num_imgs) - associate(sequence_ => me*[(i, i=1, num_imgs)]) - array = sequence_ - call prif_co_min(array) - associate(min_sequence => [(i, i=1, num_imgs)]) - result_ = assert_that(all(min_sequence == array)) - end associate - end associate - end function - - function min_default_integer_7D_array() result(result_) - type(result_t) result_ - integer array(2,1,1, 1,1,1, 2), status_, me, num_imgs - - status_ = -1 - call prif_this_image_no_coarray(this_image=me) - array = 3 - me - call prif_co_min(array, stat=status_) - call prif_num_images(num_images=num_imgs) - result_ = assert_that(all(array == 3 - num_imgs)) .and. assert_equals(0, status_) - end function - - function min_default_real_scalars() result(result_) - type(result_t) result_ - real scalar - real, parameter :: pi = 3.141592654 - integer status_, me, num_imgs - - status_ = -1 - call prif_this_image_no_coarray(this_image=me) - scalar = -pi*me - call prif_co_min(scalar, stat=status_) - call prif_num_images(num_images=num_imgs) - result_ = assert_equals(-dble(pi*num_imgs), dble(scalar) ) .and. assert_equals(0, status_) - end function - - function min_double_precision_2D_array() result(result_) - type(result_t) result_ - double precision, allocatable :: array(:,:) - double precision, parameter :: tent(*,*) = dble(reshape(-[0,1,2,3,2,1], [3,2])) - integer :: me, num_imgs - - call prif_this_image_no_coarray(this_image=me) - array = tent*dble(me) - call prif_co_min(array) - call prif_num_images(num_images=num_imgs) - result_ = assert_that(all(array==tent*num_imgs)) - end function - - function min_elements_in_2D_string_arrays() result(result_) - type(result_t) result_ - character(len=*), parameter :: script(*,*,*) = reshape( & - [ "To be ","or not " & ! images with odd image - , "to ","be. " & ! numbers get this slice - ! ---------------------- - , "that ","is " & ! images with even image - , "the ","question"], & ! numbers get this slice - [2,2,2]) - character(len=len(script)), dimension(size(script,1),size(script,2)) :: slice - integer me, ni - - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) - associate(slice_number => mod(me-1,size(script,3)) + 1) - slice = script(:,:,slice_number) - end associate - call prif_co_min(slice) - associate(expected => minval(script(:,:,1:min(ni,size(script,3))), dim=3)) - result_ = assert_that(all(expected == slice),"all(expected == scramlet)") - end associate - end function - - function alphabetically_1st_scalar_string() result(result_) - type(result_t) result_ - integer, parameter :: length = len("to party!") - character(len=length), parameter :: words(*) = [character(len=length):: "Loddy","doddy","we","like","to party!"] - character(len=length) :: my_word, expected_word - integer :: me, num_imgs - - call prif_this_image_no_coarray(this_image=me) - associate(periodic_index => 1 + mod(me-1,size(words))) - my_word = words(periodic_index) - call prif_co_min(my_word) - end associate - - call prif_num_images(num_images=num_imgs) - expected_word = minval(words(1:min(num_imgs, size(words))), dim=1) - result_ = assert_equals(expected_word, my_word) - end function - -end module caf_co_min_test diff --git a/test/caf_co_reduce_test.f90 b/test/caf_co_reduce_test.f90 deleted file mode 100644 index 45ee2de1d..000000000 --- a/test/caf_co_reduce_test.f90 +++ /dev/null @@ -1,249 +0,0 @@ -module caf_co_reduce_test - use prif, only : prif_co_reduce, prif_num_images, prif_this_image_no_coarray, prif_error_stop - use veggies, only : result_t, test_item_t, assert_equals, describe, it, assert_that, assert_equals - use iso_c_binding, only : c_bool, c_funloc, c_char, c_double, c_int64_t - - implicit none - private - public :: test_prif_co_reduce - -contains - - function test_prif_co_reduce() result(tests) - type(test_item_t) tests - - tests = describe( & - "The prif_co_reduce subroutine", & - [ it("finds the alphabetically first length-5 string with result_image present", alphabetically_1st_size1_string_array) & - ,it("sums default integer scalars with no optional arguments present", sum_default_integer_scalars) & - ,it("sums integer(c_int64_t) scalars with no optional arguments present", sum_c_int64_t_scalars) & - ,it("multiplies default real scalars with all optional arguments present", multiply_default_real_scalars) & - ,it("multiplies real(c_double) scalars with all optional arguments present", multiply_c_double_scalars) & - ,it("performs a collective .and. operation across logical scalars", reports_on_consensus) & - ,it("sums default complex scalars with a stat-variable present", sum_default_complex_scalars) & - ,it("sums complex(c_double) scalars with a stat-variable present", sum_complex_c_double_scalars) & - ,it("sums default integer elements of a 2D array across images", sum_integer_array_elements) & - ]) - end function - - function alphabetically_1st_size1_string_array() result(result_) - type(result_t) result_ - character(len=5, kind=c_char), parameter :: names(*) = ["larry","harry","carey","betty","tommy","billy"] - character(len=len(names), kind=c_char) :: my_name(1) - character(len=len(names)) :: expected_name - integer :: me, num_imgs - - call prif_this_image_no_coarray(this_image=me) - associate(periodic_index => 1 + mod(me-1,size(names))) - my_name(1) = names(periodic_index) - call prif_co_reduce(my_name, c_funloc(alphabetize)) - end associate - - call prif_num_images(num_images=num_imgs) - expected_name = minval(names(1:min(num_imgs, size(names))), dim=1) - result_ = assert_that(all(expected_name == my_name)) - - contains - - function alphabetize(lhs, rhs) result(first_alphabetically) - character(len=5), intent(in) :: lhs, rhs - character(len=5) :: first_alphabetically - - first_alphabetically = min(lhs,rhs) - end function - - end function - - function sum_integer_array_elements() result(result_) - type(result_t) result_ - integer status_, num_imgs - integer, parameter :: input_array(*,*) = reshape([1, 2, 3, 4], [2, 2]) - integer array(2,2) - - array = input_array - call prif_co_reduce(array, c_funloc(add_integers)) - call prif_num_images(num_images=num_imgs) - result_ = assert_that(all(num_imgs*input_array==array)) - - contains - - pure function add_integers(lhs, rhs) result(total) - integer, intent(in) :: lhs, rhs - integer total - total = lhs + rhs - end function - - end function - - function sum_complex_c_double_scalars() result(result_) - type(result_t) result_ - integer status_, num_imgs - complex(c_double) z - complex(c_double), parameter :: z_input=(1._c_double, 1._c_double) - - z = z_input - call prif_co_reduce(z, c_funloc(add_complex), stat=status_) - call prif_num_images(num_images=num_imgs) - result_ = assert_equals(real(num_imgs*z_input, c_double), real(z, c_double)) .and. assert_equals(0, status_) - - contains - - pure function add_complex(lhs, rhs) result(total) - complex(c_double), intent(in) :: lhs, rhs - complex(c_double) total - total = lhs + rhs - end function - - end function - - function sum_default_complex_scalars() result(result_) - type(result_t) result_ - integer status_, num_imgs - complex z - complex, parameter :: z_input=(1.,1.) - - z = z_input - call prif_co_reduce(z, c_funloc(add_complex), stat=status_) - call prif_num_images(num_images=num_imgs) - result_ = assert_equals(dble(num_imgs*z_input), dble(z)) .and. assert_equals(0, status_) - - contains - - pure function add_complex(lhs, rhs) result(total) - complex, intent(in) :: lhs, rhs - complex total - total = lhs + rhs - end function - - end function - - function sum_default_integer_scalars() result(result_) - type(result_t) result_ - integer i, num_imgs - - i = 1 - call prif_co_reduce(i, c_funloc(add)) - call prif_num_images(num_images=num_imgs) - result_ = assert_equals(num_imgs, i) - - contains - - pure function add(lhs, rhs) result(total) - integer, intent(in) :: lhs, rhs - integer total - total = lhs + rhs - end function - - end function - - function sum_c_int64_t_scalars() result(result_) - type(result_t) result_ - integer(c_int64_t) i - integer :: num_imgs - - i = 1_c_int64_t - call prif_co_reduce(i, c_funloc(add)) - call prif_num_images(num_images=num_imgs) - result_ = assert_that(int(num_imgs, c_int64_t)==i) - - contains - - pure function add(lhs, rhs) result(total) - integer(c_int64_t), intent(in) :: lhs, rhs - integer(c_int64_t) total - total = lhs + rhs - end function - - end function - - function reports_on_consensus() result(result_) - type(result_t) result_ - logical(c_bool) one_false, one_true, all_true - logical(c_bool), parameter :: c_true=.true._c_bool, c_false=.false._c_bool - logical ans1, ans2, ans3 - integer :: me, num_imgs - - call prif_this_image_no_coarray(this_image=me) - one_false = merge(c_false, c_true, me==1) - call prif_co_reduce(one_false, c_funloc(logical_and)) - - call prif_this_image_no_coarray(this_image=me) - one_true = merge(c_true, c_false, me==1) - call prif_co_reduce(one_true, c_funloc(logical_and)) - - all_true = c_true - call prif_co_reduce(all_true, c_funloc(logical_and)) - call prif_num_images(num_images=num_imgs) - - ans1 = one_false .eqv. c_false - ans2 = one_true .eqv. merge(c_true,c_false,num_imgs==1) - ans3 = all_true .eqv. c_true - result_ = assert_that(ans1) .and. & - assert_that(ans2) .and. & - assert_that(ans3) - contains - - pure function logical_and(lhs, rhs) result(lhs_and_rhs) - logical(c_bool), intent(in) :: lhs, rhs - logical(c_bool) lhs_and_rhs - lhs_and_rhs = lhs .and. rhs - end function - - end function - - function multiply_c_double_scalars() result(result_) - type(result_t) result_ - real(c_double) p - integer j, status_, me, num_imgs - character(len=:), allocatable :: error_message - - error_message = "unused" - call prif_this_image_no_coarray(this_image=me) - p = real(me,c_double) - call prif_co_reduce(p, c_funloc(multiply_doubles), result_image=1, stat=status_, errmsg=error_message) - call prif_num_images(num_images=num_imgs) - associate(expected_result => merge( product([(real(j,c_double), j = 1, num_imgs)]), real(me,c_double), me==1 )) - result_ = & - assert_equals(expected_result, real(p,c_double)) .and. & - assert_equals(0, status_) .and. & - assert_equals("unused", error_message) - end associate - - contains - - pure function multiply_doubles(lhs, rhs) result(product_) - real(c_double), intent(in) :: lhs, rhs - real(c_double) product_ - product_ = lhs * rhs - end function - - end function - - function multiply_default_real_scalars() result(result_) - type(result_t) result_ - real p - integer j, status_, me, num_imgs - character(len=:), allocatable :: error_message - - error_message = "unused" - call prif_this_image_no_coarray(this_image=me) - p = real(me) - call prif_co_reduce(p, c_funloc(multiply), result_image=1, stat=status_, errmsg=error_message) - call prif_num_images(num_images=num_imgs) - associate(expected_result => merge( product([(dble(j), j = 1, num_imgs)]), dble(me), me==1 )) - result_ = & - assert_equals(expected_result, dble(p)) .and. & - assert_equals(0, status_) .and. & - assert_equals("unused", error_message) - end associate - - contains - - pure function multiply(lhs, rhs) result(product_) - real, intent(in) :: lhs, rhs - real product_ - product_ = lhs * rhs - end function - - end function -end module caf_co_reduce_test diff --git a/test/caf_co_sum_test.f90 b/test/caf_co_sum_test.f90 deleted file mode 100644 index 7dee3ddf2..000000000 --- a/test/caf_co_sum_test.f90 +++ /dev/null @@ -1,150 +0,0 @@ -module caf_co_sum_test - use prif, only : prif_co_sum, prif_num_images, prif_this_image_no_coarray - use veggies, only: result_t, test_item_t, assert_equals, describe, it, assert_that, assert_equals, succeed - - implicit none - private - public :: test_prif_co_sum - -contains - function test_prif_co_sum() result(tests) - type(test_item_t) tests - - tests = describe( & - "The prif_co_sum subroutine", & - [ it("sums default integer scalars with no optional arguments present", sum_default_integer_scalars) & - ,it("sums default integer scalars with all arguments present", sum_integers_all_arguments) & - ,it("sums integer(c_int64_t) scalars with stat argument present", sum_c_int64_scalars) & - ,it("sums default integer 1D arrays with no optional arguments present", sum_default_integer_1D_array) & - ,it("sums default integer 15D arrays with stat argument present", sum_default_integer_15D_array) & - ,it("sums default real scalars with result_image argument present", sum_default_real_scalars) & - ,it("sums double precision 2D arrays with no optional arguments present", sum_double_precision_2D_array) & - ,it("sums default complex scalars with stat argument present", sum_default_complex_scalars) & - ,it("sums double precision 1D complex arrays with no optional arguments present", sum_dble_complex_1D_arrays) & - ]) - end function - - function sum_default_integer_scalars() result(result_) - type(result_t) result_ - integer i, num_imgs - - i = 1 - call prif_co_sum(i) - call prif_num_images(num_images=num_imgs) - result_ = assert_equals(num_imgs, i) - end function - - function sum_integers_all_arguments() result(result_) - type(result_t) result_ - integer i, status_, result_image_, me, num_imgs - character(len=*), parameter :: whitespace = repeat(" ", ncopies=29) - character(len=:), allocatable :: error_message - - i = 1 - result_image_ = 1 - status_ = -1 - error_message = whitespace - - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(num_images=num_imgs) - associate(expected_i => merge(num_imgs*i, i, me==result_image_)) - call prif_co_sum(i, result_image_, status_, error_message) - result_ = assert_equals(expected_i, i) .and. assert_equals(0, status_) .and. assert_equals(whitespace, error_message) - end associate - end function - - function sum_c_int64_scalars() result(result_) - use iso_c_binding, only : c_int64_t - type(result_t) result_ - integer(c_int64_t) i - integer i_default_kind, status_, num_imgs - - status_ = -1 - i = 2_c_int64_t - call prif_co_sum(i, stat=status_) - i_default_kind = i - call prif_num_images(num_images=num_imgs) - result_ = assert_equals(2*num_imgs, int(i)) .and. assert_equals(0, status_) - end function - - function sum_default_integer_1D_array() result(result_) - type(result_t) result_ - integer i, images - integer, allocatable :: array(:) - - call prif_num_images(num_images=images) - associate(sequence_ => [(i,i=1,images)]) - array = sequence_ - call prif_co_sum(array) - result_ = assert_that(all(array==images*sequence_)) - end associate - end function - - function sum_default_integer_15D_array() result(result_) - type(result_t) result_ - integer array(2,1,1, 1,1,1, 1,1,1, 1,1,1, 1,2,1) - integer status_, num_imgs - - status_ = -1 - array = 3 - call prif_co_sum(array, stat=status_) - call prif_num_images(num_images=num_imgs) - result_ = assert_that(all(3*num_imgs == array)) .and. assert_equals(0, status_) - end function - - function sum_default_real_scalars() result(result_) - type(result_t) result_ - real scalar - real, parameter :: e = 2.7182818459045 - integer result_image_, me, num_imgs - - result_image_ = 1 - scalar = e - call prif_co_sum(scalar, result_image=result_image_) - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(num_images=num_imgs) - associate(expected_result => merge(num_imgs*e, e, me==result_image_)) - result_ = assert_equals(dble(expected_result), dble(scalar)) - end associate - end function - - function sum_double_precision_2D_array() result(result_) - type(result_t) result_ - double precision, allocatable :: array(:,:) - double precision, parameter :: input(*,*) = reshape(-[6,5,4,3,2,1], [3,2]) - integer :: num_imgs - - array = input - call prif_co_sum(array) - call prif_num_images(num_images=num_imgs) - result_ = assert_equals(product(num_imgs*input), product(array)) - end function - - function sum_default_complex_scalars() result(result_) - type(result_t) result_ - real scalar - complex z - complex, parameter :: i=(0.,1.) - integer status_, num_imgs - - status_ = -1 - z = i - call prif_co_sum(z, stat=status_) - call prif_num_images(num_images=num_imgs) - result_ = assert_equals(dble(abs(i*num_imgs)), dble(abs(z)) ) .and. assert_equals(0, status_) - end function - - function sum_dble_complex_1D_arrays() result(result_) - type(result_t) result_ - integer, parameter :: dp = kind(1.D0) - integer :: num_imgs - complex(dp), allocatable :: array(:) - complex(dp), parameter :: input(*) = [(1.D0,1.0D0)] - - array = [(1.D0,1.D0)] - call prif_co_sum(array) - call prif_num_images(num_images=num_imgs) - result_ = assert_that(all([input*num_imgs] == array)) - end function - -end module caf_co_sum_test diff --git a/test/caf_coarray_inquiry_test.f90 b/test/caf_coarray_inquiry_test.f90 deleted file mode 100644 index bdfee64b0..000000000 --- a/test/caf_coarray_inquiry_test.f90 +++ /dev/null @@ -1,52 +0,0 @@ -module caf_coarray_inquiry_test - use prif, only : & - prif_allocate_coarray, prif_deallocate_coarray, & - prif_coarray_handle, prif_num_images, & - prif_local_data_pointer - use veggies, only: result_t, test_item_t, assert_that, describe, it - use iso_c_binding, only: & - c_ptr, c_int64_t, c_size_t, c_null_funptr, c_associated - - implicit none - private - public :: test_coarray_inquiry -contains - function test_coarray_inquiry() result(tests) - type(test_item_t) :: tests - - tests = & - describe( & - "PRIF coarray inquiry functions", & - [ describe( & - "prif_local_data_pointer", & - [ it( & - "returns the same pointer as when the coarray was allocated", & - check_prif_local_data_pointer) & - ]) & - ]) - end function - - function check_prif_local_data_pointer() result(result_) - type(result_t) :: result_ - - integer(kind=c_int64_t), dimension(1) :: lcobounds, ucobounds - integer :: dummy_element, num_imgs - type(prif_coarray_handle) :: coarray_handle - type(c_ptr) :: allocation_ptr, local_ptr - - call prif_num_images(num_images=num_imgs) - lcobounds(1) = 1 - ucobounds(1) = num_imgs - - call prif_allocate_coarray( & - lcobounds, & - ucobounds, & - int(storage_size(dummy_element)/8, c_size_t), & - c_null_funptr, & - coarray_handle, & - allocation_ptr) - call prif_local_data_pointer(coarray_handle, local_ptr) - result_ = assert_that(c_associated(local_ptr, allocation_ptr)) - call prif_deallocate_coarray([coarray_handle]) - end function -end module diff --git a/test/caf_error_stop_test.f90 b/test/caf_error_stop_test.f90 deleted file mode 100644 index a5f25282e..000000000 --- a/test/caf_error_stop_test.f90 +++ /dev/null @@ -1,76 +0,0 @@ -module caf_error_stop_test - use veggies, only: test_item_t, describe, result_t, it, assert_that, assert_equals - use unit_test_parameters_m, only : expected_error_stop_code - - implicit none - private - public :: test_prif_this_image - - integer, parameter :: max_message_len = 128 - -contains - function test_prif_this_image() result(tests) - type(test_item_t) :: tests - - tests = describe( & - "A program that executes the prif_error_stop function", & - [ it("exits with a non-zero exitstat when the program omits the stop code", exit_with_no_stop_code) & - ,it("prints a character stop code and exits with a non-zero exitstat", exit_with_character_stop_code) & - ,it("prints an integer stop code and exits with exitstat equal to the stop code", exit_with_integer_stop_code) & - ]) - end function - - function exit_with_no_stop_code() result(result_) - type(result_t) :: result_ - integer exit_status - integer command_status - character(len=max_message_len) command_message - - call execute_command_line( & - command = "./build/run-fpm.sh run --example error_stop_with_no_code > /dev/null 2>&1" & - ,wait = .true. & - ,exitstat = exit_status & - ,cmdstat = command_status & - ,cmdmsg = command_message & - ) - result_ = assert_that(exit_status /= 0) .and. assert_equals(0, command_status, command_message) - - end function - - function exit_with_integer_stop_code() result(result_) - type(result_t) :: result_ - integer exit_status - integer command_status - character(len=max_message_len) command_message - - call execute_command_line( & - command = "./build/run-fpm.sh run --example error_stop_with_integer_code > /dev/null 2>&1" & - ,wait = .true. & - ,exitstat = exit_status & - ,cmdstat = command_status & - ,cmdmsg = command_message & - ) - result_ = & - assert_equals(expected_error_stop_code, exit_status, "exit_status") & - .and. assert_equals(0, command_status, command_message) - - end function - - function exit_with_character_stop_code() result(result_) - type(result_t) :: result_ - integer exit_status - integer command_status - character(len=max_message_len) command_message - - call execute_command_line( & - command = "./build/run-fpm.sh run --example error_stop_with_character_code > /dev/null 2>&1" & - ,wait = .true. & - ,exitstat = exit_status & - ,cmdstat = command_status & - ,cmdmsg = command_message & - ) - result_ = assert_that(exit_status /= 0) .and. assert_equals(0, command_status, command_message) - - end function - -end module caf_error_stop_test diff --git a/test/caf_image_index_test.f90 b/test/caf_image_index_test.f90 deleted file mode 100644 index e10c2f196..000000000 --- a/test/caf_image_index_test.f90 +++ /dev/null @@ -1,98 +0,0 @@ -module caf_image_index_test - use iso_c_binding, only: c_int, c_ptr, c_size_t, c_null_funptr, c_int64_t - use prif, only: prif_coarray_handle, prif_allocate_coarray, prif_deallocate_coarray, prif_image_index, prif_num_images - use veggies, only: result_t, test_item_t, assert_equals, describe, it - - implicit none - private - public :: test_prif_image_index -contains - function test_prif_image_index() result(tests) - type(test_item_t) :: tests - - tests = describe( & - "prif_image_index", & - [ it("returns 1 for the simplest case", check_simple_case) & - , it("returns 1 when given the lower bounds", check_lower_bounds) & - , it("returns 0 with invalid subscripts", check_invalid_subscripts) & - , it("returns the expected answer for a more complicated case", check_complicated) & - ]) - end function - - function check_simple_case() result(result_) - type(result_t) :: result_ - - type(prif_coarray_handle) :: coarray_handle - type(c_ptr) :: allocated_memory - integer(c_int) :: answer - - call prif_allocate_coarray( & - lcobounds = [1_c_int64_t], & - ucobounds = [2_c_int64_t], & - size_in_bytes = 1_c_size_t, & - final_func = c_null_funptr, & - coarray_handle = coarray_handle, & - allocated_memory = allocated_memory) - call prif_image_index(coarray_handle, [1_c_int64_t], image_index=answer) - result_ = assert_equals(1_c_int, answer) - call prif_deallocate_coarray([coarray_handle]) - end function - - function check_lower_bounds() result(result_) - type(result_t) :: result_ - - type(prif_coarray_handle) :: coarray_handle - type(c_ptr) :: allocated_memory - integer(c_int) :: answer - - call prif_allocate_coarray( & - lcobounds = [2_c_int64_t, 3_c_int64_t], & - ucobounds = [3_c_int64_t, 4_c_int64_t], & - size_in_bytes = 1_c_size_t, & - final_func = c_null_funptr, & - coarray_handle = coarray_handle, & - allocated_memory = allocated_memory) - call prif_image_index(coarray_handle, [2_c_int64_t, 3_c_int64_t], image_index=answer) - result_ = assert_equals(1_c_int, answer) - call prif_deallocate_coarray([coarray_handle]) - end function - - function check_invalid_subscripts() result(result_) - type(result_t) :: result_ - - type(prif_coarray_handle) :: coarray_handle - type(c_ptr) :: allocated_memory - integer(c_int) :: answer - - call prif_allocate_coarray( & - lcobounds = [-2_c_int64_t, 2_c_int64_t], & - ucobounds = [2_c_int64_t, 6_c_int64_t], & - size_in_bytes = 1_c_size_t, & - final_func = c_null_funptr, & - coarray_handle = coarray_handle, & - allocated_memory = allocated_memory) - call prif_image_index(coarray_handle, [-1_c_int64_t, 1_c_int64_t], image_index=answer) - result_ = assert_equals(0_c_int, answer) - call prif_deallocate_coarray([coarray_handle]) - end function - - function check_complicated() result(result_) - type(result_t) :: result_ - - type(prif_coarray_handle) :: coarray_handle - type(c_ptr) :: allocated_memory - integer(c_int) :: answer, ni - - call prif_num_images(num_images=ni) - call prif_allocate_coarray( & - lcobounds = [1_c_int64_t, 2_c_int64_t], & - ucobounds = [2_c_int64_t, 3_c_int64_t], & - size_in_bytes = 1_c_size_t, & - final_func = c_null_funptr, & - coarray_handle = coarray_handle, & - allocated_memory = allocated_memory) - call prif_image_index(coarray_handle, [1_c_int64_t, 3_c_int64_t], image_index=answer) - result_ = assert_equals(merge(3_c_int,0_c_int,ni >= 3), answer) - call prif_deallocate_coarray([coarray_handle]) - end function -end module diff --git a/test/caf_num_images_test.f90 b/test/caf_num_images_test.f90 deleted file mode 100644 index 4640a15a7..000000000 --- a/test/caf_num_images_test.f90 +++ /dev/null @@ -1,27 +0,0 @@ -module caf_num_images_test - use prif, only : prif_num_images - use veggies, only: result_t, test_item_t, assert_that, describe, it - - implicit none - private - public :: test_prif_num_images - -contains - function test_prif_num_images() result(tests) - type(test_item_t) :: tests - - tests = & - describe( & - "The prif_num_images function result", & - [ it("is a valid number of images when invoked with no arguments", check_num_images_valid) & - ]) - end function - - function check_num_images_valid() result(result_) - type(result_t) :: result_ - integer :: num_imgs - call prif_num_images(num_images=num_imgs) - result_ = assert_that(num_imgs>0, "positive number of images") - end function - -end module caf_num_images_test diff --git a/test/caf_rma_test.f90 b/test/caf_rma_test.f90 deleted file mode 100644 index a603eb7b9..000000000 --- a/test/caf_rma_test.f90 +++ /dev/null @@ -1,229 +0,0 @@ -module caf_rma_test - use iso_c_binding, only: & - c_ptr, c_int64_t, c_intptr_t, c_size_t, c_null_funptr, c_f_pointer, c_loc, c_sizeof - use prif, only: & - prif_coarray_handle, & - prif_allocate_coarray, & - prif_deallocate_coarray, & - prif_allocate, & - prif_deallocate, & - prif_num_images, & - prif_put, & - prif_put_indirect, & - prif_get, & - prif_get_indirect, & - prif_sync_all, & - prif_this_image_no_coarray - use veggies, only: result_t, test_item_t, assert_equals, describe, it - - implicit none - private - public :: test_prif_rma -contains - function test_prif_rma() result(tests) - type(test_item_t) :: tests - - tests = describe( & - "PRIF RMA", & - [ it("can send a value to another image", check_put) & - , it("can send a value with indirect interface", check_put_indirect) & - , it("can get a value from another image", check_get) & - , it("can get a value with indirect interface", check_get_indirect) & - ]) - end function - - function check_put() result(result_) - type(result_t) :: result_ - - integer :: dummy_element, num_imgs, expected, neighbor - integer, target :: me - type(prif_coarray_handle) :: coarray_handle - type(c_ptr) :: allocated_memory - integer, pointer :: local_slice - integer(c_int64_t) :: lcobounds(1), ucobounds(1) - - call prif_num_images(num_images=num_imgs) - lcobounds(1) = 1 - ucobounds(1) = num_imgs - call prif_allocate_coarray( & - lcobounds = lcobounds, & - ucobounds = ucobounds, & - size_in_bytes = int(storage_size(dummy_element)/8, c_size_t), & - final_func = c_null_funptr, & - coarray_handle = coarray_handle, & - allocated_memory = allocated_memory) - call c_f_pointer(allocated_memory, local_slice) - - call prif_this_image_no_coarray(this_image=me) - neighbor = merge(me+1, 1, me < num_imgs) - expected = merge(me-1, num_imgs, me > 1) - - call prif_put( & - image_num = neighbor, & - coarray_handle = coarray_handle, & - offset = 0_c_size_t, & - current_image_buffer = c_loc(me), & - size_in_bytes = c_sizeof(me)) - call prif_sync_all - - result_ = assert_equals(expected, local_slice) - - call prif_deallocate_coarray([coarray_handle]) - end function - - function check_put_indirect() result(result_) - type(result_t) :: result_ - - type :: my_type - type(c_ptr) :: my_component - end type - - type(my_type), target :: dummy_element - integer, pointer :: component_access - integer :: dummy_component, num_imgs, expected, neighbor - integer, target :: me - type(prif_coarray_handle) :: coarray_handle - type(c_ptr) :: allocated_memory - type(my_type), pointer :: local_slice - integer(c_int64_t) :: lcobounds(1), ucobounds(1) - integer(c_intptr_t) :: base_addr - - call prif_num_images(num_images=num_imgs) - lcobounds(1) = 1 - ucobounds(1) = num_imgs - call prif_allocate_coarray( & - lcobounds = lcobounds, & - ucobounds = ucobounds, & - size_in_bytes = int(storage_size(dummy_element)/8, c_size_t), & - final_func = c_null_funptr, & - coarray_handle = coarray_handle, & - allocated_memory = allocated_memory) - call c_f_pointer(allocated_memory, local_slice) - call prif_allocate( & - size_in_bytes = int(storage_size(dummy_component)/8, c_size_t), & - allocated_memory = local_slice%my_component) - call prif_sync_all - - call prif_this_image_no_coarray(this_image=me) - neighbor = merge(me+1, 1, me < num_imgs) - expected = merge(me-1, num_imgs, me > 1) - - call prif_get( & - image_num = neighbor, & - coarray_handle = coarray_handle, & - offset = 0_c_size_t, & - current_image_buffer = c_loc(dummy_element), & - size_in_bytes = int(storage_size(dummy_element)/8, c_size_t)) - base_addr = transfer(dummy_element%my_component, base_addr) - call prif_put_indirect( & - image_num = neighbor, & - remote_ptr = base_addr, & - current_image_buffer = c_loc(me), & - size_in_bytes = int(storage_size(me)/8, c_size_t)) - call prif_sync_all - - call c_f_pointer(local_slice%my_component, component_access) - result_ = assert_equals(expected, component_access) - - call prif_deallocate(local_slice%my_component) - call prif_deallocate_coarray([coarray_handle]) - end function - - function check_get() result(result_) - type(result_t) :: result_ - - integer :: dummy_element, num_imgs, me, neighbor, expected - integer, target :: retrieved - type(prif_coarray_handle) :: coarray_handle - type(c_ptr) :: allocated_memory - integer, pointer :: local_slice - integer(c_int64_t) :: lcobounds(1), ucobounds(1) - - call prif_num_images(num_images=num_imgs) - lcobounds(1) = 1 - ucobounds(1) = num_imgs - call prif_allocate_coarray( & - lcobounds = lcobounds, & - ucobounds = ucobounds, & - size_in_bytes = int(storage_size(dummy_element)/8, c_size_t), & - final_func = c_null_funptr, & - coarray_handle = coarray_handle, & - allocated_memory = allocated_memory) - call c_f_pointer(allocated_memory, local_slice) - - call prif_this_image_no_coarray(this_image=me) - neighbor = merge(me+1, 1, me < num_imgs) - expected = neighbor - local_slice = me - call prif_sync_all - - call prif_get( & - image_num = neighbor, & - coarray_handle = coarray_handle, & - offset = 0_c_size_t, & - current_image_buffer = c_loc(retrieved), & - size_in_bytes = c_sizeof(retrieved)) - - result_ = assert_equals(expected, retrieved) - - call prif_deallocate_coarray([coarray_handle]) - end function - - function check_get_indirect() result(result_) - type(result_t) :: result_ - - type :: my_type - type(c_ptr) :: my_component - end type - - type(my_type), target :: dummy_element - integer, pointer :: component_access - integer :: dummy_component, num_imgs, me, expected, neighbor - integer, target :: retrieved - type(prif_coarray_handle) :: coarray_handle - type(c_ptr) :: allocated_memory - type(my_type), pointer :: local_slice - integer(c_int64_t) :: lcobounds(1), ucobounds(1) - integer(c_intptr_t) :: base_addr - - call prif_num_images(num_images=num_imgs) - lcobounds(1) = 1 - ucobounds(1) = num_imgs - call prif_allocate_coarray( & - lcobounds = lcobounds, & - ucobounds = ucobounds, & - size_in_bytes = int(storage_size(dummy_element)/8, c_size_t), & - final_func = c_null_funptr, & - coarray_handle = coarray_handle, & - allocated_memory = allocated_memory) - call c_f_pointer(allocated_memory, local_slice) - call prif_allocate( & - size_in_bytes = int(storage_size(dummy_component)/8, c_size_t), & - allocated_memory = local_slice%my_component) - - call prif_this_image_no_coarray(this_image=me) - neighbor = merge(me+1, 1, me < num_imgs) - expected = neighbor - call c_f_pointer(local_slice%my_component, component_access) - component_access = me - call prif_sync_all - - call prif_get( & - image_num = neighbor, & - coarray_handle = coarray_handle, & - offset = 0_c_size_t, & - current_image_buffer = c_loc(dummy_element), & - size_in_bytes = int(storage_size(dummy_element)/8, c_size_t)) - base_addr = transfer(dummy_element%my_component, base_addr) - call prif_get_indirect( & - image_num = neighbor, & - remote_ptr = base_addr, & - current_image_buffer = c_loc(retrieved), & - size_in_bytes = int(storage_size(retrieved)/8, c_size_t)) - - result_ = assert_equals(expected, retrieved) - - call prif_deallocate(local_slice%my_component) - call prif_deallocate_coarray([coarray_handle]) - end function -end module diff --git a/test/caf_stop_test.f90 b/test/caf_stop_test.f90 deleted file mode 100644 index e518ca9bb..000000000 --- a/test/caf_stop_test.f90 +++ /dev/null @@ -1,74 +0,0 @@ -module caf_stop_test - use veggies, only: test_item_t, describe, result_t, it, assert_that, assert_equals - use unit_test_parameters_m, only : expected_stop_code - - implicit none - private - public :: test_prif_this_image - -contains - function test_prif_this_image() result(tests) - type(test_item_t) :: tests - - tests = describe( & - "A program that executes the prif_stop function", & - [ it("exits with a zero exitstat when the program omits the stop code", exit_with_no_stop_code) & - ,it("prints an integer stop code and exits with exitstat equal to the stop code", exit_with_integer_stop_code) & - ,it("prints a character stop code and exits with a non-zero exitstat", exit_with_character_stop_code) & - ,it("invokes a registered callback", check_callback_invocation) & - ]) - end function - - function exit_with_no_stop_code() result(result_) - type(result_t) :: result_ - integer exit_status - - call execute_command_line( & - command = "./build/run-fpm.sh run --example stop_with_no_code > /dev/null 2>&1", & - wait = .true., & - exitstat = exit_status & - ) - result_ = assert_equals(0, exit_status) - - end function - - function exit_with_integer_stop_code() result(result_) - type(result_t) :: result_ - integer exit_status - - call execute_command_line( & - command = "./build/run-fpm.sh run --example stop_with_integer_code > /dev/null 2>&1", & - wait = .true., & - exitstat = exit_status & - ) - result_ = assert_equals(expected_stop_code, exit_status) - - end function - - function exit_with_character_stop_code() result(result_) - type(result_t) :: result_ - integer exit_status - - call execute_command_line( & - command = "./build/run-fpm.sh run --example stop_with_character_code > /dev/null 2>&1", & - wait = .true., & - exitstat = exit_status & - ) - result_ = assert_equals(0, exit_status) ! the standard recommends zero exit status for character stop codes - - end function - - function check_callback_invocation() result(result_) - type(result_t) :: result_ - - integer :: exit_status - - call execute_command_line( & - command = "./build/run-fpm.sh run --example register_stop_callback > /dev/null 2>&1", & - wait = .true., & - exitstat = exit_status & - ) - result_ = assert_equals(0, exit_status) - end function - -end module caf_stop_test diff --git a/test/caf_teams_test.f90 b/test/caf_teams_test.f90 deleted file mode 100644 index 7eb530439..000000000 --- a/test/caf_teams_test.f90 +++ /dev/null @@ -1,65 +0,0 @@ -module caf_teams_test - use iso_c_binding, only: c_size_t, c_ptr, c_null_funptr, c_int64_t - use prif, only: & - prif_coarray_handle, & - prif_allocate_coarray, & - prif_deallocate_coarray, & - prif_this_image_no_coarray, & - prif_num_images, & - prif_team_type, & - prif_form_team, & - prif_change_team, & - prif_end_team - use veggies, only: result_t, test_item_t, assert_equals, describe, it, succeed - - implicit none - private - public :: test_caf_teams -contains - function test_caf_teams() result(tests) - type(test_item_t) :: tests - - tests = describe( & - "Teams", & - [ it("can be created, changed to, and allocate coarrays", check_teams) & - ]) - end function - - function check_teams() result(result_) - type(result_t) :: result_ - - ! TODO: use final_func to observe automatic deallocation of coarrays - integer :: dummy_element, initial_num_imgs, num_imgs, me, i - integer(c_size_t) :: element_size - integer(c_int64_t) :: which_team - integer, parameter :: num_coarrays = 4 - type(prif_coarray_handle) :: coarrays(num_coarrays) - type(c_ptr) :: allocated_memory - type(prif_team_type) :: team - - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(num_images=initial_num_imgs) - which_team = merge(1_c_int64_t, 2_c_int64_t, mod(me, 2) == 0) - element_size = int(storage_size(dummy_element)/8, c_size_t) - call prif_form_team(team_number = which_team, team = team) - call prif_change_team(team) - call prif_num_images(num_images=num_imgs) - result_ = assert_equals( & - initial_num_imgs/2 + mod(initial_num_imgs,2)*(int(which_team)-1), & - num_imgs, & - "Team has correct number of images") - do i = 1, num_coarrays - call prif_allocate_coarray( & - lcobounds = [1_c_int64_t], & - ucobounds = [int(num_imgs, c_int64_t)], & - size_in_bytes = element_size, & - final_func = c_null_funptr, & - coarray_handle = coarrays(i), & - allocated_memory = allocated_memory) - end do - call prif_deallocate_coarray(coarrays(4:4)) - call prif_deallocate_coarray(coarrays(2:2)) - call prif_end_team() - result_ = result_.and.succeed("Seems to have worked") - end function -end module diff --git a/test/caf_this_image_test.f90 b/test/caf_this_image_test.f90 deleted file mode 100644 index 1f960e6f9..000000000 --- a/test/caf_this_image_test.f90 +++ /dev/null @@ -1,33 +0,0 @@ -module caf_this_image_test - use prif, only : prif_this_image_no_coarray, prif_num_images, prif_co_sum - use veggies, only: result_t, test_item_t, assert_that, describe, it, succeed - - implicit none - private - public :: test_prif_this_image_no_coarray - -contains - function test_prif_this_image_no_coarray() result(tests) - type(test_item_t) :: tests - - integer, parameter :: initiation_success = 0 - - tests = describe( & - "The prif_this_image_no_coarray function result", & - [ it("is the proper member of the set {1,2,...,num_images()} when invoked as this_image()", check_this_image_set) & - ]) - end function - - function check_this_image_set() result(result_) - type(result_t) :: result_ - integer, allocatable :: image_numbers(:) - integer i, me, ni - - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(num_images=ni) - image_numbers = [(merge(0, me, me/=i), i = 1, ni)] - call prif_co_sum(image_numbers) - result_ = assert_that(all(image_numbers == [(i, i = 1, ni)]) .and. size(image_numbers)>0, "correct image set") - end function - -end module caf_this_image_test diff --git a/test/main.f90 b/test/main.f90 index 2e61c4484..b552ead87 100644 --- a/test/main.f90 +++ b/test/main.f90 @@ -1,93 +1,111 @@ -! This file was originally generated by cart, but then manually edited. -! DO NOT REGENERATE THIS FILE! +! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +!#include "assert_macros.h" + program main - use iso_c_binding, only : c_bool - use prif, only : & - prif_stop & - ,prif_error_stop - implicit none + !! Test the Caffeine implementation of the Parallel Runtime Interface for Fortran (PRIF) + use assert_m + use iso_c_binding, only : c_bool + use julienne_m, only : command_line_t, GitHub_CI + use prif, only : & + prif_init & + ,prif_error_stop & + ,prif_stop & + ,prif_sync_all & + ,prif_this_image_no_coarray + use prif_allocate_test_m, only : prif_allocate_test_t + use prif_co_broadcast_test_m, only : prif_co_broadcast_test_t + use prif_co_max_test_m, only : prif_co_max_test_t + use prif_co_min_test_m, only : prif_co_min_test_t + use prif_co_reduce_test_m, only : prif_co_reduce_test_t + use prif_co_sum_test_m, only : prif_co_sum_test_t + !use prif_error_stop_test_m, only : prif_error_stop_test_t + use prif_image_index_test_m, only : prif_image_index_test_t + use prif_init_test_m, only : prif_init_test_t + use prif_num_images_test_m, only : prif_num_images_test_t + use prif_rma_test_m, only : prif_rma_test_t + !use prif_stop_test_m, only : prif_stop_test_t + use prif_teams_test_m, only : prif_teams_test_t + use prif_this_image_test_m, only : prif_this_image_test_t + implicit none - logical(kind=c_bool), parameter :: false = .false._c_bool + integer :: passes=0, tests=0 + integer me - if (.not.run()) call prif_error_stop(quiet=false, stop_code_char = "Unit tests failed to run") + call stop_and_print_usage_info_if_help_requested + call run_tests_and_report(passes, tests) + call prif_this_image_no_coarray(this_image=me) - call prif_stop(quiet=false) + if (me==1) print "(a,*(a,G0))", new_line(''), "_________ In total, ",passes," of ",tests, " tests pass. _________" + call prif_sync_all + if (passes /= tests) call prif_error_stop(quiet=.false._c_bool) + call prif_stop(quiet=.true._c_bool) contains - function run() result(passed) - use a00_caffeinate_test, only: & - a00_caffeinate_caffeinate => & - test_caffeinate - use caf_allocate_test, only: & - caf_allocate_prif_allocate => & - test_prif_allocate - use caf_co_broadcast_test, only: & - caf_co_broadcast_prif_co_broadcast => & - test_prif_co_broadcast - use caf_co_max_test, only: & - caf_co_max_prif_co_max => & - test_prif_co_max - use caf_co_min_test, only: & - caf_co_min_prif_co_min => & - test_prif_co_min - use caf_co_reduce_test, only: & - caf_co_reduce_prif_co_reduce => & - test_prif_co_reduce - use caf_co_sum_test, only: & - caf_co_sum_prif_co_sum => & - test_prif_co_sum - use caf_coarray_inquiry_test, only: & - caf_coarray_inquiry_coarray_inquiry => & - test_coarray_inquiry - use caf_error_stop_test, only: & - caf_error_stop_prif_this_image => & - test_prif_this_image - use caf_image_index_test, only: & - caf_image_index_prif_image_index => & - test_prif_image_index - use caf_num_images_test, only: & - caf_num_images_prif_num_images => & - test_prif_num_images - use caf_rma_test, only: & - caf_rma_prif_rma => & - test_prif_rma - use caf_stop_test, only: & - caf_stop_prif_this_image => & - test_prif_this_image - use caf_teams_test, only: & - caf_teams_caf_teams => & - test_caf_teams - use caf_this_image_test, only: & - caf_this_image_prif_this_image_no_coarray => & - test_prif_this_image_no_coarray - use veggies, only: test_item_t, test_that, run_tests + subroutine stop_and_print_usage_info_if_help_requested + type(command_line_t) command_line + character(len=*), parameter :: usage = & + new_line('') // new_line('') // & + 'Usage: fpm test -- [--help] | [--contains ]' // & + new_line('') // new_line('') // & + 'where square brackets ([]) denote optional arguments, a pipe (|) separates alternative arguments,' // new_line('') // & + 'angular brackets (<>) denote a user-provided value, and passing a substring limits execution to' // new_line('') // & + 'the tests with test subjects or test descriptions containing the user-specified substring.' // new_line('') + integer, parameter :: successful_initiation = 0 + integer init_exit_code, me - logical :: passed + if (command_line%argument_present([character(len=len("--help"))::"--help","-h"])) stop usage + end subroutine - type(test_item_t) :: tests - type(test_item_t) :: individual_tests(15) + subroutine run_tests_and_report(passes, tests) + integer, intent(inout) :: passes, tests - individual_tests(1) = a00_caffeinate_caffeinate() - individual_tests(2) = caf_allocate_prif_allocate() - individual_tests(3) = caf_co_broadcast_prif_co_broadcast() - individual_tests(4) = caf_co_max_prif_co_max() - individual_tests(5) = caf_co_min_prif_co_min() - individual_tests(6) = caf_co_reduce_prif_co_reduce() - individual_tests(7) = caf_co_sum_prif_co_sum() - individual_tests(8) = caf_coarray_inquiry_coarray_inquiry() - individual_tests(9) = caf_error_stop_prif_this_image() - individual_tests(10) = caf_image_index_prif_image_index() - individual_tests(11) = caf_num_images_prif_num_images() - individual_tests(12) = caf_rma_prif_rma() - individual_tests(13) = caf_stop_prif_this_image() - individual_tests(14) = caf_teams_caf_teams() - individual_tests(15) = caf_this_image_prif_this_image_no_coarray() - tests = test_that(individual_tests) + type(prif_allocate_test_t) prif_allocate_test + type(prif_co_broadcast_test_t) prif_co_broadcast_test + type(prif_co_max_test_t) prif_co_max_test + type(prif_co_min_test_t) prif_co_min_test + type(prif_co_reduce_test_t) prif_co_reduce_test + type(prif_co_sum_test_t) prif_co_sum_test + type(prif_image_index_test_t) prif_image_index_test + type(prif_init_test_t) prif_init_test + type(prif_num_images_test_t) prif_num_images_test + type(prif_rma_test_t) prif_rma_test + type(prif_teams_test_t) prif_teams_test + type(prif_this_image_test_t) prif_this_image_test + !type(prif_error_stop_test_t) prif_error_stop_test + !type(prif_stop_test_t) prif_stop_test + call prif_init_test%report(passes, tests) ! This test must run first + call prif_allocate_test%report(passes, tests) + call prif_co_broadcast_test%report(passes, tests) + call prif_co_max_test%report(passes, tests) + call prif_co_min_test%report(passes, tests) + call prif_co_reduce_test%report(passes, tests) + call prif_co_sum_test%report(passes, tests) + call prif_image_index_test%report(passes, tests) + call prif_num_images_test%report(passes, tests) + call prif_teams_test%report(passes, tests) + call prif_this_image_test%report(passes, tests) + call prif_rma_test%report(passes, tests) + !call prif_stop_test%report(passes, tests) + !call prif_error_stop_test%report(passes, tests) +!#ifdef __flang__ + !print * + !print *,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!" + !print * + !print *,"LLVM Flang detected. Skipping tests that crash:" + !print *," - prif_co_max_test" + !print *," - prif_co_min_test" + !print *," - prif_co_reduce_test" + !print *," - prif_co_sum_test" + !print *," - prif_image_index_test" + !print * + !print *,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!" +!#endif - passed = run_tests(tests) + end subroutine run_tests_and_report - end function end program diff --git a/test/prif_allocate_test_m.F90 b/test/prif_allocate_test_m.F90 new file mode 100644 index 000000000..da7cf3cd7 --- /dev/null +++ b/test/prif_allocate_test_m.F90 @@ -0,0 +1,157 @@ +! Copyright (c) 2022-2024, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +#include "language-support.F90" + +module prif_allocate_test_m + !! Unit test for Caffeine's support for symmetric and asymmetric memory allocations + use prif, only : prif_allocate_coarray, prif_deallocate_coarray, prif_coarray_handle & + ,prif_allocate, prif_deallocate, prif_num_images + use julienne_m, only : test_t , string_t & + ,test_result_t , vector_function_strategy_t & + ,test_description_t , vector_test_description_t & + ,test_description_substring +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : test_function_i +#endif + use iso_c_binding, only: c_ptr, c_int, c_intmax_t, c_size_t, c_null_funptr, c_f_pointer, c_null_ptr, c_loc + implicit none + + private + public :: prif_allocate_test_t + + type, extends(test_t) :: prif_allocate_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + + type, extends(vector_function_strategy_t) :: symmetric_allocation_test_function_t + contains + procedure, nopass :: vector_function => check_symmetric_allocation + end type + +contains + + pure function subject() result(specimen) + character(len=:), allocatable :: specimen + specimen = "The prif_allocate_coarray subroutine" + end function + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:), vector_test_results(:) + type(test_description_t), allocatable :: scalar_test_descriptions(:) + type(vector_test_description_t), allocatable :: vector_test_descriptions(:) + type(symmetric_allocation_test_function_t) symmetric_allocation_test_function + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + scalar_test_descriptions = [ & + test_description_t("allocating/using/deallocating a corank-1 integer scalar coarray", & + check_asymmetric_allocation) & + ] +#else + procedure(test_function_i), pointer :: check_asymmetric_allocation_ptr + + check_asymmetric_allocation_ptr => check_asymmetric_allocation + + scalar_test_descriptions = [ & + test_description_t("allocating/using/deallocating a corank-1 integer scalar coarray", & + check_asymmetric_allocation_ptr) & + ] +#endif + + vector_test_descriptions = [ & + vector_test_description_t( & + [ string_t("a local slice being initially unassociated") & + ,string_t("an allocated slice being associated") & + ,string_t("a defined slice having the expected value") & + ], symmetric_allocation_test_function & + ) & + ] + + associate( & + substring_in_subject => index(subject(), test_description_substring) /= 0, & + substring_in_description => scalar_test_descriptions%contains_text(string_t(test_description_substring)), & + num_vector_tests => size(vector_test_descriptions) & + ) + scalar_test_descriptions = pack(scalar_test_descriptions, substring_in_subject .or. substring_in_description) + + block + integer i + + associate( & + substring_in_description_vector => & + [(any(vector_test_descriptions(i)%contains_text(test_description_substring)), i=1,num_vector_tests)] & + ) + if (substring_in_subject) then + vector_test_results = [(vector_test_descriptions(i)%run(), i=1,num_vector_tests)] + else if (any(substring_in_description_vector)) then + vector_test_descriptions = pack(vector_test_descriptions, substring_in_description_vector) + vector_test_results = [(vector_test_descriptions(i)%run(), i=1,size(vector_test_descriptions))] + vector_test_results = & + pack(vector_test_results, vector_test_results%description_contains(string_t(test_description_substring))) + else + vector_test_results = [test_result_t::] + end if + test_results = [scalar_test_descriptions%run(), vector_test_results] + end associate + end block + end associate + + end function results + + function check_symmetric_allocation() result(test_passes) + !! Allocate memory for an integer scalar single corank coarray, such as the following decl + !! integer :: coarr[*] + logical, allocatable :: test_passes(:) + integer(kind=c_intmax_t), dimension(1) :: lcobounds, ucobounds + integer(kind=c_intmax_t), dimension(0), parameter :: lbounds = [integer(kind=c_intmax_t) ::] + integer(kind=c_intmax_t), dimension(0), parameter :: ubounds = [integer(kind=c_intmax_t) ::] + integer, pointer :: local_slice + integer dummy_element, num_imgs + type(prif_coarray_handle) coarray_handle + type(c_ptr) allocated_memory + + call prif_num_images(num_images=num_imgs) + lcobounds(1) = 1 + ucobounds(1) = num_imgs + allocated_memory = c_null_ptr + local_slice => null() + + associate(slice_initially_unassociated => .not. associated(local_slice)) + + call prif_allocate_coarray( & + lcobounds, ucobounds, int(storage_size(dummy_element)/8, c_size_t), c_null_funptr, coarray_handle, allocated_memory) + call c_f_pointer(allocated_memory, local_slice) + + associate(allocated_slice_associated => associated(local_slice)) + local_slice = 42 + associate(defined_slice_has_expected_value => 42 == local_slice) + call prif_deallocate_coarray([coarray_handle]) + test_passes = [slice_initially_unassociated, allocated_slice_associated, defined_slice_has_expected_value] + end associate + end associate + + end associate + + end function + + function check_asymmetric_allocation() result(test_passes) + logical test_passes + + type(c_ptr) :: allocated_memory + integer(c_int), pointer :: local_slice + + call prif_allocate(sizeof(local_slice), allocated_memory) + call c_f_pointer(allocated_memory, local_slice) + + local_slice = 42 + + associate(definition_succeeds => 42 == local_slice) + test_passes = definition_succeeds + end associate + + call prif_deallocate(c_loc(local_slice)) + end function + +end module prif_allocate_test_m diff --git a/test/prif_co_broadcast_test_m.F90 b/test/prif_co_broadcast_test_m.F90 new file mode 100644 index 000000000..f269c8dad --- /dev/null +++ b/test/prif_co_broadcast_test_m.F90 @@ -0,0 +1,106 @@ +! Copyright (c) 2022-2024, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +#include "language-support.F90" + +module prif_co_broadcast_test_m + !! Unit test for the prif_co_broadcast subroutine + use prif, only : prif_co_broadcast, prif_num_images, prif_this_image_no_coarray + use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : test_function_i +#endif + implicit none + + private + public :: prif_co_broadcast_test_t + + type, extends(test_t) :: prif_co_broadcast_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + + type object_t + integer i + logical fallacy + character(len=len("fooey")) actor + complex issues + end type + + interface operator(==) + module procedure equals + end interface + +contains + + pure function subject() result(specimen) + character(len=:), allocatable :: specimen + specimen = "The prif_co_broadcast subroutine" + end function + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(test_description_t), allocatable :: test_descriptions(:) + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + test_descriptions = [ & + test_description_t("broadcasts a default integer scalar with no optional arguments", broadcast_default_integer) & + ,test_description_t("broadcasts a derived type scalar with no allocatable components", broadcast_derived_type) & + ] +#else + procedure(test_function_i), pointer :: broadcast_default_integer_ptr, broadcast_derived_type_ptr + + broadcast_default_integer_ptr => broadcast_default_integer + broadcast_derived_type_ptr => broadcast_derived_type + + test_descriptions = [ & + test_description_t("broadcasting a default integer when called without optional arguments", broadcast_default_integer_ptr) & + ,test_description_t("broadcasting a derived type with no allocatable components", broadcast_derived_type_ptr) & + ] +#endif + + test_descriptions = pack(test_descriptions, & + index(subject(), test_description_substring) /= 0 & + .or. test_descriptions%contains_text(test_description_substring)) + + test_results = test_descriptions%run() + end function + + logical pure function equals(lhs, rhs) + type(object_t), intent(in) :: lhs, rhs + equals = all([ & + lhs%i == rhs%i & + ,lhs%fallacy .eqv. rhs%fallacy & + ,lhs%actor == rhs%actor & + ,lhs%issues == rhs%issues & + ]) + end function + + function broadcast_default_integer() result(test_passes) + logical test_passes + integer iPhone, me + integer, parameter :: source_value = 7779311, junk = -99 + + call prif_this_image_no_coarray(this_image=me) + iPhone = merge(source_value, junk, me==1) + call prif_co_broadcast(iPhone, source_image=1) + test_passes = source_value == iPhone + end function + + function broadcast_derived_type() result(test_passes) + logical test_passes + type(object_t) object + integer :: me, ni + + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(num_images=ni) + object = object_t(me, .false., "gooey", me*(1.,0.)) + call prif_co_broadcast(object, source_image=ni) + associate(expected_object => object_t(ni, .false., "gooey", ni*(1.,0.))) + test_passes = expected_object == object + end associate + + end function + +end module prif_co_broadcast_test_m diff --git a/test/prif_co_max_test_m.F90 b/test/prif_co_max_test_m.F90 new file mode 100644 index 000000000..fd7bc64f8 --- /dev/null +++ b/test/prif_co_max_test_m.F90 @@ -0,0 +1,210 @@ +! Copyright (c) 2022-2024, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +#include "language-support.F90" + +module prif_co_max_test_m + !! Unit test for the prif_co_max subroutine + use iso_c_binding, only: c_size_t, c_ptr, c_intmax_t, c_null_funptr + use prif, only : prif_co_max, prif_num_images, prif_this_image_no_coarray, prif_num_images + use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : test_function_i +#endif + implicit none + + private + public :: prif_co_max_test_t + + type, extends(test_t) :: prif_co_max_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + +contains + + pure function subject() result(specimen) + character(len=:), allocatable :: specimen + specimen = "The prif_co_max subroutine global maximum computation" + + end function + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(test_description_t), allocatable :: test_descriptions(:) + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + test_descriptions = [ & + test_description_t("default-integer scalars with stat argument", max_default_integer_scalars ) & + ,test_description_t("integer(c_int64_t) scalars with no optional arguments", max_c_int64_scalars ) & + ,test_description_t("default-integer 1D arrays with no optional arguments", max_default_integer_1D_array ) & + ,test_description_t("default-integer 7D arrays with stat argument", max_default_integer_7D_array ) & + ,test_description_t("default-real scalars with stat argument present", max_default_real_scalars ) & + ,test_description_t("double-precision 2D arrays with no optional arguments", max_double_precision_2D_array ) & + ,test_description_t("elements across images with 2D arrays of strings", max_elements_in_2D_string_arrays ) & + ,test_description_t("default-character variables with no optional arguments", reverse_alphabetize_default_characters) & + ] +#else + procedure(test_function_i), pointer :: & + max_default_integer_scalars_ptr => max_default_integer_scalars & + ,max_c_int64_scalars_ptr => max_c_int64_scalars & + ,max_default_integer_1D_array_ptr => max_default_integer_1D_array & + ,max_default_integer_7D_array_ptr => max_default_integer_7D_array & + ,max_default_real_scalars_ptr => max_default_real_scalars & + ,max_double_precision_2D_array_ptr => max_double_precision_2D_array & + ,max_elements_in_2D_string_arrays_ptr => max_elements_in_2D_string_arrays & + ,reverse_alphabetize_default_characters_ptr => reverse_alphabetize_default_characters + + test_descriptions = [ & + test_description_t("default-integer scalars with stat argument", max_default_integer_scalars_ptr ) & + ,test_description_t("integer(c_int64_t) scalars with no optional arguments", max_c_int64_scalars_ptr ) & + ,test_description_t("default-integer 1D arrays with no optional arguments", max_default_integer_1D_array_ptr ) & + ,test_description_t("default-integer 7D arrays with stat argument", max_default_integer_7D_array_ptr ) & + ,test_description_t("default-real scalars with stat argument present", max_default_real_scalars_ptr ) & + ,test_description_t("double-precision 2D arrays with no optional arguments", max_double_precision_2D_array_ptr ) & + ,test_description_t("elements across images with 2D arrays of strings", max_elements_in_2D_string_arrays_ptr ) & + ,test_description_t("default-character variables with no optional arguments", reverse_alphabetize_default_characters_ptr) & + ] +#endif + + test_descriptions = pack(test_descriptions, & + index(subject(), test_description_substring) /= 0 & + .or. test_descriptions%contains_text(test_description_substring)) + + test_results = test_descriptions%run() + end function + + function max_default_integer_scalars() result(test_passes) + logical test_passes + integer i, status_, me, num_imgs + + status_ = -1 + call prif_this_image_no_coarray(this_image=me) + i = -me + call prif_co_max(i, stat=status_) + call prif_num_images(num_images=num_imgs) + test_passes = i == -num_imgs .and. status_ == 0 + end function + + function max_c_int64_scalars() result(test_passes) + use iso_c_binding, only : c_int64_t + logical test_passes + integer(c_int64_t) i + integer :: me + + call prif_this_image_no_coarray(this_image=me) + i = me + call prif_co_max(i) + test_passes = int(i) == 1 + end function + + function max_default_integer_1D_array() result(test_passes) + logical test_passes + integer i, me, num_imgs + integer, allocatable :: array(:) + + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(num_images=num_imgs) + associate(sequence_ => me*[(i, i=1, num_imgs)]) + array = sequence_ + call prif_co_max(array) + associate(min_sequence => [(i, i=1, num_imgs)]) + test_passes = all(min_sequence == array) + end associate + end associate + end function + + function max_default_integer_7D_array() result(test_passes) + logical test_passes + integer array(2,1,1, 1,1,1, 2), status_, me, num_imgs + + status_ = -1 + call prif_this_image_no_coarray(this_image=me) + array = 3 - me + call prif_co_max(array, stat=status_) + call prif_num_images(num_images=num_imgs) + test_passes = all(array == 3 - num_imgs) .and. status_ == 0 + end function + + function max_default_real_scalars() result(test_passes) + logical test_passes + real scalar + real, parameter :: pi = 3.141592654 + integer status_, me, num_imgs + + status_ = -1 + call prif_this_image_no_coarray(this_image=me) + scalar = -pi*me + call prif_co_max(scalar, stat=status_) + call prif_num_images(num_images=num_imgs) + test_passes = -dble(pi*num_imgs) == dble(scalar) .and. status_ == 0 + end function + + function max_double_precision_2D_array() result(test_passes) + logical test_passes + double precision, allocatable :: array(:,:) + double precision, parameter :: tent(*,*) = dble(reshape(-[0,1,2,3,2,1], [3,2])) + integer :: me, num_imgs + + call prif_this_image_no_coarray(this_image=me) + array = tent*dble(me) + call prif_co_max(array) + call prif_num_images(num_images=num_imgs) + test_passes = all(array==tent*num_imgs) + end function + + function max_elements_in_2D_string_arrays() result(test_passes) + logical test_passes + character(len=*), parameter :: script(*) = & + [character(len=len("the question.")) :: "To be ","or not"," to ","be."," That is ","the question."] + character(len=len(script)), dimension(3,2) :: scramlet, co_max_scramlet + integer i, cyclic_permutation(size(script)), me + + call prif_this_image_no_coarray(this_image=me) + associate(cyclic_permutation => [(1 + mod(i-1,size(script)), i=me, me+size(script) )]) + scramlet = reshape(script(cyclic_permutation), shape(scramlet)) + end associate + + co_max_scramlet = scramlet + call prif_co_max(co_max_scramlet, result_image=1) + + block + integer j, delta_j, num_imgs + character(len=len(script)) expected_script(size(script)), expected_scramlet(size(scramlet,1),size(scramlet,2)) + + call prif_num_images(num_images=num_imgs) + do j=1, size(script) + expected_script(j) = script(j) + do delta_j = 1, min(num_imgs-1, size(script)) + associate(periodic_index => 1 + mod(j+delta_j-1, size(script))) + expected_script(j) = min(expected_script(j), script(periodic_index)) + end associate + end do + end do + expected_scramlet = reshape(expected_script, shape(scramlet)) + test_passes = all(scramlet == co_max_scramlet) + end block + + end function + + function reverse_alphabetize_default_characters() result(test_passes) + logical test_passes + integer, parameter :: length = len("to party!") + character(len=length), parameter :: words(*) = [character(len=length):: "Loddy","doddy","we","like","to party!"] + character(len=:), allocatable :: my_word, expected_word + integer :: me, num_imgs + + call prif_this_image_no_coarray(this_image=me) + associate(periodic_index => 1 + mod(me-1,size(words))) + my_word = words(periodic_index) + call prif_co_max(my_word) + end associate + + call prif_num_images(num_images=num_imgs) + ! expected_word = minval(words(1:min(num_imgs, size(words)))) ! this line exposes a flang bug + expected_word = "Loddy" + test_passes = expected_word == my_word + end function + +end module prif_co_max_test_m diff --git a/test/prif_co_min_test_m.F90 b/test/prif_co_min_test_m.F90 new file mode 100644 index 000000000..b5aec7254 --- /dev/null +++ b/test/prif_co_min_test_m.F90 @@ -0,0 +1,210 @@ +! Copyright (c) 2022-2024, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +#include "language-support.F90" + +module prif_co_min_test_m + !! Unit test for the prif_co_min subroutine + use iso_c_binding, only: c_size_t, c_ptr, c_intmax_t, c_null_funptr + use prif, only : prif_co_min, prif_num_images, prif_this_image_no_coarray, prif_num_images + use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : test_function_i +#endif + implicit none + + private + public :: prif_co_min_test_t + + type, extends(test_t) :: prif_co_min_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + +contains + + pure function subject() result(specimen) + character(len=:), allocatable :: specimen + specimen = "The prif_co_min subroutine global minimum computation" + + end function + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(test_description_t), allocatable :: test_descriptions(:) + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + test_descriptions = [ & + test_description_t("default integer scalar with stat argument", min_default_integer_scalars ) & + ,test_description_t("integer(c_int64_t) scalar with no optional arguments", min_c_int64_scalars ) & + ,test_description_t("default integer 1D array elements with no optional arguments", min_default_integer_1D_array ) & + ,test_description_t("default integer 7D array elements with stat argument present", min_default_integer_7D_array ) & + ,test_description_t("default real scalars with stat argument present", min_default_real_scalars ) & + ,test_description_t("double precision 2D array elements with no optional arguments", min_double_precision_2D_array ) & + ,test_description_t("elements across images with 2D arrays of strings", min_elements_in_2D_string_arrays) & + ,test_description_t("length-5 string with no optional arguments", alphabetically_1st_scalar_string) & + ] +#else + procedure(test_function_i), pointer :: & + min_default_integer_scalars_ptr => min_default_integer_scalars & + ,min_c_int64_scalars_ptr => min_c_int64_scalars & + ,min_default_integer_1D_array_ptr => min_default_integer_1D_array & + ,min_default_integer_7D_array_ptr => min_default_integer_7D_array & + ,min_default_real_scalars_ptr => min_default_real_scalars & + ,min_double_precision_2D_array_ptr => min_double_precision_2D_array & + ,min_elements_in_2D_string_arrays_ptr => min_elements_in_2D_string_arrays & + ,alphabetically_1st_scalar_string_ptr => alphabetically_1st_scalar_string + + test_descriptions = [ & + test_description_t("default integer scalar with stat argument", min_default_integer_scalars_ptr ) & + ,test_description_t("integer(c_int64_t) scalar with no optional arguments", min_c_int64_scalars_ptr ) & + ,test_description_t("default integer 1D array elements with no optional arguments", min_default_integer_1D_array_ptr ) & + ,test_description_t("default integer 7D array elements with stat argument present", min_default_integer_7D_array_ptr ) & + ,test_description_t("default real scalars with stat argument present", min_default_real_scalars_ptr ) & + ,test_description_t("double precision 2D array elements with no optional arguments", min_double_precision_2D_array_ptr ) & + ,test_description_t("elements across images with 2D arrays of strings", min_elements_in_2D_string_arrays_ptr) & + ,test_description_t("length-5 string with no optional arguments", alphabetically_1st_scalar_string_ptr) & + ] +#endif + + test_descriptions = pack(test_descriptions, & + index(subject(), test_description_substring) /= 0 & + .or. test_descriptions%contains_text(test_description_substring)) + + test_results = test_descriptions%run() + end function + + function min_default_integer_scalars() result(test_passes) + logical test_passes + integer i, status_, me, num_imgs + + status_ = -1 + call prif_this_image_no_coarray(this_image=me) + i = -me + call prif_co_min(i, stat=status_) + call prif_num_images(num_images=num_imgs) + test_passes = i == -num_imgs .and. status_ == 0 + end function + + function min_c_int64_scalars() result(test_passes) + use iso_c_binding, only : c_int64_t + logical test_passes + integer(c_int64_t) i + integer :: me + + call prif_this_image_no_coarray(this_image=me) + i = me + call prif_co_min(i) + test_passes = int(i) == 1 + end function + + function min_default_integer_1D_array() result(test_passes) + logical test_passes + integer i, me, num_imgs + integer, allocatable :: array(:) + + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(num_images=num_imgs) + associate(sequence_ => me*[(i, i=1, num_imgs)]) + array = sequence_ + call prif_co_min(array) + associate(min_sequence => [(i, i=1, num_imgs)]) + test_passes = all(min_sequence == array) + end associate + end associate + end function + + function min_default_integer_7D_array() result(test_passes) + logical test_passes + integer array(2,1,1, 1,1,1, 2), status_, me, num_imgs + + status_ = -1 + call prif_this_image_no_coarray(this_image=me) + array = 3 - me + call prif_co_min(array, stat=status_) + call prif_num_images(num_images=num_imgs) + test_passes = all(array == 3 - num_imgs) .and. status_ == 0 + end function + + function min_default_real_scalars() result(test_passes) + logical test_passes + real scalar + real, parameter :: pi = 3.141592654 + integer status_, me, num_imgs + + status_ = -1 + call prif_this_image_no_coarray(this_image=me) + scalar = -pi*me + call prif_co_min(scalar, stat=status_) + call prif_num_images(num_images=num_imgs) + test_passes = -dble(pi*num_imgs) == dble(scalar) .and. status_ == 0 + end function + + function min_double_precision_2D_array() result(test_passes) + logical test_passes + double precision, allocatable :: array(:,:) + double precision, parameter :: tent(*,*) = dble(reshape(-[0,1,2,3,2,1], [3,2])) + integer :: me, num_imgs + + call prif_this_image_no_coarray(this_image=me) + array = tent*dble(me) + call prif_co_min(array) + call prif_num_images(num_images=num_imgs) + test_passes = all(array==tent*num_imgs) + end function + + function min_elements_in_2D_string_arrays() result(test_passes) + logical test_passes + character(len=*), parameter :: script(*) = & + [character(len=len("the question.")) :: "To be ","or not"," to ","be."," That is ","the question."] + character(len=len(script)), dimension(3,2) :: scramlet, co_min_scramlet + integer i, cyclic_permutation(size(script)), me + + call prif_this_image_no_coarray(this_image=me) + associate(cyclic_permutation => [(1 + mod(i-1,size(script)), i=me, me+size(script) )]) + scramlet = reshape(script(cyclic_permutation), shape(scramlet)) + end associate + + co_min_scramlet = scramlet + call prif_co_min(co_min_scramlet, result_image=1) + + block + integer j, delta_j, num_imgs + character(len=len(script)) expected_script(size(script)), expected_scramlet(size(scramlet,1),size(scramlet,2)) + + call prif_num_images(num_images=num_imgs) + do j=1, size(script) + expected_script(j) = script(j) + do delta_j = 1, min(num_imgs-1, size(script)) + associate(periodic_index => 1 + mod(j+delta_j-1, size(script))) + expected_script(j) = min(expected_script(j), script(periodic_index)) + end associate + end do + end do + expected_scramlet = reshape(expected_script, shape(scramlet)) + test_passes = all(scramlet == co_min_scramlet) + end block + + end function + + function alphabetically_1st_scalar_string() result(test_passes) + logical test_passes + integer, parameter :: length = len("to party!") + character(len=length), parameter :: words(*) = [character(len=length):: "Loddy","doddy","we","like","to party!"] + character(len=:), allocatable :: my_word, expected_word + integer :: me, num_imgs + + call prif_this_image_no_coarray(this_image=me) + associate(periodic_index => 1 + mod(me-1,size(words))) + my_word = words(periodic_index) + call prif_co_min(my_word) + end associate + + call prif_num_images(num_images=num_imgs) + ! expected_word = minval(words(1:min(num_imgs, size(words)))) ! this line exposes a flang bug + expected_word = "Loddy" + test_passes = expected_word == my_word + end function + +end module prif_co_min_test_m diff --git a/test/prif_co_reduce_test_m.F90 b/test/prif_co_reduce_test_m.F90 new file mode 100644 index 000000000..49b3b3f7e --- /dev/null +++ b/test/prif_co_reduce_test_m.F90 @@ -0,0 +1,299 @@ +! Copyright (c) 2022-2024, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +#include "language-support.F90" + +module prif_co_reduce_test_m + !! Unit test fort the prif_init program inititation subroutine + use prif, only : prif_co_reduce, prif_num_images, prif_this_image_no_coarray, prif_error_stop + use iso_c_binding, only : c_bool, c_funloc, c_char, c_double, c_int64_t + use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : test_function_i +#endif + implicit none + + private + public :: prif_co_reduce_test_t + + type, extends(test_t) :: prif_co_reduce_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + +contains + + pure function subject() result(specimen) + character(len=:), allocatable :: specimen + specimen = "The prif_co_reduce subroutine" + end function + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(test_description_t), allocatable :: test_descriptions(:) + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + test_descriptions = [ & + test_description_t("alphabetical reduction of strings with result_image present", alphabetically_first_string) & + ,test_description_t("sums default integer scalars with no optional arguments", sum_default_integer_scalars) & + ,test_description_t("sums integer(c_int64_t) scalars with no optional arguments", sum_c_int64_t_scalars) & + ,test_description_t("multiplies default real scalars with all optional arguments", multiply_default_real_scalars) & + ,test_description_t("multiplies real(c_double) scalars with all optional arguments", multiply_c_double_scalars) & + ,test_description_t("performs a collective .and. operation across logical scalars", reports_on_consensus) & + ,test_description_t("sums default complex scalars with a stat-variable present", sum_default_complex_scalars) & + ,test_description_t("sums complex(c_double) scalars with a stat-variable present", sum_complex_c_double_scalars) & + ,test_description_t("sums default integer elements of a 2D array across images", sum_integer_array_elements) & + ] +#else + procedure(test_function_i), pointer :: & + alphabetically_first_string_ptr => alphabetically_first_string & + ,sum_default_integer_scalars_ptr => sum_default_integer_scalars & + ,sum_c_int64_t_scalars_ptr => sum_c_int64_t_scalars & + ,multiply_default_real_scalars_ptr => multiply_default_real_scalars & + ,multiply_c_double_scalars_ptr => multiply_c_double_scalars & + ,reports_on_consensus_ptr => reports_on_consensus & + ,sum_default_complex_scalars_ptr => sum_default_complex_scalars & + ,sum_complex_c_double_scalars_ptr => sum_complex_c_double_scalars & + ,sum_integer_array_elements_ptr => sum_integer_array_elements + + test_descriptions = [ & + test_description_t("alphabetical reduction of strings with result_image present", alphabetically_first_string_ptr) & + ,test_description_t("sums default integer scalars with no optional arguments", sum_default_integer_scalars_ptr) & + ,test_description_t("sums integer(c_int64_t) scalars with no optional arguments", sum_c_int64_t_scalars_ptr) & + ,test_description_t("multiplies default real scalars with all optional arguments", multiply_default_real_scalars_ptr) & + ,test_description_t("multiplies real(c_double) scalars with all optional arguments", multiply_c_double_scalars_ptr) & + ,test_description_t("performs a collective .and. operation across logical scalars", reports_on_consensus_ptr) & + ,test_description_t("sums default complex scalars with a stat-variable present", sum_default_complex_scalars_ptr) & + ,test_description_t("sums complex(c_double) scalars with a stat-variable present", sum_complex_c_double_scalars_ptr) & + ,test_description_t("sums default integer elements of a 2D array across images", sum_integer_array_elements_ptr) & + ] +#endif + + test_descriptions = pack(test_descriptions, & + index(subject(), test_description_substring) /= 0 & + .or. test_descriptions%contains_text(test_description_substring)) + + test_results = test_descriptions%run() + end function + + function alphabetically_first_string() result(test_passes) + logical test_passes + character(len=*, kind=c_char), parameter :: names(*) = ["larry","harry","carey","betty","tommy","billy"] + character(len=:, kind=c_char), allocatable :: my_name(:) + character(len=:), allocatable :: expected_name + integer :: me, num_imgs + + call prif_this_image_no_coarray(this_image=me) + associate(periodic_index => 1 + mod(me-1,size(names))) + my_name = [names(periodic_index)] + call prif_co_reduce(my_name, c_funloc(alphabetize)) + end associate + + call prif_num_images(num_images=num_imgs) + !expected_name = minval(names(1:min(num_imgs, size(names)))) ! this exposes a flang bug + expected_name = "betty" + test_passes = all(expected_name == my_name) + + contains + + function alphabetize(lhs, rhs) result(first_alphabetically) + character(len=*), intent(in) :: lhs, rhs + character(len=:), allocatable :: first_alphabetically + + 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 + + end function + + function sum_integer_array_elements() result(test_passes) + logical test_passes + integer status_, num_imgs + integer, parameter :: input_array(*,*) = reshape([1, 2, 3, 4], [2, 2]) + integer array(2,2) + + array = input_array + call prif_co_reduce(array, c_funloc(add_integers)) + call prif_num_images(num_images=num_imgs) + test_passes = all(num_imgs*input_array==array) + + contains + + pure function add_integers(lhs, rhs) result(total) + integer, intent(in) :: lhs, rhs + integer total + total = lhs + rhs + end function + + end function + + function sum_complex_c_double_scalars() result(test_passes) + logical test_passes + integer status_, num_imgs + complex(c_double) z + complex(c_double), parameter :: z_input=(1._c_double, 1._c_double) + + z = z_input + call prif_co_reduce(z, c_funloc(add_complex), stat=status_) + call prif_num_images(num_images=num_imgs) + test_passes = real(num_imgs*z_input, c_double) == real(z, c_double) .and. status_ == 0 + + contains + + pure function add_complex(lhs, rhs) result(total) + complex(c_double), intent(in) :: lhs, rhs + complex(c_double) total + total = lhs + rhs + end function + + end function + + function sum_default_complex_scalars() result(test_passes) + logical test_passes + integer status_, num_imgs + complex z + complex, parameter :: z_input=(1.,1.) + + z = z_input + call prif_co_reduce(z, c_funloc(add_complex), stat=status_) + call prif_num_images(num_images=num_imgs) + test_passes = dble(num_imgs*z_input) == dble(z) .and. status_ == 0 + + contains + + pure function add_complex(lhs, rhs) result(total) + complex, intent(in) :: lhs, rhs + complex total + total = lhs + rhs + end function + + end function + + function sum_default_integer_scalars() result(test_passes) + logical test_passes + integer i, num_imgs + + i = 1 + call prif_co_reduce(i, c_funloc(add)) + call prif_num_images(num_images=num_imgs) + test_passes = num_imgs == i + + contains + + pure function add(lhs, rhs) result(total) + integer, intent(in) :: lhs, rhs + integer total + total = lhs + rhs + end function + + end function + + function sum_c_int64_t_scalars() result(test_passes) + logical test_passes + integer(c_int64_t) i + integer :: num_imgs + + i = 1_c_int64_t + call prif_co_reduce(i, c_funloc(add)) + call prif_num_images(num_images=num_imgs) + test_passes = int(num_imgs, c_int64_t) == i + + contains + + pure function add(lhs, rhs) result(total) + integer(c_int64_t), intent(in) :: lhs, rhs + integer(c_int64_t) total + total = lhs + rhs + end function + + end function + + function reports_on_consensus() result(test_passes) + logical test_passes + logical(c_bool) one_false, one_true, all_true + logical(c_bool), parameter :: c_true=.true._c_bool, c_false=.false._c_bool + logical ans1, ans2, ans3 + integer :: me, num_imgs + + call prif_this_image_no_coarray(this_image=me) + one_false = merge(c_false, c_true, me==1) + call prif_co_reduce(one_false, c_funloc(logical_and)) + + call prif_this_image_no_coarray(this_image=me) + one_true = merge(c_true, c_false, me==1) + call prif_co_reduce(one_true, c_funloc(logical_and)) + + all_true = c_true + call prif_co_reduce(all_true, c_funloc(logical_and)) + call prif_num_images(num_images=num_imgs) + + ans1 = one_false .eqv. c_false + ans2 = one_true .eqv. merge(c_true,c_false,num_imgs==1) + ans3 = all_true .eqv. c_true + test_passes = ans1 .and. ans2 .and. ans3 + + contains + + pure function logical_and(lhs, rhs) result(lhs_and_rhs) + logical(c_bool), intent(in) :: lhs, rhs + logical(c_bool) lhs_and_rhs + lhs_and_rhs = lhs .and. rhs + end function + + end function + + function multiply_c_double_scalars() result(test_passes) + logical test_passes + real(c_double) p + integer j, status_, me, num_imgs + character(len=:), allocatable :: error_message + + error_message = "unused" + call prif_this_image_no_coarray(this_image=me) + p = real(me,c_double) + call prif_co_reduce(p, c_funloc(multiply_doubles), result_image=1, stat=status_, errmsg=error_message) + call prif_num_images(num_images=num_imgs) + associate(expected_result => merge( product([(real(j,c_double), j = 1, num_imgs)]), real(me,c_double), me==1 )) + test_passes = (expected_result == real(p,c_double)) .and. (0 == status_) .and. ("unused" == error_message) + end associate + + contains + + pure function multiply_doubles(lhs, rhs) result(product_) + real(c_double), intent(in) :: lhs, rhs + real(c_double) product_ + product_ = lhs * rhs + end function + + end function + + function multiply_default_real_scalars() result(test_passes) + logical test_passes + real p + integer j, status_, me, num_imgs + character(len=:), allocatable :: error_message + + error_message = "unused" + call prif_this_image_no_coarray(this_image=me) + p = real(me) + call prif_co_reduce(p, c_funloc(multiply), result_image=1, stat=status_, errmsg=error_message) + call prif_num_images(num_images=num_imgs) + associate(expected_result => merge( product([(dble(j), j = 1, num_imgs)]), dble(me), me==1 )) + test_passes = (expected_result == dble(p)) .and. (0 == status_) .and. ("unused" == error_message) + end associate + + contains + + pure function multiply(lhs, rhs) result(product_) + real, intent(in) :: lhs, rhs + real product_ + product_ = lhs * rhs + end function + + end function + +end module prif_co_reduce_test_m diff --git a/test/prif_co_sum_test_m.F90 b/test/prif_co_sum_test_m.F90 new file mode 100644 index 000000000..5b6a3d47e --- /dev/null +++ b/test/prif_co_sum_test_m.F90 @@ -0,0 +1,202 @@ +! Copyright (c) 2022-2024, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +#include "language-support.F90" + +module prif_co_sum_test_m + !! Unit test fort the prif_co_sum program inititation subroutine + use prif, only : prif_co_sum, prif_num_images, prif_this_image_no_coarray + use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : test_function_i +#endif + implicit none + + private + public :: prif_co_sum_test_t + + type, extends(test_t) :: prif_co_sum_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + +contains + + pure function subject() result(specimen) + character(len=:), allocatable :: specimen + specimen = "The prif_co_sum subroutine" + end function + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(test_description_t), allocatable :: test_descriptions(:) + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + test_descriptions = [ & + test_description_t("summing default integer scalars with no optional arguments", sum_default_integer_scalars) & + ,test_description_t("summing default integer scalars with all arguments", sum_integers_all_arguments) & + ,test_description_t("summing integer(c_int64_t) scalars with stat argument", sum_c_int64_scalars) & + ,test_description_t("summing default integer 1D arrays with no optional arguments", sum_default_integer_1D_array) & + ,test_description_t("summing default integer 15D arrays with stat argument", sum_default_integer_15D_array) & + ,test_description_t("summing default real scalars with result_image argument", sum_default_real_scalars) & + ,test_description_t("summing double precision 2D arrays with no optional arguments", sum_double_precision_2D_array) & + ,test_description_t("summing default complex scalars with stat argument", sum_default_complex_scalars) & + ,test_description_t("summing double-precision 1D complex arrays with no optional arguments", sum_dble_complex_1D_arrays) & + ] +#else + procedure(test_function_i), pointer :: & + sum_default_integer_scalars_ptr => sum_default_integer_scalars & + ,sum_integers_all_arguments_ptr => sum_integers_all_arguments & + ,sum_c_int64_scalars_ptr => sum_c_int64_scalars & + ,sum_default_integer_1D_array_ptr => sum_default_integer_1D_array & + ,sum_default_integer_15D_array_ptr => sum_default_integer_15D_array& + ,sum_default_real_scalars_ptr => sum_default_real_scalars & + ,sum_double_precision_2D_array_ptr => sum_double_precision_2D_array& + ,sum_default_complex_scalars_ptr => sum_default_complex_scalars & + ,sum_dble_complex_1D_arrays_ptr => sum_dble_complex_1D_arrays + + test_descriptions = [ & + test_description_t("summing default integer scalars with no optional arguments", sum_default_integer_scalars_ptr) & + ,test_description_t("summing default integer scalars with all arguments", sum_integers_all_arguments_ptr) & + ,test_description_t("summing integer(c_int64_t) scalars with stat argument", sum_c_int64_scalars_ptr) & + ,test_description_t("summing default integer 1D arrays with no optional arguments", sum_default_integer_1D_array_ptr) & + ,test_description_t("summing default integer 15D arrays with stat argument", sum_default_integer_15D_array_ptr)& + ,test_description_t("summing default real scalars with result_image argument", sum_default_real_scalars_ptr) & + ,test_description_t("summing double precision 2D arrays with no optional arguments", sum_double_precision_2D_array_ptr)& + ,test_description_t("summing default complex scalars with stat argument", sum_default_complex_scalars_ptr) & + ,test_description_t("summing double-precision 1D complex arrays with no optional arguments", sum_dble_complex_1D_arrays_ptr)& + ] +#endif + + test_descriptions = pack(test_descriptions, & + index(subject(), test_description_substring) /= 0 & + .or. test_descriptions%contains_text(test_description_substring)) + + test_results = test_descriptions%run() + end function + + function sum_default_integer_scalars() result(test_passes) + logical test_passes + integer i, num_imgs + + i = 1 + call prif_co_sum(i) + call prif_num_images(num_images=num_imgs) + test_passes = num_imgs == i + end function + + function sum_integers_all_arguments() result(test_passes) + logical test_passes + integer i, status_, result_image_, me, num_imgs + character(len=*), parameter :: whitespace = repeat(" ", ncopies=29) + character(len=:), allocatable :: error_message + + i = 1 + result_image_ = 1 + status_ = -1 + error_message = whitespace + + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(num_images=num_imgs) + associate(expected_i => merge(num_imgs*i, i, me==result_image_)) + call prif_co_sum(i, result_image_, status_, error_message) + test_passes = (expected_i == i) .and. (status_ == 0) .and. (whitespace == error_message) + end associate + end function + + function sum_c_int64_scalars() result(test_passes) + use iso_c_binding, only : c_int64_t + logical test_passes + integer(c_int64_t) i + integer i_default_kind, status_, num_imgs + + status_ = -1 + i = 2_c_int64_t + call prif_co_sum(i, stat=status_) + i_default_kind = i + call prif_num_images(num_images=num_imgs) + test_passes = (2*num_imgs == int(i)) .and. (status_ == 0) + end function + + function sum_default_integer_1D_array() result(test_passes) + logical test_passes + integer i, images + integer, allocatable :: array(:) + + call prif_num_images(num_images=images) + associate(sequence_ => [(i,i=1,images)]) + array = sequence_ + call prif_co_sum(array) + test_passes = all(array == images*sequence_) + end associate + end function + + function sum_default_integer_15D_array() result(test_passes) + logical test_passes + integer array(2,1,1, 1,1,1, 1,1,1, 1,1,1, 1,2,1) + integer status_, num_imgs + + status_ = -1 + array = 3 + call prif_co_sum(array, stat=status_) + call prif_num_images(num_images=num_imgs) + test_passes = (all(3*num_imgs == array)) .and. (0 == status_) + end function + + function sum_default_real_scalars() result(test_passes) + logical test_passes + real scalar + real, parameter :: e = 2.7182818459045 + integer result_image_, me, num_imgs + + result_image_ = 1 + scalar = e + call prif_co_sum(scalar, result_image=result_image_) + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(num_images=num_imgs) + associate(expected_result => merge(num_imgs*e, e, me==result_image_)) + test_passes = dble(expected_result) == dble(scalar) + end associate + end function + + function sum_double_precision_2D_array() result(test_passes) + logical test_passes + double precision, allocatable :: array(:,:) + double precision, parameter :: input(*,*) = reshape(-[6,5,4,3,2,1], [3,2]) + integer :: num_imgs + + array = input + call prif_co_sum(array) + call prif_num_images(num_images=num_imgs) + test_passes = product(num_imgs*input) == product(array) + end function + + function sum_default_complex_scalars() result(test_passes) + logical test_passes + real scalar + complex z + complex, parameter :: i=(0.,1.) + integer status_, num_imgs + + status_ = -1 + z = i + call prif_co_sum(z, stat=status_) + call prif_num_images(num_images=num_imgs) + test_passes = (dble(abs(i*num_imgs)) == dble(abs(z)) ) .and. (status_ == 0) + end function + + function sum_dble_complex_1D_arrays() result(test_passes) + logical test_passes + integer, parameter :: dp = kind(1.D0) + integer :: num_imgs + complex(dp), allocatable :: array(:) + complex(dp), parameter :: input(*) = [(1.D0,1.0D0)] + + array = [(1.D0,1.D0)] + call prif_co_sum(array) + call prif_num_images(num_images=num_imgs) + test_passes = all([input*num_imgs] == array) + end function + +end module prif_co_sum_test_m diff --git a/test/prif_image_index_m.F90 b/test/prif_image_index_m.F90 new file mode 100644 index 000000000..3a90726ce --- /dev/null +++ b/test/prif_image_index_m.F90 @@ -0,0 +1,143 @@ +! Copyright (c) 2022-2024, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +#include "language-support.F90" + +module prif_image_index_test_m + !! Unit test for the prif_image_index subroutine + use iso_c_binding, only: c_int, c_intmax_t, c_ptr, c_size_t, c_null_funptr + use prif, only: prif_coarray_handle, prif_allocate_coarray, prif_deallocate_coarray, prif_image_index, prif_num_images + use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : test_function_i +#endif + implicit none + + private + public :: prif_image_index_test_t + + type, extends(test_t) :: prif_image_index_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + +contains + + pure function subject() result(specimen) + character(len=:), allocatable :: specimen + specimen = "The prif_image_index subroutine" + end function + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(test_description_t), allocatable :: test_descriptions(:) + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + test_descriptions = [ & + test_description_t("returning 1 for the simplest case", check_simple_case) & + ,test_description_t("returning 1 when given the lower bounds", check_lower_bounds) & + ,test_description_t("returning 0 with invalid subscripts", check_invalid_subscripts) & + ,test_description_t("returning the expected answer for a more complicated case", check_complicated) & + ] + +#else + procedure(test_function_i), pointer :: & + check_simple_case_ptr, & + check_lower_bounds_ptr, & + check_invalid_subscripts_ptr, & + check_complicated_ptr + + check_simple_case_ptr => check_simple_case + check_lower_bounds_ptr => check_lower_bounds + check_invalid_subscripts_ptr => check_invalid_subscripts + check_complicated_ptr => check_complicated + + test_descriptions = [ & + test_description_t("returning 1 for the simplest case", check_simple_case_ptr) & + ,test_description_t("returning 1 when given the lower bounds", check_lower_bounds_ptr) & + ,test_description_t("returning 0 with invalid subscripts", check_invalid_subscripts_ptr) & + ,test_description_t("returning the expected answer for a more complicated case", check_complicated_ptr) & + ] +#endif + + test_descriptions = pack(test_descriptions, & + index(subject(), test_description_substring) /= 0 .or. test_descriptions%contains_text(test_description_substring)) + test_results = test_descriptions%run() + end function + + + function check_simple_case() result(test_passes) + logical test_passes + type(prif_coarray_handle) :: coarray_handle + type(c_ptr) :: allocated_memory + integer(c_int) :: answer + + call prif_allocate_coarray( & + lcobounds = [1_c_intmax_t], & + ucobounds = [2_c_intmax_t], & + size_in_bytes = 1_c_size_t, & + final_func = c_null_funptr, & + coarray_handle = coarray_handle, & + allocated_memory = allocated_memory) + call prif_image_index(coarray_handle, [1_c_intmax_t], image_index=answer) + test_passes = answer == 1_c_int + call prif_deallocate_coarray([coarray_handle]) + end function + + function check_lower_bounds() result(test_passes) + logical test_passes + type(prif_coarray_handle) coarray_handle + type(c_ptr) allocated_memory + integer(c_int) answer + + call prif_allocate_coarray( & + lcobounds = [2_c_intmax_t, 3_c_intmax_t], & + ucobounds = [3_c_intmax_t, 4_c_intmax_t], & + size_in_bytes = 1_c_size_t, & + final_func = c_null_funptr, & + coarray_handle = coarray_handle, & + allocated_memory = allocated_memory) + call prif_image_index(coarray_handle, [2_c_intmax_t, 3_c_intmax_t], image_index=answer) + test_passes = answer == 1_c_int + call prif_deallocate_coarray([coarray_handle]) + end function + + function check_invalid_subscripts() result(test_passes) + logical test_passes + type(prif_coarray_handle) coarray_handle + type(c_ptr) allocated_memory + integer(c_int) answer + + call prif_allocate_coarray( & + lcobounds = [-2_c_intmax_t, 2_c_intmax_t], & + ucobounds = [2_c_intmax_t, 6_c_intmax_t], & + size_in_bytes = 1_c_size_t, & + final_func = c_null_funptr, & + coarray_handle = coarray_handle, & + allocated_memory = allocated_memory) + call prif_image_index(coarray_handle, [-1_c_intmax_t, 1_c_intmax_t], image_index=answer) + test_passes = answer == 0_c_int + call prif_deallocate_coarray([coarray_handle]) + end function + + function check_complicated() result(test_passes) + logical test_passes + type(prif_coarray_handle) coarray_handle + type(c_ptr) allocated_memory + integer(c_int) answer, ni + + call prif_num_images(num_images=ni) + call prif_allocate_coarray( & + lcobounds = [1_c_intmax_t, 2_c_intmax_t], & + ucobounds = [2_c_intmax_t, 3_c_intmax_t], & + final_func = c_null_funptr, & + size_in_bytes = 1_c_size_t, & + coarray_handle = coarray_handle, & + allocated_memory = allocated_memory) + call prif_image_index(coarray_handle, [1_c_intmax_t, 3_c_intmax_t], image_index=answer) + test_passes = answer == merge(3_c_int, 0_c_int, ni >= 3) + call prif_deallocate_coarray([coarray_handle]) + end function + +end module prif_image_index_test_m diff --git a/test/prif_init_test_m.F90 b/test/prif_init_test_m.F90 new file mode 100644 index 000000000..82f84fb61 --- /dev/null +++ b/test/prif_init_test_m.F90 @@ -0,0 +1,79 @@ +! Copyright (c) 2022-2024, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +#include "language-support.F90" + +module prif_init_test_m + !! Unit test fort the prif_init program inititation subroutine + use prif, only : prif_init, PRIF_STAT_ALREADY_INIT + use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : test_function_i +#endif + implicit none + + private + public :: prif_init_test_t + + type, extends(test_t) :: prif_init_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + +contains + + pure function subject() result(specimen) + character(len=:), allocatable :: specimen + specimen = "The prif_init subroutine" + end function + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(test_description_t), allocatable :: test_descriptions(:) + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + test_descriptions = [ & + test_description_t("completing normally when called once", check_caffeination), & + test_description_t("returning PRIF_STAT_ALREADY_INIT when called a second time", check_subsequent_prif_init_call) & + ] +#else + procedure(test_function_i), pointer :: check_caffeination_ptr, check_subsequent_prif_init_call_ptr + + check_caffeination_ptr => check_caffeination + check_subsequent_prif_init_call_ptr => check_subsequent_prif_init_call + + test_descriptions = [ & + test_description_t("completing normally when called once", check_caffeination_ptr) & + ,test_description_t("returning PRIF_STAT_ALREADY_INIT when called a second time", check_subsequent_prif_init_call_ptr) & + ] +#endif + + test_descriptions = pack(test_descriptions, & + index(subject(), test_description_substring) /= 0 & + .or. test_descriptions%contains_text(test_description_substring)) + + test_results = test_descriptions%run() + end function + + function check_caffeination() result(test_passes) + !! check program initiation + logical test_passes + integer, parameter :: successful_initiation = 0 + integer init_exit_code + + call prif_init(init_exit_code) + test_passes = init_exit_code == successful_initiation + end function + + function check_subsequent_prif_init_call() result(test_passes) + logical test_passes + + integer :: stat + + call prif_init(stat) + call prif_init(stat) + test_passes = stat == PRIF_STAT_ALREADY_INIT + end function + +end module prif_init_test_m diff --git a/test/prif_num_images_test_m.F90 b/test/prif_num_images_test_m.F90 new file mode 100644 index 000000000..0cc90c925 --- /dev/null +++ b/test/prif_num_images_test_m.F90 @@ -0,0 +1,63 @@ +! Copyright (c) 2022-2024, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +#include "language-support.F90" + +module prif_num_images_test_m + !! Unit test for the prif_num_images subroutine + use prif, only : prif_num_images + use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : test_function_i +#endif + implicit none + + private + public :: prif_num_images_test_t + + type, extends(test_t) :: prif_num_images_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + +contains + + pure function subject() result(specimen) + character(len=:), allocatable :: specimen + specimen = "The prif_num_images subroutine" + end function + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(test_description_t), allocatable :: test_descriptions(:) + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + test_descriptions = [ & + test_description_t("providing a valid number of images when called with no arguments", check_num_images_valid) & + ] +#else + procedure(test_function_i), pointer :: check_num_images_valid_ptr + + check_num_images_valid_ptr => check_num_images_valid + + test_descriptions = [ & + test_description_t("providing a valid number of images when invoked with no arguments", check_num_images_valid_ptr) & + ] +#endif + + test_descriptions = pack(test_descriptions, & + index(subject(), test_description_substring) /= 0 & + .or. test_descriptions%contains_text(test_description_substring)) + + test_results = test_descriptions%run() + end function + + function check_num_images_valid() result(test_passes) + logical test_passes + integer num_imgs + call prif_num_images(num_images=num_imgs) + test_passes = num_imgs > 0 + end function + +end module prif_num_images_test_m diff --git a/test/prif_rma_test_m.F90 b/test/prif_rma_test_m.F90 new file mode 100644 index 000000000..c38a1e09f --- /dev/null +++ b/test/prif_rma_test_m.F90 @@ -0,0 +1,273 @@ +! Copyright (c) 2022-2024, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +#include "language-support.F90" + +module prif_rma_test_m + !! Unit test fort the prif_rma program inititation subroutine + use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring + use iso_c_binding, only: & + c_ptr, c_intmax_t, c_intptr_t, c_size_t, c_null_funptr, c_f_pointer, c_loc, c_sizeof + use prif, only: & + prif_coarray_handle, & + prif_allocate_coarray, & + prif_deallocate_coarray, & + prif_allocate, & + prif_deallocate, & + prif_num_images, & + prif_put, & + prif_put_indirect, & + prif_get, & + prif_get_indirect, & + prif_sync_all, & + prif_this_image_no_coarray +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : test_function_i +#endif + implicit none + + private + public :: prif_rma_test_t + + type, extends(test_t) :: prif_rma_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + +contains + + pure function subject() result(specimen) + character(len=:), allocatable :: specimen + specimen = "The prif_rma subroutine" + end function + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(test_description_t), allocatable :: test_descriptions(:) + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + test_descriptions = [ & + test_description_t("sending a value to another image", check_put) & + ,test_description_t("sending a value with indirect interface", check_put_indirect) & + ,test_description_t("getting a value from another image", check_get) & + ,test_description_t("getting a value with indirect interface", check_get_indirect) & + ] +#else + procedure(test_function_i), pointer :: & + check_put_ptr => check_put & + ,check_put_indirect_ptr => check_put_indirect & + ,check_get_ptr => check_get & + ,check_get_indirect_ptr => check_get_indirect + + test_descriptions = [ & + test_description_t("sending a value to another image", check_put_ptr) & + ,test_description_t("sending a value with indirect interface", check_put_indirect_ptr) & + ,test_description_t("getting a value from another image", check_get_ptr) & + ,test_description_t("getting a value with indirect interface", check_get_indirect_ptr) & + ] +#endif + + test_descriptions = pack(test_descriptions, & + index(subject(), test_description_substring) /= 0 & + .or. test_descriptions%contains_text(test_description_substring)) + + test_results = test_descriptions%run() + end function + + function check_put() result(test_passes) + logical test_passes + + integer :: dummy_element, num_imgs, expected, neighbor + integer, target :: me + type(prif_coarray_handle) :: coarray_handle + type(c_ptr) :: allocated_memory + integer, pointer :: local_slice + integer(c_intmax_t) :: lcobounds(1), ucobounds(1) + + call prif_num_images(num_images=num_imgs) + lcobounds(1) = 1 + ucobounds(1) = num_imgs + call prif_allocate_coarray( & + lcobounds = lcobounds, & + ucobounds = ucobounds, & + size_in_bytes = int(storage_size(dummy_element)/8, c_size_t), & + final_func = c_null_funptr, & + coarray_handle = coarray_handle, & + allocated_memory = allocated_memory) + call c_f_pointer(allocated_memory, local_slice) + + call prif_this_image_no_coarray(this_image=me) + neighbor = merge(me+1, 1, me < num_imgs) + expected = merge(me-1, num_imgs, me > 1) + + call prif_put( & + image_num = neighbor, & + coarray_handle = coarray_handle, & + offset = 0_c_size_t, & + current_image_buffer = c_loc(me), & + size_in_bytes = c_sizeof(me)) + call prif_sync_all + + test_passes = expected == local_slice + + call prif_deallocate_coarray([coarray_handle]) + end function + + function check_put_indirect() result(test_passes) + logical test_passes + + type :: my_type + type(c_ptr) :: my_component + end type + + type(my_type), target :: dummy_element + integer, pointer :: component_access + integer :: dummy_component, num_imgs, expected, neighbor + integer, target :: me + type(prif_coarray_handle) :: coarray_handle + type(c_ptr) :: allocated_memory + type(my_type), pointer :: local_slice + integer(c_intmax_t) :: lcobounds(1), ucobounds(1) + integer(c_intptr_t) :: base_addr + + call prif_num_images(num_images=num_imgs) + lcobounds(1) = 1 + ucobounds(1) = num_imgs + call prif_allocate_coarray( & + lcobounds = lcobounds, & + ucobounds = ucobounds, & + size_in_bytes = int(storage_size(dummy_element)/8, c_size_t), & + final_func = c_null_funptr, & + coarray_handle = coarray_handle, & + allocated_memory = allocated_memory) + call c_f_pointer(allocated_memory, local_slice) + call prif_allocate( & + size_in_bytes = int(storage_size(dummy_component)/8, c_size_t), & + allocated_memory = local_slice%my_component) + call prif_sync_all + + call prif_this_image_no_coarray(this_image=me) + neighbor = merge(me+1, 1, me < num_imgs) + expected = merge(me-1, num_imgs, me > 1) + + call prif_get( & + image_num = neighbor, & + coarray_handle = coarray_handle, & + offset = 0_c_size_t, & + current_image_buffer = c_loc(dummy_element), & + size_in_bytes = int(storage_size(dummy_element)/8, c_size_t)) + base_addr = transfer(dummy_element%my_component, base_addr) + call prif_put_indirect( & + image_num = neighbor, & + remote_ptr = base_addr, & + current_image_buffer = c_loc(me), & + size_in_bytes = int(storage_size(me)/8, c_size_t)) + call prif_sync_all + + call c_f_pointer(local_slice%my_component, component_access) + test_passes = expected == component_access + + call prif_deallocate(local_slice%my_component) + call prif_deallocate_coarray([coarray_handle]) + end function + + function check_get() result(test_passes) + logical test_passes + + integer :: dummy_element, num_imgs, me, neighbor, expected + integer, target :: retrieved + type(prif_coarray_handle) :: coarray_handle + type(c_ptr) :: allocated_memory + integer, pointer :: local_slice + integer(c_intmax_t) :: lcobounds(1), ucobounds(1) + + call prif_num_images(num_images=num_imgs) + lcobounds(1) = 1 + ucobounds(1) = num_imgs + call prif_allocate_coarray( & + lcobounds = lcobounds, & + ucobounds = ucobounds, & + size_in_bytes = int(storage_size(dummy_element)/8, c_size_t), & + final_func = c_null_funptr, & + coarray_handle = coarray_handle, & + allocated_memory = allocated_memory) + call c_f_pointer(allocated_memory, local_slice) + + call prif_this_image_no_coarray(this_image=me) + neighbor = merge(me+1, 1, me < num_imgs) + expected = neighbor + local_slice = me + call prif_sync_all + + call prif_get( & + image_num = neighbor, & + coarray_handle = coarray_handle, & + offset = 0_c_size_t, & + current_image_buffer = c_loc(retrieved), & + size_in_bytes = c_sizeof(retrieved)) + + test_passes = expected == retrieved + + call prif_deallocate_coarray([coarray_handle]) + end function + + function check_get_indirect() result(test_passes) + logical test_passes + + type :: my_type + type(c_ptr) :: my_component + end type + + type(my_type), target :: dummy_element + integer, pointer :: component_access + integer :: dummy_component, num_imgs, me, expected, neighbor + integer, target :: retrieved + type(prif_coarray_handle) :: coarray_handle + type(c_ptr) :: allocated_memory + type(my_type), pointer :: local_slice + integer(c_intmax_t) :: lcobounds(1), ucobounds(1) + integer(c_intptr_t) :: base_addr + + call prif_num_images(num_images=num_imgs) + lcobounds(1) = 1 + ucobounds(1) = num_imgs + call prif_allocate_coarray( & + lcobounds = lcobounds, & + ucobounds = ucobounds, & + size_in_bytes = int(storage_size(dummy_element)/8, c_size_t), & + final_func = c_null_funptr, & + coarray_handle = coarray_handle, & + allocated_memory = allocated_memory) + call c_f_pointer(allocated_memory, local_slice) + call prif_allocate( & + size_in_bytes = int(storage_size(dummy_component)/8, c_size_t), & + allocated_memory = local_slice%my_component) + + call prif_this_image_no_coarray(this_image=me) + neighbor = merge(me+1, 1, me < num_imgs) + expected = neighbor + call c_f_pointer(local_slice%my_component, component_access) + component_access = me + call prif_sync_all + + call prif_get( & + image_num = neighbor, & + coarray_handle = coarray_handle, & + offset = 0_c_size_t, & + current_image_buffer = c_loc(dummy_element), & + size_in_bytes = int(storage_size(dummy_element)/8, c_size_t)) + base_addr = transfer(dummy_element%my_component, base_addr) + call prif_get_indirect( & + image_num = neighbor, & + remote_ptr = base_addr, & + current_image_buffer = c_loc(retrieved), & + size_in_bytes = int(storage_size(retrieved)/8, c_size_t)) + + test_passes = expected == retrieved + + call prif_deallocate(local_slice%my_component) + call prif_deallocate_coarray([coarray_handle]) + end function + +end module diff --git a/test/prif_teams_test_m.F90 b/test/prif_teams_test_m.F90 new file mode 100644 index 000000000..51c20eefe --- /dev/null +++ b/test/prif_teams_test_m.F90 @@ -0,0 +1,90 @@ +! Copyright (c) 2022-2024, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +#include "language-support.F90" + +module prif_teams_test_m + !! Unit test for Caffeine's support for teams + use iso_c_binding, only: c_size_t, c_ptr, c_intmax_t, c_null_funptr + use prif, only: & + prif_coarray_handle, prif_allocate_coarray, prif_deallocate_coarray, prif_this_image_no_coarray, prif_num_images & + ,prif_team_type, prif_form_team, prif_change_team, prif_end_team + use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : test_function_i +#endif + implicit none + + private + public :: prif_teams_test_t + + type, extends(test_t) :: prif_teams_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + +contains + + pure function subject() result(specimen) + character(len=:), allocatable :: specimen + specimen = "The teams feature set" + end function + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(test_description_t), allocatable :: test_descriptions(:) + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + test_descriptions = [test_description_t("team creation, change, and coarray allocation", check_teams)] + +#else + procedure(test_function_i), pointer :: check_teams_ptr + check_teams_ptr => check_teams + test_descriptions = [test_description_t("team creation, change, and coarray allocation", check_teams_ptr)] +#endif + + test_descriptions = pack(test_descriptions, & + index(subject(), test_description_substring) /= 0 & + .or. test_descriptions%contains_text(test_description_substring)) + + test_results = test_descriptions%run() + end function + + function check_teams() result(test_passes) + logical test_passes + integer dummy_element, initial_num_imgs, num_imgs, me, i + integer(c_size_t) element_size + integer(c_intmax_t) which_team + integer, parameter :: num_coarrays = 4 + type(prif_coarray_handle) coarrays(num_coarrays) + type(c_ptr) allocated_memory + type(prif_team_type) team + + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(num_images=initial_num_imgs) + which_team = merge(1_c_intmax_t, 2_c_intmax_t, mod(me, 2) == 0) + call prif_form_team(team_number = which_team, team = team) + call prif_change_team(team) + call prif_num_images(num_images=num_imgs) + + test_passes = num_imgs == initial_num_imgs/2 + mod(initial_num_imgs,2)*(int(which_team)-1) + + do i = 1, num_coarrays + call prif_allocate_coarray( & + lcobounds = [1_c_intmax_t], & + ucobounds = [int(num_imgs, c_intmax_t)], & + final_func = c_null_funptr, & + size_in_bytes = int(storage_size(dummy_element)/8, c_size_t), & + coarray_handle = coarrays(i), & + allocated_memory = allocated_memory) + end do + call prif_deallocate_coarray(coarrays(4:4)) + call prif_deallocate_coarray(coarrays(2:2)) + + ! TODO: use final_func to observe automatic deallocation of coarrays + + call prif_end_team() + end function + +end module prif_teams_test_m diff --git a/test/prif_this_image_test_m.F90 b/test/prif_this_image_test_m.F90 new file mode 100644 index 000000000..e56dcd1aa --- /dev/null +++ b/test/prif_this_image_test_m.F90 @@ -0,0 +1,68 @@ +! Copyright (c) 2022-2024, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +#include "language-support.F90" + +module prif_this_image_test_m + !! Unit test for the prif_this_image subroutine + use prif, only : prif_this_image_no_coarray, prif_num_images, prif_co_sum + use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : test_function_i +#endif + implicit none + + private + public :: prif_this_image_test_t + + type, extends(test_t) :: prif_this_image_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + +contains + + pure function subject() result(specimen) + character(len=:), allocatable :: specimen + specimen = "The prif_this_image_no_coarray subroutine" + end function + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(test_description_t), allocatable :: test_descriptions(:) + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + test_descriptions = [ & + test_description_t("returning its member of the image set if called with no arguments", check_this_image_set) & + ] +#else + procedure(test_function_i), pointer :: check_this_image_set_ptr + + check_this_image_set_ptr => check_this_image_set + + test_descriptions = [ & + test_description_t("returning its member of the image set if called with no arguments", check_this_image_set_ptr) & + ] +#endif + + test_descriptions = pack(test_descriptions, & + index(subject(), test_description_substring) /= 0 & + .or. test_descriptions%contains_text(test_description_substring)) + + test_results = test_descriptions%run() + end function + + function check_this_image_set() result(test_passes) + logical test_passes + integer, allocatable :: image_numbers(:) + integer i, me, ni + + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(num_images=ni) + image_numbers = [(merge(0, me, me/=i), i = 1, ni)] + call prif_co_sum(image_numbers) + test_passes = all(image_numbers == [(i, i = 1, ni)]) .and. size(image_numbers) > 0 + end function + +end module prif_this_image_test_m From 7ebab05e441d71bd709355c21190de69e0f0be1a Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Sat, 28 Dec 2024 10:41:29 -0500 Subject: [PATCH 02/29] chore(fpm.toml): switch dev-dependencies This commit replaces veggies and iso_varying_string in the fpm manifest with julienne and assert. --- manifest/fpm.toml.template | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/manifest/fpm.toml.template b/manifest/fpm.toml.template index c7137b7ef..b3bcae4d9 100644 --- a/manifest/fpm.toml.template +++ b/manifest/fpm.toml.template @@ -6,7 +6,7 @@ maintainer = "rouson@lbl.gov" copyright = "2021-2024 UC Regents" [dev-dependencies] -veggies = {git = "https://gitlab.com/everythingfunctional/veggies", tag = "v1.1.3"} -iso_varying_string = {git = "https://gitlab.com/everythingfunctional/iso_varying_string.git", tag = "v3.0.4"} +julienne = {git = "https://github.com/berkeleylab/julienne.git", tag = "1.5.3"} +assert = {git = "https://github.com/berkeleylab/assert.git", tag = "2.0.0"} [build] From 1d87e743a8a3ef6716065c2eb77123e9059dbc9a Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Sat, 28 Dec 2024 13:34:02 -0500 Subject: [PATCH 03/29] chore(test): preprocess test main git mv main.{f,F}90 --- test/{main.f90 => main.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename test/{main.f90 => main.F90} (100%) diff --git a/test/main.f90 b/test/main.F90 similarity index 100% rename from test/main.f90 rename to test/main.F90 From d70e76ce8aa85661b41e15c859fe7ed24c723ea8 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Sat, 28 Dec 2024 13:48:28 -0500 Subject: [PATCH 04/29] fix(test/main): always call prif_init This commit fixes a problem that caused seg faults when running subsets of tests. Previously, if the subset didn't include the prif_init test, then prif_init was never called. This commit calls prif_init in test/main.F90 before running the tests. Consequently, the test for normal execution of prif_init now happens via an assertion rather than in a unit test. --- test/main.F90 | 31 +++++++------------------------ test/prif_init_test_m.F90 | 35 +++++++++-------------------------- 2 files changed, 16 insertions(+), 50 deletions(-) diff --git a/test/main.F90 b/test/main.F90 index b552ead87..0f0c5e3ee 100644 --- a/test/main.F90 +++ b/test/main.F90 @@ -1,7 +1,7 @@ ! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt -!#include "assert_macros.h" +#include "assert_macros.h" program main !! Test the Caffeine implementation of the Parallel Runtime Interface for Fortran (PRIF) @@ -20,23 +20,23 @@ program main use prif_co_min_test_m, only : prif_co_min_test_t use prif_co_reduce_test_m, only : prif_co_reduce_test_t use prif_co_sum_test_m, only : prif_co_sum_test_t - !use prif_error_stop_test_m, only : prif_error_stop_test_t use prif_image_index_test_m, only : prif_image_index_test_t use prif_init_test_m, only : prif_init_test_t use prif_num_images_test_m, only : prif_num_images_test_t use prif_rma_test_m, only : prif_rma_test_t - !use prif_stop_test_m, only : prif_stop_test_t use prif_teams_test_m, only : prif_teams_test_t use prif_this_image_test_m, only : prif_this_image_test_t implicit none + integer, parameter :: successful=0 integer :: passes=0, tests=0 - integer me + integer me, init_status call stop_and_print_usage_info_if_help_requested + call prif_init(stat=init_status) + call_assert(init_status==successful) call run_tests_and_report(passes, tests) call prif_this_image_no_coarray(this_image=me) - if (me==1) print "(a,*(a,G0))", new_line(''), "_________ In total, ",passes," of ",tests, " tests pass. _________" call prif_sync_all if (passes /= tests) call prif_error_stop(quiet=.false._c_bool) @@ -75,10 +75,7 @@ subroutine run_tests_and_report(passes, tests) type(prif_rma_test_t) prif_rma_test type(prif_teams_test_t) prif_teams_test type(prif_this_image_test_t) prif_this_image_test - !type(prif_error_stop_test_t) prif_error_stop_test - !type(prif_stop_test_t) prif_stop_test - call prif_init_test%report(passes, tests) ! This test must run first call prif_allocate_test%report(passes, tests) call prif_co_broadcast_test%report(passes, tests) call prif_co_max_test%report(passes, tests) @@ -86,25 +83,11 @@ subroutine run_tests_and_report(passes, tests) call prif_co_reduce_test%report(passes, tests) call prif_co_sum_test%report(passes, tests) call prif_image_index_test%report(passes, tests) + call prif_init_test%report(passes, tests) call prif_num_images_test%report(passes, tests) + call prif_rma_test%report(passes, tests) call prif_teams_test%report(passes, tests) call prif_this_image_test%report(passes, tests) - call prif_rma_test%report(passes, tests) - !call prif_stop_test%report(passes, tests) - !call prif_error_stop_test%report(passes, tests) -!#ifdef __flang__ - !print * - !print *,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!" - !print * - !print *,"LLVM Flang detected. Skipping tests that crash:" - !print *," - prif_co_max_test" - !print *," - prif_co_min_test" - !print *," - prif_co_reduce_test" - !print *," - prif_co_sum_test" - !print *," - prif_image_index_test" - !print * - !print *,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!" -!#endif end subroutine run_tests_and_report diff --git a/test/prif_init_test_m.F90 b/test/prif_init_test_m.F90 index 82f84fb61..ae8a43d94 100644 --- a/test/prif_init_test_m.F90 +++ b/test/prif_init_test_m.F90 @@ -34,46 +34,29 @@ function results() result(test_results) #if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY test_descriptions = [ & - test_description_t("completing normally when called once", check_caffeination), & - test_description_t("returning PRIF_STAT_ALREADY_INIT when called a second time", check_subsequent_prif_init_call) & + test_description_t("returning PRIF_STAT_ALREADY_INIT when called a second time", check_redundant_prif_init_call) & ] #else - procedure(test_function_i), pointer :: check_caffeination_ptr, check_subsequent_prif_init_call_ptr - - check_caffeination_ptr => check_caffeination - check_subsequent_prif_init_call_ptr => check_subsequent_prif_init_call + procedure(test_function_i), pointer :: check_caffeination_ptr, check_redundant_prif_init_call_ptr + check_redundant_prif_init_call_ptr => check_redundant_prif_init_call test_descriptions = [ & - test_description_t("completing normally when called once", check_caffeination_ptr) & - ,test_description_t("returning PRIF_STAT_ALREADY_INIT when called a second time", check_subsequent_prif_init_call_ptr) & + test_description_t("returning PRIF_STAT_ALREADY_INIT when called a second time", check_redundant_prif_init_call_ptr) & ] #endif test_descriptions = pack(test_descriptions, & index(subject(), test_description_substring) /= 0 & .or. test_descriptions%contains_text(test_description_substring)) - test_results = test_descriptions%run() end function - function check_caffeination() result(test_passes) - !! check program initiation + function check_redundant_prif_init_call() result(test_passes) logical test_passes - integer, parameter :: successful_initiation = 0 - integer init_exit_code - - call prif_init(init_exit_code) - test_passes = init_exit_code == successful_initiation - end function - - function check_subsequent_prif_init_call() result(test_passes) - logical test_passes - - integer :: stat - - call prif_init(stat) - call prif_init(stat) - test_passes = stat == PRIF_STAT_ALREADY_INIT + integer stat + call prif_init(stat) + call prif_init(stat) + test_passes = stat == PRIF_STAT_ALREADY_INIT end function end module prif_init_test_m From b0354e1427e8253977aaefd4f99eeab2ef53935b Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Sat, 28 Dec 2024 14:18:17 -0500 Subject: [PATCH 05/29] test(stopis): def new project to test termination As suggested in the following comment, this commit defines a separate project for testing program termination: https://github.com/BerkeleyLab/caffeine/pull/133#discussion_r1761996357 --- {example/support-test => test-termination}/README.md | 0 {src/caffeine => test-termination/src}/unit_test_parameters_m.f90 | 0 .../test}/error_stop_with_character_code.f90 | 0 .../test}/error_stop_with_integer_code.f90 | 0 .../test}/error_stop_with_no_code.f90 | 0 .../test}/register_stop_callback.f90 | 0 .../test}/stop_with_character_code.f90 | 0 .../test}/stop_with_integer_code.f90 | 0 .../support-test => test-termination/test}/stop_with_no_code.f90 | 0 9 files changed, 0 insertions(+), 0 deletions(-) rename {example/support-test => test-termination}/README.md (100%) rename {src/caffeine => test-termination/src}/unit_test_parameters_m.f90 (100%) rename {example/support-test => test-termination/test}/error_stop_with_character_code.f90 (100%) rename {example/support-test => test-termination/test}/error_stop_with_integer_code.f90 (100%) rename {example/support-test => test-termination/test}/error_stop_with_no_code.f90 (100%) rename {example/support-test => test-termination/test}/register_stop_callback.f90 (100%) rename {example/support-test => test-termination/test}/stop_with_character_code.f90 (100%) rename {example/support-test => test-termination/test}/stop_with_integer_code.f90 (100%) rename {example/support-test => test-termination/test}/stop_with_no_code.f90 (100%) diff --git a/example/support-test/README.md b/test-termination/README.md similarity index 100% rename from example/support-test/README.md rename to test-termination/README.md diff --git a/src/caffeine/unit_test_parameters_m.f90 b/test-termination/src/unit_test_parameters_m.f90 similarity index 100% rename from src/caffeine/unit_test_parameters_m.f90 rename to test-termination/src/unit_test_parameters_m.f90 diff --git a/example/support-test/error_stop_with_character_code.f90 b/test-termination/test/error_stop_with_character_code.f90 similarity index 100% rename from example/support-test/error_stop_with_character_code.f90 rename to test-termination/test/error_stop_with_character_code.f90 diff --git a/example/support-test/error_stop_with_integer_code.f90 b/test-termination/test/error_stop_with_integer_code.f90 similarity index 100% rename from example/support-test/error_stop_with_integer_code.f90 rename to test-termination/test/error_stop_with_integer_code.f90 diff --git a/example/support-test/error_stop_with_no_code.f90 b/test-termination/test/error_stop_with_no_code.f90 similarity index 100% rename from example/support-test/error_stop_with_no_code.f90 rename to test-termination/test/error_stop_with_no_code.f90 diff --git a/example/support-test/register_stop_callback.f90 b/test-termination/test/register_stop_callback.f90 similarity index 100% rename from example/support-test/register_stop_callback.f90 rename to test-termination/test/register_stop_callback.f90 diff --git a/example/support-test/stop_with_character_code.f90 b/test-termination/test/stop_with_character_code.f90 similarity index 100% rename from example/support-test/stop_with_character_code.f90 rename to test-termination/test/stop_with_character_code.f90 diff --git a/example/support-test/stop_with_integer_code.f90 b/test-termination/test/stop_with_integer_code.f90 similarity index 100% rename from example/support-test/stop_with_integer_code.f90 rename to test-termination/test/stop_with_integer_code.f90 diff --git a/example/support-test/stop_with_no_code.f90 b/test-termination/test/stop_with_no_code.f90 similarity index 100% rename from example/support-test/stop_with_no_code.f90 rename to test-termination/test/stop_with_no_code.f90 From b425d2f7eb0d85dbcbdd198dc5532b2664ec8328 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Sat, 28 Dec 2024 14:32:07 -0500 Subject: [PATCH 06/29] doc(test-termination): update README.md --- test-termination/README.md | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/test-termination/README.md b/test-termination/README.md index 399282e7c..db3bcb7cc 100644 --- a/test-termination/README.md +++ b/test-termination/README.md @@ -1,7 +1,8 @@ -Test Support ------------- -The programs in this directory intentionally terminate to support the `stop` and `error stop` -unit tests, which use Fortran's `execute_command_line` to run the programs in this directory -and to check for the expected non-zero stop codes. Running the tests in this manner enables -the tests to continue executing after the child process launched by `execute_command_line` -terminates. +Test Termination +---------------- +The code in this subdirectory intentionally terminate to test the following +procedures and interface from prif.F90: + - `prif_error_stop` + - `prif_register_stop_callback` + - `prif_stop_callback_interface` + - `prif_stop` From ad8f546d23cc4199be3ea8b9c09bbc796c1923b6 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Sat, 28 Dec 2024 14:46:22 -0500 Subject: [PATCH 07/29] doc(test-termination): update README.md --- test-termination/README.md | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/test-termination/README.md b/test-termination/README.md index db3bcb7cc..3af011b32 100644 --- a/test-termination/README.md +++ b/test-termination/README.md @@ -6,3 +6,32 @@ procedures and interface from prif.F90: - `prif_register_stop_callback` - `prif_stop_callback_interface` - `prif_stop` + +Usage +----- +To build or rebuild and run the tests in this subdirectory, execute the following +commands: +``` +fpm clean --all +cd .. +./install.sh +cd - +mkdir build +cp ../build/run-fpm.sh build +../build/run-fpm.sh test +``` +which should yield trailing output similar to the following: +``` + ERROR STOP 'USER_PROVIDED_STRING' + callback invoked + STOP + STOP 'USER_PROVIDED_STRING' + STOP 99 + STOP + Execution for object " error_stop_with_character_code " returned exit code 1 + Execution for object " error_stop_with_integer_code " returned exit code 100 + Execution for object " error_stop_with_no_code " returned exit code 1 + Execution for object " stop_with_integer_code " returned exit code 99 + *cmd_run*:stopping due to failed executions +STOP 1 +``` From 435d14830dc9b60aad3f3cead2b9f3eca0579a27 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Sat, 28 Dec 2024 23:49:18 -0500 Subject: [PATCH 08/29] rm(co_reduce_test): rm temporary code This commit removes code that was temporarily inserted when diagnosing a flang bug and uncomments the correct code. --- test/prif_co_reduce_test_m.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/test/prif_co_reduce_test_m.F90 b/test/prif_co_reduce_test_m.F90 index 49b3b3f7e..f5a9b6dea 100644 --- a/test/prif_co_reduce_test_m.F90 +++ b/test/prif_co_reduce_test_m.F90 @@ -91,8 +91,7 @@ function alphabetically_first_string() result(test_passes) end associate call prif_num_images(num_images=num_imgs) - !expected_name = minval(names(1:min(num_imgs, size(names)))) ! this exposes a flang bug - expected_name = "betty" + expected_name = minval(names(1:min(num_imgs, size(names)))) ! this exposes a flang bug test_passes = all(expected_name == my_name) contains From ce8aa06257a75296331eb5359ee131c1f5bbe03f Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Sun, 29 Dec 2024 01:07:21 -0500 Subject: [PATCH 09/29] test: extend test_t, override report binding This commit defines a new prif_test_t type that extends Julienne's test_t type in ordero to override test_t's "report" type-bound procedure in order to replace parallel Fortran featuers with PRIF calls. --- test/main.F90 | 2 +- test/prif_allocate_test_m.F90 | 10 ++-- test/prif_co_broadcast_test_m.F90 | 5 +- test/prif_co_max_test_m.F90 | 5 +- test/prif_co_min_test_m.F90 | 5 +- test/prif_co_reduce_test_m.F90 | 5 +- test/prif_co_sum_test_m.F90 | 5 +- test/prif_image_index_m.F90 | 5 +- test/prif_init_test_m.F90 | 5 +- test/prif_num_images_test_m.F90 | 5 +- test/prif_rma_test_m.F90 | 5 +- test/prif_teams_test_m.F90 | 5 +- test/prif_test_m.f90 | 30 ++++++++++++ test/prif_test_s.f90 | 79 +++++++++++++++++++++++++++++++ test/prif_this_image_test_m.F90 | 5 +- 15 files changed, 148 insertions(+), 28 deletions(-) create mode 100644 test/prif_test_m.f90 create mode 100644 test/prif_test_s.f90 diff --git a/test/main.F90 b/test/main.F90 index 0f0c5e3ee..7a1b853f0 100644 --- a/test/main.F90 +++ b/test/main.F90 @@ -1,4 +1,4 @@ -! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute +! Copyright (c) 2020-2024, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt #include "assert_macros.h" diff --git a/test/prif_allocate_test_m.F90 b/test/prif_allocate_test_m.F90 index da7cf3cd7..3126b7519 100644 --- a/test/prif_allocate_test_m.F90 +++ b/test/prif_allocate_test_m.F90 @@ -7,10 +7,10 @@ module prif_allocate_test_m !! Unit test for Caffeine's support for symmetric and asymmetric memory allocations use prif, only : prif_allocate_coarray, prif_deallocate_coarray, prif_coarray_handle & ,prif_allocate, prif_deallocate, prif_num_images - use julienne_m, only : test_t , string_t & - ,test_result_t , vector_function_strategy_t & - ,test_description_t , vector_test_description_t & - ,test_description_substring + use prif_test_m, only : prif_test_t, test_description_substring + use julienne_m, only : test_result_t , vector_function_strategy_t, string_t & + ,test_description_t, vector_test_description_t + #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY use julienne_m, only : test_function_i #endif @@ -20,7 +20,7 @@ module prif_allocate_test_m private public :: prif_allocate_test_t - type, extends(test_t) :: prif_allocate_test_t + type, extends(prif_test_t) :: prif_allocate_test_t contains procedure, nopass :: subject procedure, nopass :: results diff --git a/test/prif_co_broadcast_test_m.F90 b/test/prif_co_broadcast_test_m.F90 index f269c8dad..4c7eda15c 100644 --- a/test/prif_co_broadcast_test_m.F90 +++ b/test/prif_co_broadcast_test_m.F90 @@ -6,7 +6,8 @@ module prif_co_broadcast_test_m !! Unit test for the prif_co_broadcast subroutine use prif, only : prif_co_broadcast, prif_num_images, prif_this_image_no_coarray - use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring + use prif_test_m, only : prif_test_t, test_description_substring + use julienne_m, only : test_t, test_result_t, test_description_t #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY use julienne_m, only : test_function_i #endif @@ -15,7 +16,7 @@ module prif_co_broadcast_test_m private public :: prif_co_broadcast_test_t - type, extends(test_t) :: prif_co_broadcast_test_t + type, extends(prif_test_t) :: prif_co_broadcast_test_t contains procedure, nopass :: subject procedure, nopass :: results diff --git a/test/prif_co_max_test_m.F90 b/test/prif_co_max_test_m.F90 index fd7bc64f8..5f01ea05f 100644 --- a/test/prif_co_max_test_m.F90 +++ b/test/prif_co_max_test_m.F90 @@ -7,7 +7,8 @@ module prif_co_max_test_m !! Unit test for the prif_co_max subroutine use iso_c_binding, only: c_size_t, c_ptr, c_intmax_t, c_null_funptr use prif, only : prif_co_max, prif_num_images, prif_this_image_no_coarray, prif_num_images - use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring + use prif_test_m, only : prif_test_t, test_description_substring + use julienne_m, only : test_result_t, test_description_t #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY use julienne_m, only : test_function_i #endif @@ -16,7 +17,7 @@ module prif_co_max_test_m private public :: prif_co_max_test_t - type, extends(test_t) :: prif_co_max_test_t + type, extends(prif_test_t) :: prif_co_max_test_t contains procedure, nopass :: subject procedure, nopass :: results diff --git a/test/prif_co_min_test_m.F90 b/test/prif_co_min_test_m.F90 index b5aec7254..2da2de53b 100644 --- a/test/prif_co_min_test_m.F90 +++ b/test/prif_co_min_test_m.F90 @@ -7,7 +7,8 @@ module prif_co_min_test_m !! Unit test for the prif_co_min subroutine use iso_c_binding, only: c_size_t, c_ptr, c_intmax_t, c_null_funptr use prif, only : prif_co_min, prif_num_images, prif_this_image_no_coarray, prif_num_images - use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring + use prif_test_m, only : prif_test_t, test_description_substring + use julienne_m, only : test_result_t, test_description_t #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY use julienne_m, only : test_function_i #endif @@ -16,7 +17,7 @@ module prif_co_min_test_m private public :: prif_co_min_test_t - type, extends(test_t) :: prif_co_min_test_t + type, extends(prif_test_t) :: prif_co_min_test_t contains procedure, nopass :: subject procedure, nopass :: results diff --git a/test/prif_co_reduce_test_m.F90 b/test/prif_co_reduce_test_m.F90 index f5a9b6dea..72df3c74c 100644 --- a/test/prif_co_reduce_test_m.F90 +++ b/test/prif_co_reduce_test_m.F90 @@ -6,8 +6,9 @@ module prif_co_reduce_test_m !! Unit test fort the prif_init program inititation subroutine use prif, only : prif_co_reduce, prif_num_images, prif_this_image_no_coarray, prif_error_stop + use prif_test_m, only : prif_test_t, test_description_substring use iso_c_binding, only : c_bool, c_funloc, c_char, c_double, c_int64_t - use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring + use julienne_m, only : test_result_t, test_description_t #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY use julienne_m, only : test_function_i #endif @@ -16,7 +17,7 @@ module prif_co_reduce_test_m private public :: prif_co_reduce_test_t - type, extends(test_t) :: prif_co_reduce_test_t + type, extends(prif_test_t) :: prif_co_reduce_test_t contains procedure, nopass :: subject procedure, nopass :: results diff --git a/test/prif_co_sum_test_m.F90 b/test/prif_co_sum_test_m.F90 index 5b6a3d47e..d0d204157 100644 --- a/test/prif_co_sum_test_m.F90 +++ b/test/prif_co_sum_test_m.F90 @@ -6,7 +6,8 @@ module prif_co_sum_test_m !! Unit test fort the prif_co_sum program inititation subroutine use prif, only : prif_co_sum, prif_num_images, prif_this_image_no_coarray - use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring + use prif_test_m, only : prif_test_t, test_description_substring + use julienne_m, only : test_result_t, test_description_t #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY use julienne_m, only : test_function_i #endif @@ -15,7 +16,7 @@ module prif_co_sum_test_m private public :: prif_co_sum_test_t - type, extends(test_t) :: prif_co_sum_test_t + type, extends(prif_test_t) :: prif_co_sum_test_t contains procedure, nopass :: subject procedure, nopass :: results diff --git a/test/prif_image_index_m.F90 b/test/prif_image_index_m.F90 index 3a90726ce..aff2ba0e4 100644 --- a/test/prif_image_index_m.F90 +++ b/test/prif_image_index_m.F90 @@ -7,7 +7,8 @@ module prif_image_index_test_m !! Unit test for the prif_image_index subroutine use iso_c_binding, only: c_int, c_intmax_t, c_ptr, c_size_t, c_null_funptr use prif, only: prif_coarray_handle, prif_allocate_coarray, prif_deallocate_coarray, prif_image_index, prif_num_images - use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring + use prif_test_m, only: prif_test_t, test_description_substring + use julienne_m, only : test_result_t, test_description_t #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY use julienne_m, only : test_function_i #endif @@ -16,7 +17,7 @@ module prif_image_index_test_m private public :: prif_image_index_test_t - type, extends(test_t) :: prif_image_index_test_t + type, extends(prif_test_t) :: prif_image_index_test_t contains procedure, nopass :: subject procedure, nopass :: results diff --git a/test/prif_init_test_m.F90 b/test/prif_init_test_m.F90 index ae8a43d94..ff10f336f 100644 --- a/test/prif_init_test_m.F90 +++ b/test/prif_init_test_m.F90 @@ -6,7 +6,8 @@ module prif_init_test_m !! Unit test fort the prif_init program inititation subroutine use prif, only : prif_init, PRIF_STAT_ALREADY_INIT - use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring + use prif_test_m, only : prif_test_t, test_description_substring + use julienne_m, only : test_result_t, test_description_t #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY use julienne_m, only : test_function_i #endif @@ -15,7 +16,7 @@ module prif_init_test_m private public :: prif_init_test_t - type, extends(test_t) :: prif_init_test_t + type, extends(prif_test_t) :: prif_init_test_t contains procedure, nopass :: subject procedure, nopass :: results diff --git a/test/prif_num_images_test_m.F90 b/test/prif_num_images_test_m.F90 index 0cc90c925..a5db1e0a9 100644 --- a/test/prif_num_images_test_m.F90 +++ b/test/prif_num_images_test_m.F90 @@ -6,7 +6,8 @@ module prif_num_images_test_m !! Unit test for the prif_num_images subroutine use prif, only : prif_num_images - use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring + use prif_test_m, only : prif_test_t, test_description_substring + use julienne_m, only : test_t, test_result_t, test_description_t #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY use julienne_m, only : test_function_i #endif @@ -15,7 +16,7 @@ module prif_num_images_test_m private public :: prif_num_images_test_t - type, extends(test_t) :: prif_num_images_test_t + type, extends(prif_test_t) :: prif_num_images_test_t contains procedure, nopass :: subject procedure, nopass :: results diff --git a/test/prif_rma_test_m.F90 b/test/prif_rma_test_m.F90 index c38a1e09f..1d59df708 100644 --- a/test/prif_rma_test_m.F90 +++ b/test/prif_rma_test_m.F90 @@ -5,9 +5,10 @@ module prif_rma_test_m !! Unit test fort the prif_rma program inititation subroutine - use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring + use julienne_m, only : test_t, test_result_t, test_description_t use iso_c_binding, only: & c_ptr, c_intmax_t, c_intptr_t, c_size_t, c_null_funptr, c_f_pointer, c_loc, c_sizeof + use prif_test_m, only : prif_test_t, test_description_substring use prif, only: & prif_coarray_handle, & prif_allocate_coarray, & @@ -29,7 +30,7 @@ module prif_rma_test_m private public :: prif_rma_test_t - type, extends(test_t) :: prif_rma_test_t + type, extends(prif_test_t) :: prif_rma_test_t contains procedure, nopass :: subject procedure, nopass :: results diff --git a/test/prif_teams_test_m.F90 b/test/prif_teams_test_m.F90 index 51c20eefe..4017f870f 100644 --- a/test/prif_teams_test_m.F90 +++ b/test/prif_teams_test_m.F90 @@ -6,10 +6,11 @@ module prif_teams_test_m !! Unit test for Caffeine's support for teams use iso_c_binding, only: c_size_t, c_ptr, c_intmax_t, c_null_funptr + use prif_test_m, only : prif_test_t, test_description_substring use prif, only: & prif_coarray_handle, prif_allocate_coarray, prif_deallocate_coarray, prif_this_image_no_coarray, prif_num_images & ,prif_team_type, prif_form_team, prif_change_team, prif_end_team - use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring + use julienne_m, only : test_result_t, test_description_t #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY use julienne_m, only : test_function_i #endif @@ -18,7 +19,7 @@ module prif_teams_test_m private public :: prif_teams_test_t - type, extends(test_t) :: prif_teams_test_t + type, extends(prif_test_t) :: prif_teams_test_t contains procedure, nopass :: subject procedure, nopass :: results diff --git a/test/prif_test_m.f90 b/test/prif_test_m.f90 new file mode 100644 index 000000000..5f0562130 --- /dev/null +++ b/test/prif_test_m.f90 @@ -0,0 +1,30 @@ +! Copyright (c) 2022-2024, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt +module prif_test_m + !! Override Julienne's test_t type-bound procedure "report" to replace parallel Fortran featuers with PRIF calls + use julienne_m, only : test_t + implicit none + + private + public :: prif_test_t + public :: test_description_substring + + type, abstract, extends(test_t) :: prif_test_t + contains + procedure report + end type + + character(len=:), allocatable, protected :: test_description_substring + + interface + + module subroutine report(test, passes, tests) + !! Print the test results and increment the tallies of passing tests and total tests + implicit none + class(prif_test_t), intent(in) :: test + integer, intent(inout) :: passes, tests + end subroutine + + end interface + +end module prif_test_m diff --git a/test/prif_test_s.f90 b/test/prif_test_s.f90 new file mode 100644 index 000000000..9bc2a50e1 --- /dev/null +++ b/test/prif_test_s.f90 @@ -0,0 +1,79 @@ +! Copyright (c) 2020-2024, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt +submodule(prif_test_m) prif_test_s + use iso_c_binding, only : c_funloc, c_bool + use julienne_m, only : command_line_t + use prif, only : prif_this_image_no_coarray, prif_co_broadcast, prif_co_reduce + use prif_test_m, only : test_description_substring + implicit none + +contains + + subroutine co_all(boolean) + logical(c_bool), intent(inout) :: boolean + call prif_co_reduce(boolean, c_funloc(both)) + contains + pure function both(lhs,rhs) result(lhs_and_rhs) + logical(c_bool), intent(in) :: lhs, rhs + logical(c_bool) lhs_and_rhs + lhs_and_rhs = lhs .and. rhs + end function + end subroutine + + module procedure report + integer me + + call prif_this_image_no_coarray(this_image=me) + + if (me==1) then + + first_report: & + if (.not. allocated(test_description_substring)) then + block + type(command_line_t) command_line + test_description_substring = command_line%flag_value("--contains") + end block + print * + if (len(test_description_substring)==0) then + print '(a)',"Running all tests." + print '(a)',"(Add '-- --contains ' to run only tests with subjects or descriptions containing the specified string.)" + else + print '(*(a))',"Running only tests with subjects or descriptions containing '", test_description_substring,"'." + end if + end if first_report + + print '(*(a))', new_line('a'), test%subject() + + end if + + call prif_co_broadcast(test_description_substring, source_image=1) + + associate(test_results => test%results()) + associate(num_tests => size(test_results)) + tests = tests + num_tests + if (me==1) then + block + integer i + do i=1,num_tests + if (me==1) print '(3x,a)', test_results(i)%characterize() + end do + end block + end if + block + logical(c_bool), allocatable :: passing_tests(:) + integer test + passing_tests = test_results%passed() + do test = 1, size(passing_tests) + call co_all(passing_tests(test)) + end do + associate(num_passes => count(passing_tests)) + if (me==1) print '(a,2(i0,a))'," ",num_passes," of ", num_tests," tests pass." + passes = passes + num_passes + end associate + end block + end associate + end associate + + end procedure + +end submodule prif_test_s diff --git a/test/prif_this_image_test_m.F90 b/test/prif_this_image_test_m.F90 index e56dcd1aa..675af3c75 100644 --- a/test/prif_this_image_test_m.F90 +++ b/test/prif_this_image_test_m.F90 @@ -6,7 +6,8 @@ module prif_this_image_test_m !! Unit test for the prif_this_image subroutine use prif, only : prif_this_image_no_coarray, prif_num_images, prif_co_sum - use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring + use prif_test_m, only : prif_test_t, test_description_substring + use julienne_m, only : test_result_t, test_description_t #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY use julienne_m, only : test_function_i #endif @@ -15,7 +16,7 @@ module prif_this_image_test_m private public :: prif_this_image_test_t - type, extends(test_t) :: prif_this_image_test_t + type, extends(prif_test_t) :: prif_this_image_test_t contains procedure, nopass :: subject procedure, nopass :: results From c2b765f16b1948c5879547c19b7a59ff962c3596 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Sun, 29 Dec 2024 01:39:39 -0500 Subject: [PATCH 10/29] fix(co_min_test): simplify logic --- test/prif_co_min_test_m.F90 | 46 +++++++++++++------------------------ 1 file changed, 16 insertions(+), 30 deletions(-) diff --git a/test/prif_co_min_test_m.F90 b/test/prif_co_min_test_m.F90 index 2da2de53b..6f1ddd4de 100644 --- a/test/prif_co_min_test_m.F90 +++ b/test/prif_co_min_test_m.F90 @@ -152,41 +152,28 @@ function min_double_precision_2D_array() result(test_passes) array = tent*dble(me) call prif_co_min(array) call prif_num_images(num_images=num_imgs) - test_passes = all(array==tent*num_imgs) + test_passes = all(array==tent*dble(num_imgs)) end function function min_elements_in_2D_string_arrays() result(test_passes) logical test_passes - character(len=*), parameter :: script(*) = & - [character(len=len("the question.")) :: "To be ","or not"," to ","be."," That is ","the question."] - character(len=len(script)), dimension(3,2) :: scramlet, co_min_scramlet - integer i, cyclic_permutation(size(script)), me + character(len=*), parameter :: script(*,*,*) = reshape( & + [ "To be ","or not " & ! odd images get + , "to ","be. " & ! this slice: script(:,:,1) + !-------------------------- + , "that ","is " & ! even images get + , "the ","question"], & ! this slice: script(:,:,2) + [2,2,2]) + character(len=len(script)), dimension(size(script,1),size(script,2)) :: slice + integer me, ni call prif_this_image_no_coarray(this_image=me) - associate(cyclic_permutation => [(1 + mod(i-1,size(script)), i=me, me+size(script) )]) - scramlet = reshape(script(cyclic_permutation), shape(scramlet)) + call prif_num_images(ni) + slice = script(:,:,mod(me-1,size(script,3))+1) + call prif_co_min(slice) + associate(expected => minval(script(:,:,1:min(ni,size(script,3))), dim=3)) + test_passes = all(expected == slice) end associate - - co_min_scramlet = scramlet - call prif_co_min(co_min_scramlet, result_image=1) - - block - integer j, delta_j, num_imgs - character(len=len(script)) expected_script(size(script)), expected_scramlet(size(scramlet,1),size(scramlet,2)) - - call prif_num_images(num_images=num_imgs) - do j=1, size(script) - expected_script(j) = script(j) - do delta_j = 1, min(num_imgs-1, size(script)) - associate(periodic_index => 1 + mod(j+delta_j-1, size(script))) - expected_script(j) = min(expected_script(j), script(periodic_index)) - end associate - end do - end do - expected_scramlet = reshape(expected_script, shape(scramlet)) - test_passes = all(scramlet == co_min_scramlet) - end block - end function function alphabetically_1st_scalar_string() result(test_passes) @@ -203,8 +190,7 @@ function alphabetically_1st_scalar_string() result(test_passes) end associate call prif_num_images(num_images=num_imgs) - ! expected_word = minval(words(1:min(num_imgs, size(words)))) ! this line exposes a flang bug - expected_word = "Loddy" + expected_word = minval(words(1:min(num_imgs, size(words)))) ! this line exposes a flang bug test_passes = expected_word == my_word end function From 3f26d78b9accacbc271dc4b143adc91c8f9cbba1 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Sun, 29 Dec 2024 02:03:40 -0500 Subject: [PATCH 11/29] fix(com_max_test): borrow logic from co_min_test --- test/prif_co_max_test_m.F90 | 93 ++++++++++++++++--------------------- 1 file changed, 40 insertions(+), 53 deletions(-) diff --git a/test/prif_co_max_test_m.F90 b/test/prif_co_max_test_m.F90 index 5f01ea05f..ec38e5f50 100644 --- a/test/prif_co_max_test_m.F90 +++ b/test/prif_co_max_test_m.F90 @@ -78,115 +78,103 @@ function results() result(test_results) function max_default_integer_scalars() result(test_passes) logical test_passes - integer i, status_, me, num_imgs + integer i, status_, n status_ = -1 - call prif_this_image_no_coarray(this_image=me) - i = -me + call prif_this_image_no_coarray(this_image=i) call prif_co_max(i, stat=status_) - call prif_num_images(num_images=num_imgs) - test_passes = i == -num_imgs .and. status_ == 0 + call prif_num_images(num_images=n) + test_passes = i == n .and. status_ == 0 end function function max_c_int64_scalars() result(test_passes) use iso_c_binding, only : c_int64_t logical test_passes integer(c_int64_t) i - integer :: me + integer me, status_, n + status_ = -1 call prif_this_image_no_coarray(this_image=me) i = me - call prif_co_max(i) - test_passes = int(i) == 1 + call prif_co_max(i, stat=status_) + call prif_num_images(num_images=n) + test_passes = i == int(n) end function function max_default_integer_1D_array() result(test_passes) logical test_passes - integer i, me, num_imgs + integer i, me, n integer, allocatable :: array(:) call prif_this_image_no_coarray(this_image=me) - call prif_num_images(num_images=num_imgs) - associate(sequence_ => me*[(i, i=1, num_imgs)]) + call prif_num_images(num_images=n) + associate(sequence_ => me*[(i, i=1, n)]) array = sequence_ call prif_co_max(array) - associate(min_sequence => [(i, i=1, num_imgs)]) - test_passes = all(min_sequence == array) + associate(max_sequence => n*[(i, i=1, n)]) + test_passes = all(max_sequence == array) end associate end associate end function function max_default_integer_7D_array() result(test_passes) logical test_passes - integer array(2,1,1, 1,1,1, 2), status_, me, num_imgs + integer array(2,1,1, 1,1,1, 2), status_, me, n status_ = -1 call prif_this_image_no_coarray(this_image=me) array = 3 - me call prif_co_max(array, stat=status_) - call prif_num_images(num_images=num_imgs) - test_passes = all(array == 3 - num_imgs) .and. status_ == 0 + call prif_num_images(num_images=n) + test_passes = all(array == 3 - 1) .and. status_ == 0 end function function max_default_real_scalars() result(test_passes) logical test_passes real scalar real, parameter :: pi = 3.141592654 - integer status_, me, num_imgs + integer status_, me, n status_ = -1 call prif_this_image_no_coarray(this_image=me) scalar = -pi*me call prif_co_max(scalar, stat=status_) - call prif_num_images(num_images=num_imgs) - test_passes = -dble(pi*num_imgs) == dble(scalar) .and. status_ == 0 + call prif_num_images(num_images=n) + test_passes = -dble(pi*1) == dble(scalar) .and. status_ == 0 end function function max_double_precision_2D_array() result(test_passes) logical test_passes double precision, allocatable :: array(:,:) double precision, parameter :: tent(*,*) = dble(reshape(-[0,1,2,3,2,1], [3,2])) - integer :: me, num_imgs + integer :: me, n call prif_this_image_no_coarray(this_image=me) array = tent*dble(me) call prif_co_max(array) - call prif_num_images(num_images=num_imgs) - test_passes = all(array==tent*num_imgs) + call prif_num_images(num_images=n) + test_passes = all(array==tent*dble(1)) end function function max_elements_in_2D_string_arrays() result(test_passes) logical test_passes - character(len=*), parameter :: script(*) = & - [character(len=len("the question.")) :: "To be ","or not"," to ","be."," That is ","the question."] - character(len=len(script)), dimension(3,2) :: scramlet, co_max_scramlet - integer i, cyclic_permutation(size(script)), me + character(len=*), parameter :: script(*,*,*) = reshape( & + [ "To be ","or not " & ! odd images get + , "to ","be. " & ! this slice: script(:,:,1) + !-------------------------- + , "that ","is " & ! even images get + , "the ","question"], & ! this slice: script(:,:,2) + [2,2,2]) + character(len=len(script)), dimension(size(script,1),size(script,2)) :: slice + integer me, ni call prif_this_image_no_coarray(this_image=me) - associate(cyclic_permutation => [(1 + mod(i-1,size(script)), i=me, me+size(script) )]) - scramlet = reshape(script(cyclic_permutation), shape(scramlet)) + call prif_num_images(ni) + slice = script(:,:,mod(me-1,size(script,3))+1) + call prif_co_max(slice) + associate(expected => maxval(script(:,:,1:min(ni,size(script,3))), dim=3)) + test_passes = all(expected == slice) end associate - - co_max_scramlet = scramlet - call prif_co_max(co_max_scramlet, result_image=1) - - block - integer j, delta_j, num_imgs - character(len=len(script)) expected_script(size(script)), expected_scramlet(size(scramlet,1),size(scramlet,2)) - - call prif_num_images(num_images=num_imgs) - do j=1, size(script) - expected_script(j) = script(j) - do delta_j = 1, min(num_imgs-1, size(script)) - associate(periodic_index => 1 + mod(j+delta_j-1, size(script))) - expected_script(j) = min(expected_script(j), script(periodic_index)) - end associate - end do - end do - expected_scramlet = reshape(expected_script, shape(scramlet)) - test_passes = all(scramlet == co_max_scramlet) - end block - end function function reverse_alphabetize_default_characters() result(test_passes) @@ -194,7 +182,7 @@ function reverse_alphabetize_default_characters() result(test_passes) integer, parameter :: length = len("to party!") character(len=length), parameter :: words(*) = [character(len=length):: "Loddy","doddy","we","like","to party!"] character(len=:), allocatable :: my_word, expected_word - integer :: me, num_imgs + integer :: me, n call prif_this_image_no_coarray(this_image=me) associate(periodic_index => 1 + mod(me-1,size(words))) @@ -202,9 +190,8 @@ function reverse_alphabetize_default_characters() result(test_passes) call prif_co_max(my_word) end associate - call prif_num_images(num_images=num_imgs) - ! expected_word = minval(words(1:min(num_imgs, size(words)))) ! this line exposes a flang bug - expected_word = "Loddy" + call prif_num_images(num_images=n) + expected_word = maxval(words(1:min(n, size(words)))) ! this line exposes a flang bug test_passes = expected_word == my_word end function From dec2d23d4c4824d30baeb509e7b8913251c71d8d Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Sun, 29 Dec 2024 02:34:31 -0500 Subject: [PATCH 12/29] fix(co_reduce_test): improve logic --- test/prif_co_reduce_test_m.F90 | 49 ++++++++++++++++------------------ 1 file changed, 23 insertions(+), 26 deletions(-) diff --git a/test/prif_co_reduce_test_m.F90 b/test/prif_co_reduce_test_m.F90 index 72df3c74c..adbcef8a8 100644 --- a/test/prif_co_reduce_test_m.F90 +++ b/test/prif_co_reduce_test_m.F90 @@ -2,10 +2,12 @@ ! Terms of use are as specified in LICENSE.txt #include "language-support.F90" +#include "assert_macros.h" module prif_co_reduce_test_m !! Unit test fort the prif_init program inititation subroutine - use prif, only : prif_co_reduce, prif_num_images, prif_this_image_no_coarray, prif_error_stop + use assert_m + use prif, only : prif_co_reduce, prif_num_images, prif_this_image_no_coarray, prif_error_stop, prif_co_max use prif_test_m, only : prif_test_t, test_description_substring use iso_c_binding, only : c_bool, c_funloc, c_char, c_double, c_int64_t use julienne_m, only : test_result_t, test_description_t @@ -36,15 +38,15 @@ function results() result(test_results) #if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY test_descriptions = [ & - test_description_t("alphabetical reduction of strings with result_image present", alphabetically_first_string) & - ,test_description_t("sums default integer scalars with no optional arguments", sum_default_integer_scalars) & - ,test_description_t("sums integer(c_int64_t) scalars with no optional arguments", sum_c_int64_t_scalars) & - ,test_description_t("multiplies default real scalars with all optional arguments", multiply_default_real_scalars) & - ,test_description_t("multiplies real(c_double) scalars with all optional arguments", multiply_c_double_scalars) & - ,test_description_t("performs a collective .and. operation across logical scalars", reports_on_consensus) & - ,test_description_t("sums default complex scalars with a stat-variable present", sum_default_complex_scalars) & - ,test_description_t("sums complex(c_double) scalars with a stat-variable present", sum_complex_c_double_scalars) & - ,test_description_t("sums default integer elements of a 2D array across images", sum_integer_array_elements) & + test_description_t("sums default integer scalars with no optional arguments", sum_default_integer_scalars) & + ,test_description_t("sums integer(c_int64_t) scalars with no optional arguments", sum_c_int64_t_scalars) & + ,test_description_t("multiplies default real scalars with all optional arguments", multiply_default_real_scalars) & + ,test_description_t("multiplies real(c_double) scalars with all optional arguments", multiply_c_double_scalars) & + ,test_description_t("performs a collective .and. operation across logical scalars", reports_on_consensus) & + ,test_description_t("sums default complex scalars with a stat-variable present", sum_default_complex_scalars) & + ,test_description_t("sums complex(c_double) scalars with a stat-variable present", sum_complex_c_double_scalars) & + ,test_description_t("sums default integer elements of a 2D array across images", sum_integer_array_elements) & + ,test_description_t("alphabetical reduction of strings with result_image present", alphabetically_first_string) & ] #else procedure(test_function_i), pointer :: & @@ -59,8 +61,7 @@ function results() result(test_results) ,sum_integer_array_elements_ptr => sum_integer_array_elements test_descriptions = [ & - test_description_t("alphabetical reduction of strings with result_image present", alphabetically_first_string_ptr) & - ,test_description_t("sums default integer scalars with no optional arguments", sum_default_integer_scalars_ptr) & + test_description_t("sums default integer scalars with no optional arguments", sum_default_integer_scalars_ptr) & ,test_description_t("sums integer(c_int64_t) scalars with no optional arguments", sum_c_int64_t_scalars_ptr) & ,test_description_t("multiplies default real scalars with all optional arguments", multiply_default_real_scalars_ptr) & ,test_description_t("multiplies real(c_double) scalars with all optional arguments", multiply_c_double_scalars_ptr) & @@ -68,6 +69,7 @@ function results() result(test_results) ,test_description_t("sums default complex scalars with a stat-variable present", sum_default_complex_scalars_ptr) & ,test_description_t("sums complex(c_double) scalars with a stat-variable present", sum_complex_c_double_scalars_ptr) & ,test_description_t("sums default integer elements of a 2D array across images", sum_integer_array_elements_ptr) & + ,test_description_t("alphabetical reduction of strings with result_image present", alphabetically_first_string_ptr) & ] #endif @@ -81,30 +83,25 @@ function results() result(test_results) function alphabetically_first_string() result(test_passes) logical test_passes character(len=*, kind=c_char), parameter :: names(*) = ["larry","harry","carey","betty","tommy","billy"] - character(len=:, kind=c_char), allocatable :: my_name(:) - character(len=:), allocatable :: expected_name - integer :: me, num_imgs + character(len=len(names), kind=c_char) my_name, expected_name + integer :: me, n call prif_this_image_no_coarray(this_image=me) associate(periodic_index => 1 + mod(me-1,size(names))) - my_name = [names(periodic_index)] + my_name = names(periodic_index) call prif_co_reduce(my_name, c_funloc(alphabetize)) end associate - call prif_num_images(num_images=num_imgs) - expected_name = minval(names(1:min(num_imgs, size(names)))) ! this exposes a flang bug - test_passes = all(expected_name == my_name) + call prif_num_images(num_images=n) + expected_name = minval(names(1:min(n, size(names)))) ! this exposes a flang bug + test_passes = expected_name == my_name contains - function alphabetize(lhs, rhs) result(first_alphabetically) + pure function alphabetize(lhs, rhs) result(first_alphabetically) character(len=*), intent(in) :: lhs, rhs - character(len=:), allocatable :: first_alphabetically - - 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 + character(len=len(lhs)) first_alphabetically + call_assert(len(lhs) == len(rhs)) first_alphabetically = min(lhs,rhs) end function From 7268613a0c3b109622c5732abb709cfb6384ad9c Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Sun, 29 Dec 2024 22:39:56 -0500 Subject: [PATCH 13/29] refac(prif_test_s): make co_all impure elemental This eliminates a do loop in prif_test_t's "report" tybe-bound procedure. --- test/prif_test_s.f90 | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/test/prif_test_s.f90 b/test/prif_test_s.f90 index 9bc2a50e1..a794955ca 100644 --- a/test/prif_test_s.f90 +++ b/test/prif_test_s.f90 @@ -9,7 +9,7 @@ contains - subroutine co_all(boolean) + impure elemental subroutine co_all(boolean) logical(c_bool), intent(inout) :: boolean call prif_co_reduce(boolean, c_funloc(both)) contains @@ -61,11 +61,8 @@ pure function both(lhs,rhs) result(lhs_and_rhs) end if block logical(c_bool), allocatable :: passing_tests(:) - integer test passing_tests = test_results%passed() - do test = 1, size(passing_tests) - call co_all(passing_tests(test)) - end do + call co_all(passing_tests) associate(num_passes => count(passing_tests)) if (me==1) print '(a,2(i0,a))'," ",num_passes," of ", num_tests," tests pass." passes = passes + num_passes From 2ffdbb67aa6b3228c9eb17278f78c4956ee90c46 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Sun, 29 Dec 2024 22:47:54 -0500 Subject: [PATCH 14/29] chore(prif_test_s): rm redundant logic in report --- test/prif_test_s.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/prif_test_s.f90 b/test/prif_test_s.f90 index a794955ca..735609154 100644 --- a/test/prif_test_s.f90 +++ b/test/prif_test_s.f90 @@ -42,7 +42,7 @@ pure function both(lhs,rhs) result(lhs_and_rhs) end if end if first_report - print '(*(a))', new_line('a'), test%subject() + print '(*(a))', new_line(''), test%subject() end if @@ -55,7 +55,7 @@ pure function both(lhs,rhs) result(lhs_and_rhs) block integer i do i=1,num_tests - if (me==1) print '(3x,a)', test_results(i)%characterize() + print '(3x,a)', test_results(i)%characterize() end do end block end if From 7ce33b7fb0d9dddb4474d8db606813db8b14ce8c Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Thu, 2 Jan 2025 12:38:55 -0800 Subject: [PATCH 15/29] doc(test-termination/README): specify environment The new text at the bottom of the test-termination/README.md specifies the environment variable definitions used in running the termination tests. --- test-termination/README.md | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/test-termination/README.md b/test-termination/README.md index 3af011b32..b417e4046 100644 --- a/test-termination/README.md +++ b/test-termination/README.md @@ -1,6 +1,6 @@ Test Termination ---------------- -The code in this subdirectory intentionally terminate to test the following +The code in this subdirectory intentionally terminate to tests the following procedures and interface from prif.F90: - `prif_error_stop` - `prif_register_stop_callback` @@ -35,3 +35,19 @@ which should yield trailing output similar to the following: *cmd_run*:stopping due to failed executions STOP 1 ``` +The environment variables that might be relevant to reproducing the above behavior +include `FPM_FC`, `FPM_CC`, `FPM_FFLAGS`, `LC_RPATH`, and either `DYLD_LIBRARY_PATH` +on macOS or `LD_LIBRARY_PATH` on Linux. On the macOS system tested, `FPM_FC` +and `FPM_CC` point to `flang-new` and `clang` (version information below), whereas +`LC_RPATH` and `DYLD_LIBRARY_PATH` are both set to the same path as that of `flang-new` +but with the trailing `bin` replaced by `lib`. + +``` +% flang-new --version +flang-new version 20.0.0git (git@github.com:ROCm/llvm-project 27e3c3a2c5716678cef303ba211ccea46a421b00) +Target: arm64-apple-darwin23.6.0 +Thread model: posix +InstalledDir: /Users/rouson/Repositories/llvm-project/install/rocm/bin +Build config: +assertions +``` + From 3b5c974b7e625d8779e52557c8c46c46c655c5f3 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Thu, 2 Jan 2025 12:43:01 -0800 Subject: [PATCH 16/29] build(test-terminatio): add fpm.toml file --- test-termination/fpm.toml | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 test-termination/fpm.toml diff --git a/test-termination/fpm.toml b/test-termination/fpm.toml new file mode 100644 index 000000000..a5efa8941 --- /dev/null +++ b/test-termination/fpm.toml @@ -0,0 +1,10 @@ +name = "Caffeine-Termination-Tests" +license = "(Please see caffeine/LICENSE.txt.)" +author = "(Please see caffeine/fpm.toml.)" +maintainer = "(Please see caffeine/fpm.toml.)" + +[dev-dependencies] +caffeine = { path = ".." } + +[build] +link = ["gasnet-smp-seq", "gcc"] From dd3fb3a6e2ae5d2979ed319c8591d27813772ac2 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Thu, 2 Jan 2025 14:23:56 -0800 Subject: [PATCH 17/29] build: rm external assert lib dependence --- manifest/fpm.toml.template | 1 - test/main.F90 | 5 ----- test/prif_co_reduce_test_m.F90 | 4 +--- 3 files changed, 1 insertion(+), 9 deletions(-) diff --git a/manifest/fpm.toml.template b/manifest/fpm.toml.template index b3bcae4d9..1b0961044 100644 --- a/manifest/fpm.toml.template +++ b/manifest/fpm.toml.template @@ -7,6 +7,5 @@ copyright = "2021-2024 UC Regents" [dev-dependencies] julienne = {git = "https://github.com/berkeleylab/julienne.git", tag = "1.5.3"} -assert = {git = "https://github.com/berkeleylab/assert.git", tag = "2.0.0"} [build] diff --git a/test/main.F90 b/test/main.F90 index 7a1b853f0..ded41cba0 100644 --- a/test/main.F90 +++ b/test/main.F90 @@ -1,11 +1,7 @@ ! Copyright (c) 2020-2024, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt - -#include "assert_macros.h" - program main !! Test the Caffeine implementation of the Parallel Runtime Interface for Fortran (PRIF) - use assert_m use iso_c_binding, only : c_bool use julienne_m, only : command_line_t, GitHub_CI use prif, only : & @@ -34,7 +30,6 @@ program main call stop_and_print_usage_info_if_help_requested call prif_init(stat=init_status) - call_assert(init_status==successful) call run_tests_and_report(passes, tests) call prif_this_image_no_coarray(this_image=me) if (me==1) print "(a,*(a,G0))", new_line(''), "_________ In total, ",passes," of ",tests, " tests pass. _________" diff --git a/test/prif_co_reduce_test_m.F90 b/test/prif_co_reduce_test_m.F90 index adbcef8a8..11042b256 100644 --- a/test/prif_co_reduce_test_m.F90 +++ b/test/prif_co_reduce_test_m.F90 @@ -2,11 +2,9 @@ ! Terms of use are as specified in LICENSE.txt #include "language-support.F90" -#include "assert_macros.h" module prif_co_reduce_test_m !! Unit test fort the prif_init program inititation subroutine - use assert_m use prif, only : prif_co_reduce, prif_num_images, prif_this_image_no_coarray, prif_error_stop, prif_co_max use prif_test_m, only : prif_test_t, test_description_substring use iso_c_binding, only : c_bool, c_funloc, c_char, c_double, c_int64_t @@ -101,7 +99,7 @@ function alphabetically_first_string() result(test_passes) pure function alphabetize(lhs, rhs) result(first_alphabetically) character(len=*), intent(in) :: lhs, rhs character(len=len(lhs)) first_alphabetically - call_assert(len(lhs) == len(rhs)) + if (len(lhs) /= len(rhs)) call prif_error_stop(quiet=.false., stop_code_char="argument size mismatchin in function alphabetize") first_alphabetically = min(lhs,rhs) end function From 00ae2b321119090ccd734a7fa76f838673a0ac5e Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Thu, 2 Jan 2025 18:14:20 -0800 Subject: [PATCH 18/29] chore: rm unused parameter declarations --- test/prif_allocate_test_m.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/test/prif_allocate_test_m.F90 b/test/prif_allocate_test_m.F90 index 3126b7519..69ec6f6aa 100644 --- a/test/prif_allocate_test_m.F90 +++ b/test/prif_allocate_test_m.F90 @@ -105,8 +105,6 @@ function check_symmetric_allocation() result(test_passes) !! integer :: coarr[*] logical, allocatable :: test_passes(:) integer(kind=c_intmax_t), dimension(1) :: lcobounds, ucobounds - integer(kind=c_intmax_t), dimension(0), parameter :: lbounds = [integer(kind=c_intmax_t) ::] - integer(kind=c_intmax_t), dimension(0), parameter :: ubounds = [integer(kind=c_intmax_t) ::] integer, pointer :: local_slice integer dummy_element, num_imgs type(prif_coarray_handle) coarray_handle From 6d03002da35faf0676c9ad976768578328eb388e Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Thu, 2 Jan 2025 19:09:29 -0800 Subject: [PATCH 19/29] test(co_reduce): fix standard violations This commit appends `_c_bool` to the `quiet` argument of `prif_co_reduce` and removes the `pure` attribue from the encompassing procedure. --- test/prif_co_reduce_test_m.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/prif_co_reduce_test_m.F90 b/test/prif_co_reduce_test_m.F90 index 11042b256..992869b0d 100644 --- a/test/prif_co_reduce_test_m.F90 +++ b/test/prif_co_reduce_test_m.F90 @@ -96,10 +96,10 @@ function alphabetically_first_string() result(test_passes) contains - pure function alphabetize(lhs, rhs) result(first_alphabetically) + function alphabetize(lhs, rhs) result(first_alphabetically) character(len=*), intent(in) :: lhs, rhs character(len=len(lhs)) first_alphabetically - if (len(lhs) /= len(rhs)) call prif_error_stop(quiet=.false., stop_code_char="argument size mismatchin in function alphabetize") + if (len(lhs) /= len(rhs)) call prif_error_stop(quiet=.false._c_bool, stop_code_char="argument size mismatchin in function alphabetize") first_alphabetically = min(lhs,rhs) end function From 9ae13e938c2ad3b5df779d46f798c928f347dca1 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Thu, 2 Jan 2025 22:12:20 -0800 Subject: [PATCH 20/29] test(this_image): report diagnostics if test fails --- manifest/fpm.toml.template | 2 +- test/prif_this_image_test_m.F90 | 20 ++++++++++++++------ 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/manifest/fpm.toml.template b/manifest/fpm.toml.template index 1b0961044..b931cf5a8 100644 --- a/manifest/fpm.toml.template +++ b/manifest/fpm.toml.template @@ -6,6 +6,6 @@ maintainer = "rouson@lbl.gov" copyright = "2021-2024 UC Regents" [dev-dependencies] -julienne = {git = "https://github.com/berkeleylab/julienne.git", tag = "1.5.3"} +julienne = {git = "https://github.com/berkeleylab/julienne.git", tag = "1.6.0"} [build] diff --git a/test/prif_this_image_test_m.F90 b/test/prif_this_image_test_m.F90 index 675af3c75..76ca75b92 100644 --- a/test/prif_this_image_test_m.F90 +++ b/test/prif_this_image_test_m.F90 @@ -7,9 +7,9 @@ module prif_this_image_test_m !! Unit test for the prif_this_image subroutine use prif, only : prif_this_image_no_coarray, prif_num_images, prif_co_sum use prif_test_m, only : prif_test_t, test_description_substring - use julienne_m, only : test_result_t, test_description_t + use julienne_m, only : test_result_t, test_description_t, test_diagnosis_t, string_t, operator(.cat.) #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : test_function_i + use julienne_m, only : diagnosis_function_i #endif implicit none @@ -38,7 +38,7 @@ function results() result(test_results) test_description_t("returning its member of the image set if called with no arguments", check_this_image_set) & ] #else - procedure(test_function_i), pointer :: check_this_image_set_ptr + procedure(diagnosis_function_i), pointer :: check_this_image_set_ptr check_this_image_set_ptr => check_this_image_set @@ -54,16 +54,24 @@ function results() result(test_results) test_results = test_descriptions%run() end function - function check_this_image_set() result(test_passes) - logical test_passes + function check_this_image_set() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis integer, allocatable :: image_numbers(:) integer i, me, ni + integer, allocatable :: expected_image_numbers(:) call prif_this_image_no_coarray(this_image=me) call prif_num_images(num_images=ni) image_numbers = [(merge(0, me, me/=i), i = 1, ni)] call prif_co_sum(image_numbers) - test_passes = all(image_numbers == [(i, i = 1, ni)]) .and. size(image_numbers) > 0 + associate(expected_values => [(i, i = 1, ni)]) + ! TODO: support support array aguments to string_t(); remove .cat. below; generate CSV list instead + test_diagnosis = test_diagnosis_t( & + test_passed = all(image_numbers == expected_values) .and. size(image_numbers) > 0, & + diagnostics_string = & + "expected: " // .cat. string_t(expected_values) // ", actual: " // .cat. string_t(image_numbers) & + ) + end associate end function end module prif_this_image_test_m From 1da811b3aad45ca01831c22f5fa777cb657988a4 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Thu, 2 Jan 2025 22:25:11 -0800 Subject: [PATCH 21/29] test(num_images): report diagnostics if test fails --- test/prif_num_images_test_m.F90 | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/test/prif_num_images_test_m.F90 b/test/prif_num_images_test_m.F90 index a5db1e0a9..687596215 100644 --- a/test/prif_num_images_test_m.F90 +++ b/test/prif_num_images_test_m.F90 @@ -7,9 +7,9 @@ module prif_num_images_test_m !! Unit test for the prif_num_images subroutine use prif, only : prif_num_images use prif_test_m, only : prif_test_t, test_description_substring - use julienne_m, only : test_t, test_result_t, test_description_t + use julienne_m, only : test_t, test_result_t, test_description_t, test_diagnosis_t, string_t #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : test_function_i + use julienne_m, only : diagnosis_function_i #endif implicit none @@ -38,7 +38,7 @@ function results() result(test_results) test_description_t("providing a valid number of images when called with no arguments", check_num_images_valid) & ] #else - procedure(test_function_i), pointer :: check_num_images_valid_ptr + procedure(diagnosis_function_i), pointer :: check_num_images_valid_ptr check_num_images_valid_ptr => check_num_images_valid @@ -54,11 +54,12 @@ function results() result(test_results) test_results = test_descriptions%run() end function - function check_num_images_valid() result(test_passes) - logical test_passes - integer num_imgs - call prif_num_images(num_images=num_imgs) - test_passes = num_imgs > 0 + function check_num_images_valid() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + integer n + + call prif_num_images(num_images=n) + test_diagnosis = test_diagnosis_t(test_passed = n > 0, diagnostics_string = "expected: n > 0" // ", actual: " // string_t(n)) end function end module prif_num_images_test_m From 9ab0a7fbc1e1c85690d059671354306a1b65fcd1 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Fri, 3 Jan 2025 10:38:05 -0800 Subject: [PATCH 22/29] test(init): report diagnostics if test fails --- test/prif_init_test_m.F90 | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/test/prif_init_test_m.F90 b/test/prif_init_test_m.F90 index ff10f336f..1dda471d1 100644 --- a/test/prif_init_test_m.F90 +++ b/test/prif_init_test_m.F90 @@ -7,9 +7,9 @@ module prif_init_test_m !! Unit test fort the prif_init program inititation subroutine use prif, only : prif_init, PRIF_STAT_ALREADY_INIT use prif_test_m, only : prif_test_t, test_description_substring - use julienne_m, only : test_result_t, test_description_t + use julienne_m, only : test_result_t, test_description_t, string_t, test_diagnosis_t #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : test_function_i + use julienne_m, only : diagnosis_function_i #endif implicit none @@ -38,7 +38,7 @@ function results() result(test_results) test_description_t("returning PRIF_STAT_ALREADY_INIT when called a second time", check_redundant_prif_init_call) & ] #else - procedure(test_function_i), pointer :: check_caffeination_ptr, check_redundant_prif_init_call_ptr + procedure(diagnosis_function_i), pointer :: check_caffeination_ptr, check_redundant_prif_init_call_ptr check_redundant_prif_init_call_ptr => check_redundant_prif_init_call test_descriptions = [ & @@ -52,12 +52,15 @@ function results() result(test_results) test_results = test_descriptions%run() end function - function check_redundant_prif_init_call() result(test_passes) - logical test_passes + function check_redundant_prif_init_call() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis integer stat call prif_init(stat) call prif_init(stat) - test_passes = stat == PRIF_STAT_ALREADY_INIT + test_diagnosis = test_diagnosis_t( & + test_passed = stat == PRIF_STAT_ALREADY_INIT & + ,diagnostics_string = "expected: " //string_t(PRIF_STAT_ALREADY_INIT) // "(PRIF_STAT_ALREADY_INIT), actual: " // string_t(stat) & + ) end function end module prif_init_test_m From 5cc15380389f155c745821ec4bb0ed209c88e8fd Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Fri, 3 Jan 2025 11:04:18 -0800 Subject: [PATCH 23/29] test(image_index): report diagnostics for failures --- test/prif_image_index_m.F90 | 44 ++++++++++++++++++++++++------------- 1 file changed, 29 insertions(+), 15 deletions(-) diff --git a/test/prif_image_index_m.F90 b/test/prif_image_index_m.F90 index aff2ba0e4..c6a5fc7c9 100644 --- a/test/prif_image_index_m.F90 +++ b/test/prif_image_index_m.F90 @@ -8,9 +8,9 @@ module prif_image_index_test_m use iso_c_binding, only: c_int, c_intmax_t, c_ptr, c_size_t, c_null_funptr use prif, only: prif_coarray_handle, prif_allocate_coarray, prif_deallocate_coarray, prif_image_index, prif_num_images use prif_test_m, only: prif_test_t, test_description_substring - use julienne_m, only : test_result_t, test_description_t + use julienne_m, only : test_result_t, test_description_t, string_t, test_diagnosis_t #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : test_function_i + use julienne_m, only : diagnosis_function_i #endif implicit none @@ -43,7 +43,7 @@ function results() result(test_results) ] #else - procedure(test_function_i), pointer :: & + procedure(diagnosis_function_i), pointer :: & check_simple_case_ptr, & check_lower_bounds_ptr, & check_invalid_subscripts_ptr, & @@ -68,8 +68,8 @@ function results() result(test_results) end function - function check_simple_case() result(test_passes) - logical test_passes + function check_simple_case() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis type(prif_coarray_handle) :: coarray_handle type(c_ptr) :: allocated_memory integer(c_int) :: answer @@ -82,12 +82,15 @@ function check_simple_case() result(test_passes) coarray_handle = coarray_handle, & allocated_memory = allocated_memory) call prif_image_index(coarray_handle, [1_c_intmax_t], image_index=answer) - test_passes = answer == 1_c_int call prif_deallocate_coarray([coarray_handle]) + test_diagnosis = test_diagnosis_t( & + test_passed = answer == 1_c_int & + ,diagnostics_string = "expected " // string_t(1_c_int) // ", actual " // string_t(answer) & + ) end function - function check_lower_bounds() result(test_passes) - logical test_passes + function check_lower_bounds() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis type(prif_coarray_handle) coarray_handle type(c_ptr) allocated_memory integer(c_int) answer @@ -100,12 +103,15 @@ function check_lower_bounds() result(test_passes) coarray_handle = coarray_handle, & allocated_memory = allocated_memory) call prif_image_index(coarray_handle, [2_c_intmax_t, 3_c_intmax_t], image_index=answer) - test_passes = answer == 1_c_int call prif_deallocate_coarray([coarray_handle]) + test_diagnosis = test_diagnosis_t( & + test_passed = answer == 1_c_int & + ,diagnostics_string = "expected " // string_t(1_c_int) // ", actual " // string_t(answer) & + ) end function - function check_invalid_subscripts() result(test_passes) - logical test_passes + function check_invalid_subscripts() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis type(prif_coarray_handle) coarray_handle type(c_ptr) allocated_memory integer(c_int) answer @@ -118,12 +124,15 @@ function check_invalid_subscripts() result(test_passes) coarray_handle = coarray_handle, & allocated_memory = allocated_memory) call prif_image_index(coarray_handle, [-1_c_intmax_t, 1_c_intmax_t], image_index=answer) - test_passes = answer == 0_c_int call prif_deallocate_coarray([coarray_handle]) + test_diagnosis = test_diagnosis_t( & + test_passed = answer == 0_c_int & + ,diagnostics_string = "expected " // string_t(0_c_int) // ", actual " // string_t(answer) & + ) end function - function check_complicated() result(test_passes) - logical test_passes + function check_complicated() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis type(prif_coarray_handle) coarray_handle type(c_ptr) allocated_memory integer(c_int) answer, ni @@ -137,8 +146,13 @@ function check_complicated() result(test_passes) coarray_handle = coarray_handle, & allocated_memory = allocated_memory) call prif_image_index(coarray_handle, [1_c_intmax_t, 3_c_intmax_t], image_index=answer) - test_passes = answer == merge(3_c_int, 0_c_int, ni >= 3) call prif_deallocate_coarray([coarray_handle]) + associate(expected_answer => merge(3_c_int, 0_c_int, ni >= 3)) + test_diagnosis = test_diagnosis_t( & + test_passed = answer == expected_answer & + ,diagnostics_string = "expected " // string_t(expected_answer) // ", actual " // string_t(answer) & + ) + end associate end function end module prif_image_index_test_m From 9341364a8a65adfac0fe8981b66eee8b24360daa Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Fri, 3 Jan 2025 11:57:09 -0800 Subject: [PATCH 24/29] test(co_broadcast):report diagnostics for failures --- test/prif_co_broadcast_test_m.F90 | 58 ++++++++++++++++++++----------- 1 file changed, 38 insertions(+), 20 deletions(-) diff --git a/test/prif_co_broadcast_test_m.F90 b/test/prif_co_broadcast_test_m.F90 index 4c7eda15c..26510d51f 100644 --- a/test/prif_co_broadcast_test_m.F90 +++ b/test/prif_co_broadcast_test_m.F90 @@ -7,9 +7,9 @@ module prif_co_broadcast_test_m !! Unit test for the prif_co_broadcast subroutine use prif, only : prif_co_broadcast, prif_num_images, prif_this_image_no_coarray use prif_test_m, only : prif_test_t, test_description_substring - use julienne_m, only : test_t, test_result_t, test_description_t + use julienne_m, only : test_t, test_result_t, test_description_t, test_diagnosis_t, string_t #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : test_function_i + use julienne_m, only : diagnosis_function_i #endif implicit none @@ -50,7 +50,7 @@ function results() result(test_results) ,test_description_t("broadcasts a derived type scalar with no allocatable components", broadcast_derived_type) & ] #else - procedure(test_function_i), pointer :: broadcast_default_integer_ptr, broadcast_derived_type_ptr + procedure(diagnosis_function_i), pointer :: broadcast_default_integer_ptr, broadcast_derived_type_ptr broadcast_default_integer_ptr => broadcast_default_integer broadcast_derived_type_ptr => broadcast_derived_type @@ -68,38 +68,56 @@ function results() result(test_results) test_results = test_descriptions%run() end function - logical pure function equals(lhs, rhs) + pure function equals(lhs, rhs) result(lhs_equals_rhs) type(object_t), intent(in) :: lhs, rhs - equals = all([ & - lhs%i == rhs%i & - ,lhs%fallacy .eqv. rhs%fallacy & - ,lhs%actor == rhs%actor & - ,lhs%issues == rhs%issues & - ]) + logical lhs_equals_rhs + lhs_equals_rhs = & + (lhs%i == rhs%i) & + .and. (lhs%fallacy .eqv. rhs%fallacy) & + .and. (lhs%actor == rhs%actor) & + .and. (lhs%issues == rhs%issues) end function - function broadcast_default_integer() result(test_passes) - logical test_passes - integer iPhone, me + pure function stringify(self) result(string) + class(object_t), intent(in) :: self + type(string_t) string + string = "object_t(" & + // string_t(self%i) & + // "," // merge("T","F",self%fallacy) & + // "," // string_t(self%actor) & + // ",(" // string_t(self%issues%Re) //","// string_t(self%issues%Re) // ")" & + // ")" + end function + + function broadcast_default_integer() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + integer received_value, me integer, parameter :: source_value = 7779311, junk = -99 call prif_this_image_no_coarray(this_image=me) - iPhone = merge(source_value, junk, me==1) - call prif_co_broadcast(iPhone, source_image=1) - test_passes = source_value == iPhone + received_value = merge(source_value, junk, me==1) + call prif_co_broadcast(received_value, source_image=1) + + test_diagnosis = test_diagnosis_t( & + test_passed = source_value == received_value & + ,diagnostics_string = "expected " // string_t(source_value) // ", actual " // string_t(received_value) & + ) end function - function broadcast_derived_type() result(test_passes) - logical test_passes + function broadcast_derived_type() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis type(object_t) object - integer :: me, ni + integer me, ni call prif_this_image_no_coarray(this_image=me) call prif_num_images(num_images=ni) object = object_t(me, .false., "gooey", me*(1.,0.)) call prif_co_broadcast(object, source_image=ni) associate(expected_object => object_t(ni, .false., "gooey", ni*(1.,0.))) - test_passes = expected_object == object + test_diagnosis = test_diagnosis_t( & + test_passed = expected_object == object & + ,diagnostics_string = "expected " // stringify(object) // ", actual " // stringify(expected_object) & + ) end associate end function From a5294908a72e232d96bb3fad8533853e820d07f4 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Fri, 3 Jan 2025 16:02:19 -0800 Subject: [PATCH 25/29] test(co_sum): report diagnostics for test failures --- test/prif_co_sum_test_m.F90 | 139 +++++++++++++++++++++++++----------- 1 file changed, 98 insertions(+), 41 deletions(-) diff --git a/test/prif_co_sum_test_m.F90 b/test/prif_co_sum_test_m.F90 index d0d204157..1d4c41406 100644 --- a/test/prif_co_sum_test_m.F90 +++ b/test/prif_co_sum_test_m.F90 @@ -7,9 +7,9 @@ module prif_co_sum_test_m !! Unit test fort the prif_co_sum program inititation subroutine use prif, only : prif_co_sum, prif_num_images, prif_this_image_no_coarray use prif_test_m, only : prif_test_t, test_description_substring - use julienne_m, only : test_result_t, test_description_t + use julienne_m, only : test_result_t, test_description_t, test_diagnosis_t, string_t, operator(.csv.) #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : test_function_i + use julienne_m, only : diagnosis_function_i #endif implicit none @@ -46,7 +46,7 @@ function results() result(test_results) ,test_description_t("summing double-precision 1D complex arrays with no optional arguments", sum_dble_complex_1D_arrays) & ] #else - procedure(test_function_i), pointer :: & + procedure(diagnosis_function_i), pointer :: & sum_default_integer_scalars_ptr => sum_default_integer_scalars & ,sum_integers_all_arguments_ptr => sum_integers_all_arguments & ,sum_c_int64_scalars_ptr => sum_c_int64_scalars & @@ -77,18 +77,21 @@ function results() result(test_results) test_results = test_descriptions%run() end function - function sum_default_integer_scalars() result(test_passes) - logical test_passes - integer i, num_imgs + function sum_default_integer_scalars() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + integer image_count, n - i = 1 - call prif_co_sum(i) - call prif_num_images(num_images=num_imgs) - test_passes = num_imgs == i + image_count = 1 + call prif_co_sum(image_count) + call prif_num_images(num_images=n) + test_diagnosis = test_diagnosis_t( & + test_passed = image_count == n & + ,diagnostics_string = "expected " // string_t(n) // ", actual " // string_t(image_count) & + ) end function - function sum_integers_all_arguments() result(test_passes) - logical test_passes + function sum_integers_all_arguments() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis integer i, status_, result_image_, me, num_imgs character(len=*), parameter :: whitespace = repeat(" ", ncopies=29) character(len=:), allocatable :: error_message @@ -102,26 +105,36 @@ function sum_integers_all_arguments() result(test_passes) call prif_num_images(num_images=num_imgs) associate(expected_i => merge(num_imgs*i, i, me==result_image_)) call prif_co_sum(i, result_image_, status_, error_message) - test_passes = (expected_i == i) .and. (status_ == 0) .and. (whitespace == error_message) + test_diagnosis = test_diagnosis_t( & + test_passed = (expected_i == i) .and. (status_ == 0) .and. (whitespace == error_message) & + ,diagnostics_string = & + "expected i=" // string_t(expected_i) // ", status=" // "0" // ", error_message='" // whitespace // "'" & + // ", actual i=" // string_t(i) // ", status=" // string_t(status_) // ", error_message='" // error_message // "'" & + ) end associate end function - function sum_c_int64_scalars() result(test_passes) + function sum_c_int64_scalars() result(test_diagnosis) use iso_c_binding, only : c_int64_t - logical test_passes + type(test_diagnosis_t) test_diagnosis integer(c_int64_t) i integer i_default_kind, status_, num_imgs status_ = -1 i = 2_c_int64_t call prif_co_sum(i, stat=status_) - i_default_kind = i + i_default_kind = int(i,kind(i_default_kind)) call prif_num_images(num_images=num_imgs) - test_passes = (2*num_imgs == int(i)) .and. (status_ == 0) + test_diagnosis = test_diagnosis_t( & + test_passed = (2*num_imgs == i_default_kind) .and. (status_ == 0) & + ,diagnostics_string = & + "expected i=" // string_t(2*num_imgs) // ", status_= " // "0" & + // "; actual i=" // string_t(i_default_kind) // ", status_= " // string_t(status_) & + ) end function - function sum_default_integer_1D_array() result(test_passes) - logical test_passes + function sum_default_integer_1D_array() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis integer i, images integer, allocatable :: array(:) @@ -129,26 +142,40 @@ function sum_default_integer_1D_array() result(test_passes) associate(sequence_ => [(i,i=1,images)]) array = sequence_ call prif_co_sum(array) - test_passes = all(array == images*sequence_) + test_diagnosis = test_diagnosis_t( & + test_passed = all(array == images*sequence_) & + ,diagnostics_string = & + "expected " // .csv. string_t(images*sequence_) & + // "; actual " // .csv. string_t(array) & + ) end associate end function - function sum_default_integer_15D_array() result(test_passes) - logical test_passes - integer array(2,1,1, 1,1,1, 1,1,1, 1,1,1, 1,2,1) + function sum_default_integer_15D_array() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + integer, target :: array(2,1,1, 1,1,1, 1,1,1, 1,1,1, 1,2,1) + integer, pointer :: array_1D_ptr(:) integer status_, num_imgs status_ = -1 array = 3 call prif_co_sum(array, stat=status_) call prif_num_images(num_images=num_imgs) - test_passes = (all(3*num_imgs == array)) .and. (0 == status_) + associate(expected_sum => 3*num_imgs) + array_1D_ptr(1:size(array)) => array + test_diagnosis = test_diagnosis_t( & + test_passed = all(array == expected_sum) .and. (status_ == 0) & + ,diagnostics_string = & + "expected element value = " // string_t(expected_sum) // ", status_= " // "0" & + // "; actual element values = " // .csv. string_t(array_1D_ptr) // ", status_= " // string_t(status_) & + ) + end associate end function - function sum_default_real_scalars() result(test_passes) - logical test_passes + function sum_default_real_scalars() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis real scalar - real, parameter :: e = 2.7182818459045 + real, parameter :: e = 2.7182818459045, tolerance = 1E-07 integer result_image_, me, num_imgs result_image_ = 1 @@ -157,25 +184,40 @@ function sum_default_real_scalars() result(test_passes) call prif_this_image_no_coarray(this_image=me) call prif_num_images(num_images=num_imgs) associate(expected_result => merge(num_imgs*e, e, me==result_image_)) - test_passes = dble(expected_result) == dble(scalar) + test_diagnosis = test_diagnosis_t( & + test_passed = abs(expected_result - scalar) < tolerance & + ,diagnostics_string = "expected " // string_t(expected_result) & + // "; actual " // string_t(scalar) & + ) end associate end function - function sum_double_precision_2D_array() result(test_passes) - logical test_passes - double precision, allocatable :: array(:,:) - double precision, parameter :: input(*,*) = reshape(-[6,5,4,3,2,1], [3,2]) - integer :: num_imgs + function sum_double_precision_2D_array() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + double precision, allocatable, target :: array(:,:) + double precision, parameter :: input(*,*) = reshape(-[6,5,4,3,2,1], [3,2]), tolerance = 1D-14 + double precision, pointer :: array_1D_ptr(:) + integer num_imgs array = input call prif_co_sum(array) call prif_num_images(num_images=num_imgs) - test_passes = product(num_imgs*input) == product(array) + + associate(expected_sum => input*num_imgs) + array_1D_ptr(1:size(array)) => array + test_diagnosis = test_diagnosis_t( & + test_passed = all(abs(expected_sum - array) < tolerance) & + ,diagnostics_string = & + "expected " // .csv. string_t(reshape(expected_sum, [size(expected_sum)])) // & + "; actual " // .csv. string_t(array_1D_ptr) & + ) + end associate end function - function sum_default_complex_scalars() result(test_passes) - logical test_passes + function sum_default_complex_scalars() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis real scalar + real, parameter :: tolerance = 1E-07 complex z complex, parameter :: i=(0.,1.) integer status_, num_imgs @@ -184,20 +226,35 @@ function sum_default_complex_scalars() result(test_passes) z = i call prif_co_sum(z, stat=status_) call prif_num_images(num_images=num_imgs) - test_passes = (dble(abs(i*num_imgs)) == dble(abs(z)) ) .and. (status_ == 0) + associate(expected_z => i*num_imgs) + test_diagnosis = test_diagnosis_t( & + test_passed = (abs(expected_z - z) < tolerance ) .and. (status_ == 0) & + ,diagnostics_string = & + "expected (" // string_t(expected_z%Re) //","// string_t(expected_z%Im) // "; status= " // "0" & + // "; actual " // string_t( z%Re) //","// string_t( z%Im) // "; status= " // string_t(status_) & + ) + end associate end function - function sum_dble_complex_1D_arrays() result(test_passes) - logical test_passes + function sum_dble_complex_1D_arrays() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis integer, parameter :: dp = kind(1.D0) integer :: num_imgs complex(dp), allocatable :: array(:) complex(dp), parameter :: input(*) = [(1.D0,1.0D0)] + double precision, parameter :: tolerance = 1E-14 - array = [(1.D0,1.D0)] + array = input call prif_co_sum(array) call prif_num_images(num_images=num_imgs) - test_passes = all([input*num_imgs] == array) + associate(expected_sum => input*num_imgs) + test_diagnosis = test_diagnosis_t( & + test_passed = all(abs(expected_sum - array) < tolerance) & + ,diagnostics_string = & + "expected (" // string_t(expected_sum(1)%Re) // "," // string_t(expected_sum(1)%Im) // ")" & + // "; actual (" // string_t( array(1)%Re) // "," // string_t( array(1)%Im) // ")" & + ) + end associate end function end module prif_co_sum_test_m From 277c74621b5510d6cea0b505d36959069ef16a2a Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Fri, 3 Jan 2025 17:03:49 -0800 Subject: [PATCH 26/29] test(co_min): report diagnostics for test failures --- test/prif_co_min_test_m.F90 | 115 ++++++++++++++++++++++++------------ 1 file changed, 77 insertions(+), 38 deletions(-) diff --git a/test/prif_co_min_test_m.F90 b/test/prif_co_min_test_m.F90 index 6f1ddd4de..5e0b6fe62 100644 --- a/test/prif_co_min_test_m.F90 +++ b/test/prif_co_min_test_m.F90 @@ -8,9 +8,9 @@ module prif_co_min_test_m use iso_c_binding, only: c_size_t, c_ptr, c_intmax_t, c_null_funptr use prif, only : prif_co_min, prif_num_images, prif_this_image_no_coarray, prif_num_images use prif_test_m, only : prif_test_t, test_description_substring - use julienne_m, only : test_result_t, test_description_t + use julienne_m, only : test_result_t, test_description_t, test_diagnosis_t, string_t, operator(.csv.) #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : test_function_i + use julienne_m, only : diagnosis_function_i #endif implicit none @@ -47,7 +47,7 @@ function results() result(test_results) ,test_description_t("length-5 string with no optional arguments", alphabetically_1st_scalar_string) & ] #else - procedure(test_function_i), pointer :: & + procedure(diagnosis_function_i), pointer :: & min_default_integer_scalars_ptr => min_default_integer_scalars & ,min_c_int64_scalars_ptr => min_c_int64_scalars & ,min_default_integer_1D_array_ptr => min_default_integer_1D_array & @@ -76,8 +76,8 @@ function results() result(test_results) test_results = test_descriptions%run() end function - function min_default_integer_scalars() result(test_passes) - logical test_passes + function min_default_integer_scalars() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis integer i, status_, me, num_imgs status_ = -1 @@ -85,23 +85,30 @@ function min_default_integer_scalars() result(test_passes) i = -me call prif_co_min(i, stat=status_) call prif_num_images(num_images=num_imgs) - test_passes = i == -num_imgs .and. status_ == 0 + test_diagnosis = test_diagnosis_t( & + test_passed = (i == -num_imgs) .and. (status_ == 0) & + ,diagnostics_string = "expected i = " // string_t(-num_imgs) // ", status = 0" & + // "; actual i = " // string_t(i) // ", status = " // string_t(status_) & + ) end function - function min_c_int64_scalars() result(test_passes) + function min_c_int64_scalars() result(test_diagnosis) use iso_c_binding, only : c_int64_t - logical test_passes + type(test_diagnosis_t) test_diagnosis integer(c_int64_t) i - integer :: me + integer me call prif_this_image_no_coarray(this_image=me) - i = me + i = int(me, c_int64_t) call prif_co_min(i) - test_passes = int(i) == 1 + test_diagnosis = test_diagnosis_t( & + test_passed= i == 1_c_int64_t & + ,diagnostics_string = "expected i = 1; actual i = " // string_t(int(i)) & + ) end function - function min_default_integer_1D_array() result(test_passes) - logical test_passes + function min_default_integer_1D_array() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis integer i, me, num_imgs integer, allocatable :: array(:) @@ -111,27 +118,37 @@ function min_default_integer_1D_array() result(test_passes) array = sequence_ call prif_co_min(array) associate(min_sequence => [(i, i=1, num_imgs)]) - test_passes = all(min_sequence == array) + test_diagnosis = test_diagnosis_t( & + test_passed = all(min_sequence == array) & + ,diagnostics_string = "expected " // .csv. string_t(min_sequence) // "; actual = " // .csv. string_t(array) & + ) end associate end associate end function - function min_default_integer_7D_array() result(test_passes) - logical test_passes - integer array(2,1,1, 1,1,1, 2), status_, me, num_imgs + function min_default_integer_7D_array() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + integer, target :: array(2,1,1, 1,1,1, 2) + integer, pointer :: array_1D_ptr(:) + integer status_, me, num_imgs status_ = -1 call prif_this_image_no_coarray(this_image=me) array = 3 - me call prif_co_min(array, stat=status_) call prif_num_images(num_images=num_imgs) - test_passes = all(array == 3 - num_imgs) .and. status_ == 0 + array_1D_ptr(1:size(array)) => array + test_diagnosis = test_diagnosis_t( & + test_passed = all(array == 3 - num_imgs) .and. status_ == 0 & + ,diagnostics_string = "expected element values " // string_t(3 - num_imgs) // ", status_ = 0" & + // "; actual element values " // .csv. string_t(array_1D_ptr) // ", status_ = " // string_t(status_) & + ) end function - function min_default_real_scalars() result(test_passes) - logical test_passes + function min_default_real_scalars() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis real scalar - real, parameter :: pi = 3.141592654 + real, parameter :: pi = 3.141592654, tolerance = 1E-07 integer status_, me, num_imgs status_ = -1 @@ -139,24 +156,37 @@ function min_default_real_scalars() result(test_passes) scalar = -pi*me call prif_co_min(scalar, stat=status_) call prif_num_images(num_images=num_imgs) - test_passes = -dble(pi*num_imgs) == dble(scalar) .and. status_ == 0 + associate(expected_value => -pi*num_imgs) + test_diagnosis = test_diagnosis_t( & + test_passed =(abs(scalar - expected_value) < tolerance) .and. (status_ == 0) & + ,diagnostics_string = "expected " // string_t(expected_value) // ", status = 0" & + // "; actual " // string_t(scalar) // ", status = " // string_t(status_) & + ) + end associate end function - function min_double_precision_2D_array() result(test_passes) - logical test_passes - double precision, allocatable :: array(:,:) - double precision, parameter :: tent(*,*) = dble(reshape(-[0,1,2,3,2,1], [3,2])) - integer :: me, num_imgs + function min_double_precision_2D_array() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + double precision, dimension(:,:), allocatable, target :: array, expected + double precision, dimension(:), pointer :: array_1D_ptr, expected_1D_ptr + double precision, parameter :: tent(*,*) = dble(reshape(-[0,1,2,3,2,1], [3,2])), tolerance=1D-14 + integer me, num_imgs call prif_this_image_no_coarray(this_image=me) array = tent*dble(me) call prif_co_min(array) call prif_num_images(num_images=num_imgs) - test_passes = all(array==tent*dble(num_imgs)) + expected = tent*dble(num_imgs) + array_1D_ptr(1:size(array)) => array + expected_1D_ptr(1:size(expected)) => expected + test_diagnosis = test_diagnosis_t( & + test_passed = all(abs(array - tent*dble(num_imgs)) < tolerance) & + ,diagnostics_string = "expected " // .csv. string_t(expected_1D_ptr) // "; actual " // .csv. string_t(array_1D_ptr) & + ) end function - function min_elements_in_2D_string_arrays() result(test_passes) - logical test_passes + function min_elements_in_2D_string_arrays() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis character(len=*), parameter :: script(*,*,*) = reshape( & [ "To be ","or not " & ! odd images get , "to ","be. " & ! this slice: script(:,:,1) @@ -164,24 +194,30 @@ function min_elements_in_2D_string_arrays() result(test_passes) , "that ","is " & ! even images get , "the ","question"], & ! this slice: script(:,:,2) [2,2,2]) - character(len=len(script)), dimension(size(script,1),size(script,2)) :: slice + character(len=len(script)), dimension(size(script,1),size(script,2)), target :: slice, expected + character(len=len(script)), dimension(:), pointer :: slice_1D_ptr, expected_1D_ptr + integer me, ni call prif_this_image_no_coarray(this_image=me) call prif_num_images(ni) slice = script(:,:,mod(me-1,size(script,3))+1) call prif_co_min(slice) - associate(expected => minval(script(:,:,1:min(ni,size(script,3))), dim=3)) - test_passes = all(expected == slice) - end associate + slice_1D_ptr(1:size(slice)) => slice + expected = minval(script(:,:,1:min(ni,size(script,3))), dim=3) + expected_1D_ptr(1:size(expected)) => expected + test_diagnosis = test_diagnosis_t( & + test_passed = all(expected == slice) & + ,diagnostics_string = "expected " // .csv. string_t(expected_1D_ptr) // "; actual " // .csv. string_t(slice_1D_ptr) & + ) end function - function alphabetically_1st_scalar_string() result(test_passes) - logical test_passes + function alphabetically_1st_scalar_string() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis integer, parameter :: length = len("to party!") character(len=length), parameter :: words(*) = [character(len=length):: "Loddy","doddy","we","like","to party!"] character(len=:), allocatable :: my_word, expected_word - integer :: me, num_imgs + integer me, num_imgs call prif_this_image_no_coarray(this_image=me) associate(periodic_index => 1 + mod(me-1,size(words))) @@ -191,7 +227,10 @@ function alphabetically_1st_scalar_string() result(test_passes) call prif_num_images(num_images=num_imgs) expected_word = minval(words(1:min(num_imgs, size(words)))) ! this line exposes a flang bug - test_passes = expected_word == my_word + test_diagnosis = test_diagnosis_t( & + test_passed = expected_word == my_word & + ,diagnostics_string = "expected " // expected_word // "; actual " // my_word & + ) end function end module prif_co_min_test_m From b3e90e50c71c41eb25cac83e2b17876241e0e451 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Fri, 3 Jan 2025 17:43:47 -0800 Subject: [PATCH 27/29] test(co_max): report diagnostics for test failures --- test/prif_co_max_test_m.F90 | 110 ++++++++++++++++++++++++------------ 1 file changed, 75 insertions(+), 35 deletions(-) diff --git a/test/prif_co_max_test_m.F90 b/test/prif_co_max_test_m.F90 index ec38e5f50..e0f2d5ae7 100644 --- a/test/prif_co_max_test_m.F90 +++ b/test/prif_co_max_test_m.F90 @@ -8,9 +8,9 @@ module prif_co_max_test_m use iso_c_binding, only: c_size_t, c_ptr, c_intmax_t, c_null_funptr use prif, only : prif_co_max, prif_num_images, prif_this_image_no_coarray, prif_num_images use prif_test_m, only : prif_test_t, test_description_substring - use julienne_m, only : test_result_t, test_description_t + use julienne_m, only : test_result_t, test_description_t, test_diagnosis_t, string_t, operator(.csv.) #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : test_function_i + use julienne_m, only : diagnosis_function_i #endif implicit none @@ -47,7 +47,7 @@ function results() result(test_results) ,test_description_t("default-character variables with no optional arguments", reverse_alphabetize_default_characters) & ] #else - procedure(test_function_i), pointer :: & + procedure(diagnosis_function_i), pointer :: & max_default_integer_scalars_ptr => max_default_integer_scalars & ,max_c_int64_scalars_ptr => max_c_int64_scalars & ,max_default_integer_1D_array_ptr => max_default_integer_1D_array & @@ -76,20 +76,24 @@ function results() result(test_results) test_results = test_descriptions%run() end function - function max_default_integer_scalars() result(test_passes) - logical test_passes + function max_default_integer_scalars() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis integer i, status_, n status_ = -1 call prif_this_image_no_coarray(this_image=i) call prif_co_max(i, stat=status_) call prif_num_images(num_images=n) - test_passes = i == n .and. status_ == 0 + test_diagnosis = test_diagnosis_t( & + test_passed = (i==n) .and. (status_==0) & + ,diagnostics_string = "expected i = " // string_t(i) // ", status_ = 0" & + // "; actual i = " // string_t(n) // ", status_ = " // string_t(status_) & + ) end function - function max_c_int64_scalars() result(test_passes) + function max_c_int64_scalars() result(test_diagnosis) use iso_c_binding, only : c_int64_t - logical test_passes + type(test_diagnosis_t) test_diagnosis integer(c_int64_t) i integer me, status_, n @@ -98,11 +102,15 @@ function max_c_int64_scalars() result(test_passes) i = me call prif_co_max(i, stat=status_) call prif_num_images(num_images=n) - test_passes = i == int(n) + test_diagnosis = test_diagnosis_t( & + test_passed = (i == int(n,c_int64_t)) .and. (status_ == 0) & + ,diagnostics_string = "expected i = " // string_t(int(i)) // ", status = 0" & + // "; actual i = " // string_t(n) // ", status = " // string_t(status_) & + ) end function - function max_default_integer_1D_array() result(test_passes) - logical test_passes + function max_default_integer_1D_array() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis integer i, me, n integer, allocatable :: array(:) @@ -112,27 +120,38 @@ function max_default_integer_1D_array() result(test_passes) array = sequence_ call prif_co_max(array) associate(max_sequence => n*[(i, i=1, n)]) - test_passes = all(max_sequence == array) + test_diagnosis = test_diagnosis_t( & + test_passed = all(max_sequence == array), & + diagnostics_string = "expected element values " // .csv. string_t(max_sequence) & + // "; actual element values " // .csv. string_t(array) & + ) end associate end associate end function - function max_default_integer_7D_array() result(test_passes) - logical test_passes - integer array(2,1,1, 1,1,1, 2), status_, me, n + function max_default_integer_7D_array() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + integer, target :: array(2,1,1, 1,1,1, 2) + integer, pointer :: array_1D_ptr(:) + integer status_, me, n status_ = -1 call prif_this_image_no_coarray(this_image=me) array = 3 - me call prif_co_max(array, stat=status_) call prif_num_images(num_images=n) - test_passes = all(array == 3 - 1) .and. status_ == 0 + array_1D_ptr(1:size(array)) => array + test_diagnosis = test_diagnosis_t( & + test_passed = all(array == 3 - 1) .and. status_ == 0 & + ,diagnostics_string = "expected element values " // string_t(3 - 1) & + // "; actual element values " // .csv. string_t(array_1D_ptr) & + ) end function - function max_default_real_scalars() result(test_passes) - logical test_passes + function max_default_real_scalars() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis real scalar - real, parameter :: pi = 3.141592654 + real, parameter :: pi = 3.141592654, tolerance = 1E-7, expected = -pi integer status_, me, n status_ = -1 @@ -140,24 +159,36 @@ function max_default_real_scalars() result(test_passes) scalar = -pi*me call prif_co_max(scalar, stat=status_) call prif_num_images(num_images=n) - test_passes = -dble(pi*1) == dble(scalar) .and. status_ == 0 + test_diagnosis = test_diagnosis_t( & + test_passed = (abs(scalar-expected) < tolerance) .and. (status_ == 0) & + ,diagnostics_string = "expected scalar " // string_t(expected) // ", status = 0" & + // "; actual scalar " // string_t(scalar) // ", status = " // string_t(status_) & + ) end function - function max_double_precision_2D_array() result(test_passes) - logical test_passes - double precision, allocatable :: array(:,:) - double precision, parameter :: tent(*,*) = dble(reshape(-[0,1,2,3,2,1], [3,2])) + function max_double_precision_2D_array() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + double precision, dimension(:,:), allocatable, target :: array, expected + double precision, dimension(:), pointer :: array_1D_ptr, expected_1D_ptr + double precision, parameter :: tent(*,*) = dble(reshape(-[0,1,2,3,2,1], [3,2])), tolerance = 1D-14 integer :: me, n call prif_this_image_no_coarray(this_image=me) array = tent*dble(me) call prif_co_max(array) call prif_num_images(num_images=n) - test_passes = all(array==tent*dble(1)) + expected = tent*dble(1) + array_1D_ptr(1:size(array)) => array + expected_1D_ptr(1:size(expected)) => expected + test_diagnosis = test_diagnosis_t( & + test_passed = all(abs(array-expected) < tolerance) & + ,diagnostics_string = "expected element values " // .csv. string_t(expected_1D_ptr) & + // "; actual element values " // .csv. string_t(array_1D_ptr) & + ) end function - function max_elements_in_2D_string_arrays() result(test_passes) - logical test_passes + function max_elements_in_2D_string_arrays() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis character(len=*), parameter :: script(*,*,*) = reshape( & [ "To be ","or not " & ! odd images get , "to ","be. " & ! this slice: script(:,:,1) @@ -165,20 +196,26 @@ function max_elements_in_2D_string_arrays() result(test_passes) , "that ","is " & ! even images get , "the ","question"], & ! this slice: script(:,:,2) [2,2,2]) - character(len=len(script)), dimension(size(script,1),size(script,2)) :: slice + character(len=len(script)), dimension(size(script,1),size(script,2)), target :: slice, expected + character(len=len(script)), dimension(:), pointer :: slice_1D_ptr, expected_1D_ptr integer me, ni call prif_this_image_no_coarray(this_image=me) call prif_num_images(ni) slice = script(:,:,mod(me-1,size(script,3))+1) call prif_co_max(slice) - associate(expected => maxval(script(:,:,1:min(ni,size(script,3))), dim=3)) - test_passes = all(expected == slice) - end associate + expected = maxval(script(:,:,1:min(ni,size(script,3))), dim=3) + expected_1D_ptr(1:size(expected)) => expected + slice_1D_ptr(1:size(slice)) => slice + test_diagnosis = test_diagnosis_t( & + test_passed = all(expected == slice) & + ,diagnostics_string = "expected slice " // .csv. string_t(expected_1D_ptr) & + // "; actual slice " // .csv. string_t(slice_1D_ptr) & + ) end function - function reverse_alphabetize_default_characters() result(test_passes) - logical test_passes + function reverse_alphabetize_default_characters() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis integer, parameter :: length = len("to party!") character(len=length), parameter :: words(*) = [character(len=length):: "Loddy","doddy","we","like","to party!"] character(len=:), allocatable :: my_word, expected_word @@ -192,7 +229,10 @@ function reverse_alphabetize_default_characters() result(test_passes) call prif_num_images(num_images=n) expected_word = maxval(words(1:min(n, size(words)))) ! this line exposes a flang bug - test_passes = expected_word == my_word + test_diagnosis = test_diagnosis_t( & + test_passed = expected_word == my_word & + ,diagnostics_string = "expected " // expected_word // "; actual " // my_word & + ) end function -end module prif_co_max_test_m +end module prif_co_max_test_m \ No newline at end of file From d70134e4de511e5aac5630b5c0d0631e3906d60d Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Fri, 3 Jan 2025 22:28:32 -0800 Subject: [PATCH 28/29] test(teams): report diagnostics for test failures --- test/prif_teams_test_m.F90 | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/test/prif_teams_test_m.F90 b/test/prif_teams_test_m.F90 index 4017f870f..1fed8cd1a 100644 --- a/test/prif_teams_test_m.F90 +++ b/test/prif_teams_test_m.F90 @@ -10,9 +10,9 @@ module prif_teams_test_m use prif, only: & prif_coarray_handle, prif_allocate_coarray, prif_deallocate_coarray, prif_this_image_no_coarray, prif_num_images & ,prif_team_type, prif_form_team, prif_change_team, prif_end_team - use julienne_m, only : test_result_t, test_description_t + use julienne_m, only : test_result_t, test_description_t, test_diagnosis_t, string_t #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : test_function_i + use julienne_m, only : diagnosis_function_i #endif implicit none @@ -40,7 +40,7 @@ function results() result(test_results) test_descriptions = [test_description_t("team creation, change, and coarray allocation", check_teams)] #else - procedure(test_function_i), pointer :: check_teams_ptr + procedure(diagnosis_function_i), pointer :: check_teams_ptr check_teams_ptr => check_teams test_descriptions = [test_description_t("team creation, change, and coarray allocation", check_teams_ptr)] #endif @@ -52,8 +52,8 @@ function results() result(test_results) test_results = test_descriptions%run() end function - function check_teams() result(test_passes) - logical test_passes + function check_teams() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis integer dummy_element, initial_num_imgs, num_imgs, me, i integer(c_size_t) element_size integer(c_intmax_t) which_team @@ -69,7 +69,12 @@ function check_teams() result(test_passes) call prif_change_team(team) call prif_num_images(num_images=num_imgs) - test_passes = num_imgs == initial_num_imgs/2 + mod(initial_num_imgs,2)*(int(which_team)-1) + associate(expected_images => initial_num_imgs/2 + mod(initial_num_imgs,2)*(int(which_team)-1)) + test_diagnosis = test_diagnosis_t( & + test_passed = num_imgs == expected_images & + ,diagnostics_string = "expected " // string_t(expected_images) // "; actual " // string_t(num_imgs) & + ) + end associate do i = 1, num_coarrays call prif_allocate_coarray( & From e892ce2e230f5cdc8562941d5f3ec2f67b18eaca Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Fri, 3 Jan 2025 23:01:15 -0800 Subject: [PATCH 29/29] test(rma): report diagnostics for test failures --- test/prif_rma_test_m.F90 | 51 +++++++++++++++++++++++----------------- 1 file changed, 30 insertions(+), 21 deletions(-) diff --git a/test/prif_rma_test_m.F90 b/test/prif_rma_test_m.F90 index 1d59df708..1a3e0cc18 100644 --- a/test/prif_rma_test_m.F90 +++ b/test/prif_rma_test_m.F90 @@ -5,7 +5,7 @@ module prif_rma_test_m !! Unit test fort the prif_rma program inititation subroutine - use julienne_m, only : test_t, test_result_t, test_description_t + use julienne_m, only : test_t, test_result_t, test_description_t, test_diagnosis_t, string_t use iso_c_binding, only: & c_ptr, c_intmax_t, c_intptr_t, c_size_t, c_null_funptr, c_f_pointer, c_loc, c_sizeof use prif_test_m, only : prif_test_t, test_description_substring @@ -23,7 +23,7 @@ module prif_rma_test_m prif_sync_all, & prif_this_image_no_coarray #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : test_function_i + use julienne_m, only : diagnosis_function_i #endif implicit none @@ -55,7 +55,7 @@ function results() result(test_results) ,test_description_t("getting a value with indirect interface", check_get_indirect) & ] #else - procedure(test_function_i), pointer :: & + procedure(diagnosis_function_i), pointer :: & check_put_ptr => check_put & ,check_put_indirect_ptr => check_put_indirect & ,check_get_ptr => check_get & @@ -76,10 +76,10 @@ function results() result(test_results) test_results = test_descriptions%run() end function - function check_put() result(test_passes) - logical test_passes + function check_put() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis - integer :: dummy_element, num_imgs, expected, neighbor + integer dummy_element, num_imgs, expected, neighbor integer, target :: me type(prif_coarray_handle) :: coarray_handle type(c_ptr) :: allocated_memory @@ -110,15 +110,17 @@ function check_put() result(test_passes) size_in_bytes = c_sizeof(me)) call prif_sync_all - test_passes = expected == local_slice - + test_diagnosis = test_diagnosis_t( & + test_passed = expected == local_slice & + ,diagnostics_string = "expected " // string_t(expected) // "; actual " // string_t(local_slice) & + ) call prif_deallocate_coarray([coarray_handle]) end function - function check_put_indirect() result(test_passes) - logical test_passes + function check_put_indirect() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis - type :: my_type + type my_type type(c_ptr) :: my_component end type @@ -167,14 +169,17 @@ function check_put_indirect() result(test_passes) call prif_sync_all call c_f_pointer(local_slice%my_component, component_access) - test_passes = expected == component_access + test_diagnosis = test_diagnosis_t( & + test_passed = expected == component_access & + ,diagnostics_string = "expected " // string_t(expected) // "; actual " // string_t(component_access) & + ) call prif_deallocate(local_slice%my_component) call prif_deallocate_coarray([coarray_handle]) end function - function check_get() result(test_passes) - logical test_passes + function check_get() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis integer :: dummy_element, num_imgs, me, neighbor, expected integer, target :: retrieved @@ -208,15 +213,17 @@ function check_get() result(test_passes) current_image_buffer = c_loc(retrieved), & size_in_bytes = c_sizeof(retrieved)) - test_passes = expected == retrieved - + test_diagnosis = test_diagnosis_t( & + test_passed = expected == retrieved & + ,diagnostics_string = "expected " // string_t(expected) // "; actual " // string_t(retrieved) & + ) call prif_deallocate_coarray([coarray_handle]) end function - function check_get_indirect() result(test_passes) - logical test_passes + function check_get_indirect() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis - type :: my_type + type my_type type(c_ptr) :: my_component end type @@ -265,8 +272,10 @@ function check_get_indirect() result(test_passes) current_image_buffer = c_loc(retrieved), & size_in_bytes = int(storage_size(retrieved)/8, c_size_t)) - test_passes = expected == retrieved - + test_diagnosis = test_diagnosis_t( & + test_passed = expected == retrieved & + ,diagnostics_string = "expected " // string_t(expected) // "; actual " // string_t(retrieved) & + ) call prif_deallocate(local_slice%my_component) call prif_deallocate_coarray([coarray_handle]) end function