46 PROGRAM test_redist_p2p_parallel
47 USE ftest_common,
ONLY: init_mpi, finish_mpi, test_abort
50 xt_int_kind, xi => xt_int_kind, &
57 USE test_idxlist_utils,
ONLY: test_err_count
58 USE test_redist_common,
ONLY: communicators_are_congruent, &
59 check_redist, redist_exchanger_option
62 CHARACTER(len=*),
PARAMETER :: filename =
'test_redist_p2p_parallel_f.f90'
63 TYPE(xt_config) :: config
64 INTEGER :: comm_rank, comm_size, ierror
68 config = redist_exchanger_option()
70 CALL mpi_comm_rank(mpi_comm_world, comm_rank, ierror)
71 IF (ierror /= mpi_success) &
72 CALL test_abort(
"MPI error!", filename, __line__)
74 CALL mpi_comm_size(mpi_comm_world, comm_size, ierror)
75 IF (ierror /= mpi_success) &
76 CALL test_abort(
"MPI error!", filename, __line__)
80 CALL block_redist_test
82 IF (test_err_count() /= 0) &
83 CALL test_abort(
"non-zero error count!", filename, __line__)
89 SUBROUTINE simple_test
90 INTEGER,
PARAMETER :: data_size = 10
91 INTEGER,
PARAMETER :: src_num_indices = data_size, &
92 dst_num_indices = data_size
93 INTEGER(xt_int_kind) :: src_index_list(data_size), &
94 dst_index_list(data_size)
95 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
97 TYPE(xt_redist) :: redist
98 DOUBLE PRECISION :: src_data(data_size), dst_data(data_size)
102 DO i = 1, src_num_indices
103 src_index_list(i) = int(comm_rank * data_size + (i - 1), xi)
108 DO i = 1, dst_num_indices
110 = int(mod(comm_rank * data_size + i + 1, comm_size * data_size), xi)
119 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist), &
121 CALL test_abort(
"error in xt_redist_get_mpi_comm", filename, __line__)
123 DO i = 1, src_num_indices
124 src_data(i) = dble(comm_rank * data_size + i - 1)
127 CALL check_redist(redist, src_data, dst_data, dst_index_list)
134 END SUBROUTINE simple_test
137 SUBROUTINE nonuniform_test
139 INTEGER(xt_int_kind),
ALLOCATABLE :: src_index_list(:), dst_index_list(:)
140 DOUBLE PRECISION,
ALLOCATABLE :: src_data(:), dst_data(:), ref_dst_data(:)
141 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
142 TYPE(xt_xmap) :: xmap
143 TYPE(Xt_redist) :: redist
144 INTEGER :: i, src_num_indices, dst_num_indices
146 ALLOCATE(src_index_list(comm_size), dst_index_list(comm_size), &
147 src_data(comm_size), dst_data(comm_size), ref_dst_data(comm_size))
148 src_num_indices = merge(comm_size, 0, comm_rank == 0)
149 DO i = 1, src_num_indices
150 src_index_list(i) = int(i - 1, xi)
156 dst_num_indices = comm_size
157 DO i = 1, dst_num_indices
158 dst_index_list(i) = int(i - 1, xi)
170 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist), &
172 CALL test_abort(
"error in xt_redist_get_mpi_comm", filename, __line__)
175 IF (comm_rank == 0)
THEN
177 src_data(i) = dble(i - 1)
184 ref_dst_data(i) = dble(i-1)
186 CALL check_redist(redist, src_data, dst_data, ref_dst_data)
193 END SUBROUTINE nonuniform_test
196 SUBROUTINE block_redist_test
198 INTEGER :: ngdom, gvol_size, i, nwin, ig0, ig, j, p, qa, qb
200 INTEGER,
ALLOCATABLE :: gdoma(:), gdomb(:), gsurfdata(:), &
201 gdepth(:), ig2col_off(:), b_surfdata_ref(:), gvoldata(:), &
202 src_block_offsets(:), src_block_sizes(:), dst_block_offsets(:), &
203 dst_block_sizes(:), b_voldata_ref(:)
204 INTEGER,
ALLOCATABLE :: a_surfdata(:), b_surfdata(:), &
205 a_voldata(:), b_voldata(:)
206 INTEGER(xi),
ALLOCATABLE :: iveca(:), ivecb(:)
207 INTEGER :: ia, ib, blk_ofs_accum, gdepth_i
208 TYPE(Xt_idxlist) :: idxlist_a, idxlist_b
209 TYPE(xt_xmap) :: xmap
210 TYPE(Xt_redist) :: redist, block_redist, block_redist2
212 IF (2 * comm_size > huge(1_xt_int_kind)) &
213 CALL test_abort(
'too large number of tasks', filename, __line__)
215 ngdom = 2 * comm_size
217 ALLOCATE(gdoma(ngdom), gdomb(ngdom))
219 ALLOCATE(gsurfdata(ngdom), gdepth(ngdom))
220 ALLOCATE(ig2col_off(ngdom))
225 gsurfdata(i) = 99 + i
227 ig2col_off(i) = gvol_size
228 gvol_size = gvol_size + gdepth(i)
231 nwin = ngdom / comm_size
233 ig0 = comm_rank * nwin
234 IF (nwin * comm_size /= ngdom) &
235 CALL test_abort(
"internal error", filename, __line__)
238 ALLOCATE(iveca(nwin), ivecb(nwin))
241 iveca(i) = int(gdoma(ig), xi)
242 ivecb(i) = int(gdomb(ig), xi)
254 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist), &
256 CALL test_abort(
"error in xt_redist_get_mpi_comm", filename, __line__)
258 ALLOCATE(a_surfdata(nwin), b_surfdata(nwin), b_surfdata_ref(nwin))
260 a_surfdata(i) = gsurfdata(iveca(i) + 1)
262 b_surfdata_ref(i) = gsurfdata(ivecb(i) + 1)
265 CALL check_redist(redist, a_surfdata, b_surfdata, b_surfdata_ref)
269 ALLOCATE(gvoldata(gvol_size))
272 p = ig2col_off(i) + j
273 gvoldata(p) = (i - 1) * 100 + j - 1
278 ALLOCATE(src_block_offsets(nwin), src_block_sizes(nwin), &
279 dst_block_offsets(nwin), dst_block_sizes(nwin))
281 ALLOCATE(a_voldata(gvol_size), b_voldata(gvol_size), &
282 b_voldata_ref(gvol_size))
284 b_voldata_ref(:) = -1
289 ia = int(iveca(i)) + 1
290 gdepth_i = gdepth(ia)
291 src_block_offsets(i) = blk_ofs_accum
292 blk_ofs_accum = blk_ofs_accum + gdepth_i
293 src_block_sizes(i) = gdepth_i
296 a_voldata(qa + j) = gvoldata(p + j)
304 ib = int(ivecb(i)) + 1
305 gdepth_i = gdepth(ib)
306 dst_block_offsets(i) = blk_ofs_accum
307 blk_ofs_accum = blk_ofs_accum + gdepth_i
308 dst_block_sizes(i) = gdepth_i
311 b_voldata_ref(qb + j) = gvoldata(p + j)
318 src_block_offsets, src_block_sizes, nwin, &
319 dst_block_offsets, dst_block_sizes, nwin, mpi_integer, config)
321 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(block_redist), &
323 CALL test_abort(
"error in xt_redist_get_mpi_comm", filename, __line__)
325 CALL check_redist(block_redist, a_voldata, b_voldata, b_voldata_ref)
329 src_block_sizes, nwin, dst_block_sizes, nwin, mpi_integer, config)
332 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(block_redist2),&
334 CALL test_abort(
"error in xt_redist_get_mpi_comm", filename, __line__)
336 CALL check_redist(block_redist2, a_voldata, b_voldata, b_voldata_ref)
344 END SUBROUTINE block_redist_test
346 END PROGRAM test_redist_p2p_parallel
void xt_config_delete(Xt_config config)
void xt_initialize(MPI_Comm default_comm)
void xt_idxlist_delete(Xt_idxlist idxlist)
Xt_idxlist xt_idxvec_new(const Xt_int *idxlist, int num_indices)
void xt_redist_delete(Xt_redist redist)
Xt_redist xt_redist_p2p_blocks_custom_new(Xt_xmap xmap, const int *src_block_sizes, int src_block_num, const int *dst_block_sizes, int dst_block_num, MPI_Datatype datatype, Xt_config config)
Xt_redist xt_redist_p2p_new(Xt_xmap xmap, MPI_Datatype datatype)
Xt_redist xt_redist_p2p_blocks_off_custom_new(Xt_xmap xmap, const int *src_block_offsets, const int *src_block_sizes, int src_block_num, const int *dst_block_offsets, const int *dst_block_sizes, int dst_block_num, MPI_Datatype datatype, Xt_config config)
void xt_xmap_delete(Xt_xmap xmap)
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)