Yet Another eXchange Tool  0.9.0
test_redist_collection_displace_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 MODULE redist_collection_displace
49  USE mpi
50  USE ftest_common, ONLY: test_abort, cmp_arrays
51  USE yaxt, ONLY: &
52  xt_xmap, xt_xmap_delete, &
55  xt_request, xt_redist_a_exchange, xt_config
56  ! older PGI compilers do not handle generic interface correctly
57 #if defined __PGI && (__PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 10))
59 #endif
60  ! and when taking the slice address and the optimizer is on,
61  ! some other random failure occurs even with very recent compiler versions
62 #if defined __PGI && __PGIC__ <= 19
63 #undef HAVE_FC_C_LOC_OF_SLICE
64 #endif
65  USE test_redist_common, ONLY: build_odd_selection_xmap, &
66  check_wait_request
67  USE iso_c_binding, ONLY: c_ptr
68 #include "xt_slice_c_loc.inc"
69  IMPLICIT NONE
70  PRIVATE
71  INTEGER, PARAMETER :: cache_size = 16, cache_overrun = 2
72  INTEGER, PARAMETER :: num_slice = 3, dst_step = 2
73  INTEGER, PARAMETER :: src_slice_len = 5
74  INTEGER, PARAMETER :: dst_slice_len &
75  = (src_slice_len + dst_step - 1)/dst_step
76  CHARACTER(len=*), PARAMETER :: &
77  filename = 'test_redist_collection_displace_f.f90'
78  CHARACTER(len=*), PARAMETER :: err_msg(2) = &
79  (/ "error on xt_redist_s_exchange", "error on xt_redist_a_exchange" /)
80  PUBLIC :: test_displacement_variations
81 CONTAINS
82  ! test with one redist used three times (with different input
83  ! data displacements until the cache is full)
84  ! set up data
85  SUBROUTINE test_displacement_variations(comm, config)
86  INTEGER, INTENT(in) :: comm
87  TYPE(xt_config), INTENT(in) :: config
88  TYPE(xt_xmap) :: xmap
89  TYPE(xt_redist) :: redist, redists(num_slice), redist_coll, &
90  redist_coll_copy
91 
92  xmap = build_odd_selection_xmap(src_slice_len)
93  redist = xt_redist_p2p_new(xmap, mpi_double_precision, config)
94 
95  CALL xt_xmap_delete(xmap)
96 
97  ! generate redist_collection
98  redists = redist
99 
100  redist_coll = xt_redist_collection_new(redists, num_slice, &
101  cache_size, comm, config)
102 
103  CALL xt_redist_delete(redist)
104 
105  CALL run_displacement_check(redist_coll)
106  redist_coll_copy = xt_redist_copy(redist_coll)
107  CALL run_displacement_check(redist_coll_copy)
108 
109  ! clean up
110  CALL xt_redist_delete(redist_coll)
111  CALL xt_redist_delete(redist_coll_copy)
112  END SUBROUTINE test_displacement_variations
113 
114 #ifndef HAVE_FC_PTR_BOUND_REMAP
115  SUBROUTINE ptr_bind(p, ub, a)
116  DOUBLE PRECISION, POINTER :: p(:,:)
117  INTEGER, INTENT(in) :: ub(2)
118  DOUBLE PRECISION, TARGET :: a(ub(1), ub(2))
119  p => a
120  END SUBROUTINE ptr_bind
121 #endif
122 
123  SUBROUTINE run_displacement_check(redist_coll)
124  TYPE(xt_redist), INTENT(in) :: redist_coll
125  INTEGER :: i, j, k
126  DOUBLE PRECISION, TARGET :: &
127  src(src_slice_len * (num_slice+1) + cache_size + cache_overrun), &
128  dst(dst_slice_len * (num_slice+1) + cache_size + cache_overrun)
129  DOUBLE PRECISION, POINTER :: src_data(:, :), dst_data(:, :)
130  DOUBLE PRECISION, POINTER :: src_data_(:), dst_data_(:)
131  TYPE(c_ptr) :: src_data_p(num_slice), dst_data_p(num_slice)
132  DOUBLE PRECISION, PARAMETER :: ref_dst_data(dst_slice_len, num_slice) = &
133  reshape((/ ((dble(i + j * src_slice_len), &
134  & i = 1, src_slice_len, dst_step), &
135  & j = 0, num_slice - 1) /), &
136  & (/ dst_slice_len, num_slice /))
137  TYPE(xt_request) :: request
138  INTEGER :: iexch
139 
140 #ifdef HAVE_FC_PTR_BOUND_REMAP
141  src_data(1:src_slice_len, 1:num_slice) => src(1:src_slice_len*num_slice)
142 #else
143  CALL ptr_bind(src_data, (/ src_slice_len, num_slice /), src)
144 #endif
145  DO j = 1, num_slice
146  DO i = 1, src_slice_len
147  src_data(i, j) = dble(i + (j - 1) * src_slice_len)
148  END DO
149  END DO
150 
151  src_data_ => src(src_slice_len*num_slice+1:)
152 
153 #ifdef HAVE_FC_PTR_BOUND_REMAP
154  dst_data(1:dst_slice_len, 1:num_slice) => dst(1:dst_slice_len*num_slice)
155 #else
156  CALL ptr_bind(dst_data, (/ dst_slice_len, num_slice /), dst)
157 #endif
158 
159  dst_data_ => dst(dst_slice_len*num_slice+1:)
160 
161  DO i = 1, num_slice - 1
162  xt_slice_c_loc(src_data(:, i), src_data_p(i))
163  xt_slice_c_loc(dst_data(:, i), dst_data_p(i))
164  END DO
165 
166  ! test exchange
167  DO k = 1, cache_size + cache_overrun
168  src_data_(k:k+src_slice_len-1) = src_data(:,num_slice)
169 
170 
171  xt_slice_c_loc(src_data_(k:k+src_slice_len-1), src_data_p(3))
172  xt_slice_c_loc(dst_data_(k:k+dst_slice_len-1), dst_data_p(3))
173 
174  DO iexch = 1, 2
175  dst = -1.0d0
176  IF (iexch == 1) THEN
177  CALL xt_redist_s_exchange(redist_coll, num_slice, src_data_p, &
178  dst_data_p)
179  ELSE
180  CALL xt_redist_a_exchange(redist_coll, num_slice, src_data_p, &
181  dst_data_p, request)
182  CALL check_wait_request(request, filename, __line__)
183  ENDIF
184  IF (cmp_arrays(ref_dst_data(:, 1:num_slice-1), &
185  & dst_data(:, 1:num_slice-1)) &
186  .OR. cmp_arrays(ref_dst_data(:,num_slice), &
187  & dst_data_(k:k+dst_slice_len-1))) &
188  CALL test_abort(err_msg(iexch), filename, __line__)
189  ENDDO
190  END DO
191  END SUBROUTINE run_displacement_check
192 
193 END MODULE redist_collection_displace
194 !
195 ! Local Variables:
196 ! f90-continuation-indent: 5
197 ! coding: utf-8
198 ! indent-tabs-mode: nil
199 ! show-trailing-whitespace: t
200 ! require-trailing-newline: t
201 ! End:
202 !
Definition: yaxt.f90:49
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_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_collection_new(Xt_redist *redists, int num_redists, int cache_size, MPI_Comm comm)
Xt_redist xt_redist_p2p_new(Xt_xmap xmap, MPI_Datatype datatype)
void xt_xmap_delete(Xt_xmap xmap)
Definition: xt_xmap.c:85