1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48#include "fc_feature_defs.inc"
49PROGRAM test_redist_collection_static_parallel
50 USE mpi
51 USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
52 USE test_idxlist_utils, ONLY: test_err_count
61 USE test_redist_common, ONLY: check_redist_xi, check_wait_request, &
62 redist_exchanger_option
63 USE iso_c_binding, ONLY: c_loc, c_ptr
64
65#if defined __PGI && (__PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 10))
67#endif
68 IMPLICIT NONE
69 CHARACTER(len=*), PARAMETER :: &
70 filename = 'test_redist_collection_static_parallel_f.f90'
71 CHARACTER(len=*), PARAMETER :: err_msg(2) = &
72 (/ "xt_redist_s_exchange", "xt_redist_a_exchange" /)
73 TYPE(xt_config) :: config
74 INTEGER :: rank, comm_size, ierror
75 CALL init_mpi
77 config = redist_exchanger_option()
78
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, comm_size, ierror)
83 IF (ierror /= mpi_success) &
84 CALL test_abort('mpi_comm_size failed', filename, __line__)
85
86 IF (comm_size > 1) THEN
87 CALL test_4redist(mpi_comm_world, config)
88 CALL test_rr_exchange(mpi_comm_world, config)
89 END IF
90
91 IF (test_err_count() /= 0) &
92 CALL test_abort("non-zero error count!", filename, __line__)
95 CALL finish_mpi
96CONTAINS
97 SUBROUTINE build_idxlists(indices_a, indices_b, indices_all)
98
99 TYPE(xt_idxlist), INTENT(out) :: indices_a, indices_b, indices_all
100
101 TYPE(xt_idxlist) :: indices_a_(2)
102 INTEGER :: i
103 INTEGER(xt_int_kind), PARAMETER :: start = 0_xi
104 INTEGER(xt_int_kind) :: global_size(2), local_start(2, 2)
105 INTEGER :: local_size(2)
106
107 TYPE(xt_stripe) :: stripe
108
109 global_size(1) = int(2 * comm_size, xi)
110 global_size(2) = int(comm_size**2, xi)
111 local_size = comm_size
112 local_start = reshape((/ 0_xi, int(rank*comm_size, xi), &
113 int(comm_size, xi), int(comm_size**2-(rank+1)*comm_size, xi) /), &
114 (/ 2, 2 /))
115
116 DO i = 1, 2
118 local_start(:, i))
119 END DO
121
124
125 stripe =
xt_stripe(int(rank * 2 * comm_size**2, xi), 1_xi, 2*comm_size**2)
127
128 stripe =
xt_stripe(0_xi, 1_xi, 2*comm_size**3)
130 END SUBROUTINE build_idxlists
131
132 SUBROUTINE test_4redist(comm, config)
133 INTEGER, INTENT(in) :: comm
134 TYPE(xt_config), INTENT(in) :: config
135 INTEGER, PARAMETER :: num_tx = 4
136 TYPE(xt_idxlist) :: indices_a, indices_b, indices_all
137 INTEGER(xt_int_kind), ALLOCATABLE, TARGET :: src(:), dst(:)
138 INTEGER(xt_int_kind), POINTER :: index_vector_a(:), &
139 index_vector_b(:), index_vector_all(:)
140 TYPE(xt_xmap) :: xmaps(num_tx)
141 TYPE(xt_redist) :: redists(num_tx), redist, redist_copy
142 INTEGER(mpi_address_kind) :: src_displacements(num_tx), &
143 dst_displacements(num_tx)
144 INTEGER :: i, ierror, size_a, size_b, size_all
145 INTEGER(xt_int_kind), POINTER :: results_1(:), &
146 results_2(:), results_3(:), results_4(:)
147
148 size_a = 2 * comm_size**2
149 size_b = 2 * comm_size**2
150 size_all = 2 * comm_size**3
151
152 ALLOCATE(src(size_a + size_b + size_all), dst(size_b + size_a + 2*size_all))
153
154 index_vector_a => src(1:size_a)
155 index_vector_b => src(size_a+1:size_a+size_b)
156 index_vector_all => src(size_a+size_b+1:)
157
158 results_1 => dst(1:size_b)
159 results_2 => dst(size_b+1:size_b+size_a)
160 results_3 => dst(size_b+size_a+1:size_b+size_a+size_all)
161 results_4 => dst(size_b+size_a+size_all+1:size_b+size_a+2*size_all)
162
163 CALL build_idxlists(indices_a, indices_b, indices_all)
164
168
173
177
178 DO i = 1, num_tx
181 END DO
182
183 CALL mpi_get_address(index_vector_a, src_displacements(1), ierror)
184 CALL mpi_get_address(index_vector_b, src_displacements(2), ierror)
185 CALL mpi_get_address(index_vector_a, src_displacements(3), ierror)
186 CALL mpi_get_address(index_vector_b, src_displacements(4), ierror)
187
188 src_displacements = src_displacements - src_displacements(1)
189
190 CALL mpi_get_address(results_1, dst_displacements(1), ierror)
191 CALL mpi_get_address(results_2, dst_displacements(2), ierror)
192 CALL mpi_get_address(results_3, dst_displacements(3), ierror)
193 CALL mpi_get_address(results_4, dst_displacements(4), ierror)
194
195 dst_displacements = dst_displacements - dst_displacements(1)
196
198 src_displacements, dst_displacements, comm, config)
199
200
201
202
203
205
206 CALL test_transpose_gather(redist, dst, size_a, size_b, size_all, &
207 index_vector_a, index_vector_b, index_vector_all)
210 CALL test_transpose_gather(redist_copy, dst, size_a, size_b, size_all, &
211 index_vector_a, index_vector_b, index_vector_all)
212
213
215 END SUBROUTINE test_4redist
216
217 SUBROUTINE test_transpose_gather(redist, dst, size_a, size_b, &
218 size_all, index_vector_a, index_vector_b, index_vector_all)
219 TYPE(xt_redist), INTENT(in) :: redist
220 INTEGER, INTENT(in) :: size_a, size_b, size_all
221 INTEGER(xi), TARGET, INTENT(inout) :: dst(size_b+size_a+2*size_all)
222 INTEGER(xi), TARGET, INTENT(in) :: index_vector_a(size_a)
223 INTEGER(xi), INTENT(in) :: index_vector_b(size_b), &
224 index_vector_all(size_all)
225
226 INTEGER(xi), POINTER :: results_1(:), &
227 results_2(:), results_3(:), results_4(:)
228 TYPE(c_ptr) :: results(1), input(1)
229 INTEGER :: iexch
230 TYPE(xt_request) :: request
231
232 results_1 => dst(1:size_b)
233 results_2 => dst(size_b+1:size_b+size_a)
234 results_3 => dst(size_b+size_a+1:size_b+size_a+size_all)
235 results_4 => dst(size_b+size_a+size_all+1:size_b+size_a+2*size_all)
236
237 input(1) = c_loc(index_vector_a(1))
238 results(1) = c_loc(results_1(1))
239
240 DO iexch = 1, 2
241 dst = 0_xi
242
243 IF (iexch == 1) THEN
245 ELSE
247 CALL check_wait_request(request, filename, __line__)
248 ENDIF
249
250 IF (any(results_1(:) /= index_vector_b)) &
251 CALL test_abort(err_msg(iexch), filename, __line__)
252
253 IF (any(results_2(:) /= index_vector_a)) &
254 CALL test_abort(err_msg(iexch), filename, __line__)
255
256 IF (any(results_3(:) /= index_vector_all)) &
257 CALL test_abort(err_msg(iexch), filename, __line__)
258
259 IF (any(results_4(:) /= index_vector_all)) &
260 CALL test_abort(err_msg(iexch), filename, __line__)
261 ENDDO
262 END SUBROUTINE test_transpose_gather
263
264
265
266 SUBROUTINE test_rr_exchange(comm, config)
267 INTEGER, INTENT(in) :: comm
268 TYPE(xt_config), INTENT(in) :: config
269 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
270 INTEGER, PARAMETER :: num_local_indices = 5
271 INTEGER(xi) :: src_indices(num_local_indices)
272 INTEGER(xi) :: i_xi, temp, dst_indices(num_local_indices, 2)
273 INTEGER(xi) :: num_indices_global
274 INTEGER :: i
275 TYPE(xt_xmap) :: xmaps(2)
276 TYPE(xt_redist) :: redists(2), redist
277 INTEGER(xi) :: results(num_local_indices, 2)
278 INTEGER(mpi_address_kind) :: src_displacements(2), dst_displacements(2), &
279 addr_temp
280 INTEGER :: ierror
281
282 num_indices_global = int(comm_size, xi) * int(num_local_indices, xi)
283 DO i = 1, num_local_indices
284 i_xi = int(i, xi)
285 src_indices(i) &
286 = int(rank, xi) * int(num_local_indices, xi) + (i_xi - 1_xi)
287 dst_indices(i, 1) = mod(src_indices(i) + 1_xi, num_indices_global)
288 temp = src_indices(i) - 1_xi
289 dst_indices(i, 2) = merge(num_indices_global - 1_xi, temp, temp < 0_xi)
290 END DO
291
293 DO i = 1, 2
299 END DO
300
302
303 src_displacements = 0_mpi_address_kind
304 dst_displacements(1) = 0_mpi_address_kind
305 CALL mpi_get_address(results(1, 2), dst_displacements(2), ierror)
306 IF (ierror /= mpi_success) &
307 CALL test_abort("error in mpi_get_address", filename, __line__)
308 CALL mpi_get_address(results(1, 1), addr_temp, ierror)
309 IF (ierror /= mpi_success) &
310 CALL test_abort("error in mpi_get_address", filename, __line__)
311 dst_displacements(2) = dst_displacements(2) - addr_temp
312
314 dst_displacements, comm, config)
315
316
317
318
319
321
322 CALL check_redist_xi(redist, num_local_indices, src_indices, &
323 SIZE(results), results, dst_indices)
324
325
327 END SUBROUTINE test_rr_exchange
328
329END PROGRAM test_redist_collection_static_parallel
330
331
332
333
334
335
336
337
338
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_s_exchange(Xt_redist redist, int num_arrays, const void *const src_data[], void *const dst_data[])
void xt_redist_a_exchange(Xt_redist redist, int num_arrays, const void *const src_data[], void *const dst_data[], Xt_request *request)
Xt_redist xt_redist_collection_static_new(Xt_redist *redists, int num_redists, const MPI_Aint src_displacements[num_redists], const MPI_Aint dst_displacements[num_redists], 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)