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