fix ncontig

Author: neok-m4700

CMakeLists.txt

@@ -763,7 +763,6 @@ if(opencoarrays_aware_compiler)
   # Fixed GCC 7 regressions, should run on GCC 6 and 7
   add_caf_test(static_event_post_issue_293 3 static_event_post_issue_293)
 
-  add_caf_test(issue-493-coindex-slice 8 issue-493-coindex-slice) # Contributed by @neok-m4700 in #493
 
   # These co_reduce (#172, fixed by PR #332, addl discussion in PR
   # #331) tests are for bugs not regressions. Should be fixed in all
@@ -773,9 +772,11 @@ if(opencoarrays_aware_compiler)
   add_caf_test(co_reduce-factorial-int64 4 co_reduce-factorial-int64)
 
   # issues reported by @neok-m4700
-  add_caf_test(issue-488-multi-dim-cobounds-true  8 issue-488-multi-dim-cobounds true)
-  add_caf_test(issue-488-multi-dim-cobounds-false 8 issue-488-multi-dim-cobounds false)
-  add_caf_test(issue-503-multidim-array-broadcast 2 issue-503-multidim-array-broadcast)
+  add_caf_test(coindex-slice            8 coindex-slice)
+  add_caf_test(multi-dim-cobounds-true  8 multi-dim-cobounds true)
+  add_caf_test(multi-dim-cobounds-false 8 multi-dim-cobounds false)
+  add_caf_test(multidim-array-broadcast 2 multidim-array-broadcast)
+  add_caf_test(non-contig-red-ndarray   2 non-contig-red-ndarray)
 
   # IMAGE FAIL tests
   if(NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 7.0.0)

src/mpi/mpi_caf.c

