update patch for issue 493 - improved regression scenario

Author: neok-m4700

src/mpi/mpi_caf.c

@@ -4627,10 +4627,13 @@ PREFIX (get_by_ref) (caf_token_t token, int image_index,
                         }
                     }
 
-                  /* Only increase the dim counter, when in an array ref, and
-                     MODE != CAF_ARR_REF_SINGLE (delta == 1) see caf_array_ref_t. */
-                  if (in_array_ref && dst_cur_dim < dst_rank && delta != 1)
-                    ++dst_cur_dim;
+                  /* Only increase the dim counter, when in an array ref */
+                  if (in_array_ref && dst_cur_dim < dst_rank)
+                  {
+                    // Mode != CAF_ARR_REF_SINGLE (delta == 1), and no rank reduction
+                    if (!(delta == 1 && dst_rank != GFC_DESCRIPTOR_RANK(src)))
+                      ++dst_cur_dim;
+                  }
                 }
               size *= (ptrdiff_t)delta;
             }
@@ -4776,10 +4779,13 @@ PREFIX (get_by_ref) (caf_token_t token, int image_index,
                           dst->dim[dst_cur_dim]._stride = size;
                         }
                     }
-                  /* Only increase the dim counter, when in an array ref, and
-                     MODE != CAF_ARR_REF_SINGLE (delta == 1) see caf_array_ref_t. */
-                  if (in_array_ref && dst_cur_dim < dst_rank && delta != 1)
-                    ++dst_cur_dim;
+                  /* Only increase the dim counter, when in an array ref */
+                  if (in_array_ref && dst_cur_dim < dst_rank)
+                  {
+                    // Mode != CAF_ARR_REF_SINGLE (delta == 1), and no rank reduction
+                    if (!(delta == 1 && dst_rank != GFC_DESCRIPTOR_RANK(src)))
+                      ++dst_cur_dim;
+                  }
                 }
               size *= (ptrdiff_t)delta;
             }
@@ -5350,7 +5356,7 @@ PREFIX (send_by_ref) (caf_token_t token, int image_index,
                                   "rank out of range.\n";
     const char extentoutofrange[] = "libcaf_mpi::caf_send_by_ref(): "
                                     "extent out of range.\n";
-    const char cannotallocdst[] = "libcaf_mpi::caf_get_by_ref(): "
+    const char cannotallocdst[] = "libcaf_mpi::caf_send_by_ref(): "
                                   "can not allocate %d bytes of memory.\n";
     const char unabletoallocdst[] = "libcaf_mpi::caf_send_by_ref(): "
                                   "unable to allocate memory on remote image.\n";

src/tests/regression/reported/issue-493-coindex-slice.f90

@@ -5,7 +5,9 @@ program slice
 
    type(coarr) :: co
    integer :: nimg, me, z, nx, ny, nz, north, south, mex, mey, mez, coords(3)
-   real, allocatable :: bufxz(:, :) ! a plane (2d) slice, normal in the y direction
+   integer :: shape2d(2), shape3d(3)
+   real, allocatable :: buf3d(:, :, :) ! a plane slice as a rank 3 array with a single transverse layer
+   real, allocatable :: buf2d(:, :) ! a plane (2d) slice, normal in the y direction
 
    nx = 6
    ny = 4
@@ -17,7 +19,12 @@ program slice
    if (nimg /= 8) stop
 
    allocate(co % a(nx, ny, nz)[1:2, 1:2, *])
-   allocate(bufxz(nx, nz))
+   allocate(buf2d(nx, nz), buf3d(nx, 1, nz))
+
+   ! this example should NOT reallocate buf2d nor buf3d
+   ! compare shapes before and after syncing
+   shape2d = shape(buf2d)
+   shape3d = shape(buf3d)
 
    co % a = reshape([(z, z=1, nx * ny * nz)], shape(co % a))
 
@@ -33,19 +40,34 @@ program slice
    if (north <= 2) then
       z = image_index(co % a, [mex, north, mez])
       sync images(z)
-      bufxz = co % a(1:nx, 1, 1:nz)[mex, north, mez]
-      co % a(1:nx, ny, 1:nz) = bufxz
+      ! no reduction on rank
+      buf3d = co % a(1:nx, 1:1, 1:nz)[mex, north, mez]
+      co % a(1:nx, ny:ny, 1:nz) = buf3d
+
+      ! reduction along dim 2
+      buf2d = co % a(1:nx, 1, 1:nz)[mex, north, mez]
+      co % a(1:nx, ny, 1:nz) = buf2d
    end if
    if (south >= 1) then
       z = image_index(co % a, [mex, south, mez])
       sync images(z)
-      bufxz = co % a(1:nx, 1, 1:nz)[mex, south, mez]
-      co % a(1:nx, ny, 1:nz) = bufxz
+      buf3d = co % a(1:nx, ny:ny, 1:nz)[mex, south, mez]
+      co % a(1:nx, 1:1, 1:nz) = buf3d
+
+      buf2d = co % a(1:nx, ny, 1:nz)[mex, south, mez]
+      co % a(1:nx, 1, 1:nz) = buf2d
    end if
    sync all
 
-   deallocate(co % a, bufxz)
-   if(this_image() == 1) write(*,*) "Test passed."
+   deallocate(co % a, buf2d, buf3d)
+   
+   if (any(shape2d /= shape(buf2d)) .or. any(shape3d /= shape(buf3d))) then
+      write(*, *) 'Test failed!'
+      error stop 5
+   else
+      write(*, *) 'Test passed.'
+   end if
+
    ! Regression would cause error message:
    ! Fortran runtime error on image <...>: libcaf_mpi::caf_get_by_ref(): rank out of range.
- end program
+end program