1
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48#include "fc_feature_defs.inc"
49MODULE redist_collection_displace
50 USE mpi
51 USE ftest_common, ONLY: test_abort, cmp_arrays
52 USE yaxt, ONLY: &
57
58#if defined __PGI && (__PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 10))
60#endif
61
62
63#if defined __PGI && (__PGIC__ <= 23 || __PGIC__ == 24 && __PGIC_MINOR__ <= 3)
64#undef HAVE_FC_C_LOC_OF_SLICE
65#endif
66 USE test_redist_common, ONLY: build_odd_selection_xmap, &
67 check_wait_request
68 USE iso_c_binding, ONLY: c_ptr
69#include "xt_slice_c_loc.inc"
70 IMPLICIT NONE
71 PRIVATE
72 INTEGER, PARAMETER :: cache_size = 16, cache_overrun = 2
73 INTEGER, PARAMETER :: num_slice = 3, dst_step = 2
74 INTEGER, PARAMETER :: src_slice_len = 5
75 INTEGER, PARAMETER :: dst_slice_len &
76 = (src_slice_len + dst_step - 1)/dst_step
77 CHARACTER(len=*), PARAMETER :: &
78 filename = 'test_redist_collection_displace_f.f90'
79 CHARACTER(len=*), PARAMETER :: err_msg(2) = &
80 (/ "error on xt_redist_s_exchange", "error on xt_redist_a_exchange" /)
81 PUBLIC :: test_displacement_variations
82CONTAINS
83
84
85
86 SUBROUTINE test_displacement_variations(comm, config)
87 INTEGER, INTENT(in) :: comm
88 TYPE(xt_config), INTENT(in) :: config
89 TYPE(xt_xmap) :: xmap
90 TYPE(xt_redist) :: redist, redists(num_slice), redist_coll, &
91 redist_coll_copy
92
93 xmap = build_odd_selection_xmap(src_slice_len, comm)
95
97
98
99 redists = redist
100
102 cache_size, comm, config)
103
105
106 CALL run_displacement_check(redist_coll)
108 CALL run_displacement_check(redist_coll_copy)
109
110
113 END SUBROUTINE test_displacement_variations
114
115#ifndef HAVE_FC_PTR_BOUND_REMAP
116 SUBROUTINE ptr_bind(p, ub, a)
117 DOUBLE PRECISION, POINTER :: p(:,:)
118 INTEGER, INTENT(in) :: ub(2)
119 DOUBLE PRECISION, TARGET :: a(ub(1), ub(2))
120 p => a
121 END SUBROUTINE ptr_bind
122#endif
123
124 SUBROUTINE run_displacement_check(redist_coll)
125 TYPE(xt_redist), INTENT(in) :: redist_coll
126 INTEGER :: i, j, k
127 DOUBLE PRECISION, TARGET :: &
128 src(src_slice_len * (num_slice+1) + cache_size + cache_overrun), &
129 dst(dst_slice_len * (num_slice+1) + cache_size + cache_overrun)
130 DOUBLE PRECISION, POINTER :: src_data(:, :), dst_data(:, :)
131 DOUBLE PRECISION, POINTER :: src_data_(:), dst_data_(:)
132 TYPE(c_ptr) :: src_data_p(num_slice), dst_data_p(num_slice)
133 DOUBLE PRECISION, PARAMETER :: ref_dst_data(dst_slice_len, num_slice) = &
134 reshape((/ ((dble(i + j * src_slice_len), &
135 & i = 1, src_slice_len, dst_step), &
136 & j = 0, num_slice - 1) /), &
137 & (/ dst_slice_len, num_slice /))
138 TYPE(xt_request) :: request
139 INTEGER :: iexch
140
141#ifdef HAVE_FC_PTR_BOUND_REMAP
142 src_data(1:src_slice_len, 1:num_slice) => src(1:src_slice_len*num_slice)
143#else
144 CALL ptr_bind(src_data, (/ src_slice_len, num_slice /), src)
145#endif
146 DO j = 1, num_slice
147 DO i = 1, src_slice_len
148 src_data(i, j) = dble(i + (j - 1) * src_slice_len)
149 END DO
150 END DO
151
152 src_data_ => src(src_slice_len*num_slice+1:)
153
154#ifdef HAVE_FC_PTR_BOUND_REMAP
155 dst_data(1:dst_slice_len, 1:num_slice) => dst(1:dst_slice_len*num_slice)
156#else
157 CALL ptr_bind(dst_data, (/ dst_slice_len, num_slice /), dst)
158#endif
159
160 dst_data_ => dst(dst_slice_len*num_slice+1:)
161
162 DO i = 1, num_slice - 1
163 xt_slice_c_loc(src_data(:, i), src_data_p(i))
164 xt_slice_c_loc(dst_data(:, i), dst_data_p(i))
165 END DO
166
167
168 DO k = 1, cache_size + cache_overrun
169 src_data_(k:k+src_slice_len-1) = src_data(:,num_slice)
170
171
172 xt_slice_c_loc(src_data_(k:k+src_slice_len-1), src_data_p(3))
173 xt_slice_c_loc(dst_data_(k:k+dst_slice_len-1), dst_data_p(3))
174
175 DO iexch = 1, 2
176 dst = -1.0d0
177 IF (iexch == 1) THEN
179 dst_data_p)
180 ELSE
182 dst_data_p, request)
183 CALL check_wait_request(request, filename, __line__)
184 ENDIF
185 IF (cmp_arrays(ref_dst_data(:, 1:num_slice-1), &
186 & dst_data(:, 1:num_slice-1)) &
187 .OR. cmp_arrays(ref_dst_data(:,num_slice), &
188 & dst_data_(k:k+dst_slice_len-1))) &
189 CALL test_abort(err_msg(iexch), filename, __line__)
190 ENDDO
191 END DO
192 END SUBROUTINE run_displacement_check
193
194END MODULE redist_collection_displace
195
196
197
198
199
200
201
202
203
void xt_redist_delete(Xt_redist redist)
Xt_redist xt_redist_copy(Xt_redist redist)
void xt_redist_s_exchange(Xt_redist redist, int num_arrays, const void *const src_data[], void *const dst_data[])
void xt_redist_a_exchange(Xt_redist redist, int num_arrays, const void *const src_data[], void *const dst_data[], Xt_request *request)
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)