Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
test_redist_p2p_parallel_f.f90
1!>
2!! @file test_redist_p2p_parallel_f.f90
3!!
4!! @copyright Copyright (C) 2016 Jörg Behrens <behrens@dkrz.de>
5!! Moritz Hanke <hanke@dkrz.de>
6!! Thomas Jahns <jahns@dkrz.de>
7!!
8!! @author Jörg Behrens <behrens@dkrz.de>
9!! Moritz Hanke <hanke@dkrz.de>
10!! Thomas Jahns <jahns@dkrz.de>
11!!
12!
13! Keywords:
14! Maintainer: Jörg Behrens <behrens@dkrz.de>
15! Moritz Hanke <hanke@dkrz.de>
16! Thomas Jahns <jahns@dkrz.de>
17! URL: https://dkrz-sw.gitlab-pages.dkrz.de/yaxt/
18!
19! Redistribution and use in source and binary forms, with or without
20! modification, are permitted provided that the following conditions are
21! met:
22!
23! Redistributions of source code must retain the above copyright notice,
24! this list of conditions and the following disclaimer.
25!
26! Redistributions in binary form must reproduce the above copyright
27! notice, this list of conditions and the following disclaimer in the
28! documentation and/or other materials provided with the distribution.
29!
30! Neither the name of the DKRZ GmbH nor the names of its contributors
31! may be used to endorse or promote products derived from this software
32! without specific prior written permission.
33!
34! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
35! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
36! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
37! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
38! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
39! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
40! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
41! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
42! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
43! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
44! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
45!
46#include "fc_feature_defs.inc"
47PROGRAM test_redist_p2p_parallel
48 USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
49 USE mpi
50 USE yaxt, ONLY: xt_initialize, xt_finalize, &
51 xt_int_kind, xi => xt_int_kind, &
54 xt_redist, xt_redist_p2p_new, xt_redist_get_mpi_comm, &
58 USE test_idxlist_utils, ONLY: test_err_count
59 USE test_redist_common, ONLY: communicators_are_congruent, &
60 check_redist, redist_exchanger_option
61 IMPLICIT NONE
62
63 CHARACTER(len=*), PARAMETER :: filename = 'test_redist_p2p_parallel_f.f90'
64 TYPE(xt_config) :: config
65 INTEGER :: comm_rank, comm_size, ierror
66
67 CALL init_mpi
68 CALL xt_initialize(mpi_comm_world)
69 config = redist_exchanger_option()
70
71 CALL mpi_comm_rank(mpi_comm_world, comm_rank, ierror)
72 IF (ierror /= mpi_success) &
73 CALL test_abort("MPI error!", filename, __line__)
74
75 CALL mpi_comm_size(mpi_comm_world, comm_size, ierror)
76 IF (ierror /= mpi_success) &
77 CALL test_abort("MPI error!", filename, __line__)
78
79 CALL simple_test
80 CALL nonuniform_test
81 CALL block_redist_test
82
83 IF (test_err_count() /= 0) &
84 CALL test_abort("non-zero error count!", filename, __line__)
85 CALL xt_config_delete(config)
86 CALL xt_finalize
87 CALL finish_mpi
88
89CONTAINS
90 SUBROUTINE simple_test
91 INTEGER, PARAMETER :: data_size = 10
92 INTEGER, PARAMETER :: src_num_indices = data_size, &
93 dst_num_indices = data_size
94 INTEGER(xt_int_kind) :: src_index_list(data_size), &
95 dst_index_list(data_size)
96 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
97 TYPE(xt_xmap) :: xmap
98 TYPE(xt_redist) :: redist
99 DOUBLE PRECISION :: src_data(data_size), dst_data(data_size)
100 INTEGER :: i
101
102 ! source index list
103 DO i = 1, src_num_indices
104 src_index_list(i) = int(comm_rank * data_size + (i - 1), xi)
105 END DO
106
107 src_idxlist = xt_idxvec_new(src_index_list)
108 ! destination index list
109 DO i = 1, dst_num_indices
110 dst_index_list(i) &
111 = int(mod(comm_rank * data_size + i + 1, comm_size * data_size), xi)
112 END DO
113 dst_idxlist = xt_idxvec_new(dst_index_list)
114 ! xmap
115 xmap = xt_xmap_all2all_new(src_idxlist, dst_idxlist, mpi_comm_world)
116 ! redist_p2p
117 redist = xt_redist_p2p_new(xmap, mpi_double_precision, config)
118
119 ! test communicator of redist
120 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist), &
121 mpi_comm_world)) &
122 CALL test_abort("error in xt_redist_get_mpi_comm", filename, __line__)
123
124 DO i = 1, src_num_indices
125 src_data(i) = dble(comm_rank * data_size + i - 1)
126 END DO
127
128 CALL check_redist(redist, src_data, dst_data, dst_index_list)
129
130 ! clean up
131 CALL xt_redist_delete(redist)
132 CALL xt_xmap_delete(xmap)
133 CALL xt_idxlist_delete(src_idxlist)
134 CALL xt_idxlist_delete(dst_idxlist)
135 END SUBROUTINE simple_test
136
137 ! test nonuniform numbers of send and receive partners
138 SUBROUTINE nonuniform_test
139 ! source index list
140 INTEGER(xt_int_kind), ALLOCATABLE :: src_index_list(:), dst_index_list(:)
141 DOUBLE PRECISION, ALLOCATABLE :: src_data(:), dst_data(:), ref_dst_data(:)
142 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
143 TYPE(xt_xmap) :: xmap
144 TYPE(Xt_redist) :: redist
145 INTEGER :: i, src_num_indices, dst_num_indices
146
147 ALLOCATE(src_index_list(comm_size), dst_index_list(comm_size), &
148 src_data(comm_size), dst_data(comm_size), ref_dst_data(comm_size))
149 src_num_indices = merge(comm_size, 0, comm_rank == 0)
150 DO i = 1, src_num_indices
151 src_index_list(i) = int(i - 1, xi)
152 END DO
153
154 src_idxlist = xt_idxvec_new(src_index_list, src_num_indices)
155
156 ! destination index list
157 dst_num_indices = comm_size
158 DO i = 1, dst_num_indices
159 dst_index_list(i) = int(i - 1, xi)
160 END DO
161
162 dst_idxlist = xt_idxvec_new(dst_index_list, dst_num_indices)
163
164 ! xmap
165 xmap = xt_xmap_all2all_new(src_idxlist, dst_idxlist, mpi_comm_world)
166
167 ! redist_p2p
168 redist = xt_redist_p2p_new(xmap, mpi_double_precision, config)
169
170 ! test communicator of redist
171 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist), &
172 mpi_comm_world)) &
173 CALL test_abort("error in xt_redist_get_mpi_comm", filename, __line__)
174
175 ! test exchange
176 IF (comm_rank == 0) THEN
177 DO i = 1, comm_size
178 src_data(i) = dble(i - 1)
179 END DO
180 ELSE
181 src_data(:) = -2.0d0
182 END IF
183
184 DO i = 1, comm_size
185 ref_dst_data(i) = dble(i-1)
186 END DO
187 CALL check_redist(redist, src_data, dst_data, ref_dst_data)
188
189 ! clean up
190 CALL xt_redist_delete(redist)
191 CALL xt_xmap_delete(xmap)
192 CALL xt_idxlist_delete(src_idxlist)
193 CALL xt_idxlist_delete(dst_idxlist)
194 END SUBROUTINE nonuniform_test
195
196 ! test redist with blocks
197 SUBROUTINE block_redist_test
198 ! gvol_size: volume of deep ocean
199 INTEGER :: ngdom, gvol_size, i, nwin, ig0, ig, j, p, qa, qb
200 ! gdepth: ocean depth of an one dim. ocean
201 INTEGER, ALLOCATABLE :: gdoma(:), gdomb(:), gsurfdata(:), &
202 gdepth(:), ig2col_off(:), b_surfdata_ref(:), gvoldata(:), &
203 src_block_offsets(:), src_block_sizes(:), dst_block_offsets(:), &
204 dst_block_sizes(:), b_voldata_ref(:)
205 INTEGER, ALLOCATABLE :: a_surfdata(:), b_surfdata(:), &
206 a_voldata(:), b_voldata(:)
207 INTEGER(xi), ALLOCATABLE :: iveca(:), ivecb(:)
208 INTEGER :: ia, ib, blk_ofs_accum, gdepth_i
209 TYPE(Xt_idxlist) :: idxlist_a, idxlist_b
210 TYPE(xt_xmap) :: xmap
211 TYPE(Xt_redist) :: redist, block_redist, block_redist2
212
213 IF (2 * comm_size > huge(1_xt_int_kind)) &
214 CALL test_abort('too large number of tasks', filename, __line__)
215 ! the global index domain (1dim problem):
216 ngdom = 2 * comm_size
217 ! start state (index distribution) of global domain
218 ALLOCATE(gdoma(ngdom), gdomb(ngdom))
219 ! end state ""
220 ALLOCATE(gsurfdata(ngdom), gdepth(ngdom))
221 ALLOCATE(ig2col_off(ngdom)) ! offset of surface DATA within vol
222 gvol_size = 0
223 DO i = 1, ngdom
224 gdoma(i) = i - 1
225 gdomb(i) = ngdom - i
226 gsurfdata(i) = 99 + i
227 gdepth(i) = i
228 ig2col_off(i) = gvol_size
229 gvol_size = gvol_size + gdepth(i)
230 END DO
231
232 nwin = ngdom / comm_size ! my local window size of the global surface domain
233 ! start of my window within global index domain (== global offset)
234 ig0 = comm_rank * nwin
235 IF (nwin * comm_size /= ngdom) &
236 CALL test_abort("internal error", filename, __line__)
237
238 ! local index
239 ALLOCATE(iveca(nwin), ivecb(nwin))
240 DO i = 1, nwin
241 ig = ig0 + i
242 iveca(i) = int(gdoma(ig), xi)
243 ivecb(i) = int(gdomb(ig), xi)
244 END DO
245
246 idxlist_a = xt_idxvec_new(iveca, nwin)
247 idxlist_b = xt_idxvec_new(ivecb, nwin)
248
249 xmap = xt_xmap_all2all_new(idxlist_a, idxlist_b, mpi_comm_world)
250
251 ! simple redist
252 redist = xt_redist_p2p_new(xmap, mpi_integer, config)
253
254 ! test communicator of redist
255 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist), &
256 mpi_comm_world)) &
257 CALL test_abort("error in xt_redist_get_mpi_comm", filename, __line__)
258
259 ALLOCATE(a_surfdata(nwin), b_surfdata(nwin), b_surfdata_ref(nwin))
260 DO i = 1, nwin
261 a_surfdata(i) = gsurfdata(iveca(i) + 1)
262 b_surfdata(i) = -1
263 b_surfdata_ref(i) = gsurfdata(ivecb(i) + 1)
264 END DO
265
266 CALL check_redist(redist, a_surfdata, b_surfdata, b_surfdata_ref)
267 CALL xt_redist_delete(redist)
268
269 ! generate global volume data
270 ALLOCATE(gvoldata(gvol_size))
271 DO i = 1, ngdom
272 DO j = 1, gdepth(i)
273 p = ig2col_off(i) + j
274 gvoldata(p) = (i - 1) * 100 + j - 1
275 END DO
276 END DO
277
278 ! generate blocks
279 ALLOCATE(src_block_offsets(nwin), src_block_sizes(nwin), &
280 dst_block_offsets(nwin), dst_block_sizes(nwin))
281 ! we only need local size but simply oversize here
282 ALLOCATE(a_voldata(gvol_size), b_voldata(gvol_size), &
283 b_voldata_ref(gvol_size))
284 a_voldata(:) = -1
285 b_voldata_ref(:) = -1
286
287 qa = 0
288 blk_ofs_accum = 0
289 DO i = 1, nwin
290 ia = int(iveca(i)) + 1
291 gdepth_i = gdepth(ia)
292 src_block_offsets(i) = blk_ofs_accum
293 blk_ofs_accum = blk_ofs_accum + gdepth_i
294 src_block_sizes(i) = gdepth_i
295 p = ig2col_off(ia)
296 DO j = 1, gdepth_i
297 a_voldata(qa + j) = gvoldata(p + j)
298 END DO
299 qa = qa + gdepth_i
300 END DO
301
302 qb = 0
303 blk_ofs_accum = 0
304 DO i = 1, nwin
305 ib = int(ivecb(i)) + 1
306 gdepth_i = gdepth(ib)
307 dst_block_offsets(i) = blk_ofs_accum
308 blk_ofs_accum = blk_ofs_accum + gdepth_i
309 dst_block_sizes(i) = gdepth_i
310 p = ig2col_off(ib)
311 DO j = 1, gdepth_i
312 b_voldata_ref(qb + j) = gvoldata(p + j)
313 END DO
314 qb = qb + gdepth_i
315 END DO
316
317 ! redist with blocks
318 block_redist = xt_redist_p2p_blocks_off_custom_new(xmap, &
319 src_block_offsets, src_block_sizes, nwin, &
320 dst_block_offsets, dst_block_sizes, nwin, mpi_integer, config)
321 ! test communicator of redist
322 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(block_redist), &
323 mpi_comm_world)) &
324 CALL test_abort("error in xt_redist_get_mpi_comm", filename, __line__)
325
326 CALL check_redist(block_redist, a_voldata, b_voldata, b_voldata_ref)
327
328 ! redist with blocks but without explicit offsets:
329 block_redist2 = xt_redist_p2p_blocks_custom_new(xmap, &
330 src_block_sizes, nwin, dst_block_sizes, nwin, mpi_integer, config)
331 ! test communicator of redist
332
333 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(block_redist2),&
334 mpi_comm_world)) &
335 CALL test_abort("error in xt_redist_get_mpi_comm", filename, __line__)
336
337 CALL check_redist(block_redist2, a_voldata, b_voldata, b_voldata_ref)
338
339 ! cleanup
340 CALL xt_redist_delete(block_redist2)
341 CALL xt_redist_delete(block_redist)
342 CALL xt_xmap_delete(xmap)
343 CALL xt_idxlist_delete(idxlist_a)
344 CALL xt_idxlist_delete(idxlist_b)
345 END SUBROUTINE block_redist_test
346
347END PROGRAM test_redist_p2p_parallel
348!
349! Local Variables:
350! f90-continuation-indent: 5
351! coding: utf-8
352! indent-tabs-mode: nil
353! show-trailing-whitespace: t
354! require-trailing-newline: t
355! End:
356!
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_delete(Xt_idxlist idxlist)
Definition xt_idxlist.c:75
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_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)
Definition xt_xmap.c:86
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)