48 PROGRAM test_redist_collection_parallel
50 USE ftest_common,
ONLY: init_mpi, finish_mpi, test_abort, icbrt
51 USE test_idxlist_utils,
ONLY: test_err_count
61 #if defined __PGI && (__PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 10))
64 USE test_redist_common,
ONLY: check_wait_request, redist_exchanger_option
65 USE iso_c_binding,
ONLY: c_loc, c_ptr
66 #include "xt_slice_c_loc.inc"
68 INTEGER :: rank, world_size, ierror
69 CHARACTER(len=*),
PARAMETER :: &
70 filename =
'test_redist_collection_parallel_f.f90'
71 CHARACTER(len=*),
PARAMETER :: err_msg(2) = &
72 (/
"error in xt_redist_s_exchange",
"error in xt_redist_a_exchange" /)
73 TYPE(xt_config) :: config
77 config = redist_exchanger_option()
79 CALL mpi_comm_rank(mpi_comm_world, rank, ierror)
80 IF (ierror /= mpi_success) &
81 CALL test_abort(
'mpi_comm_rank failed', filename, __line__)
82 CALL mpi_comm_size(mpi_comm_world, world_size, ierror)
83 IF (ierror /= mpi_success) &
84 CALL test_abort(
'mpi_comm_size failed', filename, __line__)
86 IF (world_size > 1)
THEN
87 CALL test_4redist(mpi_comm_world, config)
88 CALL test_rr_exchange(mpi_comm_world, config)
91 IF (test_err_count() /= 0) &
92 CALL test_abort(
"non-zero error count!", filename, __line__)
96 SUBROUTINE build_idxlists(indices_a, indices_b, indices_all)
97 TYPE(xt_idxlist),
INTENT(out) :: indices_a, indices_b, indices_all
99 TYPE(xt_idxlist) :: indices_a_(2)
101 INTEGER(xt_int_kind),
PARAMETER :: start = 0
102 INTEGER(xt_int_kind) :: global_size(2), local_start(2, 2)
103 INTEGER :: local_size(2)
105 TYPE(xt_stripe) :: stripe
107 global_size(1) = int(2 * world_size, xi)
108 global_size(2) = int(world_size**2, xi)
109 local_size = world_size
110 local_start = reshape((/ 0_xi, int(rank*world_size, xi), &
111 int(world_size, xi), &
112 int((world_size-(rank+1))*world_size, xi) /), (/ 2, 2 /))
123 stripe = xt_stripe(int(rank * 2 * world_size**2, xi), 1_xi, 2*world_size**2)
126 stripe = xt_stripe(0_xi, 1_xi, 2*world_size**3)
128 END SUBROUTINE build_idxlists
130 SUBROUTINE test_4redist(comm, config)
132 INTEGER,
INTENT(in) :: comm
133 TYPE(xt_config),
INTENT(in) :: config
134 INTEGER,
PARAMETER :: num_tx = 4
135 TYPE(xt_idxlist) :: indices_a, indices_b, indices_all
136 INTEGER(xt_int_kind),
ALLOCATABLE :: index_vector_a(:), &
138 TYPE(xt_xmap) :: xmaps(num_tx)
139 TYPE(xt_redist) :: redists(num_tx), redist, redist_copy
140 INTEGER :: i, vec_size
143 > icbrt((huge(1_xi)-mod(huge(1_xi),2_xi))/2_xi)) &
144 CALL test_abort(
'communicator too large for test', filename, __line__)
146 vec_size = 2*world_size**2
147 ALLOCATE(index_vector_a(vec_size), index_vector_b(vec_size))
148 CALL build_idxlists(indices_a, indices_b, indices_all)
175 CALL exchange_4redist(redist, index_vector_a, index_vector_b)
178 CALL exchange_4redist(redist_copy, index_vector_a, index_vector_b)
182 END SUBROUTINE test_4redist
184 SUBROUTINE exchange_4redist(redist, index_vector_a, index_vector_b)
185 TYPE(xt_redist),
INTENT(in) :: redist
186 INTEGER(xt_int_kind),
INTENT(in) :: index_vector_a(2*world_size**2), &
187 index_vector_b(2*world_size**2)
188 INTEGER(xt_int_kind),
TARGET,
ALLOCATABLE :: buf(:)
189 INTEGER(xt_int_kind),
POINTER :: results_1(:), &
190 results_2(:), results_3(:), results_4(:)
191 INTEGER :: result_sizes(4), buf_size, ofs
192 INTEGER,
PARAMETER :: result_spacing(4) = (/ 2, 14, 5, 8 /)
195 result_sizes(1) = 2*world_size**2
196 result_sizes(2) = 2*world_size**2
197 result_sizes(3) = 2*world_size**3
198 result_sizes(4) = 2*world_size**3
200 buf_size = sum(result_spacing) + sum(result_sizes)
201 ALLOCATE(buf(buf_size))
204 ofs = result_spacing(1)
205 results_1 => buf(ofs+1:ofs+result_sizes(1))
206 ofs = ofs + result_sizes(1) + result_spacing(2)
207 results_2 => buf(ofs+1:ofs+result_sizes(2))
208 ofs = ofs + result_sizes(2) + result_spacing(3)
209 results_3 => buf(ofs+1:ofs+result_sizes(3))
210 ofs = ofs + result_sizes(3) + result_spacing(4)
211 results_4 => buf(ofs+1:ofs+result_sizes(4))
213 CALL do_4redist(redist, index_vector_a, index_vector_b, &
214 results_1, results_2, results_3, results_4, iexch)
216 CALL check_4redist_results(results_1, results_2, results_3, results_4, &
217 index_vector_a, index_vector_b, iexch)
221 ofs = sum(result_spacing(1:2)) + sum(result_sizes(1:2))
222 results_3 => buf(ofs+1:ofs+result_sizes(3))
225 CALL do_4redist(redist, index_vector_a, index_vector_b, &
226 results_1, results_2, results_3, results_4, iexch)
228 CALL check_4redist_results(results_1, results_2, results_3, results_4, &
229 index_vector_a, index_vector_b, iexch)
233 END SUBROUTINE exchange_4redist
235 SUBROUTINE do_4redist(redist, index_vector_a, index_vector_b, &
236 results_1, results_2, results_3, results_4, iexch)
237 TYPE(xt_redist),
INTENT(in) :: redist
238 INTEGER(xt_int_kind),
INTENT(in),
TARGET :: &
239 index_vector_a(*), index_vector_b(*)
240 INTEGER(xt_int_kind),
INTENT(inout),
TARGET :: &
241 results_1(*), results_2(*), results_3(*), results_4(*)
242 INTEGER,
INTENT(in) :: iexch
244 TYPE(c_ptr) :: results(4), input(4)
245 TYPE(xt_request) :: request
247 results(1) = c_loc(results_1)
248 results(2) = c_loc(results_2)
249 results(3) = c_loc(results_3)
250 results(4) = c_loc(results_4)
252 input(1) = c_loc(index_vector_a)
253 input(2) = c_loc(index_vector_b)
254 input(3) = c_loc(index_vector_a)
255 input(4) = c_loc(index_vector_b)
260 CALL check_wait_request(request, filename, __line__)
262 END SUBROUTINE do_4redist
264 SUBROUTINE check_4redist_results(results_1, results_2, results_3, results_4, &
265 index_vector_a, index_vector_b, iexch)
266 INTEGER(xt_int_kind),
INTENT(in) :: index_vector_a(:), index_vector_b(:), &
267 results_1(:), results_2(:), results_3(0:), results_4(0:)
268 INTEGER,
INTENT(in) :: iexch
269 INTEGER(xt_int_kind) :: i, n
272 IF (any(results_1 /= index_vector_b)) &
273 CALL test_abort(err_msg(iexch), filename, __line__)
275 IF (any(results_2 /= index_vector_a)) &
276 CALL test_abort(err_msg(iexch), filename, __line__)
278 n = int(
SIZE(results_3), xt_int_kind)
281 DO i = 0_xi, n - 1_xi
282 p_3 = p_3 .OR. results_3(i) /= i
283 p_4 = p_4 .OR. results_4(i) /= i
285 IF (p_3 .OR. p_4)
CALL test_abort(err_msg(iexch), filename, __line__)
286 END SUBROUTINE check_4redist_results
291 SUBROUTINE test_rr_exchange(comm, config)
292 INTEGER,
INTENT(in) :: comm
293 TYPE(xt_config),
INTENT(in) :: config
295 TYPE(xt_idxlist) :: src_indices, dst_indices(2)
296 INTEGER(xt_int_kind) :: src_indices_(5)
297 INTEGER(xt_int_kind) :: i, temp, dst_indices_(5, 2)
298 TYPE(xt_xmap) :: xmaps(2)
299 TYPE(xt_redist) :: redists(2), redist, redist_copy
301 IF (world_size > (huge(1_xi)-mod(huge(1_xi),5_xi))/5_xi) &
302 CALL test_abort(
'communicator too large for test', filename, __line__)
305 src_indices_(i) = int(rank, xi) * 5_xi + (i - 1_xi)
306 dst_indices_(i, 1) = mod(src_indices_(i) + 1_xi, &
307 & int(world_size, xi) * 5_xi)
308 temp = src_indices_(i) - 1_xi
309 dst_indices_(i, 2) = merge(int(world_size, xi) * 5_xi - 1_xi, &
336 CALL rr_exchange(redist, src_indices_, dst_indices_)
339 CALL rr_exchange(redist_copy, src_indices_, dst_indices_)
343 END SUBROUTINE test_rr_exchange
345 SUBROUTINE rr_exchange(redist, src_indices_, ref_dst_indices_)
346 #if defined __GNUC__ && __GNUC__ >= 5 && __GNUC__ <= 8
351 USE yaxt,
ONLY: xt_slice_c_loc
352 #undef XT_SLICE_C_LOC
353 #define XT_SLICE_C_LOC(slice, cptr) CALL xt_slice_c_loc(slice, cptr)
355 TYPE(xt_redist),
INTENT(in) :: redist
356 INTEGER,
PARAMETER :: nredist = 2
357 INTEGER(xt_int_kind),
TARGET,
INTENT(in) :: src_indices_(5)
358 INTEGER(xt_int_kind),
INTENT(in) :: ref_dst_indices_(5, nredist)
360 INTEGER(xt_int_kind),
TARGET :: results(5,nredist)
361 TYPE(c_ptr) :: results_p(nredist), input(nredist)
363 TYPE(xt_request) :: request
366 xt_slice_c_loc(results(:,i), results_p(i))
367 input(i) = c_loc(src_indices_)
377 CALL check_wait_request(request, filename, __line__)
381 IF (any(results /= ref_dst_indices_)) &
382 CALL test_abort(err_msg(iexch), filename, __line__)
384 END SUBROUTINE rr_exchange
386 END PROGRAM test_redist_collection_parallel
void xt_config_delete(Xt_config config)
void xt_initialize(MPI_Comm default_comm)
void xt_idxlist_get_indices(Xt_idxlist idxlist, Xt_int *indices)
void xt_idxlist_delete(Xt_idxlist idxlist)
Xt_idxlist xt_idxlist_collection_new(Xt_idxlist *idxlists, int num_idxlists)
Xt_idxlist xt_idxsection_new(Xt_int start, int num_dimensions, const Xt_int global_size[num_dimensions], const int local_size[num_dimensions], const Xt_int local_start[num_dimensions])
Xt_idxlist xt_idxstripes_new(struct Xt_stripe const *stripes, int num_stripes)
Xt_idxlist xt_idxvec_new(const Xt_int *idxlist, int num_indices)
void xt_redist_delete(Xt_redist redist)
Xt_redist xt_redist_copy(Xt_redist redist)
void xt_redist_a_exchange(Xt_redist redist, int num_arrays, const void **src_data, void **dst_data, Xt_request *request)
void xt_redist_s_exchange(Xt_redist redist, int num_arrays, const void **src_data, void **dst_data)
Xt_redist xt_redist_collection_new(Xt_redist *redists, int num_redists, int cache_size, MPI_Comm comm)
Xt_redist xt_redist_p2p_new(Xt_xmap xmap, MPI_Datatype datatype)
void xt_xmap_delete(Xt_xmap xmap)
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)