48 PROGRAM test_redist_collection_static_parallel
50 USE ftest_common,
ONLY: init_mpi, finish_mpi, test_abort
51 USE test_idxlist_utils,
ONLY: test_err_count
60 USE test_redist_common,
ONLY: check_redist_xi, check_wait_request, &
61 redist_exchanger_option
62 USE iso_c_binding,
ONLY: c_loc, c_ptr
64 #if defined __PGI && (__PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 10))
68 CHARACTER(len=*),
PARAMETER :: &
69 filename =
'test_redist_collection_static_parallel_f.f90'
70 CHARACTER(len=*),
PARAMETER :: err_msg(2) = &
71 (/
"xt_redist_s_exchange",
"xt_redist_a_exchange" /)
72 TYPE(xt_config) :: config
73 INTEGER :: rank, comm_size, ierror
76 config = redist_exchanger_option()
78 CALL mpi_comm_rank(mpi_comm_world, rank, ierror)
79 IF (ierror /= mpi_success) &
80 CALL test_abort(
'mpi_comm_rank failed', filename, __line__)
81 CALL mpi_comm_size(mpi_comm_world, comm_size, ierror)
82 IF (ierror /= mpi_success) &
83 CALL test_abort(
'mpi_comm_size failed', filename, __line__)
85 IF (comm_size > 1)
THEN
86 CALL test_4redist(mpi_comm_world, config)
87 CALL test_rr_exchange(mpi_comm_world, config)
90 IF (test_err_count() /= 0) &
91 CALL test_abort(
"non-zero error count!", filename, __line__)
96 SUBROUTINE build_idxlists(indices_a, indices_b, indices_all)
98 TYPE(xt_idxlist),
INTENT(out) :: indices_a, indices_b, indices_all
100 TYPE(xt_idxlist) :: indices_a_(2)
102 INTEGER(xt_int_kind),
PARAMETER :: start = 0
103 INTEGER(xt_int_kind) :: global_size(2), local_start(2, 2)
104 INTEGER :: local_size(2)
106 TYPE(xt_stripe) :: stripe
108 global_size(1) = int(2 * comm_size, xi)
109 global_size(2) = int(comm_size**2, xi)
110 local_size = comm_size
111 local_start = reshape((/ 0_xi, int(rank*comm_size, xi), &
112 int(comm_size, xi), int(comm_size**2-(rank+1)*comm_size, xi) /), &
124 stripe = xt_stripe(int(rank * 2 * comm_size**2, xi), 1_xi, 2*comm_size**2)
127 stripe = xt_stripe(0_xi, 1_xi, 2*comm_size**3)
129 END SUBROUTINE build_idxlists
131 SUBROUTINE test_4redist(comm, config)
132 INTEGER,
INTENT(in) :: comm
133 TYPE(xt_config),
INTENT(in) :: config
134 INTEGER,
PARAMETER :: num_tx = 4
135 TYPE(xt_idxlist) :: indices_a, indices_b, indices_all
136 INTEGER(xt_int_kind),
ALLOCATABLE,
TARGET :: src(:), dst(:)
137 INTEGER(xt_int_kind),
POINTER :: index_vector_a(:), &
138 index_vector_b(:), index_vector_all(:)
139 TYPE(xt_xmap) :: xmaps(num_tx)
140 TYPE(xt_redist) :: redists(num_tx), redist, redist_copy
141 INTEGER(mpi_address_kind) :: src_displacements(num_tx), &
142 dst_displacements(num_tx)
143 INTEGER :: i, ierror, size_a, size_b, size_all
144 INTEGER(xt_int_kind),
POINTER :: results_1(:), &
145 results_2(:), results_3(:), results_4(:)
147 size_a = 2 * comm_size**2
148 size_b = 2 * comm_size**2
149 size_all = 2 * comm_size**3
151 ALLOCATE(src(size_a + size_b + size_all), dst(size_b + size_a + 2*size_all))
153 index_vector_a => src(1:size_a)
154 index_vector_b => src(size_a+1:size_a+size_b)
155 index_vector_all => src(size_a+size_b+1:)
157 results_1 => dst(1:size_b)
158 results_2 => dst(size_b+1:size_b+size_a)
159 results_3 => dst(size_b+size_a+1:size_b+size_a+size_all)
160 results_4 => dst(size_b+size_a+size_all+1:size_b+size_a+2*size_all)
162 CALL build_idxlists(indices_a, indices_b, indices_all)
182 CALL mpi_get_address(index_vector_a, src_displacements(1), ierror)
183 CALL mpi_get_address(index_vector_b, src_displacements(2), ierror)
184 CALL mpi_get_address(index_vector_a, src_displacements(3), ierror)
185 CALL mpi_get_address(index_vector_b, src_displacements(4), ierror)
187 src_displacements = src_displacements - src_displacements(1)
189 CALL mpi_get_address(results_1, dst_displacements(1), ierror)
190 CALL mpi_get_address(results_2, dst_displacements(2), ierror)
191 CALL mpi_get_address(results_3, dst_displacements(3), ierror)
192 CALL mpi_get_address(results_4, dst_displacements(4), ierror)
194 dst_displacements = dst_displacements - dst_displacements(1)
197 src_displacements, dst_displacements, comm, config)
205 CALL test_transpose_gather(redist, dst, size_a, size_b, size_all, &
206 index_vector_a, index_vector_b, index_vector_all)
209 CALL test_transpose_gather(redist_copy, dst, size_a, size_b, size_all, &
210 index_vector_a, index_vector_b, index_vector_all)
214 END SUBROUTINE test_4redist
216 SUBROUTINE test_transpose_gather(redist, dst, size_a, size_b, &
217 size_all, index_vector_a, index_vector_b, index_vector_all)
218 TYPE(xt_redist),
INTENT(in) :: redist
219 INTEGER,
INTENT(in) :: size_a, size_b, size_all
220 INTEGER(xi),
TARGET,
INTENT(inout) :: dst(size_b+size_a+2*size_all)
221 INTEGER(xi),
TARGET,
INTENT(in) :: index_vector_a(size_a)
222 INTEGER(xi),
INTENT(in) :: index_vector_b(size_b), &
223 index_vector_all(size_all)
225 INTEGER(xi),
POINTER :: results_1(:), &
226 results_2(:), results_3(:), results_4(:)
227 TYPE(c_ptr) :: results(1), input(1)
229 TYPE(xt_request) :: request
231 results_1 => dst(1:size_b)
232 results_2 => dst(size_b+1:size_b+size_a)
233 results_3 => dst(size_b+size_a+1:size_b+size_a+size_all)
234 results_4 => dst(size_b+size_a+size_all+1:size_b+size_a+2*size_all)
236 input(1) = c_loc(index_vector_a(1))
237 results(1) = c_loc(results_1(1))
246 CALL check_wait_request(request, filename, __line__)
249 IF (any(results_1(:) /= index_vector_b)) &
250 CALL test_abort(err_msg(iexch), filename, __line__)
252 IF (any(results_2(:) /= index_vector_a)) &
253 CALL test_abort(err_msg(iexch), filename, __line__)
255 IF (any(results_3(:) /= index_vector_all)) &
256 CALL test_abort(err_msg(iexch), filename, __line__)
258 IF (any(results_4(:) /= index_vector_all)) &
259 CALL test_abort(err_msg(iexch), filename, __line__)
261 END SUBROUTINE test_transpose_gather
265 SUBROUTINE test_rr_exchange(comm, config)
266 INTEGER,
INTENT(in) :: comm
267 TYPE(xt_config),
INTENT(in) :: config
268 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
269 INTEGER,
PARAMETER :: num_local_indices = 5
270 INTEGER(xi) :: src_indices(num_local_indices)
271 INTEGER(xi) :: i_xi, temp, dst_indices(num_local_indices, 2)
272 INTEGER(xi) :: num_indices_global
274 TYPE(xt_xmap) :: xmaps(2)
275 TYPE(xt_redist) :: redists(2), redist
276 INTEGER(xi) :: results(num_local_indices, 2)
277 INTEGER(mpi_address_kind) :: src_displacements(2), dst_displacements(2), &
281 num_indices_global = int(comm_size, xi) * int(num_local_indices, xi)
282 DO i = 1, num_local_indices
285 = int(rank, xi) * int(num_local_indices, xi) + (i_xi - 1_xi)
286 dst_indices(i, 1) = mod(src_indices(i) + 1_xi, num_indices_global)
287 temp = src_indices(i) - 1_xi
288 dst_indices(i, 2) = merge(num_indices_global - 1_xi, temp, temp < 0_xi)
302 src_displacements = 0_mpi_address_kind
303 dst_displacements(1) = 0_mpi_address_kind
304 CALL mpi_get_address(results(1, 2), dst_displacements(2), ierror)
305 IF (ierror /= mpi_success) &
306 CALL test_abort(
"error in mpi_get_address", filename, __line__)
307 CALL mpi_get_address(results(1, 1), addr_temp, ierror)
308 IF (ierror /= mpi_success) &
309 CALL test_abort(
"error in mpi_get_address", filename, __line__)
310 dst_displacements(2) = dst_displacements(2) - addr_temp
313 dst_displacements, comm, config)
321 CALL check_redist_xi(redist, num_local_indices, src_indices, &
322 SIZE(results), results, dst_indices)
326 END SUBROUTINE test_rr_exchange
328 END PROGRAM test_redist_collection_static_parallel
void xt_config_delete(Xt_config config)
void xt_initialize(MPI_Comm default_comm)
void xt_idxlist_get_indices(Xt_idxlist idxlist, Xt_int *indices)
void xt_idxlist_delete(Xt_idxlist idxlist)
Xt_idxlist xt_idxlist_collection_new(Xt_idxlist *idxlists, int num_idxlists)
Xt_idxlist xt_idxsection_new(Xt_int start, int num_dimensions, const Xt_int global_size[num_dimensions], const int local_size[num_dimensions], const Xt_int local_start[num_dimensions])
Xt_idxlist xt_idxstripes_new(struct Xt_stripe const *stripes, int num_stripes)
Xt_idxlist xt_idxvec_new(const Xt_int *idxlist, int num_indices)
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_static_new(Xt_redist *redists, int num_redists, const MPI_Aint src_displacements[num_redists], const MPI_Aint dst_displacements[num_redists], MPI_Comm comm)
Xt_redist xt_redist_p2p_new(Xt_xmap xmap, MPI_Datatype datatype)
void xt_xmap_delete(Xt_xmap xmap)
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)