@@ -6787,7 +6787,7 @@ internal_co_reduce (MPI_Op op, gfc_descriptor_t *source, int result_image, int *
   MPI_Datatype datatype = get_MPI_datatype (source, src_len);
 
   size = 1;
-  for (j = 0; j < rank; j++)
+  for (j = 0; j < rank; ++j)
     {
       ptrdiff_t dimextent = source->dim[j]._ubound
                             - source->dim[j].lower_bound + 1;
@@ -6812,21 +6812,18 @@ internal_co_reduce (MPI_Op op, gfc_descriptor_t *source, int result_image, int *
       goto co_reduce_cleanup;
     }
 
-  for (i = 0; i < size; i++)
+  for (i = 0; i < size; ++i)
     {
       ptrdiff_t array_offset_sr = 0;
-      ptrdiff_t stride = 1;
+      ptrdiff_t tot_ext = 1;
       ptrdiff_t extent = 1;
-      for (j = 0; j < GFC_DESCRIPTOR_RANK (source)-1; j++)
+      for (j = 0; j < rank-1; ++j)
         {
-          array_offset_sr += ((i / (extent*stride))
-                           % (source->dim[j]._ubound
-                              - source->dim[j].lower_bound + 1))
-                          * source->dim[j]._stride;
           extent = (source->dim[j]._ubound - source->dim[j].lower_bound + 1);
-          stride = source->dim[j]._stride;
+          array_offset_sr += ((i / tot_ext) % extent) * source->dim[j]._stride;
+          tot_ext *= extent;
         }
-      array_offset_sr += (i / extent) * source->dim[rank-1]._stride;
+      array_offset_sr += (i / tot_ext) * source->dim[rank-1]._stride;
       void *sr = (void *)((char *) source->base_addr
                           + array_offset_sr*GFC_DESCRIPTOR_SIZE (source));
       if (result_image == 0)
@@ -6880,10 +6877,9 @@ PREFIX (co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat, char *e
   MPI_Datatype datatype = get_MPI_datatype (a, 0);
 
   size = 1;
-  for (j = 0; j < rank; j++)
+  for (j = 0; j < rank; ++j)
     {
-      ptrdiff_t dimextent = a->dim[j]._ubound
-                            - a->dim[j].lower_bound + 1;
+      ptrdiff_t dimextent = a->dim[j]._ubound - a->dim[j].lower_bound + 1;
       if (dimextent < 0)
         dimextent = 0;
       size *= dimextent;
@@ -6915,21 +6911,18 @@ PREFIX (co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat, char *e
         caf_runtime_error ("Co_broadcast of character arrays not yet supported\n");
     }
 
-  for (i = 0; i < size; i++)
+  for (i = 0; i < size; ++i)
     {
       ptrdiff_t array_offset_sr = 0;
-      ptrdiff_t stride = 1;
+      ptrdiff_t tot_ext = 1;
       ptrdiff_t extent = 1;
-      for (j = 0; j < GFC_DESCRIPTOR_RANK (a)-1; j++)
+      for (j = 0; j < rank-1; ++j)
         {
-          array_offset_sr += ((i / (extent*stride))
-                           % (a->dim[j]._ubound
-                              - a->dim[j].lower_bound + 1))
-                          * a->dim[j]._stride;
           extent = (a->dim[j]._ubound - a->dim[j].lower_bound + 1);
-          stride = a->dim[j]._stride;
+          array_offset_sr += ((i / tot_ext) % extent) * a->dim[j]._stride;
+          tot_ext *= extent;
         }
-      array_offset_sr += (i / (extent * stride)) * a->dim[rank-1]._stride;
+      array_offset_sr += (i / tot_ext) * a->dim[rank-1]._stride;
       void *sr = (void *)((char *) a->base_addr
                           + array_offset_sr*GFC_DESCRIPTOR_SIZE (a));
 

src/tests/regression/open/issue-422-send.f90

@@ -3,8 +3,9 @@ caf_compile_executable(co_reduce-factorial-int8 issue-172-wrong-co_reduce-int8.f
 caf_compile_executable(co_reduce-factorial-int64 issue-172-wrong-co_reduce-int64.f90)
 caf_compile_executable(source-alloc-sync issue-243-source-allocation-no-sync.f90)
 caf_compile_executable(convert-before-put issue-292-convert-type-before-put.f90)
-caf_compile_executable(issue-493-coindex-slice issue-493-coindex-slice.f90)
 caf_compile_executable(issue-422-send issue-422-send.F90)
 caf_compile_executable(issue-422-send-get issue-422-send-get.F90)
-caf_compile_executable(issue-488-multi-dim-cobounds issue-488-multi-dim-cobounds.f90)
-caf_compile_executable(issue-503-multidim-array-broadcast issue-503-multidim-array-broadcast.f90)
+caf_compile_executable(multi-dim-cobounds issue-488-multi-dim-cobounds.f90)
+caf_compile_executable(coindex-slice issue-493-coindex-slice.f90)
+caf_compile_executable(multidim-array-broadcast issue-503-multidim-array-broadcast.f90)
+caf_compile_executable(non-contig-red-ndarray issue-503-non-contig-red-ndarray.f90)

src/tests/regression/open/issue-422-sendget.f90

@@ -0,0 +1,53 @@
+program main
+   real, allocatable, dimension(:, :, :, :) :: arr, arr_copy
+   integer :: i, me, nimg
+   real :: redc, sumc, sumnc, rednc
+   real :: eps = epsilon(0.)
+   logical :: failc, failnc
+
+   allocate(arr(9, 20, 3, 18))
+
+   me = this_image()
+   nimg = num_images()
+
+   if (me == 1) then
+      arr = reshape([(i, i=1, size(arr))], shape(arr))
+   end if
+
+   call co_broadcast(arr, source_image=1)
+   arr_copy = arr
+
+   print *, '==> CONTIGUOUS <=='
+   sumc = sum(arr)
+   redc = sumc
+   call co_sum(redc)
+   print *, 'sumc=', sumc
+   print *, 'excpected: nimg * sumc=', nimg * sumc
+   print *, 'got: redc=', redc
+
+   failc = abs(redc - nimg * sumc) > eps
+
+   print *, '==> NON CONTIGUOUS <=='
+   sumnc = sum(arr(::3, ::2, :, ::5))
+
+   call co_sum(arr_copy)
+   call co_sum(arr(::3, ::2, :, ::5))
+
+   rednc = sum(arr(::3, ::2, :, ::5))
+   print *, 'sumnc=', sumnc
+   print *, 'expected (nimg * sumnc)=', nimg * sumnc
+   print *, 'expected=', sum(arr_copy(::3, ::2, :, ::5))
+   print *, 'got: rednc=', rednc
+
+   failnc = abs(rednc - nimg * sumnc) > eps
+
+   sync all
+
+   if (failc .or. failnc) then
+      write(*, *) 'Test failed!'
+      error stop 5
+   else
+      write(*, *) 'Test passed.'
+   end if
+   deallocate(arr)
+end program