Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
test_redist_p2p_f.f90
1!>
2!! @file test_redist_p2p_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_f
48 USE mpi
49 USE yaxt, ONLY: xt_int_kind, xt_xmap, xt_idxlist, xt_redist, xt_offset_ext, &
50 xi => xt_int_kind, xt_int_mpidt, xt_initialize, xt_finalize, &
54 xt_redist_copy, xt_redist_delete, xt_redist_get_mpi_comm, &
57 ! pgfortran is in most versions well incapable of handling multiply extended
58 ! generic interfaces
59#ifdef __PGI
60 USE xt_redist_logical, ONLY: xt_redist_s_exchange
61#endif
62 USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
63 USE test_redist_common, ONLY: check_redist, communicators_are_congruent, &
64 redist_exchanger_option
65 USE test_idxlist_utils, ONLY: test_err_count
66 IMPLICIT NONE
67 CHARACTER(len=*), PARAMETER :: filename = 'test_redist_p2p_f.f90'
68 TYPE(xt_config) :: config
69
70 CALL init_mpi
71
72 CALL xt_initialize(mpi_comm_world)
73 config = redist_exchanger_option()
74
75 ! offset-free test:
76 ! source index list
77 CALL test_without_offsets
78 CALL test_with_offsets
79 CALL test_offset_extents
80
81 IF (test_err_count() /= 0) &
82 CALL test_abort("non-zero error count!", filename, __line__)
83
84 CALL xt_config_delete(config)
85 CALL xt_finalize
86 CALL finish_mpi
87
88CONTAINS
89
90 SUBROUTINE test_without_offsets
91 INTEGER, PARAMETER :: src_num_indices = 14, dst_num_indices = 13
92 INTEGER(xt_int_kind), PARAMETER :: src_index_list(src_num_indices) &
93 = (/ 5_xi, 67_xi, 4_xi, 5_xi, 13_xi, &
94 & 9_xi, 2_xi, 1_xi, 0_xi, 96_xi, &
95 & 13_xi, 12_xi, 1_xi, 3_xi /), &
96 dst_index_list(dst_num_indices) = &
97 & (/ 5_xi, 4_xi, 3_xi, 96_xi, 1_xi, &
98 & 5_xi, 4_xi, 5_xi, 4_xi, 3_xi, &
99 & 13_xi, 2_xi, 1_xi /)
100 INTEGER :: i
101#ifndef __PGI
102 DOUBLE PRECISION, PARAMETER :: src_data(src_num_indices) = &
103 (/ (dble(i), i=0,src_num_indices-1) /)
104#else
105 ! for PGI Fortran DBLE must be evaluated at run-time
106 DOUBLE PRECISION :: src_data(src_num_indices)
107#endif
108 DOUBLE PRECISION, PARAMETER :: ref_dst_data(dst_num_indices) &
109 = (/ 0.0d0, 2.0d0, 13.0d0, 9.0d0, 7.0d0, &
110 & 0.0d0, 2.0d0, 0.0d0, 2.0d0, 13.0d0, &
111 & 4.0d0, 6.0d0, 7.0d0 /)
112 LOGICAL :: src_l(src_num_indices), &
113 dst_l(dst_num_indices), ref_dst_l(dst_num_indices)
114 DOUBLE PRECISION :: dst_data(dst_num_indices)
115 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
116 TYPE(xt_xmap) :: xmap
117 TYPE(xt_redist) :: redist_dp, redist_copy, redist_l
118
119#ifdef __PGI
120 DO i = 1, src_num_indices
121 src_data(i) = dble(i - 1)
122 END DO
123#endif
124
125 src_idxlist = xt_idxvec_new(src_index_list, src_num_indices)
126
127 dst_idxlist = xt_idxvec_new(dst_index_list, dst_num_indices)
128
129 ! xmap
130 xmap = xt_xmap_all2all_new(src_idxlist, dst_idxlist, mpi_comm_world)
131
132 ! redist_p2p
133 redist_dp = xt_redist_p2p_new(xmap, mpi_double_precision, config)
134
135 ! test communicator of redist
136 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist_dp), &
137 mpi_comm_world)) &
138 CALL test_abort("error in xt_redist_get_mpi_Comm", filename, __line__)
139
140 ! test exchange
141 CALL check_redist(redist_dp, src_data, dst_data, ref_dst_data)
142
143 ! repeat for logicals
144 src_l = nint(mod(src_data, 2.0d0)) == 1
145 dst_l = .false.
146 ref_dst_l = nint(mod(ref_dst_data, 2.0d0)) == 1
147 redist_l = xt_redist_p2p_new(xmap, mpi_logical, config)
148 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist_l), &
149 mpi_comm_world)) &
150 CALL test_abort("error in xt_redist_get_mpi_Comm", filename, __line__)
151 CALL xt_redist_s_exchange(redist_l, src_l, dst_l)
152 IF (any(dst_l .NEQV. ref_dst_l)) &
153 CALL test_abort("error in xt_redist_s_exchange for 1D logical array", &
154 filename, __line__)
155 redist_copy = xt_redist_copy(redist_dp)
156 CALL xt_redist_delete(redist_dp)
157 CALL check_redist(redist_copy, src_data, dst_data, ref_dst_data)
158
159 ! clean up
160 CALL xt_redist_delete(redist_copy)
161 CALL xt_redist_delete(redist_l)
162 CALL xt_xmap_delete(xmap)
163 CALL xt_idxlist_delete(src_idxlist)
164 CALL xt_idxlist_delete(dst_idxlist)
165 END SUBROUTINE test_without_offsets
166
167 SUBROUTINE test_with_offsets
168 ! source index list
169 INTEGER, PARAMETER :: src_num = 14, dst_num = 13
170 INTEGER(xt_int_kind), PARAMETER :: src_index_list(src_num) = &
171 (/ 5_xi, 67_xi, 4_xi, 5_xi, 13_xi, &
172 & 9_xi, 2_xi, 1_xi, 0_xi, 96_xi, &
173 & 13_xi, 12_xi, 1_xi, 3_xi /), &
174 dst_index_list(dst_num) = &
175 (/ 5_xi, 4_xi, 3_xi, 96_xi, 1_xi, &
176 & 5_xi, 4_xi, 5_xi, 4_xi, 3_xi, &
177 & 13_xi, 2_xi, 1_xi /)
178 INTEGER :: i
179 INTEGER, PARAMETER :: src_pos(src_num) = (/ (i, i = 0, src_num - 1) /), &
180 dst_pos(dst_num) = (/ ( dst_num - i, i = 1, dst_num ) /)
181 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
182 TYPE(xt_xmap) :: xmap
183 TYPE(xt_redist) :: redist, redist_copy
184#ifndef __PGI
185 DOUBLE PRECISION, PARAMETER :: src_data(src_num) = &
186 (/ (dble(i), i=0,src_num-1) /)
187#else
188 ! for PGI Fortran DBLE must be evaluated at run-time
189 DOUBLE PRECISION :: src_data(src_num)
190#endif
191 DOUBLE PRECISION :: dst_data(dst_num)
192 DOUBLE PRECISION, PARAMETER :: ref_dst_data(dst_num) = &
193 (/ 0.0d0, 2.0d0, 13.0d0, 9.0d0, 7.0d0, &
194 & 0.0d0, 2.0d0, 0.0d0, 2.0d0, 13.0d0, &
195 & 4.0d0, 6.0d0, 7.0d0 /)
196
197#ifdef __PGI
198 DO i = 1, src_num
199 src_data(i) = dble(i - 1)
200 END DO
201#endif
202
203 src_idxlist = xt_idxvec_new(src_index_list)
204
205 dst_idxlist = xt_idxvec_new(dst_index_list, dst_num)
206
207 xmap = xt_xmap_all2all_new(src_idxlist, dst_idxlist, mpi_comm_world)
208
209 ! redist_p2p with offsets
210 redist = xt_redist_p2p_off_custom_new(xmap, src_pos, dst_pos, &
211 mpi_double_precision, config)
212
213 ! test communicator of redist
214 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist), &
215 mpi_comm_world)) &
216 CALL test_abort("error in xt_redist_get_MPI_Comm", filename, __line__)
217
218 ! test exchange
219 CALL check_redist(redist, src_data, dst_data, ref_dst_data(dst_num:1:-1))
220
221 redist_copy = xt_redist_copy(redist)
222 CALL xt_redist_delete(redist)
223 CALL check_redist(redist_copy, src_data, dst_data, &
224 ref_dst_data(dst_num:1:-1))
225
226 ! clean up
227 CALL xt_redist_delete(redist_copy)
228 CALL xt_xmap_delete(xmap)
229 CALL xt_idxlist_delete(src_idxlist)
230 CALL xt_idxlist_delete(dst_idxlist)
231 END SUBROUTINE test_with_offsets
232
233 SUBROUTINE test_offset_extents
234 ! source/destination index lists
235 INTEGER, PARAMETER :: src_num = 14, dst_num = 13
236 INTEGER(xt_int_kind), PARAMETER :: src_index_list(src_num) = &
237 (/ 5_xi, 67_xi, 4_xi, 5_xi, 13_xi, &
238 & 9_xi, 2_xi, 1_xi, 0_xi, 96_xi, &
239 & 13_xi, 12_xi, 1_xi, 3_xi /), &
240 dst_index_list(dst_num) = &
241 (/ 5_xi, 4_xi, 3_xi, 96_xi, 1_xi, &
242 & 5_xi, 4_xi, 5_xi, 4_xi, 3_xi, &
243 & 13_xi, 2_xi, 1_xi /)
244#ifdef __G95__
245 INTEGER :: i
246 INTEGER(xt_int_kind), PARAMETER :: src_data(src_num) &
247 = (/ (int(i, xi), i = 0, 13) /)
248#else
249 INTEGER(xt_int_kind) :: i
250 INTEGER(xt_int_kind), PARAMETER :: src_data(src_num) &
251 = (/ (i, i = 0_xi, 13_xi) /)
252#endif
253 INTEGER(xt_int_kind) :: dst_data(dst_num)
254 INTEGER(xt_int_kind), PARAMETER :: ref_dst_data(dst_num) = &
255 (/ 7_xi, 6_xi, 4_xi, 13_xi, 2_xi, &
256 & 0_xi, 2_xi, 0_xi, 7_xi, 9_xi, &
257 & 13_xi, 2_xi, 0_xi /)
258 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
259 TYPE(xt_xmap) :: xmap
260 TYPE(xt_redist) :: redist, redist_copy
261 TYPE(xt_offset_ext), PARAMETER :: &
262 src_pos(1) = (/ xt_offset_ext(0, src_num, 1) /), &
263 dst_pos(1) = (/ xt_offset_ext(dst_num - 1, dst_num, -1) /)
264
265 src_idxlist = xt_idxvec_new(src_index_list)
266 dst_idxlist = xt_idxvec_new(dst_index_list)
267
268 xmap = xt_xmap_all2all_new(src_idxlist, dst_idxlist, mpi_comm_world)
269
270 ! redist_p2p with extents of offsets
271 redist = xt_redist_p2p_ext_new(xmap, src_pos, dst_pos, xt_int_mpidt, config)
272 ! test communicator of redist
273 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist), &
274 mpi_comm_world)) &
275 CALL test_abort("error in xt_redist_get_MPI_Comm", &
276 filename, __line__)
277
278 ! test exchange
279 CALL check_redist(redist, src_data, dst_data, ref_dst_data)
280
281 redist_copy = xt_redist_copy(redist)
282 CALL xt_redist_delete(redist)
283 CALL check_redist(redist_copy, src_data, dst_data, ref_dst_data)
284
285 ! clean up
286 CALL xt_redist_delete(redist_copy)
287 CALL xt_xmap_delete(xmap)
288 CALL xt_idxlist_delete(src_idxlist)
289 CALL xt_idxlist_delete(dst_idxlist)
290 END SUBROUTINE test_offset_extents
291
292END PROGRAM test_redist_p2p_f
293!
294! Local Variables:
295! f90-continuation-indent: 5
296! coding: utf-8
297! indent-tabs-mode: nil
298! show-trailing-whitespace: t
299! require-trailing-newline: t
300! End:
301!
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_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
Xt_redist xt_redist_p2p_new(Xt_xmap xmap, MPI_Datatype datatype)
Xt_redist xt_redist_p2p_off_custom_new(Xt_xmap xmap, const int *src_offsets, const int *dst_offsets, MPI_Datatype datatype, Xt_config config)
Xt_redist xt_redist_p2p_ext_new(Xt_xmap xmap, int num_src_ext, const struct Xt_offset_ext src_extents[], int num_dst_ext, const struct Xt_offset_ext dst_extents[], 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)