Skip to content

Commit 93a6a1e

Browse files
author
Damian Rouson
committed
feat(test): add data partitioning/gathering
with unit tests
1 parent 5232cd6 commit 93a6a1e

File tree

4 files changed

+400
-6
lines changed

4 files changed

+400
-6
lines changed

‎src/data-partition-implementation.f90‎

Lines changed: 142 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,142 @@
1+
submodule(data_partition_interface) data_partition_implementation
2+
use assertions_interface, only : assert, assertions
3+
implicit none
4+
5+
contains
6+
7+
module procedure define_partitions
8+
9+
if (allocated(first_datum)) deallocate(first_datum)
10+
if (allocated(last_datum)) deallocate(last_datum)
11+
12+
associate( ni => num_images() )
13+
14+
call assert( ni<=cardinality, "sufficient data for distribution across images")
15+
16+
allocate(first_datum(ni), last_datum(ni))
17+
18+
block
19+
integer i, image
20+
do image=1,ni
21+
associate( remainder => mod(cardinality, ni), quotient => cardinality/ni )
22+
first_datum(image) = sum([(quotient+overflow(i, remainder), i=1, image-1)]) + 1
23+
last_datum(image) = first_datum(image) + quotient + overflow(image, remainder) - 1
24+
end associate
25+
end do
26+
end block
27+
end associate
28+
29+
contains
30+
31+
pure function overflow(im, excess) result(extra_datum)
32+
integer, intent(in) :: im, excess
33+
integer extra_datum
34+
extra_datum= merge(1,0,im<=excess)
35+
end function
36+
37+
end procedure
38+
39+
module procedure first
40+
if (assertions) call assert( allocated(first_datum), "allocated(first_datum)")
41+
first_index= first_datum( image_number )
42+
end procedure
43+
44+
module procedure last
45+
if (assertions) call assert( allocated(last_datum), "allocated(last_datum)")
46+
last_index = last_datum( image_number )
47+
end procedure
48+
49+
module procedure gather_real_1D_array
50+
51+
if (present(dim)) call assert (dim==1, "dimensioned partitioned == 1")
52+
53+
associate( me => this_image() )
54+
write(6,*) 'gather_real_1D_array(): executing on image', me
55+
flush(6)
56+
associate( first=>first(me), last=>last(me) )
57+
if (.not. present(result_image)) then
58+
a(1:first-1) = 0.
59+
a(last+1:) = 0.
60+
call co_sum(a)
61+
else
62+
block
63+
real(real64), allocatable, dimension(:) :: a_lower, a_upper
64+
a_lower = a(1:first-1)
65+
a_upper = a(last+1:)
66+
a(1:first-1) = 0.
67+
a(last+1:) = 0.
68+
call co_sum(a, result_image=result_image)
69+
if (result_image /= me) then
70+
a(1:first-1) = a_lower
71+
a(last+1:) = a_upper
72+
end if
73+
end block
74+
end if
75+
end associate
76+
end associate
77+
end procedure
78+
79+
module procedure gather_real_2D_array
80+
81+
integer dim_
82+
if (present(dim)) then
83+
dim_ = dim
84+
else
85+
dim_ = 2
86+
end if
87+
88+
associate( me => this_image() )
89+
write(6,*) 'gather_real_2D_array(): executing on image', me
90+
flush(6)
91+
associate( first => first(me), last => last(me) )
92+
if (.not. present(result_image)) then
93+
select case(dim_)
94+
case(1)
95+
a(1:first-1, :) = 0.
96+
a(last+1:, :) = 0.
97+
case(2)
98+
a(:, 1:first-1) = 0.
99+
a(:, last+1:) = 0.
100+
case default
101+
error stop "gather_real_2D_array: invalid dim argument"
102+
end select
103+
call co_sum(a)
104+
else
105+
block
106+
real(real64), allocatable, dimension(:,:) :: a_lower, a_upper
107+
select case(dim_)
108+
case(1)
109+
a_lower = a(1:first-1, :)
110+
a_upper = a(last+1:, :)
111+
a(1:first-1, :) = 0.
112+
a(last+1:, :) = 0.
113+
case(2)
114+
a_lower = a(:, 1:first-1)
115+
a_upper = a(:, last+1:)
116+
a(:, 1:first-1) = 0.
117+
a(:, last+1:) = 0.
118+
case default
119+
error stop "gather_real_2D_array: invalid dim argument"
120+
end select
121+
122+
call co_sum(a, result_image=result_image)
123+
124+
if (result_image /= me) then
125+
select case(dim_)
126+
case(1)
127+
a(1:first-1, :) = a_lower
128+
a(last+1:, :) = a_upper
129+
case(2)
130+
a(:, 1:first-1) = a_lower
131+
a(:, last+1:) = a_upper
132+
case default
133+
error stop "gather_real_2D_array: invalid dim argument"
134+
end select
135+
end if
136+
end block
137+
end if
138+
end associate
139+
end associate
140+
end procedure
141+
142+
end submodule data_partition_implementation

