48 MODULE redist_collection_displace
50 USE ftest_common,
ONLY: test_abort, cmp_arrays
57 #if defined __PGI && (__PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 10))
62 #if defined __PGI && __PGIC__ <= 19
63 #undef HAVE_FC_C_LOC_OF_SLICE
65 USE test_redist_common,
ONLY: build_odd_selection_xmap, &
67 USE iso_c_binding,
ONLY: c_ptr
68 #include "xt_slice_c_loc.inc"
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
85 SUBROUTINE test_displacement_variations(comm, config)
86 INTEGER,
INTENT(in) :: comm
87 TYPE(xt_config),
INTENT(in) :: config
89 TYPE(xt_redist) :: redist, redists(num_slice), redist_coll, &
92 xmap = build_odd_selection_xmap(src_slice_len)
101 cache_size, comm, config)
105 CALL run_displacement_check(redist_coll)
107 CALL run_displacement_check(redist_coll_copy)
112 END SUBROUTINE test_displacement_variations
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))
120 END SUBROUTINE ptr_bind
123 SUBROUTINE run_displacement_check(redist_coll)
124 TYPE(xt_redist),
INTENT(in) :: redist_coll
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
140 #ifdef HAVE_FC_PTR_BOUND_REMAP
141 src_data(1:src_slice_len, 1:num_slice) => src(1:src_slice_len*num_slice)
143 CALL ptr_bind(src_data, (/ src_slice_len, num_slice /), src)
146 DO i = 1, src_slice_len
147 src_data(i, j) = dble(i + (j - 1) * src_slice_len)
151 src_data_ => src(src_slice_len*num_slice+1:)
153 #ifdef HAVE_FC_PTR_BOUND_REMAP
154 dst_data(1:dst_slice_len, 1:num_slice) => dst(1:dst_slice_len*num_slice)
156 CALL ptr_bind(dst_data, (/ dst_slice_len, num_slice /), dst)
159 dst_data_ => dst(dst_slice_len*num_slice+1:)
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))
167 DO k = 1, cache_size + cache_overrun
168 src_data_(k:k+src_slice_len-1) = src_data(:,num_slice)
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))
182 CALL check_wait_request(request, filename, __line__)
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__)
191 END SUBROUTINE run_displacement_check
193 END MODULE redist_collection_displace
void xt_redist_delete(Xt_redist redist)
Xt_redist xt_redist_copy(Xt_redist redist)
void xt_redist_a_exchange(Xt_redist redist, int num_arrays, const void **src_data, void **dst_data, Xt_request *request)
void xt_redist_s_exchange(Xt_redist redist, int num_arrays, const void **src_data, void **dst_data)
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)