Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
test_redist_repeat_parallel_f.f90
1!>
2!! @file test_redist_repeat_parallel_f.f90
3!! @brief Parallelized Fortran test of redist_repeat class
4!!
5!! @copyright Copyright (C) 2013 Jörg Behrens <behrens@dkrz.de>
6!! Moritz Hanke <hanke@dkrz.de>
7!! Thomas Jahns <jahns@dkrz.de>
8!!
9!! @author Jörg Behrens <behrens@dkrz.de>
10!! Moritz Hanke <hanke@dkrz.de>
11!! Thomas Jahns <jahns@dkrz.de>
12!!
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_repeat_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, &
55 xt_idxfsection_new, xt_idxlist_collection_new, xt_idxstripes_new, &
59 xt_idxlist_get_indices, xt_int_mpidt, &
61 ! older PGI compilers do not handle generic interface correctly
62#if defined __PGI
63 USE xt_redist_int_i2, ONLY: xt_redist_s_exchange, xt_redist_a_exchange
64 USE xt_redist_int_i4, ONLY: xt_redist_s_exchange, xt_redist_a_exchange
65 USE xt_redist_int_i8, ONLY: xt_redist_s_exchange, xt_redist_a_exchange
66#endif
67 USE test_redist_common, ONLY: check_wait_request, redist_exchanger_option
68 USE iso_c_binding, ONLY: c_int
69 IMPLICIT NONE
70 CHARACTER(len=*), PARAMETER :: filename = 'test_redist_repeat_parallel_f.f90'
71 CHARACTER(len=*), PARAMETER :: err_msg(2) = &
72 (/ "error on xt_redist_s_exchange", "error on xt_redist_a_exchange" /)
73 TYPE(xt_config) :: config
74 INTEGER :: comm_size, ierror
75 CALL init_mpi
76 CALL xt_initialize(mpi_comm_world)
77 config = redist_exchanger_option()
78
79 CALL mpi_comm_size(mpi_comm_world, comm_size, ierror)
80 IF (ierror /= mpi_success) &
81 CALL test_abort('mpi_comm_size failed', filename, __line__)
82
83 IF (comm_size > 1) THEN
84 CALL test_4redist(mpi_comm_world, config, 2*comm_size**2)
85 END IF
86
87 IF (test_err_count() /= 0) &
88 CALL test_abort("non-zero error count!", filename, __line__)
89 CALL xt_config_delete(config)
90 CALL xt_finalize
91 CALL finish_mpi
92CONTAINS
93 ! create index lists to exchange data sections from a global 4D
94 ! array.
95 !
96 ! For the source side, the global array is of size W x X x Y x Z,
97 ! where W=X=Y=comm_size and Z=2. The source data is decomposed
98 ! into two shards of size comm_size*comm_size per process, where one
99 ! shard is positioned at (1, comm_rank, 1, 1), the other at (1,
100 ! comm_size-comm_rank, 1, 2), i.e. the decomposition of the last
101 ! dimension is decomposed anti-symmetrically.
102 !
103 ! The destination decomposition is a contiguous subset of the
104 ! interval [0,W*X*Y*Z-1], the stripe [S, S+2*comm_size^2] with S =
105 ! comm_rank * 2 * comm_size**2. This corresponds to a section of a
106 ! 4D array reshaped to [W,X,Z,Y], decomposed along the Y-axis
107 ! according to comm_rank (but enumerated differently from source
108 ! array).
109 SUBROUTINE build_idxlists(indices_a, indices_b, comm_size, comm_rank)
110 TYPE(xt_idxlist), INTENT(out) :: indices_a, indices_b
111 INTEGER, INTENT(in) :: comm_size, comm_rank
112
113 INTEGER, PARAMETER :: glob_rank = 4
114 TYPE(xt_idxlist) :: indices_a_(2)
115 INTEGER :: i
116 INTEGER(xt_int_kind), PARAMETER :: start = 0
117 INTEGER(xt_int_kind) :: global_size(glob_rank), local_start(glob_rank, 2)
118 INTEGER :: local_size(glob_rank)
119
120 TYPE(xt_stripe) :: stripe
121
122 global_size(1) = int(comm_size, xi)
123 global_size(2) = int(comm_size, xi)
124 global_size(3) = int(comm_size, xi)
125 global_size(4) = 2_xi
126 local_size(1) = comm_size
127 local_size(2) = 1
128 local_size(3) = comm_size
129 local_size(4) = 1
130 local_start(1, 1) = 1_xi
131 local_start(2, 1) = int(comm_rank + 1, xi)
132 local_start(3, 1) = 1_xi
133 local_start(4, 1) = 1_xi
134 !
135 local_start(1, 2) = 1_xi
136 local_start(2, 2) = int(comm_size-comm_rank, xi)
137 local_start(3, 2) = 1_xi
138 local_start(4, 2) = 2_xi
139
140 DO i = 1, 2
141 indices_a_(i) = xt_idxfsection_new(start, global_size, local_size, &
142 local_start(:, i))
143 END DO
144 indices_a = xt_idxlist_collection_new(indices_a_)
145
146 CALL xt_idxlist_delete(indices_a_(1))
147 CALL xt_idxlist_delete(indices_a_(2))
148
149 stripe = xt_stripe(start = int(comm_rank * 2 * comm_size**2, xi), &
150 & stride = 1_xi, &
151 & nstrides = int(2*comm_size**2, c_int))
152 indices_b = xt_idxstripes_new(stripe)
153 END SUBROUTINE build_idxlists
154
155 ! redist test for 4 level repetition of redist (i.e. 3D extension of 2D
156 ! redist)
157 SUBROUTINE test_4redist(comm, config, dim1)
158 INTEGER, INTENT(in) :: comm
159 TYPE(xt_config), INTENT(in) :: config
160 INTEGER, INTENT(in) :: dim1
161 TYPE(xt_idxlist) :: indices_a, indices_b
162 INTEGER(xt_int_kind) :: index_vector_a(dim1), &
163 index_vector_b(dim1)
164 TYPE(xt_xmap) :: xmap
165 TYPE(xt_redist) :: redist_repeat, redist_repeat_2, redist_p2p
166 INTEGER, PARAMETER :: dim2a = 9, rpt_cnt = 4
167 INTEGER(xt_int_kind) :: results_1(dim1,rpt_cnt), &
168 results_2(dim1,dim2a), dim1_xi
169 INTEGER(xt_int_kind) :: input_data(dim1,dim2a)
170 INTEGER(xt_int_kind) :: ref_results_1(dim1,rpt_cnt), &
171 ref_results_2(dim1,dim2a)
172 INTEGER(mpi_address_kind) :: extent
173 INTEGER(mpi_address_kind) :: base_address, temp_address
174 INTEGER(c_int), PARAMETER :: &
175 displacements(rpt_cnt, 2) &
176 = reshape((/ 0_c_int, 1_c_int, 2_c_int, 3_c_int, &
177 & 1_c_int, 2_c_int, 4_c_int, 8_c_int /), (/ rpt_cnt, 2 /))
178 ! skip_lev_2 must correspond to the levels skipped via displacements_2
179 LOGICAL, PARAMETER :: skip_lev_2(9) &
180 = (/ .true., .false., .false., &
181 & .true., .false., .true., &
182 & .true., .true., .false. /)
183 INTEGER :: i, j, ierror
184 TYPE(xt_request) :: request1, request2
185 INTEGER :: iexch
186 INTEGER :: comm_rank, comm_size
187
188 CALL mpi_comm_rank(comm, comm_rank, ierror)
189 IF (ierror /= mpi_success) &
190 CALL test_abort('mpi_comm_rank failed', filename, __line__)
191 CALL mpi_comm_size(comm, comm_size, ierror)
192 IF (ierror /= mpi_success) &
193 CALL test_abort('mpi_comm_size failed', filename, __line__)
194
195 CALL build_idxlists(indices_a, indices_b, comm_size, comm_rank)
196
197 CALL xt_idxlist_get_indices(indices_a, index_vector_a)
198 CALL xt_idxlist_get_indices(indices_b, index_vector_b)
199
200 xmap = xt_xmap_all2all_new(indices_a, indices_b, comm)
201
202 CALL xt_idxlist_delete(indices_a)
203 CALL xt_idxlist_delete(indices_b)
204
205 redist_p2p = xt_redist_p2p_new(xmap, xt_int_mpidt)
206 CALL xt_xmap_delete(xmap)
207
208 CALL mpi_get_address(input_data(1,1), base_address, ierror)
209 CALL mpi_get_address(input_data(1,2), temp_address, ierror)
210 extent = temp_address - base_address
211
212 redist_repeat = xt_redist_repeat_new(redist_p2p, extent, extent, &
213 rpt_cnt, displacements(:, 1), config)
214 redist_repeat_2 = xt_redist_repeat_new(redist_p2p, extent, extent, &
215 rpt_cnt, displacements(:, 2), config)
216
217 CALL xt_redist_delete(redist_p2p)
218
219 dim1_xi = int(dim1, xi)
220 DO j = 1, dim2a
221 DO i = 1, dim1
222 input_data(i, j) = index_vector_a(i) + int(j-1, xi) * 2_xi * dim1_xi
223 END DO
224 END DO
225
226 DO j = 1, rpt_cnt
227 DO i = 1, dim1
228 ref_results_1(i, j) = index_vector_b(i) + int(j-1, xi) * 2_xi * dim1_xi
229 END DO
230 END DO
231 DO j = 1, dim2a
232 IF (skip_lev_2(j)) THEN
233 ref_results_2(:, j) = -1_xi
234 ELSE
235 DO i = 1, dim1
236 ref_results_2(i, j) &
237 = index_vector_b(i) + int(j-1, xi) * 2_xi * dim1_xi
238 END DO
239 END IF
240 END DO
241
242 DO iexch = 1, 2
243 results_1 = -1
244 results_2 = -1
245
246 IF (iexch == 1) THEN
247 CALL xt_redist_s_exchange(redist_repeat, input_data, results_1)
248 CALL xt_redist_s_exchange(redist_repeat_2, input_data, results_2)
249 ELSE
250 CALL xt_redist_a_exchange(redist_repeat, input_data, results_1, &
251 request1)
252 CALL xt_redist_a_exchange(redist_repeat_2, input_data, results_2, &
253 request2)
254 CALL check_wait_request(request1, filename, __line__)
255 CALL check_wait_request(request2, filename, __line__)
256 ENDIF
257
258 ! check results
259 IF (any(results_1 /= ref_results_1)) &
260 CALL test_abort(err_msg(iexch), filename, __line__)
261 IF (any(results_2 /= ref_results_2)) &
262 CALL test_abort(err_msg(iexch), filename, __line__)
263 ENDDO
264 ! clean up
265
266 CALL xt_redist_delete(redist_repeat)
267 CALL xt_redist_delete(redist_repeat_2)
268 END SUBROUTINE test_4redist
269
270END PROGRAM test_redist_repeat_parallel
271!
272! Local Variables:
273! f90-continuation-indent: 5
274! coding: utf-8
275! indent-tabs-mode: nil
276! show-trailing-whitespace: t
277! require-trailing-newline: t
278! End:
279!
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_idxstripes_new(struct Xt_stripe const *stripes, int num_stripes)
void xt_redist_delete(Xt_redist redist)
Definition xt_redist.c:74
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_p2p_new(Xt_xmap xmap, MPI_Datatype datatype)
Xt_redist xt_redist_repeat_new(Xt_redist redist, MPI_Aint src_extent, MPI_Aint dst_extent, int num_repetitions, const int displacements[num_repetitions])
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)