Merge pull request #21 from BerkeleyLab/complex-double

Finish collective subroutine support

Author: rouson

install.sh

@@ -289,6 +289,11 @@ GASNET_CC="`$PKG_CONFIG $pkg --variable=GASNET_CC`"
 GASNET_CFLAGS="`$PKG_CONFIG $pkg --variable=GASNET_CFLAGS`"
 GASNET_CPPFLAGS="`$PKG_CONFIG $pkg --variable=GASNET_CPPFLAGS`"
 
+if [ "$GASNET_CC" != "$FPM_CC" ]; then 
+  echo "GASNET_CC=$GASNET_CC" and  "FPM_CC=$FPM_CC don't match"
+  exit 1;
+fi
+
 echo "# DO NOT EDIT OR COMMIT -- Created by caffeine/install.sh" > build/fpm.toml
 cp manifest/fpm.toml.template build/fpm.toml
 GASNET_LIB_LOCATIONS=`echo $GASNET_LIBS | awk '{locs=""; for(i = 1; i <= NF; i++) if ($i ~ /^-L/) {locs=(locs " " $i);}; print locs; }'`

src/caffeine/caffeine.c

@@ -18,7 +18,7 @@ static gex_Rank_t rank, size;
   const int double_Complex_workaround = CFI_type_double_Complex;
 #else
   const int float_Complex_workaround = 2052;
-  const int double_Complex_workaround = 4011;
+  const int double_Complex_workaround =4100;
 #endif
 
 void caf_c_caffeinate(int argc, char *argv[])
@@ -63,7 +63,6 @@ void caf_c_sync_all()
   gasnet_barrier_wait(0,GASNET_BARRIERFLAG_ANONYMOUS);
 }
 
-// GASNETT_INLINE(caf_c_co_reduce)
 void caf_c_co_reduce(
   CFI_cdesc_t* a_desc, int result_image, int* stat, char* errmsg, int num_elements, gex_Coll_ReduceFn_t* user_op, void* client_data
 )
