Yet Another eXchange Tool  0.9.0
test_redist_p2p_f.f90
1 
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://doc.redmine.dkrz.de/yaxt/html/
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 PROGRAM test_redist_p2p_f
47  USE mpi
48  USE yaxt, ONLY: xt_int_kind, xt_xmap, xt_idxlist, xt_redist, xt_offset_ext, &
49  xi => xt_int_kind, xt_int_mpidt, xt_initialize, xt_finalize, &
53  xt_redist_copy, xt_redist_delete, xt_redist_get_mpi_comm, &
55  xt_config, xt_config_delete
56  ! pgfortran is in most versions well incapable of handling multiply extended
57  ! generic interfaces
58 #ifdef __PGI
60 #endif
61  USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
62  USE test_redist_common, ONLY: check_redist, communicators_are_congruent, &
63  redist_exchanger_option
64  USE test_idxlist_utils, ONLY: test_err_count
65  IMPLICIT NONE
66  CHARACTER(len=*), PARAMETER :: filename = 'test_redist_p2p_f.f90'
67  TYPE(xt_config) :: config
68 
69  ! init mpi
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 
88 CONTAINS
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 
292 END 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 !
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_delete(Xt_idxlist idxlist)
Definition: xt_idxlist.c:74
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_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_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:85
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)