/* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */ /* * * (C) 2017 by Argonne National Laboratory. * See COPYRIGHT in top-level directory. */ #include "mpiimpl.h" /* Intercommunicator Reduce_scatter_block * * We first do an intercommunicator reduce to rank 0 on left group, * then an intercommunicator reduce to rank 0 on right group, followed * by local intracommunicator scattervs in each group. */ #undef FUNCNAME #define FUNCNAME MPIR_Reduce_scatter_block_inter_remote_reduce_local_scatter #undef FCNAME #define FCNAME MPL_QUOTE(FUNCNAME) int MPIR_Reduce_scatter_block_inter_remote_reduce_local_scatter(const void *sendbuf, void *recvbuf, int recvcount, MPI_Datatype datatype, MPI_Op op, MPIR_Comm * comm_ptr, MPIR_Errflag_t * errflag) { int rank, mpi_errno, root, local_size, total_count; int mpi_errno_ret = MPI_SUCCESS; MPI_Aint true_extent, true_lb = 0, extent; void *tmp_buf = NULL; MPIR_Comm *newcomm_ptr = NULL; MPIR_CHKLMEM_DECL(1); rank = comm_ptr->rank; local_size = comm_ptr->local_size; total_count = local_size * recvcount; if (rank == 0) { /* In each group, rank 0 allocates a temp. buffer for the * reduce */ MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent); MPIR_Datatype_get_extent_macro(datatype, extent); MPIR_CHKLMEM_MALLOC(tmp_buf, void *, total_count * (MPL_MAX(extent, true_extent)), mpi_errno, "tmp_buf", MPL_MEM_BUFFER); /* adjust for potential negative lower bound in datatype */ tmp_buf = (void *) ((char *) tmp_buf - true_lb); } /* first do a reduce from right group to rank 0 in left group, * then from left group to rank 0 in right group */ if (comm_ptr->is_low_group) { /* reduce from right group to rank 0 */ root = (rank == 0) ? MPI_ROOT : MPI_PROC_NULL; mpi_errno = MPIR_Reduce_inter_auto(sendbuf, tmp_buf, total_count, datatype, op, root, comm_ptr, errflag); if (mpi_errno) { /* for communication errors, just record the error but continue */ *errflag = MPIX_ERR_PROC_FAILED == MPIR_ERR_GET_CLASS(mpi_errno) ? MPIR_ERR_PROC_FAILED : MPIR_ERR_OTHER; MPIR_ERR_SET(mpi_errno, *errflag, "**fail"); MPIR_ERR_ADD(mpi_errno_ret, mpi_errno); } /* reduce to rank 0 of right group */ root = 0; mpi_errno = MPIR_Reduce_inter_auto(sendbuf, tmp_buf, total_count, datatype, op, root, comm_ptr, errflag); if (mpi_errno) { /* for communication errors, just record the error but continue */ *errflag = MPIX_ERR_PROC_FAILED == MPIR_ERR_GET_CLASS(mpi_errno) ? MPIR_ERR_PROC_FAILED : MPIR_ERR_OTHER; MPIR_ERR_SET(mpi_errno, *errflag, "**fail"); MPIR_ERR_ADD(mpi_errno_ret, mpi_errno); } } else { /* reduce to rank 0 of left group */ root = 0; mpi_errno = MPIR_Reduce_inter_auto(sendbuf, tmp_buf, total_count, datatype, op, root, comm_ptr, errflag); if (mpi_errno) { /* for communication errors, just record the error but continue */ *errflag = MPIX_ERR_PROC_FAILED == MPIR_ERR_GET_CLASS(mpi_errno) ? MPIR_ERR_PROC_FAILED : MPIR_ERR_OTHER; MPIR_ERR_SET(mpi_errno, *errflag, "**fail"); MPIR_ERR_ADD(mpi_errno_ret, mpi_errno); } /* reduce from right group to rank 0 */ root = (rank == 0) ? MPI_ROOT : MPI_PROC_NULL; mpi_errno = MPIR_Reduce_inter_auto(sendbuf, tmp_buf, total_count, datatype, op, root, comm_ptr, errflag); if (mpi_errno) { /* for communication errors, just record the error but continue */ *errflag = MPIX_ERR_PROC_FAILED == MPIR_ERR_GET_CLASS(mpi_errno) ? MPIR_ERR_PROC_FAILED : MPIR_ERR_OTHER; MPIR_ERR_SET(mpi_errno, *errflag, "**fail"); MPIR_ERR_ADD(mpi_errno_ret, mpi_errno); } } /* Get the local intracommunicator */ if (!comm_ptr->local_comm) MPII_Setup_intercomm_localcomm(comm_ptr); newcomm_ptr = comm_ptr->local_comm; mpi_errno = MPIR_Scatter(tmp_buf, recvcount, datatype, recvbuf, recvcount, datatype, 0, newcomm_ptr, errflag); if (mpi_errno) { /* for communication errors, just record the error but continue */ *errflag = MPIX_ERR_PROC_FAILED == MPIR_ERR_GET_CLASS(mpi_errno) ? MPIR_ERR_PROC_FAILED : MPIR_ERR_OTHER; MPIR_ERR_SET(mpi_errno, *errflag, "**fail"); MPIR_ERR_ADD(mpi_errno_ret, mpi_errno); } fn_exit: MPIR_CHKLMEM_FREEALL(); /* --BEGIN ERROR HANDLING-- */ if (mpi_errno_ret) mpi_errno = mpi_errno_ret; else if (*errflag != MPIR_ERR_NONE) MPIR_ERR_SET(mpi_errno, *errflag, "**coll_fail"); /* --END ERROR HANDLING-- */ return mpi_errno; fn_fail: goto fn_exit; }