Merge pull request #751 from sourceryinstitute/issue-727-co-broadcast-on-mixed-derived-type

Issue 727 co broadcast on mixed derived type

Author: rouson

CMakeLists.txt

@@ -813,6 +813,9 @@ if(opencoarrays_aware_compiler)
   if((gfortran_compiler AND (NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 10.0.0)) OR (CAF_RUN_DEVELOPER_TESTS OR $ENV{OPENCOARRAYS_DEVELOPER}))
     add_caf_test(co_broadcast_allocatable_components 4 co_broadcast_allocatable_components_test)
   endif()
+  if((gfortran_compiler AND (NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 11.2.2)) OR (CAF_RUN_DEVELOPER_TESTS OR $ENV{OPENCOARRAYS_DEVELOPER}))
+    add_caf_test(co_broadcast_alloc_mixed 2 co_broadcast_alloc_mixed)
+  endif()
   add_caf_test(co_min 4 co_min_test)
   add_caf_test(co_max 4 co_max_test)
   add_caf_test(co_reduce 4 co_reduce_test)

src/mpi/mpi_caf.c

@@ -7524,6 +7524,8 @@ PREFIX(co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat,
     size *= dimextent;
   }
 
+  dprint("Using mpi-datatype: 0x%x in co_broadcast (base_addr=%p, rank= %d).\n",
+         datatype, a->base_addr, rank);
   if (rank == 0)
   {
     if( datatype == MPI_BYTE)
@@ -7564,16 +7566,17 @@ PREFIX(co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat,
 
   for (i = 0; i < size; ++i)
   {
-    ptrdiff_t array_offset_sr = 0, tot_ext = 1, extent = 1;
+    ptrdiff_t array_offset = 0, tot_ext = 1, extent = 1;
     for (j = 0; j < rank - 1; ++j)
     {
       extent = a->dim[j]._ubound - a->dim[j].lower_bound + 1;
-      array_offset_sr += ((i / tot_ext) % extent) * a->dim[j]._stride;
+      array_offset += ((i / tot_ext) % extent) * a->dim[j]._stride;
       tot_ext *= extent;
     }
-    array_offset_sr += (i / tot_ext) * a->dim[rank - 1]._stride;
+    array_offset += (i / tot_ext) * a->dim[rank - 1]._stride;
+    dprint("The array offset for element %d used in co_broadcast is %d\n", i, array_offset);
     void *sr = (void *)(
-      (char *)a->base_addr + array_offset_sr * GFC_DESCRIPTOR_SIZE(a));
+      (char *)a->base_addr + array_offset * GFC_DESCRIPTOR_SIZE(a));
 
     ierr = MPI_Bcast(sr, 1, datatype, source_image - 1, CAF_COMM_WORLD);
     chk_err(ierr);

src/tests/unit/collectives/CMakeLists.txt

@@ -4,6 +4,9 @@ caf_compile_executable(co_broadcast_derived_type_test co_broadcast_derived_type.
 if((gfortran_compiler AND (NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 10.0.0)) OR (CAF_RUN_DEVELOPER_TESTS OR $ENV{OPENCOARRAYS_DEVELOPER}))
   caf_compile_executable(co_broadcast_allocatable_components_test co_broadcast_allocatable_components.f90)
 endif()
+if((gfortran_compiler AND (NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 11.2.2)) OR (CAF_RUN_DEVELOPER_TESTS OR $ENV{OPENCOARRAYS_DEVELOPER}))
+  caf_compile_executable(co_broadcast_alloc_mixed co_broadcast_alloc_mixed.f90)
+endif()
 caf_compile_executable(co_min_test co_min.F90)
 caf_compile_executable(co_max_test co_max.F90)
 caf_compile_executable(co_reduce_test co_reduce.F90)

src/tests/unit/collectives/co_broadcast_alloc_mixed.f90

@@ -0,0 +1,78 @@
+program co_broadcast_derived_with_allocs_test
+!! author: Brad Richardson & Andre Vehreschild
+!! category: regression
+!!
+!! [issue #727](https://github.com/sourceryinstitute/opencoarrays/issues/727)
+!! broadcasting derived types with a mixture of scalar and allocatable
+!! scalars or arrays lead to unexpected results
+
+implicit none
+
+type nsas_t
+  integer :: i
+  integer, allocatable :: j
+end type
+
+type asas_t
+  integer, allocatable :: i
+  integer, allocatable :: j
+end type
+
+type nsaa_t
+  integer :: i
+  integer, allocatable :: j(:)
+end type
+
+type naaa_t
+  integer :: i(3)
+  integer, allocatable :: j(:)
+end type
+
+type(nsas_t) nsas
+type(asas_t) asas
+type(nsaa_t) nsaa
+type(naaa_t) naaa
+
+integer, parameter :: source_image = 1
+
+if (this_image() == source_image)  then
+  nsas = nsas_t(2, 3)
+
+  asas = asas_t(4, 5)
+
+  nsaa = nsaa_t(6, (/ 7, 8 /))
+
+  naaa = naaa_t((/ 9,10,11 /), (/ 12,13,14,15 /))
+else
+  allocate(nsas%j)
+
+  allocate(asas%i); allocate(asas%j)
+
+  allocate(nsaa%j(2))
+
+  allocate(naaa%j(4))
+end if
+
+print *, "nsas"
+call co_broadcast(nsas, source_image)
+if (nsas%i /= 2 .or. nsas%j /= 3)  error stop "Test failed at 1."
+
+print *, "asas"
+call co_broadcast(asas, source_image)
+if (asas%i /= 4 .or. asas%j /= 5)  error stop "Test failed at 2."
+
+print *, "nsaa"
+call co_broadcast(nsaa, source_image)
+if (nsaa%i /= 6 .or. any(nsaa%j(:) /= (/ 7, 8 /)))  error stop "Test failed at 3."
+
+print *, "naaa"
+call co_broadcast(naaa, source_image)
+if (any(naaa%i(:) /= (/ 9,10,11 /)) .or. any(naaa%j(:) /= (/ 12,13,14,15 /))) then
+  error stop "Test failed at 3."
+end if
+
+sync all
+
+print *, "Test passed."
+
+end