‎src/data-partition-interface.f90‎

Lines changed: 64 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,64 @@
1+
module data_partition_interface
2+
!! distribute data identification numbers across images such that the number of
3+
!! items differs by at most 1 between any two images.
4+
use iso_fortran_env, only : real64
5+
implicit none
6+
7+
private
8+
public :: data_partition
9+
10+
type data_partition
11+
!! encapsulate a description of the data subset the executing image owns
12+
private
13+
contains
14+
procedure, nopass :: define_partitions
15+
procedure, nopass :: first
16+
procedure, nopass :: last
17+
procedure, nopass, private :: gather_real_2D_array, gather_real_1D_array
18+
generic :: gather => gather_real_2D_array, gather_real_1D_array
19+
end type
20+
21+
integer, allocatable :: first_datum(:), last_datum(:)
22+
23+
interface
24+
25+
module subroutine define_partitions(cardinality)
26+
!! define the range of data identification numbers owned by the executing image
27+
integer, intent(in) :: cardinality
28+
end subroutine
29+
30+
pure module function first(image_number) result(first_index)
31+
!! the result is the first identification number owned by the executing image
32+
implicit none
33+
integer, intent(in) :: image_number
34+
integer first_index
35+
end function
36+
37+
pure module function last(image_number) result(last_index)
38+
!! the result is the last identification number owned by the executing image
39+
implicit none
40+
integer, intent(in) :: image_number
41+
integer last_index
42+
end function
43+
44+
!! Gathers are inherently expensive and are best used either
45+
!! 1. Near the beginning/end of execution to amortize costs across an entire run or
46+
!! 2. Temporarily while developing/debugging code.
47+
48+
module subroutine gather_real_1D_array( a, result_image, dim )
49+
!! Gather the elements of an 1D array distributed along dimension dim onto result_image
50+
real(real64), intent(inout) :: a(:)
51+
integer, intent(in), optional :: result_image
52+
integer, intent(in), optional :: dim
53+
end subroutine
54+
55+
module subroutine gather_real_2D_array( a, result_image, dim )
56+
!! Gather the elements of an 2D array distributed along dimension dim onto result_image
57+
real(real64), intent(inout) :: a(:,:)
58+
integer, intent(in), optional :: result_image
59+
integer, intent(in), optional :: dim
60+
end subroutine
61+
62+
end interface
63+
64+
end module data_partition_interface

‎tests/data_partition_test.f90‎

