Yet Another eXchange Tool  0.9.0
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://doc.redmine.dkrz.de/yaxt/html/
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 PROGRAM test_redist_collection_static_parallel
49  USE mpi
50  USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
51  USE test_idxlist_utils, ONLY: test_err_count
52  USE yaxt, ONLY: xt_initialize, xt_finalize, xt_int_kind, xi => xt_int_kind, &
53  xt_idxlist, xt_idxlist_delete, xt_stripe, xt_idxvec_new, &
58  xt_idxlist_get_indices, xt_int_mpidt, &
59  xt_request, xt_redist_a_exchange, xt_config, xt_config_delete
60  USE test_redist_common, ONLY: check_redist_xi, check_wait_request, &
61  redist_exchanger_option
62  USE iso_c_binding, ONLY: c_loc, c_ptr
63  ! older PGI compilers do not handle generic interface correctly
64 #if defined __PGI && (__PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 10))
66 #endif
67  IMPLICIT NONE
68  CHARACTER(len=*), PARAMETER :: &
69  filename = 'test_redist_collection_static_parallel_f.f90'
70  CHARACTER(len=*), PARAMETER :: err_msg(2) = &
71  (/ "xt_redist_s_exchange", "xt_redist_a_exchange" /)
72  TYPE(xt_config) :: config
73  INTEGER :: rank, comm_size, ierror
74  CALL init_mpi
75  CALL xt_initialize(mpi_comm_world)
76  config = redist_exchanger_option()
77 
78  CALL mpi_comm_rank(mpi_comm_world, rank, ierror)
79  IF (ierror /= mpi_success) &
80  CALL test_abort('mpi_comm_rank failed', filename, __line__)
81  CALL mpi_comm_size(mpi_comm_world, comm_size, ierror)
82  IF (ierror /= mpi_success) &
83  CALL test_abort('mpi_comm_size failed', filename, __line__)
84 
85  IF (comm_size > 1) THEN
86  CALL test_4redist(mpi_comm_world, config)
87  CALL test_rr_exchange(mpi_comm_world, config)
88  END IF
89 
90  IF (test_err_count() /= 0) &
91  CALL test_abort("non-zero error count!", filename, __line__)
92  CALL xt_config_delete(config)
93  CALL xt_finalize
94  CALL finish_mpi
95 CONTAINS
96  SUBROUTINE build_idxlists(indices_a, indices_b, indices_all)
97  ! redist test with four different redists
98  TYPE(xt_idxlist), INTENT(out) :: indices_a, indices_b, indices_all
99 
100  TYPE(xt_idxlist) :: indices_a_(2)
101  INTEGER :: i
102  INTEGER(xt_int_kind), PARAMETER :: start = 0
103  INTEGER(xt_int_kind) :: global_size(2), local_start(2, 2)
104  INTEGER :: local_size(2)
105 
106  TYPE(xt_stripe) :: stripe
107 
108  global_size(1) = int(2 * comm_size, xi)
109  global_size(2) = int(comm_size**2, xi)
110  local_size = comm_size
111  local_start = reshape((/ 0_xi, int(rank*comm_size, xi), &
112  int(comm_size, xi), int(comm_size**2-(rank+1)*comm_size, xi) /), &
113  (/ 2, 2 /))
114 
115  DO i = 1, 2
116  indices_a_(i) = xt_idxsection_new(start, global_size, local_size, &
117  local_start(:, i))
118  END DO
119  indices_a = xt_idxlist_collection_new(indices_a_)
120 
121  CALL xt_idxlist_delete(indices_a_(1))
122  CALL xt_idxlist_delete(indices_a_(2))
123 
124  stripe = xt_stripe(int(rank * 2 * comm_size**2, xi), 1_xi, 2*comm_size**2)
125  indices_b = xt_idxstripes_new(stripe)
126 
127  stripe = xt_stripe(0_xi, 1_xi, 2*comm_size**3)
128  indices_all = xt_idxstripes_new(stripe)
129  END SUBROUTINE build_idxlists
130 
131  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, TARGET :: src(:), dst(:)
137  INTEGER(xt_int_kind), POINTER :: index_vector_a(:), &
138  index_vector_b(:), index_vector_all(:)
139  TYPE(xt_xmap) :: xmaps(num_tx)
140  TYPE(xt_redist) :: redists(num_tx), redist, redist_copy
141  INTEGER(mpi_address_kind) :: src_displacements(num_tx), &
142  dst_displacements(num_tx)
143  INTEGER :: i, ierror, size_a, size_b, size_all
144  INTEGER(xt_int_kind), POINTER :: results_1(:), &
145  results_2(:), results_3(:), results_4(:)
146 
147  size_a = 2 * comm_size**2
148  size_b = 2 * comm_size**2
149  size_all = 2 * comm_size**3
150 
151  ALLOCATE(src(size_a + size_b + size_all), dst(size_b + size_a + 2*size_all))
152 
153  index_vector_a => src(1:size_a)
154  index_vector_b => src(size_a+1:size_a+size_b)
155  index_vector_all => src(size_a+size_b+1:)
156 
157  results_1 => dst(1:size_b)
158  results_2 => dst(size_b+1:size_b+size_a)
159  results_3 => dst(size_b+size_a+1:size_b+size_a+size_all)
160  results_4 => dst(size_b+size_a+size_all+1:size_b+size_a+2*size_all)
161 
162  CALL build_idxlists(indices_a, indices_b, indices_all)
163 
164  CALL xt_idxlist_get_indices(indices_a, index_vector_a)
165  CALL xt_idxlist_get_indices(indices_b, index_vector_b)
166  CALL xt_idxlist_get_indices(indices_all, index_vector_all)
167 
168  xmaps(1) = xt_xmap_all2all_new(indices_a, indices_b, comm)
169  xmaps(2) = xt_xmap_all2all_new(indices_b, indices_a, comm)
170  xmaps(3) = xt_xmap_all2all_new(indices_a, indices_all, comm)
171  xmaps(4) = xt_xmap_all2all_new(indices_b, indices_all, comm)
172 
173  CALL xt_idxlist_delete(indices_a)
174  CALL xt_idxlist_delete(indices_b)
175  CALL xt_idxlist_delete(indices_all)
176 
177  DO i = 1, num_tx
178  redists(i) = xt_redist_p2p_new(xmaps(i), xt_int_mpidt)
179  CALL xt_xmap_delete(xmaps(i))
180  END DO
181 
182  CALL mpi_get_address(index_vector_a, src_displacements(1), ierror)
183  CALL mpi_get_address(index_vector_b, src_displacements(2), ierror)
184  CALL mpi_get_address(index_vector_a, src_displacements(3), ierror)
185  CALL mpi_get_address(index_vector_b, src_displacements(4), ierror)
186 
187  src_displacements = src_displacements - src_displacements(1)
188 
189  CALL mpi_get_address(results_1, dst_displacements(1), ierror)
190  CALL mpi_get_address(results_2, dst_displacements(2), ierror)
191  CALL mpi_get_address(results_3, dst_displacements(3), ierror)
192  CALL mpi_get_address(results_4, dst_displacements(4), ierror)
193 
194  dst_displacements = dst_displacements - dst_displacements(1)
195 
196  redist = xt_redist_collection_static_new(redists, num_tx, &
197  src_displacements, dst_displacements, comm, config)
198 
199  ! test communicator of redist
200  ! if (!test_communicator(xt_redist_get_MPI_Comm(redist), COMM))
201  ! PUT_ERR("error in xt_redist_get_MPI_Comm\n");
202 
203  CALL xt_redist_delete(redists)
204 
205  CALL test_transpose_gather(redist, dst, size_a, size_b, size_all, &
206  index_vector_a, index_vector_b, index_vector_all)
207  redist_copy = xt_redist_copy(redist)
208  CALL xt_redist_delete(redist)
209  CALL test_transpose_gather(redist_copy, dst, size_a, size_b, size_all, &
210  index_vector_a, index_vector_b, index_vector_all)
211 
212  ! clean up
213  CALL xt_redist_delete(redist_copy)
214  END SUBROUTINE test_4redist
215 
216  SUBROUTINE test_transpose_gather(redist, dst, size_a, size_b, &
217  size_all, index_vector_a, index_vector_b, index_vector_all)
218  TYPE(xt_redist), INTENT(in) :: redist
219  INTEGER, INTENT(in) :: size_a, size_b, size_all
220  INTEGER(xi), TARGET, INTENT(inout) :: dst(size_b+size_a+2*size_all)
221  INTEGER(xi), TARGET, INTENT(in) :: index_vector_a(size_a)
222  INTEGER(xi), INTENT(in) :: index_vector_b(size_b), &
223  index_vector_all(size_all)
224 
225  INTEGER(xi), POINTER :: results_1(:), &
226  results_2(:), results_3(:), results_4(:)
227  TYPE(c_ptr) :: results(1), input(1)
228  INTEGER :: iexch
229  TYPE(xt_request) :: request
230 
231  results_1 => dst(1:size_b)
232  results_2 => dst(size_b+1:size_b+size_a)
233  results_3 => dst(size_b+size_a+1:size_b+size_a+size_all)
234  results_4 => dst(size_b+size_a+size_all+1:size_b+size_a+2*size_all)
235 
236  input(1) = c_loc(index_vector_a(1))
237  results(1) = c_loc(results_1(1))
238 
239  DO iexch = 1, 2
240  dst = 0_xi
241 
242  IF (iexch == 1) THEN
243  CALL xt_redist_s_exchange(redist, 1, input, results)
244  ELSE
245  CALL xt_redist_a_exchange(redist, 1, input, results, request)
246  CALL check_wait_request(request, filename, __line__)
247  ENDIF
248  ! check results
249  IF (any(results_1(:) /= index_vector_b)) &
250  CALL test_abort(err_msg(iexch), filename, __line__)
251 
252  IF (any(results_2(:) /= index_vector_a)) &
253  CALL test_abort(err_msg(iexch), filename, __line__)
254 
255  IF (any(results_3(:) /= index_vector_all)) &
256  CALL test_abort(err_msg(iexch), filename, __line__)
257 
258  IF (any(results_4(:) /= index_vector_all)) &
259  CALL test_abort(err_msg(iexch), filename, __line__)
260  ENDDO
261  END SUBROUTINE test_transpose_gather
262 
263  ! redist test with two redists that do a round robin exchange in
264  ! different directions
265  SUBROUTINE test_rr_exchange(comm, config)
266  INTEGER, INTENT(in) :: comm
267  TYPE(xt_config), INTENT(in) :: config
268  TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
269  INTEGER, PARAMETER :: num_local_indices = 5
270  INTEGER(xi) :: src_indices(num_local_indices)
271  INTEGER(xi) :: i_xi, temp, dst_indices(num_local_indices, 2)
272  INTEGER(xi) :: num_indices_global
273  INTEGER :: i
274  TYPE(xt_xmap) :: xmaps(2)
275  TYPE(xt_redist) :: redists(2), redist
276  INTEGER(xi) :: results(num_local_indices, 2)
277  INTEGER(mpi_address_kind) :: src_displacements(2), dst_displacements(2), &
278  addr_temp
279  INTEGER :: ierror
280 
281  num_indices_global = int(comm_size, xi) * int(num_local_indices, xi)
282  DO i = 1, num_local_indices
283  i_xi = int(i, xi)
284  src_indices(i) &
285  = int(rank, xi) * int(num_local_indices, xi) + (i_xi - 1_xi)
286  dst_indices(i, 1) = mod(src_indices(i) + 1_xi, num_indices_global)
287  temp = src_indices(i) - 1_xi
288  dst_indices(i, 2) = merge(num_indices_global - 1_xi, temp, temp < 0_xi)
289  END DO
290 
291  src_idxlist = xt_idxvec_new(src_indices, num_local_indices)
292  DO i = 1, 2
293  dst_idxlist = xt_idxvec_new(dst_indices(:, i))
294  xmaps(i) = xt_xmap_all2all_new(src_idxlist, dst_idxlist, comm)
295  CALL xt_idxlist_delete(dst_idxlist)
296  redists(i) = xt_redist_p2p_new(xmaps(i), xt_int_mpidt)
297  CALL xt_xmap_delete(xmaps(i))
298  END DO
299 
300  CALL xt_idxlist_delete(src_idxlist)
301 
302  src_displacements = 0_mpi_address_kind
303  dst_displacements(1) = 0_mpi_address_kind
304  CALL mpi_get_address(results(1, 2), dst_displacements(2), ierror)
305  IF (ierror /= mpi_success) &
306  CALL test_abort("error in mpi_get_address", filename, __line__)
307  CALL mpi_get_address(results(1, 1), addr_temp, ierror)
308  IF (ierror /= mpi_success) &
309  CALL test_abort("error in mpi_get_address", filename, __line__)
310  dst_displacements(2) = dst_displacements(2) - addr_temp
311 
312  redist = xt_redist_collection_static_new(redists, 2, src_displacements, &
313  dst_displacements, comm, config)
314 
315  ! test communicator of redist
316  ! IF (!test_communicator(xt_redist_get_MPI_Comm(redist), COMM))
317  ! PUT_ERR("error in xt_redist_get_MPI_Comm\n");
318 
319  CALL xt_redist_delete(redists)
320 
321  CALL check_redist_xi(redist, num_local_indices, src_indices, &
322  SIZE(results), results, dst_indices)
323 
324  ! clean up
325  CALL xt_redist_delete(redist)
326  END SUBROUTINE test_rr_exchange
327 
328 END PROGRAM test_redist_collection_static_parallel
329 !
330 ! Local Variables:
331 ! f90-continuation-indent: 5
332 ! coding: utf-8
333 ! indent-tabs-mode: nil
334 ! show-trailing-whitespace: t
335 ! require-trailing-newline: t
336 ! End:
337 !
Definition: yaxt.f90:49
void xt_config_delete(Xt_config config)
Definition: xt_config.c:76
void xt_initialize(MPI_Comm default_comm)
Definition: xt_init.c:70
void xt_finalize(void)
Definition: xt_init.c:89
void xt_idxlist_get_indices(Xt_idxlist idxlist, Xt_int *indices)
Definition: xt_idxlist.c:102
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition: xt_idxlist.c:74
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:163
void xt_redist_delete(Xt_redist redist)
Definition: xt_redist.c:68
Xt_redist xt_redist_copy(Xt_redist redist)
Definition: xt_redist.c:63
void xt_redist_a_exchange(Xt_redist redist, int num_arrays, const void **src_data, void **dst_data, Xt_request *request)
Definition: xt_redist.c:79
void xt_redist_s_exchange(Xt_redist redist, int num_arrays, const void **src_data, void **dst_data)
Definition: xt_redist.c:73
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:85
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)