Commit a76ef193 authored by Thomas Jahns's avatar Thomas Jahns 🤸
Browse files

Add adjustable exchangers to parallel static redist collection tests.

parent c4c71863
......@@ -61,11 +61,11 @@
#include "test_redist_common.h"
static void
test_4redist(MPI_Comm comm);
test_4redist(MPI_Comm comm, Xt_config config);
static void
test_rr_exchange(MPI_Comm comm);
test_rr_exchange(MPI_Comm comm, Xt_config config);
int main(void) {
int main(int argc, char **argv) {
// init mpi
......@@ -74,15 +74,17 @@ int main(void) {
xt_mpi_call(MPI_Init(NULL, NULL), MPI_COMM_WORLD);
xt_initialize(MPI_COMM_WORLD);
Xt_config config = redist_exchanger_option(&argc, &argv);
xt_mpi_call(MPI_Comm_size(MPI_COMM_WORLD, &comm_size), MPI_COMM_WORLD);
if (comm_size > 1) {
test_4redist(MPI_COMM_WORLD);
test_rr_exchange(MPI_COMM_WORLD);
test_4redist(MPI_COMM_WORLD, config);
test_rr_exchange(MPI_COMM_WORLD, config);
}
xt_config_delete(config);
xt_finalize();
MPI_Finalize();
......@@ -97,7 +99,7 @@ test_transpose_gather(Xt_redist redist,
const Xt_int *index_vector_b);
static void
test_4redist(MPI_Comm comm)
test_4redist(MPI_Comm comm, Xt_config config)
{ // redist test with four different redists
Xt_idxlist indices_a, indices_b, indices_all;
int comm_size, comm_rank;
......@@ -180,9 +182,8 @@ test_4redist(MPI_Comm comm)
(MPI_Aint)((size_t)(results_3 - results_1) * sizeof(Xt_int)),
(MPI_Aint)((size_t)(results_4 - results_1) * sizeof(Xt_int))};
Xt_redist redist
= xt_redist_collection_static_new(redists, 4, src_displacements,
dst_displacements, comm);
Xt_redist redist = xt_redist_collection_static_custom_new(
redists, 4, src_displacements, dst_displacements, comm, config);
// test communicator of redist
......@@ -242,7 +243,7 @@ test_transpose_gather(Xt_redist redist,
}
static void
test_rr_exchange(MPI_Comm comm)
test_rr_exchange(MPI_Comm comm, Xt_config config)
{ // redist test with two redists that do a round robin exchange in
// different directions
......@@ -284,17 +285,15 @@ test_rr_exchange(MPI_Comm comm)
ofs = (MPI_Aint)((size_t)(results[0]-results[1])*sizeof(Xt_int)),
dst_displacements[numExch] = {0, ofs};
Xt_redist redist
= xt_redist_collection_static_new(redists, numExch, src_displacements,
dst_displacements, comm);
Xt_redist redist = xt_redist_collection_static_custom_new(
redists, numExch, src_displacements, dst_displacements, comm, config);
xt_redist_delete(redists[0]);
xt_redist_delete(redists[1]);
// test communicator of redist
if (!communicators_are_congruent(xt_redist_get_MPI_Comm(redist), comm))
PUT_ERR("error in xt_redist_get_MPI_Comm\n");
xt_redist_delete(redists[0]);
xt_redist_delete(redists[1]);
for (int sync_mode = 0; sync_mode < 2; ++sync_mode) {
......
......@@ -56,8 +56,9 @@ PROGRAM test_redist_collection_static_parallel
xt_redist, xt_redist_p2p_new, xt_redist_collection_static_new, &
xt_redist_copy, xt_redist_delete, xt_redist_s_exchange, &
xt_idxlist_get_indices, xt_int_mpidt, &
xt_request, xt_redist_a_exchange
USE test_redist_common, ONLY: check_redist_xi, check_wait_request
xt_request, xt_redist_a_exchange, xt_config, xt_config_delete
USE test_redist_common, ONLY: check_redist_xi, check_wait_request, &
redist_exchanger_option
USE iso_c_binding, ONLY: c_loc, c_ptr
! older PGI compilers do not handle generic interface correctly
#if defined __PGI && (__PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 10))
......@@ -68,9 +69,11 @@ PROGRAM test_redist_collection_static_parallel
filename = 'test_redist_collection_static_parallel_f.f90'
CHARACTER(len=*), PARAMETER :: err_msg(2) = &
(/ "xt_redist_s_exchange", "xt_redist_a_exchange" /)
TYPE(xt_config) :: config
INTEGER :: rank, comm_size, ierror
CALL init_mpi
CALL xt_initialize(mpi_comm_world)
config = redist_exchanger_option()
CALL mpi_comm_rank(mpi_comm_world, rank, ierror)
IF (ierror /= MPI_SUCCESS) &
......@@ -80,12 +83,13 @@ PROGRAM test_redist_collection_static_parallel
CALL test_abort('mpi_comm_size failed', filename, __LINE__)
IF (comm_size > 1) THEN
CALL test_4redist
CALL test_rr_exchange
CALL test_4redist(mpi_comm_world, config)
CALL test_rr_exchange(mpi_comm_world, config)
END IF
IF (test_err_count() /= 0) &
CALL test_abort("non-zero error count!", filename, __LINE__)
CALL xt_config_delete(config)
CALL xt_finalize
CALL finish_mpi
CONTAINS
......@@ -124,7 +128,9 @@ CONTAINS
indices_all = xt_idxstripes_new(stripe)
END SUBROUTINE build_idxlists
SUBROUTINE test_4redist
SUBROUTINE test_4redist(comm, config)
INTEGER, INTENT(in) :: comm
TYPE(xt_config), INTENT(in) :: config
INTEGER, PARAMETER :: num_tx = 4
TYPE(xt_idxlist) :: indices_a, indices_b, indices_all
INTEGER(xt_int_kind), ALLOCATABLE, TARGET :: src(:), dst(:)
......@@ -159,10 +165,10 @@ CONTAINS
CALL xt_idxlist_get_indices(indices_b, index_vector_b)
CALL xt_idxlist_get_indices(indices_all, index_vector_all)
xmaps(1) = xt_xmap_all2all_new(indices_a, indices_b, mpi_comm_world)
xmaps(2) = xt_xmap_all2all_new(indices_b, indices_a, mpi_comm_world)
xmaps(3) = xt_xmap_all2all_new(indices_a, indices_all, mpi_comm_world)
xmaps(4) = xt_xmap_all2all_new(indices_b, indices_all, mpi_comm_world)
xmaps(1) = xt_xmap_all2all_new(indices_a, indices_b, comm)
xmaps(2) = xt_xmap_all2all_new(indices_b, indices_a, comm)
xmaps(3) = xt_xmap_all2all_new(indices_a, indices_all, comm)
xmaps(4) = xt_xmap_all2all_new(indices_b, indices_all, comm)
CALL xt_idxlist_delete(indices_a)
CALL xt_idxlist_delete(indices_b)
......@@ -188,10 +194,10 @@ CONTAINS
dst_displacements = dst_displacements - dst_displacements(1)
redist = xt_redist_collection_static_new(redists, num_tx, &
src_displacements, dst_displacements, mpi_comm_world)
src_displacements, dst_displacements, comm, config)
! test communicator of redist
! if (!test_communicator(xt_redist_get_MPI_Comm(redist), MPI_COMM_WORLD))
! if (!test_communicator(xt_redist_get_MPI_Comm(redist), COMM))
! PUT_ERR("error in xt_redist_get_MPI_Comm\n");
CALL xt_redist_delete(redists)
......@@ -256,7 +262,9 @@ CONTAINS
! redist test with two redists that do a round robin exchange in
! different directions
SUBROUTINE test_rr_exchange
SUBROUTINE test_rr_exchange(comm, config)
INTEGER, INTENT(in) :: comm
TYPE(xt_config), INTENT(in) :: config
TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
INTEGER, PARAMETER :: num_local_indices = 5
INTEGER(xi) :: src_indices(num_local_indices)
......@@ -283,7 +291,7 @@ CONTAINS
src_idxlist = xt_idxvec_new(src_indices, num_local_indices)
DO i = 1, 2
dst_idxlist = xt_idxvec_new(dst_indices(:, i))
xmaps(i) = xt_xmap_all2all_new(src_idxlist, dst_idxlist, mpi_comm_world)
xmaps(i) = xt_xmap_all2all_new(src_idxlist, dst_idxlist, comm)
CALL xt_idxlist_delete(dst_idxlist)
redists(i) = xt_redist_p2p_new(xmaps(i), xt_int_mpidt)
CALL xt_xmap_delete(xmaps(i))
......@@ -302,10 +310,10 @@ CONTAINS
dst_displacements(2) = dst_displacements(2) - addr_temp
redist = xt_redist_collection_static_new(redists, 2, src_displacements, &
dst_displacements, mpi_comm_world)
dst_displacements, comm, config)
! test communicator of redist
! IF (!test_communicator(xt_redist_get_MPI_Comm(redist), MPI_COMM_WORLD))
! IF (!test_communicator(xt_redist_get_MPI_Comm(redist), COMM))
! PUT_ERR("error in xt_redist_get_MPI_Comm\n");
CALL xt_redist_delete(redists)
......
......@@ -6,10 +6,10 @@ export LIBC_FATAL_STDERR_
for nprocs in 2 3 4 8 ; do
@abs_top_builddir@/libtool --mode=execute \
@MPI_LAUNCH@ -n $nprocs \
@abs_builddir@/test_redist_collection_static_parallel
@abs_builddir@/test_redist_collection_static_parallel "$@"
@abs_top_builddir@/libtool --mode=execute \
@MPI_LAUNCH@ -n $nprocs \
@abs_builddir@/test_redist_collection_static_parallel_f
@abs_builddir@/test_redist_collection_static_parallel_f "$@"
done
#
# Local Variables:
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment