Add and test data_partition type

README.md

@@ -35,11 +35,14 @@ Utility functions
 
 * Array functions
 * Assertions
-* Emulated intrinsic functions
+* Emulated intrinsic functions: `findloc`
+* Emulated collective subroutines: `co_sum`, `co_broadcast`
+* User-defined collective subroutines: `co_all`
 * String functions
 
 Classes
 -------
+* Parallel data partitioning and gathering
 * (Co-)Object pattern abstract parent
 
 Prerequisites
@@ -65,13 +68,19 @@ fpm test \
   --flag "-Wall" \
   --flag "-std=f2018" \
   --flag "-DCOMPILER_LACKS_COLLECTIVE_SUBROUTINES" \
-  --flag "-DCOMPILER_LACKS_FINDLOC" 
+  --flag "-DCOMPILER_LACKS_FINDLOC"
 ```
-where the `COMPILER_LACKS_*` flags exercise the Sourcery Library's 
-emulated instrinsic procedures, which are intended for use with 
+where the `COMPILER_LACKS_*` flags exercise the Sourcery Library's
+emulated instrinsic procedures, which are intended for use with
 compiler versions that lack support for the named features.  Delete
 those flags with compilers that support these features.
 
+Build documentation
+-------------------
+```zsh
+ford doc/ford-documentation.md
+```
+
 [GNU Fortran]: https://gcc.gnu.org
 [OpenCoarrays]: https://github.com/sourceryinstitute/opencoarrays
 [fpm]: https://github.com/fortran-lang/fpm

src/data-partition-implementation.F90

@@ -0,0 +1,148 @@
+submodule(data_partition_interface) data_partition_implementation
+  use assertions_interface, only : assert, assertions
+  implicit none
+
+contains
+
+  module procedure define_partitions
+
+    if (allocated(first_datum)) deallocate(first_datum)
+    if (allocated(last_datum)) deallocate(last_datum)
+
+    associate( ni => num_images() )
+
+      call assert( ni<=cardinality, "sufficient data for distribution across images")
+
+      allocate(first_datum(ni), last_datum(ni))
+
+      block
+        integer i, image
+        do image=1,ni
+          associate( remainder => mod(cardinality, ni), quotient => cardinality/ni )
+            first_datum(image) = sum([(quotient+overflow(i, remainder), i=1, image-1)]) + 1
+            last_datum(image) = first_datum(image) + quotient + overflow(image, remainder) - 1
+          end associate
+        end do
+      end block
+    end associate
+
+#ifdef FORD
+  end procedure
+#else
+  contains
+#endif
+
+    pure function overflow(im, excess) result(extra_datum)
+      integer, intent(in) :: im, excess
+      integer extra_datum
+      extra_datum= merge(1,0,im<=excess)
+    end function
+
+#ifndef FORD
+  end procedure
+#endif
+
+  module procedure first
+    if (assertions) call assert( allocated(first_datum), "allocated(first_datum)")
+    first_index= first_datum( image_number )
+  end procedure
+
+  module procedure last
+    if (assertions) call assert( allocated(last_datum), "allocated(last_datum)")
+    last_index = last_datum( image_number )
+  end procedure
+
+  module procedure gather_real_1D_array
+
+    if (present(dim)) call assert (dim==1, "dimensioned partitioned == 1")
+
+    associate( me => this_image() )
+      write(6,*) 'gather_real_1D_array(): executing on image', me
+      flush(6)
+      associate( first=>first(me), last=>last(me) )
+        if (.not. present(result_image)) then
+          a(1:first-1)  = 0.
+          a(last+1:)  = 0.
+          call co_sum(a)
+        else
+          block
+            real(real64), allocatable, dimension(:) :: a_lower, a_upper
+            a_lower = a(1:first-1)
+            a_upper = a(last+1:)
+            a(1:first-1)  = 0.
+            a(last+1:)  = 0.
+            call co_sum(a, result_image=result_image)
+            if (result_image /= me) then
+              a(1:first-1) = a_lower
+              a(last+1:) = a_upper
+            end if
+          end block
+        end if
+      end associate
+    end associate
+  end procedure
+
+  module procedure gather_real_2D_array
+
+    integer dim_
+    if (present(dim)) then
+      dim_ = dim
+    else
+      dim_ = 2
+    end if
+
+    associate( me => this_image() )
+      write(6,*) 'gather_real_2D_array(): executing on image', me
+      flush(6)
+      associate( first => first(me), last => last(me) )
+        if (.not. present(result_image)) then
+          select case(dim_)
+            case(1)
+              a(1:first-1, :) = 0.
+              a(last+1:, :) = 0.
+            case(2)
+              a(:, 1:first-1) = 0.
+              a(:, last+1:) = 0.
+            case default
+              error stop "gather_real_2D_array: invalid dim argument"
+          end select
+          call co_sum(a)
+        else
+          block
+            real(real64), allocatable, dimension(:,:) :: a_lower, a_upper
+            select case(dim_)
+              case(1)
+                a_lower = a(1:first-1, :)
+                a_upper = a(last+1:, :)
+                a(1:first-1, :) = 0.
+                a(last+1:, :) = 0.
+              case(2)
+                a_lower = a(:, 1:first-1)
+                a_upper = a(:, last+1:)
+                a(:, 1:first-1) = 0.
+                a(:, last+1:) = 0.
+              case default
+                error stop "gather_real_2D_array: invalid dim argument"
+            end select
+
+            call co_sum(a, result_image=result_image)
+
+            if (result_image /= me) then
+              select case(dim_)
+                case(1)
+                  a(1:first-1, :) = a_lower
+                  a(last+1:, :) = a_upper
+                case(2)
+                  a(:, 1:first-1) = a_lower
+                  a(:, last+1:) = a_upper
+                case default
+                  error stop "gather_real_2D_array: invalid dim argument"
+              end select
+            end if
+          end block
+        end if
+      end associate
+    end associate
+  end procedure
+
+end submodule data_partition_implementation

src/data-partition-interface.f90

@@ -0,0 +1,64 @@
+module data_partition_interface
+  !! distribute data identification numbers across images such that the number of
+  !! items differs by at most 1 between any two images.
+  use iso_fortran_env, only : real64
+  implicit none
+
+  private
+  public :: data_partition
+
+  type data_partition
+    !! encapsulate a description of the data subset the executing image owns
+    private
+  contains
+    procedure, nopass :: define_partitions
+    procedure, nopass :: first
+    procedure, nopass :: last
+    procedure, nopass, private :: gather_real_2D_array, gather_real_1D_array
+    generic :: gather => gather_real_2D_array, gather_real_1D_array
+  end type
+
+  integer, allocatable :: first_datum(:), last_datum(:)
+
+  interface
+
+    module subroutine define_partitions(cardinality)
+      !! define the range of data identification numbers owned by the executing image
+      integer, intent(in) :: cardinality
+    end subroutine
+
+    pure module function first(image_number) result(first_index)
+      !! the result is the first identification number owned by the executing image
+      implicit none
+      integer, intent(in) :: image_number
+      integer first_index
+    end function
+
+    pure module function last(image_number) result(last_index)
+      !! the result is the last identification number owned by the executing image
+      implicit none
+      integer, intent(in) :: image_number
+      integer last_index
+    end function
+
+    !! Gathers are inherently expensive and are best used either
+    !! 1. Near the beginning/end of execution to amortize costs across an entire run or
+    !! 2. Temporarily while developing/debugging code.
+
+    module subroutine gather_real_1D_array( a, result_image, dim )
+      !! Gather the elements of an 1D array distributed along dimension dim onto result_image
+      real(real64), intent(inout) :: a(:)
+      integer, intent(in), optional :: result_image
+      integer, intent(in), optional :: dim
+    end subroutine
+
+    module subroutine gather_real_2D_array( a, result_image, dim )
+      !! Gather the elements of an 2D array distributed along dimension dim onto result_image
+      real(real64), intent(inout) :: a(:,:)
+      integer, intent(in), optional :: result_image
+      integer, intent(in), optional :: dim
+    end subroutine
+
+  end interface
+
+end module data_partition_interface

src/emulated_intrinsics_implementation.F90

@@ -12,13 +12,19 @@
 
   module procedure co_all
       call co_reduce(boolean, both)
+#ifdef FORD
+  end procedure
+#else
   contains
+#endif
     pure function both(lhs,rhs) result(lhs_and_rhs)
       logical, intent(in) :: lhs,rhs
       logical lhs_and_rhs
       lhs_and_rhs = lhs .and. rhs
     end function
+#ifndef FORD
   end procedure
+#endif
 
 #ifdef COMPILER_LACKS_COLLECTIVE_SUBROUTINES
   module procedure co_sum_integer