@@ -187,24 +186,22 @@ void caf_c_co_sum(CFI_cdesc_t* a_desc, int result_image, int* stat, char* errmsg
 {
   gex_DT_t a_type;
 
+  size_t c_sizeof_a = a_desc->elem_len;
+
   switch (a_desc->type)
   {
     case CFI_type_int32_t:          a_type = GEX_DT_I32; break;
     case CFI_type_int64_t:          a_type = GEX_DT_I64; break;
     case CFI_type_float:            a_type = GEX_DT_FLT; break;
     case CFI_type_double:           a_type = GEX_DT_DBL; break;
-    case float_Complex_workaround:  a_type = GEX_DT_FLT; num_elements *= 2; break;
-    case double_Complex_workaround: a_type = GEX_DT_DBL; num_elements *= 2; break;
+    case float_Complex_workaround:  a_type = GEX_DT_FLT; num_elements *= 2; c_sizeof_a /= 2; break;
+    case double_Complex_workaround: a_type = GEX_DT_DBL; num_elements *= 2; c_sizeof_a /= 2; break;
     default:
       set_stat_errmsg_or_abort(stat, errmsg, UNRECOGNIZED_TYPE, "");
   }
 
   char* a_address = (char*) a_desc->base_addr;
 
-  size_t c_sizeof_a = a_desc->elem_len;
-
-  if (a_type == float_Complex_workaround || a_type == double_Complex_workaround) c_sizeof_a /= 2;
-
   gex_Event_t ev;
 
   if (result_image) {

src/caffeine/collective_subroutines/co_broadcast_s.f90

@@ -1,5 +1,5 @@
 submodule(collective_subroutines_m)  co_broadcast_s
-  use iso_c_binding, only : c_int, c_size_t, c_ptr, c_loc, c_sizeof, c_int64_t, c_double
+  use iso_c_binding, only : c_ptr
   use utilities_m, only : get_c_ptr
   use caffeine_h_m, only : caf_c_co_broadcast
   implicit none

src/caffeine/collective_subroutines/co_reduce_s.f90

@@ -2,7 +2,7 @@
 ! Terms of use are as specified in LICENSE.txt
 submodule(collective_subroutines_m) co_reduce_s
   use iso_c_binding, only : &
-    c_int64_t, c_ptr, c_size_t, c_loc, c_double, c_null_ptr, c_funloc, c_associated, c_f_pointer, c_int, c_f_procpointer
+    c_ptr, c_size_t, c_loc, c_null_ptr, c_funloc, c_associated, c_f_pointer, c_int, c_f_procpointer
   use assert_m, only : assert
   use intrinsic_array_m, only : intrinsic_array_t
   use utilities_m, only : get_c_ptr, get_c_ptr_character, optional_value
@@ -16,11 +16,15 @@
   module procedure caf_co_reduce
 
     type(c_ptr) :: stat_ptr = c_null_ptr, errmsg_ptr = c_null_ptr
+
     procedure(c_int32_t_operation), pointer :: int32_op => null()
+    procedure(c_int64_t_operation), pointer :: int64_op => null()
     procedure(c_float_operation), pointer :: float_op => null()
+    procedure(c_double_operation), pointer :: double_op => null()
     procedure(c_bool_operation), pointer :: bool_op => null()
     procedure(c_char_operation), pointer :: char_op => null()
     procedure(c_float_complex_operation), pointer :: float_complex_op => null()
+    procedure(c_double_complex_operation), pointer :: double_complex_op => null()
 
     call assert(c_associated(operation), "caf_co_reduce: c_associated(operation)")
 
@@ -31,6 +35,14 @@
       call c_f_procpointer(operation, int32_op)
       call caf_c_co_reduce(a, optional_value(result_image), stat_ptr, errmsg_ptr, &
         int(product(shape(a)), c_size_t), c_funloc(Coll_ReduceSub_c_int32_t), c_null_ptr)
+    else if (caf_c_same_cfi_type(a, 0_c_int64_t)) then
+      call c_f_procpointer(operation, int64_op)
+      call caf_c_co_reduce(a, optional_value(result_image), stat_ptr, errmsg_ptr, &
+        int(product(shape(a)), c_size_t), c_funloc(Coll_ReduceSub_c_int64_t), c_null_ptr)
+    else if (caf_c_same_cfi_type(a, 1._c_double)) then
+      call c_f_procpointer(operation, double_op)
+      call caf_c_co_reduce(a, optional_value(result_image), stat_ptr, errmsg_ptr, &
+        int(product(shape(a)), c_size_t), c_funloc(Coll_ReduceSub_c_double), c_null_ptr)
     else if (caf_c_same_cfi_type(a, 1._c_float)) then
       call c_f_procpointer(operation, float_op)
       call caf_c_co_reduce(a, optional_value(result_image), stat_ptr, errmsg_ptr, &
@@ -51,6 +63,10 @@
       call c_f_procpointer(operation, float_complex_op)
       call caf_c_co_reduce(a, optional_value(result_image), stat_ptr, errmsg_ptr, &
         int(product(shape(a)), c_size_t), c_funloc(Coll_ReduceSub_c_float_complex), c_null_ptr)
+    else if (caf_c_same_cfi_type(a, (0._c_double, 0._c_double))) then
+      call c_f_procpointer(operation, double_complex_op)
+      call caf_c_co_reduce(a, optional_value(result_image), stat_ptr, errmsg_ptr, &
+        int(product(shape(a)), c_size_t), c_funloc(Coll_ReduceSub_c_double_complex), c_null_ptr)
     else
       error stop "caf_co_reduce: unsupported type"
     end if
@@ -75,6 +91,42 @@ subroutine Coll_ReduceSub_c_int32_t(arg1, arg2_and_out, count, cdata) bind(C)
       end do
     end subroutine
 
+    subroutine Coll_ReduceSub_c_int64_t(arg1, arg2_and_out, count, cdata) bind(C)
+      type(c_ptr), value :: arg1         !! "Left" operands
+      type(c_ptr), value :: arg2_and_out !! "Right" operands and result
+      integer(c_size_t), value :: count  !! Operand count
+      type(c_ptr), value ::  cdata       !! Client data
+      integer(c_int64_t), pointer :: lhs(:)=>null(), rhs_and_result(:)=>null()
+      integer(c_size_t) i
+
+      call assert(all([c_associated(arg1), c_associated(arg2_and_out)]), "Coll_ReduceSub_c_int64_t: operands associated")
+
+      call c_f_pointer(arg1, lhs, [count])
+      call c_f_pointer(arg2_and_out, rhs_and_result, [count])
+
+      do concurrent(i=1:count)
+        rhs_and_result(i) = int64_op(lhs(i), rhs_and_result(i))
+      end do
+    end subroutine
+
+    subroutine Coll_ReduceSub_c_double(arg1, arg2_and_out, count, cdata) bind(C)
+      type(c_ptr), value :: arg1         !! "Left" operands
+      type(c_ptr), value :: arg2_and_out !! "Right" operands and result
+      integer(c_size_t), value :: count  !! Operand count
+      type(c_ptr), value ::  cdata       !! Client data
+      real(c_double), pointer :: lhs(:)=>null(), rhs_and_result(:)=>null()
+      integer(c_size_t) i
+
+      call assert(all([c_associated(arg1), c_associated(arg2_and_out)]), "Coll_ReduceSub_c_double: operands associated")
+
+      call c_f_pointer(arg1, lhs, [count])
+      call c_f_pointer(arg2_and_out, rhs_and_result, [count])
+
+      do concurrent(i=1:count)
+        rhs_and_result(i) = double_op(lhs(i), rhs_and_result(i))
+      end do
+    end subroutine
+
     subroutine Coll_ReduceSub_c_float(arg1, arg2_and_out, count, cdata) bind(C)
       type(c_ptr), value :: arg1         !! "Left" operands
       type(c_ptr), value :: arg2_and_out !! "Right" operands and result
@@ -93,6 +145,24 @@ subroutine Coll_ReduceSub_c_float(arg1, arg2_and_out, count, cdata) bind(C)
       end do
     end subroutine
 
+    subroutine Coll_ReduceSub_c_double_complex(arg1, arg2_and_out, count, cdata) bind(C)
+      type(c_ptr), value :: arg1         !! "Left" operands
+      type(c_ptr), value :: arg2_and_out !! "Right" operands and result
+      integer(c_size_t), value :: count  !! Operand count
+      type(c_ptr), value ::  cdata       !! Client data
+      complex(c_double), pointer :: lhs(:)=>null(), rhs_and_result(:)=>null()
+      integer(c_size_t) i
+
+      call assert(all([c_associated(arg1), c_associated(arg2_and_out)]), "Coll_ReduceSub_c_dobule_complex: operands associated")
+
+      call c_f_pointer(arg1, lhs, [count])
+      call c_f_pointer(arg2_and_out, rhs_and_result, [count])
+
+      do concurrent(i=1:count)
+        rhs_and_result(i) = double_complex_op(lhs(i), rhs_and_result(i))
+      end do
+    end subroutine
+
     subroutine Coll_ReduceSub_c_float_complex(arg1, arg2_and_out, count, cdata) bind(C)
       type(c_ptr), value :: arg1         !! "Left" operands
       type(c_ptr), value :: arg2_and_out !! "Right" operands and result

src/caffeine/collective_subroutines_m.f90

@@ -1,7 +1,7 @@
 ! Copyright (c), The Regents of the University of California
 ! Terms of use are as specified in LICENSE.txt
 module collective_subroutines_m 
-  use iso_c_binding, only : c_int32_t, c_float, c_char, c_bool, c_funptr
+  use iso_c_binding, only : c_int32_t, c_int64_t, c_float, c_char, c_bool, c_funptr, c_double
   implicit none
 
   private
@@ -10,11 +10,15 @@ module collective_subroutines_m
   public :: caf_co_min
   public :: caf_co_reduce
   public :: caf_co_broadcast
+
   public :: c_int32_t_operation
+  public :: c_int64_t_operation
   public :: c_float_operation
+  public :: c_double_operation
   public :: c_bool_operation
   public :: c_char_operation
   public :: c_float_complex_operation
+  public :: c_double_complex_operation
 
   abstract interface 
 
@@ -25,13 +29,27 @@ pure function c_int32_t_operation(lhs, rhs) result(lhs_op_rhs)
       integer(c_int32_t) lhs_op_rhs
     end function
 
+    pure function c_int64_t_operation(lhs, rhs) result(lhs_op_rhs)
+      import c_int64_t
+      implicit none
+      integer(c_int64_t), intent(in) :: lhs, rhs
+      integer(c_int64_t) lhs_op_rhs
+    end function
+
     pure function c_float_operation(lhs, rhs) result(lhs_op_rhs)
       import c_float
       implicit none
       real(c_float), intent(in) :: lhs, rhs
       real(c_float) lhs_op_rhs
     end function
 
+    pure function c_double_operation(lhs, rhs) result(lhs_op_rhs)
+      import c_double
+      implicit none
+      real(c_double), intent(in) :: lhs, rhs
+      real(c_double) lhs_op_rhs
+    end function
+
     pure function c_bool_operation(lhs, rhs) result(lhs_op_rhs)
       import c_bool
       implicit none
@@ -53,6 +71,13 @@ pure function c_float_complex_operation(lhs, rhs) result(lhs_op_rhs)
       complex(c_float) lhs_op_rhs
     end function
 
+    pure function c_double_complex_operation(lhs, rhs) result(lhs_op_rhs)
+      import c_double
+      implicit none
+      complex(c_double), intent(in) :: lhs, rhs
+      complex(c_double) lhs_op_rhs
+    end function
+
   end interface
 
   interface

test/caf_co_broadcast_test.f90

@@ -1,6 +1,6 @@
 module caf_co_broadcast_test
   use caffeine_m, only : caf_co_broadcast, caf_num_images, caf_this_image
-  use vegetables, only : result_t, test_item_t, assert_equals, describe, it, assert_equals, assert_that
+  use vegetables, only : result_t, test_item_t, describe, it, assert_equals, assert_that
 
   implicit none
   private

test/caf_co_max_test.f90

@@ -21,7 +21,7 @@ function test_caf_co_max() result(tests)
            ,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) &
+           ,it("elements across images with 3D arrays of strings", max_elements_in_3D_string_arrays) &
         ])
     end function
 
@@ -91,15 +91,15 @@ function max_double_precision_2D_array() result(result_)
         result_ = assert_that(all(array==tent))
     end function
 
-    function max_elements_in_2D_string_arrays() result(result_)
+    function max_elements_in_3D_string_arrays() result(result_)
       type(result_t) result_
       character(len=*), parameter :: script(*) = ["To be ","or not","to    ","be.   "]
-      character(len=len(script)), dimension(2,2) :: scramlet, co_max_scramlet
+      character(len=len(script)), dimension(2,1,2) :: scramlet, co_max_scramlet
       integer i, cyclic_permutation(size(script))
 
       associate(me => this_image())
         associate(cyclic_permutation => [(1 + mod(i-1,size(script)), i=me, me+size(script) )]) 
-          scramlet = reshape(script(cyclic_permutation), [2,2])
+          scramlet = reshape(script(cyclic_permutation), shape(scramlet))
         end associate
       end associate
 
@@ -118,7 +118,7 @@ function max_elements_in_2D_string_arrays() result(result_)
             end associate
           end do
         end do
-        expected_scramlet = reshape(expected_script, shape(scramlet))
+        expected_scramlet = reshape(expected_script, shape(expected_scramlet))
 
         result_ =  assert_that(all(scramlet == co_max_scramlet),"all(scramlet == co_max_scramlet)")
       end block

test/caf_co_min_test.f90

@@ -93,13 +93,14 @@ function min_double_precision_2D_array() result(result_)
 
     function min_elements_in_2D_string_arrays() result(result_)
       type(result_t) result_
-      character(len=*), parameter :: script(*) = ["To be ","or not","to    ","be.   "]
-      character(len=len(script)), dimension(2,2) :: scramlet, co_min_scramlet
+      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))
 
       associate(me => this_image())
         associate(cyclic_permutation => [(1 + mod(i-1,size(script)), i=me, me+size(script) )])
-          scramlet = reshape(script(cyclic_permutation), [2,2])
+          scramlet = reshape(script(cyclic_permutation), shape(scramlet))
         end associate
       end associate
 
@@ -127,7 +128,7 @@ function min_elements_in_2D_string_arrays() result(result_)
 
     function alphabetically_1st_scalar_string() result(result_)
       type(result_t) result_
-      character(len=*), parameter :: words(*) = [character(len=len("loddy")):: "loddy","doddy","we","like","to","party"]
+      character(len=*), parameter :: words(*) = [character(len=len("to party!")):: "Loddy","doddy","we","like","to party!"]
       character(len=:), allocatable :: my_word
 
       associate(me => caf_this_image())