int MPIR_Get_intercomm_contextid(MPIR_Comm * comm_ptr, MPIR_Context_id_t * context_id,
MPIR_Context_id_t * recvcontext_id)
{
MPIR_Context_id_t mycontext_id, remote_context_id;
int mpi_errno = MPI_SUCCESS;
int tag = 31567; /* FIXME - we need an internal tag or
* communication channel. Can we use a different
* context instead?. Or can we use the tag
* provided in the intercomm routine? (not on a dup,
* but in that case it can use the collective context) */
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPIR_GET_INTERCOMM_CONTEXTID);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPIR_GET_INTERCOMM_CONTEXTID);
if (!comm_ptr->local_comm) {
/* Manufacture the local communicator */
mpi_errno = MPII_Setup_intercomm_localcomm(comm_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
mpi_errno = MPIR_Get_contextid_sparse(comm_ptr->local_comm, &mycontext_id, FALSE);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_Assert(mycontext_id != 0);
/* MPIC routine uses an internal context id. The local leads (process 0)
* exchange data */
remote_context_id = -1;
if (comm_ptr->rank == 0) {
mpi_errno = MPIC_Sendrecv(&mycontext_id, 1, MPIR_CONTEXT_ID_T_DATATYPE, 0, tag,
&remote_context_id, 1, MPIR_CONTEXT_ID_T_DATATYPE, 0, tag,
comm_ptr, MPI_STATUS_IGNORE, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
/* Make sure that all of the local processes now have this
* id */
mpi_errno = MPID_Bcast(&remote_context_id, 1, MPIR_CONTEXT_ID_T_DATATYPE,
0, comm_ptr->local_comm, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* The recvcontext_id must be the one that was allocated out of the local
* group, not the remote group. Otherwise we could end up posting two
* MPI_ANY_SOURCE,MPI_ANY_TAG recvs on the same context IDs even though we
* are attempting to post them for two separate communicators. */
*context_id = remote_context_id;
*recvcontext_id = mycontext_id;
fn_fail:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPIR_GET_INTERCOMM_CONTEXTID);
return mpi_errno;
}
int MPIR_Ibcast_sched_inter_flat(void *buffer, int count, MPI_Datatype datatype,
int root, MPIR_Comm * comm_ptr, MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Assert(comm_ptr->comm_kind == MPIR_COMM_KIND__INTERCOMM);
/* Intercommunicator broadcast.
* Root sends to rank 0 in remote group. Remote group does local
* intracommunicator broadcast. */
if (root == MPI_PROC_NULL) {
/* local processes other than root do nothing */
mpi_errno = MPI_SUCCESS;
} else if (root == MPI_ROOT) {
/* root sends to rank 0 on remote group and returns */
mpi_errno = MPIR_Sched_send(buffer, count, datatype, 0, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
} else {
/* remote group. rank 0 on remote group receives from root */
if (comm_ptr->rank == 0) {
mpi_errno = MPIR_Sched_recv(buffer, count, datatype, root, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
}
if (comm_ptr->local_comm == NULL) {
mpi_errno = MPII_Setup_intercomm_localcomm(comm_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
/* now do the usual broadcast on this intracommunicator
* with rank 0 as root. */
mpi_errno = MPIR_Ibcast_sched(buffer, count, datatype, root, comm_ptr->local_comm, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
fn_exit:
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Get_intercomm_contextid_nonblock(MPIR_Comm * comm_ptr, MPIR_Comm * newcommp,
MPIR_Request ** req)
{
int mpi_errno = MPI_SUCCESS;
int tag;
MPIR_Sched_t s;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPIR_GET_INTERCOMM_CONTEXTID_NONBLOCK);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPIR_GET_INTERCOMM_CONTEXTID_NONBLOCK);
/* do as much local setup as possible */
if (!comm_ptr->local_comm) {
mpi_errno = MPII_Setup_intercomm_localcomm(comm_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
/* now create a schedule */
mpi_errno = MPIR_Sched_next_tag(comm_ptr, &tag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Sched_create(&s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* add some entries to it */
/* first get a context ID over the local comm */
mpi_errno =
sched_get_cid_nonblock(comm_ptr, newcommp, &newcommp->recvcontext_id, &newcommp->context_id,
s, MPIR_COMM_KIND__INTERCOMM);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* finally, kick off the schedule and give the caller a request */
mpi_errno = MPIR_Sched_start(&s, comm_ptr, tag, req);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
fn_fail:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPIR_GET_INTERCOMM_CONTEXTID_NONBLOCK);
return mpi_errno;
}
int MPIR_Iallreduce_sched_inter_remote_reduce_local_bcast(const void *sendbuf, void *recvbuf,
int count, MPI_Datatype datatype,
MPI_Op op, MPIR_Comm * comm_ptr,
MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int rank, root;
MPIR_Comm *lcomm_ptr = NULL;
MPIR_Assert(comm_ptr->comm_kind == MPIR_COMM_KIND__INTERCOMM);
rank = comm_ptr->rank;
/* 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_Ireduce_sched(sendbuf, recvbuf, count, datatype, op, root, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* no barrier, these reductions can be concurrent */
/* reduce to rank 0 of right group */
root = 0;
mpi_errno = MPIR_Ireduce_sched(sendbuf, recvbuf, count, datatype, op, root, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
} else {
/* reduce to rank 0 of left group */
root = 0;
mpi_errno = MPIR_Ireduce_sched(sendbuf, recvbuf, count, datatype, op, root, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* no barrier, these reductions can be concurrent */
/* reduce from right group to rank 0 */
root = (rank == 0) ? MPI_ROOT : MPI_PROC_NULL;
mpi_errno = MPIR_Ireduce_sched(sendbuf, recvbuf, count, datatype, op, root, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
/* don't bcast until the reductions have finished */
mpi_errno = MPIR_Sched_barrier(s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* Get the local intracommunicator */
if (!comm_ptr->local_comm) {
mpi_errno = MPII_Setup_intercomm_localcomm(comm_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
lcomm_ptr = comm_ptr->local_comm;
mpi_errno = MPIR_Ibcast_sched(recvbuf, count, datatype, 0, lcomm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
fn_exit:
return mpi_errno;
fn_fail:
goto fn_exit;
}
/* comm create impl for intercommunicators, assumes that the standard error
* checking has already taken place in the calling function */
PMPI_LOCAL int MPIR_Comm_create_inter(MPIR_Comm *comm_ptr, MPIR_Group *group_ptr,
MPIR_Comm **newcomm_ptr)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Context_id_t new_context_id;
int *mapping = NULL;
int *remote_mapping = NULL;
MPIR_Comm *mapping_comm = NULL;
int remote_size = -1;
int rinfo[2];
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
MPIR_CHKLMEM_DECL(1);
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPIR_COMM_CREATE_INTER);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPIR_COMM_CREATE_INTER);
MPIR_Assert(comm_ptr->comm_kind == MPIR_COMM_KIND__INTERCOMM);
/* Create a new communicator from the specified group members */
/* If there is a context id cache in oldcomm, use it here. Otherwise,
use the appropriate algorithm to get a new context id.
Creating the context id is collective over the *input* communicator,
so it must be created before we decide if this process is a
member of the group */
/* In the multi-threaded case, MPIR_Get_contextid_sparse assumes that the
calling routine already holds the single criticial section */
if (!comm_ptr->local_comm) {
MPII_Setup_intercomm_localcomm( comm_ptr );
}
mpi_errno = MPIR_Get_contextid_sparse( comm_ptr->local_comm, &new_context_id, FALSE );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_Assert(new_context_id != 0);
MPIR_Assert(new_context_id != comm_ptr->recvcontext_id);
mpi_errno = MPII_Comm_create_calculate_mapping(group_ptr, comm_ptr,
&mapping, &mapping_comm);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
*newcomm_ptr = NULL;
if (group_ptr->rank != MPI_UNDEFINED) {
/* Get the new communicator structure and context id */
mpi_errno = MPIR_Comm_create( newcomm_ptr );
if (mpi_errno) goto fn_fail;
(*newcomm_ptr)->recvcontext_id = new_context_id;
(*newcomm_ptr)->rank = group_ptr->rank;
(*newcomm_ptr)->comm_kind = comm_ptr->comm_kind;
/* Since the group has been provided, let the new communicator know
about the group */
(*newcomm_ptr)->local_comm = 0;
(*newcomm_ptr)->local_group = group_ptr;
MPIR_Group_add_ref( group_ptr );
(*newcomm_ptr)->local_size = group_ptr->size;
(*newcomm_ptr)->pof2 = MPL_pof2((*newcomm_ptr)->local_size);
(*newcomm_ptr)->remote_group = 0;
(*newcomm_ptr)->is_low_group = comm_ptr->is_low_group;
}
/* There is an additional step. We must communicate the
information on the local context id and the group members,
given by the ranks so that the remote process can construct the
appropriate network address mapping.
First we exchange group sizes and context ids. Then the ranks
in the remote group, from which the remote network address
mapping can be constructed. We need to use the "collective"
context in the original intercommunicator */
if (comm_ptr->rank == 0) {
int info[2];
info[0] = new_context_id;
info[1] = group_ptr->size;
mpi_errno = MPIC_Sendrecv(info, 2, MPI_INT, 0, 0,
rinfo, 2, MPI_INT, 0, 0,
comm_ptr, MPI_STATUS_IGNORE, &errflag );
if (mpi_errno) { MPIR_ERR_POP( mpi_errno ); }
if (*newcomm_ptr != NULL) {
(*newcomm_ptr)->context_id = rinfo[0];
}
remote_size = rinfo[1];
MPIR_CHKLMEM_MALLOC(remote_mapping,int*,
remote_size*sizeof(int),
mpi_errno,"remote_mapping",MPL_MEM_ADDRESS);
/* Populate and exchange the ranks */
mpi_errno = MPIC_Sendrecv( mapping, group_ptr->size, MPI_INT, 0, 0,
remote_mapping, remote_size, MPI_INT, 0, 0,
comm_ptr, MPI_STATUS_IGNORE, &errflag );
if (mpi_errno) { MPIR_ERR_POP( mpi_errno ); }
/* Broadcast to the other members of the local group */
mpi_errno = MPID_Bcast( rinfo, 2, MPI_INT, 0,
comm_ptr->local_comm, &errflag);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPID_Bcast( remote_mapping, remote_size, MPI_INT, 0,
comm_ptr->local_comm, &errflag);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
}
int MPIR_Bcast_inter_remote_send_local_bcast (
void *buffer,
int count,
MPI_Datatype datatype,
int root,
MPIR_Comm *comm_ptr,
MPIR_Errflag_t *errflag)
{
int rank, mpi_errno;
int mpi_errno_ret = MPI_SUCCESS;
MPI_Status status;
MPIR_Comm *newcomm_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPIR_BCAST_INTER);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPIR_BCAST_INTER);
if (root == MPI_PROC_NULL)
{
/* local processes other than root do nothing */
mpi_errno = MPI_SUCCESS;
}
else if (root == MPI_ROOT)
{
/* root sends to rank 0 on remote group and returns */
mpi_errno = MPIC_Send(buffer, count, datatype, 0,
MPIR_BCAST_TAG, comm_ptr, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
}
else
{
/* remote group. rank 0 on remote group receives from root */
rank = comm_ptr->rank;
if (rank == 0)
{
mpi_errno = MPIC_Recv(buffer, count, datatype, root,
MPIR_BCAST_TAG, comm_ptr, &status, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
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;
/* now do the usual broadcast on this intracommunicator
with rank 0 as root. */
mpi_errno = MPIR_Bcast_intra_auto(buffer, count, datatype, 0, newcomm_ptr, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
}
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPIR_BCAST_INTER);
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno_ret)
mpi_errno = mpi_errno_ret;
else if (*errflag != MPIR_ERR_NONE)
MPIR_ERR_SET(mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* --END ERROR HANDLING-- */
return mpi_errno;
}
int MPIR_Intercomm_merge_impl(MPIR_Comm * comm_ptr, int high, MPIR_Comm ** new_intracomm_ptr)
{
int mpi_errno = MPI_SUCCESS;
int local_high, remote_high, new_size;
MPIR_Context_id_t new_context_id;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPIR_COMM_KIND__INTERCOMM_MERGE_IMPL);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPIR_COMM_KIND__INTERCOMM_MERGE_IMPL);
/* Make sure that we have a local intercommunicator */
if (!comm_ptr->local_comm) {
/* Manufacture the local communicator */
mpi_errno = MPII_Setup_intercomm_localcomm(comm_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
/* Find the "high" value of the other group of processes. This
* will be used to determine which group is ordered first in
* the generated communicator. high is logical */
local_high = high;
if (comm_ptr->rank == 0) {
/* This routine allows use to use the collective communication
* context rather than the point-to-point context. */
mpi_errno = MPIC_Sendrecv(&local_high, 1, MPI_INT, 0, 0,
&remote_high, 1, MPI_INT, 0, 0, comm_ptr,
MPI_STATUS_IGNORE, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* If local_high and remote_high are the same, then order is arbitrary.
* we use the is_low_group in the intercomm in this case. */
MPL_DBG_MSG_FMT(MPIR_DBG_COMM, VERBOSE,
(MPL_DBG_FDEST, "local_high=%d remote_high=%d is_low_group=%d",
local_high, remote_high, comm_ptr->is_low_group));
if (local_high == remote_high) {
local_high = !(comm_ptr->is_low_group);
}
}
/*
* All processes in the local group now need to get the
* value of local_high, which may have changed if both groups
* of processes had the same value for high
*/
mpi_errno = MPIR_Bcast(&local_high, 1, MPI_INT, 0, comm_ptr->local_comm, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/*
* For the intracomm, we need a consistent context id.
* That means that one of the two groups needs to use
* the recvcontext_id and the other must use the context_id
* The recvcontext_id is unique on each process, but another
* communicator may use the context_id. Therefore, we do a small hack.
* We set both flags indicating a sub-communicator (intra-node and
* inter-node) to one. This is normally not possible (a communicator
* is either intra- or inter-node) - which makes this context_id unique.
*
*/
new_size = comm_ptr->local_size + comm_ptr->remote_size;
mpi_errno = MPIR_Comm_create(new_intracomm_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
if (local_high) {
(*new_intracomm_ptr)->context_id =
MPIR_CONTEXT_SET_FIELD(SUBCOMM, comm_ptr->recvcontext_id, 3);
} else {
(*new_intracomm_ptr)->context_id = MPIR_CONTEXT_SET_FIELD(SUBCOMM, comm_ptr->context_id, 3);
}
(*new_intracomm_ptr)->recvcontext_id = (*new_intracomm_ptr)->context_id;
(*new_intracomm_ptr)->remote_size = (*new_intracomm_ptr)->local_size = new_size;
(*new_intracomm_ptr)->pof2 = MPL_pof2(new_size);
(*new_intracomm_ptr)->rank = -1;
(*new_intracomm_ptr)->comm_kind = MPIR_COMM_KIND__INTRACOMM;
/* Now we know which group comes first. Build the new mapping
* from the existing comm */
mpi_errno = create_and_map(comm_ptr, local_high, (*new_intracomm_ptr));
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* We've setup a temporary context id, based on the context id
* used by the intercomm. This allows us to perform the allreduce
* operations within the context id algorithm, since we already
* have a valid (almost - see comm_create_hook) communicator.
*/
mpi_errno = MPIR_Comm_commit((*new_intracomm_ptr));
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* printf("About to get context id \n"); fflush(stdout); */
/* In the multi-threaded case, MPIR_Get_contextid_sparse assumes that the
* calling routine already holds the single criticial section */
new_context_id = 0;
mpi_errno = MPIR_Get_contextid_sparse((*new_intracomm_ptr), &new_context_id, FALSE);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_Assert(new_context_id != 0);
/* We release this communicator that was involved just to
* get valid context id and create true one
*/
mpi_errno = MPIR_Comm_release(*new_intracomm_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Comm_create(new_intracomm_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
(*new_intracomm_ptr)->remote_size = (*new_intracomm_ptr)->local_size = new_size;
(*new_intracomm_ptr)->pof2 = MPL_pof2(new_size);
(*new_intracomm_ptr)->rank = -1;
(*new_intracomm_ptr)->comm_kind = MPIR_COMM_KIND__INTRACOMM;
(*new_intracomm_ptr)->context_id = new_context_id;
(*new_intracomm_ptr)->recvcontext_id = new_context_id;
mpi_errno = create_and_map(comm_ptr, local_high, (*new_intracomm_ptr));
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Comm_commit((*new_intracomm_ptr));
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPIR_COMM_KIND__INTERCOMM_MERGE_IMPL);
return mpi_errno;
fn_fail:
goto fn_exit;
}
/*@
MPI_Intercomm_merge - Creates an intracommuncator from an intercommunicator
Input Parameters:
+ intercomm - Intercommunicator (handle)
- high - Used to order the groups within comm (logical)
when creating the new communicator. This is a boolean value; the group
that sets high true has its processes ordered `after` the group that sets
this value to false. If all processes in the intercommunicator provide
the same value, the choice of which group is ordered first is arbitrary.
Output Parameters:
. newintracomm - Created intracommunicator (handle)
Notes:
While all processes may provide the same value for the 'high' parameter,
this requires the MPI implementation to determine which group of
processes should be ranked first.
.N ThreadSafe
.N Fortran
Algorithm:
.Eb
.i Allocate contexts
.i Local and remote group leaders swap high values
.i Determine the high value.
.i Merge the two groups and make the intra-communicator
.Ee
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_EXHAUSTED
.seealso: MPI_Intercomm_create, MPI_Comm_free
@*/
int MPI_Intercomm_merge(MPI_Comm intercomm, int high, MPI_Comm * newintracomm)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Comm *new_intracomm_ptr;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_INTERCOMM_MERGE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_INTERCOMM_MERGE);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(intercomm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(intercomm, comm_ptr);
/* Validate parameters and objects (post conversion) */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr */
MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, FALSE);
/* If comm_ptr is not valid, it will be reset to null */
if (comm_ptr && comm_ptr->comm_kind != MPIR_COMM_KIND__INTERCOMM) {
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_RECOVERABLE, FCNAME, __LINE__,
MPI_ERR_COMM, "**commnotinter", 0);
}
if (mpi_errno)
goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* Make sure that we have a local intercommunicator */
if (!comm_ptr->local_comm) {
/* Manufacture the local communicator */
MPII_Setup_intercomm_localcomm(comm_ptr);
}
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
int acthigh;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
/* Check for consistent valus of high in each local group.
* The Intel test suite checks for this; it is also an easy
* error to make */
acthigh = high ? 1 : 0; /* Clamp high into 1 or 0 */
mpi_errno = MPIR_Allreduce(MPI_IN_PLACE, &acthigh, 1, MPI_INT,
MPI_SUM, comm_ptr->local_comm, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* acthigh must either == 0 or the size of the local comm */
if (acthigh != 0 && acthigh != comm_ptr->local_size) {
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_RECOVERABLE, FCNAME, __LINE__,
MPI_ERR_ARG, "**notsame", "**notsame %s %s",
"high", "MPI_Intercomm_merge");
goto fn_fail;
}
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Intercomm_merge_impl(comm_ptr, high, &new_intracomm_ptr);
if (mpi_errno)
goto fn_fail;
MPIR_OBJ_PUBLISH_HANDLE(*newintracomm, new_intracomm_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_INTERCOMM_MERGE);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
#ifdef HAVE_ERROR_CHECKING
{
mpi_errno =
MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_intercomm_merge", "**mpi_intercomm_merge %C %d %p",
intercomm, high, newintracomm);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
