/* comm shrink impl; assumes that standard error checking has already taken
* place in the calling function */
int MPIR_Comm_shrink(MPID_Comm *comm_ptr, MPID_Comm **newcomm_ptr)
{
int mpi_errno = MPI_SUCCESS;
MPID_Group *global_failed, *comm_grp, *new_group_ptr;
int attempts = 0;
int errflag = 0, tmp_errflag = 0;
MPID_MPI_STATE_DECL(MPID_STATE_MPIR_COMM_SHRINK);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPIR_COMM_SHRINK);
/* TODO - Implement this function for intercommunicators */
MPIR_Comm_group_impl(comm_ptr, &comm_grp);
do {
mpi_errno = MPID_Comm_get_all_failed_procs(comm_ptr, &global_failed, MPIR_SHRINK_TAG);
/* Ignore the mpi_errno value here as it will definitely communicate
* with failed procs */
mpi_errno = MPIR_Group_difference_impl(comm_grp, global_failed, &new_group_ptr);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
if (MPID_Group_empty != global_failed) MPIR_Group_release(global_failed);
mpi_errno = MPIR_Comm_create_group(comm_ptr, new_group_ptr, MPIR_SHRINK_TAG, newcomm_ptr);
errflag = mpi_errno || *newcomm_ptr == NULL;
mpi_errno = MPIR_Allreduce_group(MPI_IN_PLACE, &errflag, 1, MPI_INT, MPI_MAX, comm_ptr,
new_group_ptr, MPIR_SHRINK_TAG, &tmp_errflag);
MPIR_Group_release(new_group_ptr);
if (errflag) MPIU_Object_set_ref(new_group_ptr, 0);
} while (errflag && ++attempts < 5);
if (errflag && attempts >= 5) goto fn_fail;
else mpi_errno = MPI_SUCCESS;
fn_exit:
MPIR_Group_release(comm_grp);
MPID_MPI_FUNC_EXIT(MPID_STATE_MPIR_COMM_SHRINK);
return mpi_errno;
fn_fail:
if (*newcomm_ptr) MPIU_Object_set_ref(*newcomm_ptr, 0);
MPIU_Object_set_ref(global_failed, 0);
MPIU_Object_set_ref(new_group_ptr, 0);
goto fn_exit;
}
/* comm shrink impl; assumes that standard error checking has already taken
* place in the calling function */
int MPIR_Comm_shrink(MPIR_Comm * comm_ptr, MPIR_Comm ** newcomm_ptr)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Group *global_failed = NULL, *comm_grp = NULL, *new_group_ptr = NULL;
int attempts = 0;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPIR_COMM_SHRINK);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPIR_COMM_SHRINK);
/* TODO - Implement this function for intercommunicators */
MPIR_Comm_group_impl(comm_ptr, &comm_grp);
do {
errflag = MPIR_ERR_NONE;
MPID_Comm_get_all_failed_procs(comm_ptr, &global_failed, MPIR_SHRINK_TAG);
/* Ignore the mpi_errno value here as it will definitely communicate
* with failed procs */
mpi_errno = MPIR_Group_difference_impl(comm_grp, global_failed, &new_group_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
if (MPIR_Group_empty != global_failed)
MPIR_Group_release(global_failed);
mpi_errno = MPIR_Comm_create_group(comm_ptr, new_group_ptr, MPIR_SHRINK_TAG, newcomm_ptr);
if (*newcomm_ptr == NULL) {
errflag = MPIR_ERR_PROC_FAILED;
} else if (mpi_errno) {
errflag =
MPIX_ERR_PROC_FAILED ==
MPIR_ERR_GET_CLASS(mpi_errno) ? MPIR_ERR_PROC_FAILED : MPIR_ERR_OTHER;
MPIR_Comm_release(*newcomm_ptr);
}
mpi_errno = MPII_Allreduce_group(MPI_IN_PLACE, &errflag, 1, MPI_INT, MPI_MAX, comm_ptr,
new_group_ptr, MPIR_SHRINK_TAG, &errflag);
MPIR_Group_release(new_group_ptr);
if (errflag) {
if (*newcomm_ptr != NULL && MPIR_Object_get_ref(*newcomm_ptr) > 0) {
MPIR_Object_set_ref(*newcomm_ptr, 1);
MPIR_Comm_release(*newcomm_ptr);
}
if (MPIR_Object_get_ref(new_group_ptr) > 0) {
MPIR_Object_set_ref(new_group_ptr, 1);
MPIR_Group_release(new_group_ptr);
}
}
} while (errflag && ++attempts < 5);
if (errflag && attempts >= 5)
goto fn_fail;
else
mpi_errno = MPI_SUCCESS;
fn_exit:
MPIR_Group_release(comm_grp);
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPIR_COMM_SHRINK);
return mpi_errno;
fn_fail:
if (*newcomm_ptr)
MPIR_Object_set_ref(*newcomm_ptr, 0);
MPIR_Object_set_ref(global_failed, 0);
MPIR_Object_set_ref(new_group_ptr, 0);
goto fn_exit;
}
/*@
MPI_Comm_create_group - Creates a new communicator
Input Parameters:
+ comm - communicator (handle)
. group - group, which is a subset of the group of 'comm' (handle)
- tag - safe tag unused by other communication
Output Parameters:
. newcomm - new communicator (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_GROUP
.seealso: MPI_Comm_free
@*/
int MPI_Comm_create_group(MPI_Comm comm, MPI_Group group, int tag, MPI_Comm * newcomm)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL, *newcomm_ptr;
MPIR_Group *group_ptr;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_COMM_CREATE_GROUP);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_COMM_CREATE_GROUP);
/* Validate parameters, and convert MPI object handles to object pointers */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
MPIR_Comm_get_ptr( comm, comm_ptr );
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr */
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
if (mpi_errno) goto fn_fail;
/* If comm_ptr is not valid, it will be reset to null */
MPIR_ERRTEST_COMM_INTRA(comm_ptr, mpi_errno);
/* only test for MPI_GROUP_NULL after attempting to convert the comm
* so that any errhandlers on comm will (correctly) be invoked */
MPIR_ERRTEST_GROUP(group, mpi_errno);
MPIR_ERRTEST_COMM_TAG(tag, mpi_errno);
}
MPID_END_ERROR_CHECKS;
MPIR_Group_get_ptr( group, group_ptr );
MPID_BEGIN_ERROR_CHECKS;
{
/* Check the group ptr */
MPIR_Group_valid_ptr( group_ptr, mpi_errno );
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# else
{
MPIR_Comm_get_ptr( comm, comm_ptr );
MPIR_Group_get_ptr( group, group_ptr );
}
# endif
/* ... body of routine ... */
mpi_errno = MPIR_Comm_create_group(comm_ptr, group_ptr, tag, &newcomm_ptr);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
if (newcomm_ptr)
MPIR_OBJ_PUBLISH_HANDLE(*newcomm, newcomm_ptr->handle);
else
*newcomm = MPI_COMM_NULL;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_COMM_CREATE_GROUP);
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_comm_create_group",
"**mpi_comm_create_group %C %G %d %p", comm, group, tag,
newcomm);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
