Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
test_redist_collection_static_parallel_f.f90
1
13
14!
15! Keywords:
16! Maintainer: Jörg Behrens <behrens@dkrz.de>
17! Moritz Hanke <hanke@dkrz.de>
18! Thomas Jahns <jahns@dkrz.de>
19! URL: https://dkrz-sw.gitlab-pages.dkrz.de/yaxt/
20!
21! Redistribution and use in source and binary forms, with or without
22! modification, are permitted provided that the following conditions are
23! met:
24!
25! Redistributions of source code must retain the above copyright notice,
26! this list of conditions and the following disclaimer.
27!
28! Redistributions in binary form must reproduce the above copyright
29! notice, this list of conditions and the following disclaimer in the
30! documentation and/or other materials provided with the distribution.
31!
32! Neither the name of the DKRZ GmbH nor the names of its contributors
33! may be used to endorse or promote products derived from this software
34! without specific prior written permission.
35!
36! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
37! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
38! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
39! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
40! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
41! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
42! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
43! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
44! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
45! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
46! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
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
53 USE yaxt, ONLY: xt_initialize, xt_finalize, xt_int_kind, xi => xt_int_kind, &
59 xt_idxlist_get_indices, xt_int_mpidt, &
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 ! older PGI compilers do not handle generic interface correctly
65#if defined __PGI && (__PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 10))
66 USE xt_redist_base, ONLY: xt_redist_s_exchange, xt_redist_a_exchange
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
76 CALL xt_initialize(mpi_comm_world)
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__)
93 CALL xt_config_delete(config)
94 CALL xt_finalize
95 CALL finish_mpi
96CONTAINS
97 SUBROUTINE build_idxlists(indices_a, indices_b, indices_all)
98 ! redist test with four different redists
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
117 indices_a_(i) = xt_idxsection_new(start, global_size, local_size, &
118 local_start(:, i))
119 END DO
120 indices_a = xt_idxlist_collection_new(indices_a_)
121
122 CALL xt_idxlist_delete(indices_a_(1))
123 CALL xt_idxlist_delete(indices_a_(2))
124
125 stripe = xt_stripe(int(rank * 2 * comm_size**2, xi), 1_xi, 2*comm_size**2)
126 indices_b = xt_idxstripes_new(stripe)
127
128 stripe = xt_stripe(0_xi, 1_xi, 2*comm_size**3)
129 indices_all = xt_idxstripes_new(stripe)
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
165 CALL xt_idxlist_get_indices(indices_a, index_vector_a)
166 CALL xt_idxlist_get_indices(indices_b, index_vector_b)
167 CALL xt_idxlist_get_indices(indices_all, index_vector_all)
168
169 xmaps(1) = xt_xmap_all2all_new(indices_a, indices_b, comm)
170 xmaps(2) = xt_xmap_all2all_new(indices_b, indices_a, comm)
171 xmaps(3) = xt_xmap_all2all_new(indices_a, indices_all, comm)
172 xmaps(4) = xt_xmap_all2all_new(indices_b, indices_all, comm)
173
174 CALL xt_idxlist_delete(indices_a)
175 CALL xt_idxlist_delete(indices_b)
176 CALL xt_idxlist_delete(indices_all)
177
178 DO i = 1, num_tx
179 redists(i) = xt_redist_p2p_new(xmaps(i), xt_int_mpidt)
180 CALL xt_xmap_delete(xmaps(i))
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
197 redist = xt_redist_collection_static_new(redists, num_tx, &
198 src_displacements, dst_displacements, comm, config)
199
200 ! test communicator of redist
201 ! if (!test_communicator(xt_redist_get_MPI_Comm(redist), COMM))
202 ! PUT_ERR("error in xt_redist_get_MPI_Comm\n");
203
204 CALL xt_redist_delete(redists)
205
206 CALL test_transpose_gather(redist, dst, size_a, size_b, size_all, &
207 index_vector_a, index_vector_b, index_vector_all)
208 redist_copy = xt_redist_copy(redist)
209 CALL xt_redist_delete(redist)
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 ! clean up
214 CALL xt_redist_delete(redist_copy)
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
244 CALL xt_redist_s_exchange(redist, 1, input, results)
245 ELSE
246 CALL xt_redist_a_exchange(redist, 1, input, results, request)
247 CALL check_wait_request(request, filename, __line__)
248 ENDIF
249 ! check results
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 ! redist test with two redists that do a round robin exchange in
265 ! different directions
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
292 src_idxlist = xt_idxvec_new(src_indices, num_local_indices)
293 DO i = 1, 2
294 dst_idxlist = xt_idxvec_new(dst_indices(:, i))
295 xmaps(i) = xt_xmap_all2all_new(src_idxlist, dst_idxlist, comm)
296 CALL xt_idxlist_delete(dst_idxlist)
297 redists(i) = xt_redist_p2p_new(xmaps(i), xt_int_mpidt)
298 CALL xt_xmap_delete(xmaps(i))
299 END DO
300
301 CALL xt_idxlist_delete(src_idxlist)
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
313 redist = xt_redist_collection_static_new(redists, 2, src_displacements, &
314 dst_displacements, comm, config)
315
316 ! test communicator of redist
317 ! IF (!test_communicator(xt_redist_get_MPI_Comm(redist), COMM))
318 ! PUT_ERR("error in xt_redist_get_MPI_Comm\n");
319
320 CALL xt_redist_delete(redists)
321
322 CALL check_redist_xi(redist, num_local_indices, src_indices, &
323 SIZE(results), results, dst_indices)
324
325 ! clean up
326 CALL xt_redist_delete(redist)
327 END SUBROUTINE test_rr_exchange
328
329END PROGRAM test_redist_collection_static_parallel
330!
331! Local Variables:
332! f90-continuation-indent: 5
333! coding: utf-8
334! indent-tabs-mode: nil
335! show-trailing-whitespace: t
336! require-trailing-newline: t
337! End:
338!
void xt_config_delete(Xt_config config)
Definition xt_config.c:85
void xt_initialize(MPI_Comm default_comm)
Definition xt_init.c:70
void xt_finalize(void)
Definition xt_init.c:92
void xt_idxlist_get_indices(Xt_idxlist idxlist, Xt_int *indices)
Definition xt_idxlist.c:113
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition xt_idxlist.c:75
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)
Definition xt_idxvec.c:213
void xt_redist_delete(Xt_redist redist)
Definition xt_redist.c:74
Xt_redist xt_redist_copy(Xt_redist redist)
Definition xt_redist.c:69
void xt_redist_s_exchange(Xt_redist redist, int num_arrays, const void *const src_data[], void *const dst_data[])
Definition xt_redist.c:79
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)
Definition xt_xmap.c:86
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)