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