Lines changed: 185 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,185 @@
1+
module data_partition_test
2+
!! author: Damian Rouson
3+
!!
4+
!! summary: verify data partitioning across images and data gathering
5+
use vegetables, only: result_t, test_item_t, describe, it, assert_equals, assert_that
6+
use data_partition_interface, only : data_partition
7+
use iso_fortran_env, only : real64
8+
implicit none
9+
10+
private
11+
public :: test_data_partition
12+
13+
type(data_partition) partition
14+
integer, parameter :: num_particles=31, gatherer=1, num_steps=9
15+
16+
contains
17+
18+
function test_data_partition() result(tests)
19+
type(test_item_t) tests
20+
21+
integer iteration
22+
23+
call partition%define_partitions( cardinality=num_particles)
24+
25+
associate( me=>this_image() )
26+
associate( my_first=>partition%first(me), my_last=>partition%last(me) )
27+
!do iteration=1,num_steps
28+
tests = describe( &
29+
"data_partition class", &
30+
[it( &
31+
"partitions data in nearly even blocks", &
32+
verify_block_partitioning), &
33+
it( &
34+
"all data partitioned across all images without data loss", &
35+
verify_all_particles_partitioned), &
36+
it( &
37+
"1D real array gathered on all images", &
38+
verify_all_gather_1D_real_array), &
39+
it( &
40+
"dimension 1 of 2D real array gathered on all images witout dim argument", &
41+
verify_all_gather_2D_real_array), &
42+
it( &
43+
"dimension 1 of 2D real array gathered on all images with dim argument", &
44+
verify_all_gather_2D_real_array_dim1), &
45+
it( &
46+
"dimension 1 of 2D real array gathered onto result_image with dim argument", &
47+
verify_gather_2D_real_array_dim1), &
48+
it( &
49+
"distributes all particles without losing any", &
50+
verify_all_particles_partitioned)])
51+
!end do
52+
end associate
53+
end associate
54+
end function
55+
56+
function verify_block_partitioning() result(result_)
57+
!! Verify that the data is partitioned across images evenly to
58+
!! within a difference of one datum between any two images.
59+
type(data_partition) partition
60+
type(result_t) result_
61+
integer my_particles
62+
63+
associate( me=>this_image() )
64+
associate( my_first=>partition%first(me), my_last=>partition%last(me) )
65+
my_particles = my_last - my_first + 1
66+
associate( ni=>num_images() )
67+
associate( quotient=>num_particles/ni, remainder=>mod(num_particles,ni) )
68+
result_ = assert_equals( quotient + merge(1, 0, me<=remainder), my_particles, "block distribution" )
69+
end associate
70+
end associate
71+
end associate
72+
end associate
73+
end function
74+
75+
function verify_all_particles_partitioned() result(result_)
76+
!! Verify that the number of particles on each image sums to the
77+
!! total number of particles distributed.
78+
type(data_partition) partition
79+
type(result_t) result_
80+
integer particles
81+
82+
associate(me => this_image())
83+
associate( my_first=>partition%first(me), my_last=>partition%last(me) )
84+
particles = my_last - my_first + 1
85+
call co_sum(particles)
86+
result_ = assert_equals(num_particles, particles, "all particles distributed" )
87+
end associate
88+
end associate
89+
end function
90+
91+
function verify_all_gather_1D_real_array() result(result_)
92+
type(data_partition) partition
93+
type(result_t) result_
94+
real(real64) :: particle_scalar(num_particles)
95+
real(real64), parameter :: junk=-12345._real64, expected=1._real64
96+
97+
associate(me => this_image())
98+
associate( first=>partition%first(me), last=>partition%last(me) )
99+
100+
particle_scalar(first:last) = expected !! values to be gathered
101+
particle_scalar(1:first-1) = junk !! values to be overwritten by the gather
102+
particle_scalar(last+1:) = junk !! values to be overwritten by the gather
103+
104+
call partition%gather(particle_scalar)
105+
106+
result_ = assert_that( all(particle_scalar==expected), "real 1D array all-gathered" )
107+
108+
end associate
109+
end associate
110+
end function
111+
112+
function verify_all_gather_2D_real_array() result(result_)
113+
type(data_partition) partition
114+
type(result_t) result_
115+
integer, parameter :: vec_space_dim=3
116+
real(real64) particle_vector(vec_space_dim, num_particles)
117+
real(real64), parameter :: junk=-12345._real64, expected=1._real64
118+
119+
associate(me => this_image())
120+
associate( first=>partition%first(me), last=>partition%last(me) )
121+
122+
particle_vector(:, first:last) = expected !! values to be gathered
123+
particle_vector(:, 1:first-1) = junk !! values to be overwritten by the gather
124+
particle_vector(:, last+1:) = junk !! values to be overwritten by the gather
125+
126+
call partition%gather(particle_vector)
127+
128+
result_ = assert_that(all(particle_vector==expected), "real 2D array all-gathered implicitly along dimension 1" )
129+
130+
end associate
131+
end associate
132+
end function
133+
134+
function verify_all_gather_2D_real_array_dim1() result(result_)
135+
type(data_partition) partition
136+
type(result_t) result_
137+
integer, parameter :: vec_space_dim=3
138+
real(real64) :: vector_transpose(num_particles, vec_space_dim)
139+
real(real64), parameter :: junk=-12345._real64, expected=1._real64
140+
141+
associate(me => this_image())
142+
associate( first=>partition%first(me), last=>partition%last(me) )
143+
144+
vector_transpose(first:last, :) = expected !! values to be gathered
145+
vector_transpose(1:first-1, :) = junk !! values to be overwritten by the gather
146+
vector_transpose(last+1:, :) = junk !! values to be overwritten by the gather
147+
148+
call partition%gather( vector_transpose, dim=1)
149+
150+
result_ = assert_that(all(vector_transpose==expected), "vector_transpose gathered explicitly along dimension 1" )
151+
152+
end associate
153+
end associate
154+
end function
155+
156+
function verify_gather_2D_real_array_dim1() result(result_)
157+
type(data_partition) partition
158+
type(result_t) result_
159+
integer, parameter :: vec_space_dim=3
160+
real(real64) :: vector_transpose(num_particles, vec_space_dim)
161+
real(real64), parameter :: junk=-12345._real64, expected=1._real64
162+
163+
associate(me => this_image())
164+
associate( first=>partition%first(me), last=>partition%last(me) )
165+
166+
vector_transpose(first:last, :) = expected !! values to be gathered
167+
vector_transpose(1:first-1, :) = junk !! values to be overwritten by the gather
168+
vector_transpose(last+1:, :) = junk !! values to be overwritten by the gather
169+
170+
call partition%gather( vector_transpose, result_image=gatherer, dim=1)
171+
172+
if (me==gatherer) then
173+
result_ = assert_that(all(vector_transpose==expected), "all( particle_vector==expected)")
174+
else
175+
result_ = &
176+
assert_that(all(vector_transpose(1:first-1,:)==junk), "lower transpose data unchanged)") .and. &
177+
assert_that(all(vector_transpose(first:last,:)==expected), "expected transpose data gathered") .and. &
178+
assert_that(all(vector_transpose(last+1:,:)==junk), "upper transpose data unchanged)" )
179+
end if
180+
181+
end associate
182+
end associate
183+
end function
184+
185+
end module data_partition_test

0 commit comments

Comments
 (0)