int MPIR_Ibsend_impl(const void *buf, int count, MPI_Datatype datatype, int dest, int tag,
MPID_Comm *comm_ptr, MPI_Request *request)
{
int mpi_errno = MPI_SUCCESS;
MPID_Request *request_ptr, *new_request_ptr;
ibsend_req_info *ibinfo=0;
/* We don't try tbsend in for MPI_Ibsend because we must create a
request even if we can send the message */
mpi_errno = MPIR_Bsend_isend( buf, count, datatype, dest, tag, comm_ptr,
IBSEND, &request_ptr );
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* FIXME: use the memory management macros */
ibinfo = (ibsend_req_info *)MPIU_Malloc( sizeof(ibsend_req_info) );
ibinfo->req = request_ptr;
ibinfo->cancelled = 0;
mpi_errno = MPIR_Grequest_start_impl( MPIR_Ibsend_query, MPIR_Ibsend_free,
MPIR_Ibsend_cancel, ibinfo, &new_request_ptr );
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
/* The request is immediately complete because the MPIR_Bsend_isend has
already moved the data out of the user's buffer */
MPIR_Request_add_ref( request_ptr );
/* Request count is now 2 (set to 1 in Grequest_start) */
MPIR_Grequest_complete_impl(new_request_ptr);
MPIU_OBJ_PUBLISH_HANDLE(*request, new_request_ptr->handle);
fn_exit:
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Type_contiguous_impl(int count,
MPI_Datatype old_type,
MPI_Datatype *new_type_p)
{
int mpi_errno = MPI_SUCCESS;
MPID_Datatype *new_dtp;
MPI_Datatype new_handle;
mpi_errno = MPID_Type_contiguous(count,
old_type,
&new_handle);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPID_Datatype_get_ptr(new_handle, new_dtp);
mpi_errno = MPID_Datatype_set_contents(new_dtp,
MPI_COMBINER_CONTIGUOUS,
1, /* ints (count) */
0,
1,
&count,
NULL,
&old_type);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPIU_OBJ_PUBLISH_HANDLE(*new_type_p, new_handle);
fn_exit:
return mpi_errno;
fn_fail:
goto fn_exit;
}
/*@
MPI_File_create_errhandler - Create a file error handler
Input Parameters:
. file_errhandler_fn - user defined error handling procedure (function)
Output Parameters:
. errhandler - MPI error handler (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
@*/
int MPI_File_create_errhandler(MPI_File_errhandler_function *file_errhandler_fn,
MPI_Errhandler *errhandler)
{
static const char FCNAME[] = "MPI_File_create_errhandler";
int mpi_errno = MPI_SUCCESS;
MPID_Errhandler *errhan_ptr;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_FILE_CREATE_ERRHANDLER);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_FILE_CREATE_ERRHANDLER);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_ARGNULL(file_errhandler_fn, "file_errhandler_fn", mpi_errno);
MPIR_ERRTEST_ARGNULL(errhandler, "errhandler", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
errhan_ptr = (MPID_Errhandler *)MPIU_Handle_obj_alloc( &MPID_Errhandler_mem );
MPIU_ERR_CHKANDJUMP(!errhan_ptr,mpi_errno,MPI_ERR_OTHER,"**nomem");
errhan_ptr->language = MPID_LANG_C;
errhan_ptr->kind = MPID_FILE;
MPIU_Object_set_ref(errhan_ptr,1);
errhan_ptr->errfn.C_File_Handler_function = file_errhandler_fn;
MPIU_OBJ_PUBLISH_HANDLE(*errhandler, errhan_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_FILE_CREATE_ERRHANDLER);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_file_create_errhandler",
"**mpi_file_create_errhandler %p %p", file_errhandler_fn, errhandler);
}
# endif
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
int MPIR_Type_indexed_impl(int count, const int *array_of_blocklengths,
const int *array_of_displacements,
MPI_Datatype oldtype, MPI_Datatype *newtype)
{
int mpi_errno = MPI_SUCCESS;
MPI_Datatype new_handle;
MPID_Datatype *new_dtp;
int i, *ints;
MPIU_CHKLMEM_DECL(1);
mpi_errno = MPID_Type_indexed(count,
array_of_blocklengths,
array_of_displacements,
0, /* displacements not in bytes */
oldtype,
&new_handle);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
/* copy all integer values into a temporary buffer; this
* includes the count, the blocklengths, and the displacements.
*/
MPIU_CHKLMEM_MALLOC(ints, int *, (2 * count + 1) * sizeof(int), mpi_errno, "contents integer array");
ints[0] = count;
for (i=0; i < count; i++) {
ints[i+1] = array_of_blocklengths[i];
}
for (i=0; i < count; i++) {
ints[i + count + 1] = array_of_displacements[i];
}
MPID_Datatype_get_ptr(new_handle, new_dtp);
mpi_errno = MPID_Datatype_set_contents(new_dtp,
MPI_COMBINER_INDEXED,
2*count + 1, /* ints */
0, /* aints */
1, /* types */
ints,
NULL,
&oldtype);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIU_OBJ_PUBLISH_HANDLE(*newtype, new_handle);
fn_exit:
MPIU_CHKLMEM_FREEALL();
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Type_create_struct_impl(int count,
int array_of_blocklengths[],
MPI_Aint array_of_displacements[],
MPI_Datatype array_of_types[],
MPI_Datatype *newtype)
{
int mpi_errno = MPI_SUCCESS;
int i, *ints;
MPI_Datatype new_handle;
MPID_Datatype *new_dtp;
MPIU_CHKLMEM_DECL(1);
mpi_errno = MPID_Type_struct(count,
array_of_blocklengths,
array_of_displacements,
array_of_types,
&new_handle);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIU_CHKLMEM_MALLOC_ORJUMP(ints, int *, (count + 1) * sizeof(int), mpi_errno, "content description");
ints[0] = count;
for (i=0; i < count; i++)
ints[i+1] = array_of_blocklengths[i];
MPID_Datatype_get_ptr(new_handle, new_dtp);
mpi_errno = MPID_Datatype_set_contents(new_dtp,
MPI_COMBINER_STRUCT,
count+1, /* ints (cnt,blklen) */
count, /* aints (disps) */
count, /* types */
ints,
array_of_displacements,
array_of_types);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIU_OBJ_PUBLISH_HANDLE(*newtype, new_handle);
fn_exit:
MPIU_CHKLMEM_FREEALL();
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Comm_create_errhandler_impl(MPI_Comm_errhandler_function *comm_errhandler_fn,
MPI_Errhandler *errhandler)
{
int mpi_errno = MPI_SUCCESS;
MPID_Errhandler *errhan_ptr;
errhan_ptr = (MPID_Errhandler *)MPIU_Handle_obj_alloc( &MPID_Errhandler_mem );
MPIU_ERR_CHKANDJUMP(!errhan_ptr, mpi_errno, MPI_ERR_OTHER, "**nomem");
errhan_ptr->language = MPID_LANG_C;
errhan_ptr->kind = MPID_COMM;
MPIU_Object_set_ref(errhan_ptr,1);
errhan_ptr->errfn.C_Comm_Handler_function = comm_errhandler_fn;
MPIU_OBJ_PUBLISH_HANDLE(*errhandler, errhan_ptr->handle);
fn_exit:
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Comm_create_keyval_impl(MPI_Comm_copy_attr_function *comm_copy_attr_fn,
MPI_Comm_delete_attr_function *comm_delete_attr_fn,
int *comm_keyval, void *extra_state)
{
int mpi_errno = MPI_SUCCESS;
MPID_Keyval *keyval_ptr;
keyval_ptr = (MPID_Keyval *)MPIU_Handle_obj_alloc( &MPID_Keyval_mem );
MPIU_ERR_CHKANDJUMP(!keyval_ptr, mpi_errno, MPI_ERR_OTHER,"**nomem");
/* Initialize the attribute dup function */
if (!MPIR_Process.attr_dup) {
MPIR_Process.attr_dup = MPIR_Attr_dup_list;
MPIR_Process.attr_free = MPIR_Attr_delete_list;
}
/* The handle encodes the keyval kind. Modify it to have the correct
field */
keyval_ptr->handle = (keyval_ptr->handle & ~(0x03c00000)) |
(MPID_COMM << 22);
MPIU_Object_set_ref(keyval_ptr,1);
keyval_ptr->was_freed = 0;
keyval_ptr->kind = MPID_COMM;
keyval_ptr->extra_state = extra_state;
keyval_ptr->copyfn.user_function = comm_copy_attr_fn;
keyval_ptr->copyfn.proxy = MPIR_Attr_copy_c_proxy;
keyval_ptr->delfn.user_function = comm_delete_attr_fn;
keyval_ptr->delfn.proxy = MPIR_Attr_delete_c_proxy;
MPIU_OBJ_PUBLISH_HANDLE(*comm_keyval, keyval_ptr->handle);
fn_exit:
return mpi_errno;
fn_fail:
goto fn_exit;
}
/*@
MPI_Group_range_excl - Produces a group by excluding ranges of processes from
an existing group
Input Parameters:
+ group - group (handle)
. n - number of elements in array 'ranks' (integer)
- ranges - a one-dimensional array of integer triplets of the
form (first rank, last rank, stride), indicating the ranks in
'group' of processes to be excluded from the output group 'newgroup' .
Output Parameters:
. newgroup - new group derived from above, preserving the
order in 'group' (handle)
Note:
The MPI standard requires that each of the ranks to be excluded must be
a valid rank in the group and all elements must be distinct or the
function is erroneous.
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_GROUP
.N MPI_ERR_EXHAUSTED
.N MPI_ERR_RANK
.N MPI_ERR_ARG
.seealso: MPI_Group_free
@*/
int MPI_Group_range_excl(MPI_Group group, int n, int ranges[][3],
MPI_Group *newgroup)
{
int mpi_errno = MPI_SUCCESS;
MPID_Group *group_ptr = NULL, *new_group_ptr;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_GROUP_RANGE_EXCL);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_GROUP_RANGE_EXCL);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_GROUP(group, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPID_Group_get_ptr( group, group_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate group_ptr */
MPID_Group_valid_ptr( group_ptr, mpi_errno );
/* If group_ptr is not valid, it will be reset to null */
/* Check the exclusion array. Ensure that all ranges are
valid and that the specified exclusions are unique */
if (group_ptr) {
mpi_errno = MPIR_Group_check_valid_ranges( group_ptr,
ranges, n );
}
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Group_range_excl_impl(group_ptr, n, ranges, &new_group_ptr);
if (mpi_errno) goto fn_fail;
MPIU_OBJ_PUBLISH_HANDLE(*newgroup, new_group_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_GROUP_RANGE_EXCL);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_group_range_excl",
"**mpi_group_range_excl %G %d %p %p", group, n, ranges, newgroup);
}
# endif
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Type_create_resized - Create a datatype with a new lower bound and
extent from an existing datatype
Input Parameters:
+ oldtype - input datatype (handle)
. lb - new lower bound of datatype (address integer)
- extent - new extent of datatype (address integer)
Output Parameter:
. newtype - output datatype (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TYPE
@*/
int MPI_Type_create_resized(MPI_Datatype oldtype,
MPI_Aint lb,
MPI_Aint extent,
MPI_Datatype *newtype)
{
static const char FCNAME[] = "MPI_Type_create_resized";
int mpi_errno = MPI_SUCCESS;
MPI_Datatype new_handle;
MPID_Datatype *new_dtp;
MPI_Aint aints[2];
MPID_MPI_STATE_DECL(MPID_STATE_MPI_TYPE_CREATE_RESIZED);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_TYPE_CREATE_RESIZED);
/* Get handles to MPI objects. */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPID_Datatype *datatype_ptr = NULL;
MPIR_ERRTEST_DATATYPE(oldtype, "datatype", mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* Validate datatype_ptr */
MPID_Datatype_get_ptr(oldtype, datatype_ptr);
MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno);
/* If datatype_ptr is not valid, it will be reset to null */
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPID_Type_create_resized(oldtype, lb, extent, &new_handle);
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
/* --END ERROR HANDLING-- */
aints[0] = lb;
aints[1] = extent;
MPID_Datatype_get_ptr(new_handle, new_dtp);
mpi_errno = MPID_Datatype_set_contents(new_dtp,
MPI_COMBINER_RESIZED,
0,
2, /* Aints */
1,
NULL,
aints,
&oldtype);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPIU_OBJ_PUBLISH_HANDLE(*newtype, new_handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TYPE_CREATE_RESIZED);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_type_create_resized",
"**mpi_type_create_resized %D %L %L %p", oldtype, lb, extent, newtype);
}
# endif
mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Win_allocate_shared - Create an MPI Window object for one-sided
communication and shared memory access, and allocate memory at each process.
This is a collective call executed by all processes in the group of comm. On
each process i, it allocates memory of at least size bytes that is shared among
all processes in comm, and returns a pointer to the locally allocated segment
in baseptr that can be used for load/store accesses on the calling process. The
locally allocated memory can be the target of load/store accesses by remote
processes; the base pointers for other processes can be queried using the
function 'MPI_Win_shared_query'.
The call also returns a window object that can be used by all processes in comm
to perform RMA operations. The size argument may be different at each process
and size = 0 is valid. It is the user''s responsibility to ensure that the
communicator comm represents a group of processes that can create a shared
memory segment that can be accessed by all processes in the group. The
allocated memory is contiguous across process ranks unless the info key
alloc_shared_noncontig is specified. Contiguous across process ranks means that
the first address in the memory segment of process i is consecutive with the
last address in the memory segment of process i − 1. This may enable the user
to calculate remote address offsets with local information only.
Input Parameters:
. size - size of window in bytes (nonnegative integer)
. disp_unit - local unit size for displacements, in bytes (positive integer)
. info - info argument (handle)
- comm - communicator (handle)
Output Parameters:
. baseptr - initial address of window (choice)
- win - window object returned by the call (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_ARG
.N MPI_ERR_COMM
.N MPI_ERR_INFO
.N MPI_ERR_OTHER
.N MPI_ERR_SIZE
.seealso: MPI_Win_allocate MPI_Win_create MPI_Win_create_dynamic MPI_Win_free MPI_Win_shared_query
@*/
int MPI_Win_allocate_shared(MPI_Aint size, int disp_unit, MPI_Info info, MPI_Comm comm,
void *baseptr, MPI_Win *win)
{
int mpi_errno = MPI_SUCCESS;
MPID_Win *win_ptr = NULL;
MPID_Comm *comm_ptr = NULL;
MPID_Info *info_ptr = NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_WIN_ALLOCATE_SHARED);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_RMA_FUNC_ENTER(MPID_STATE_MPI_WIN_ALLOCATE_SHARED);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
MPIR_ERRTEST_INFO_OR_NULL(info, mpi_errno);
MPIR_ERRTEST_ARGNULL(win, "win", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPID_Comm_get_ptr( comm, comm_ptr );
MPID_Info_get_ptr( info, info_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate pointers */
MPID_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPIU_ERR_CHKANDJUMP1(disp_unit <= 0, mpi_errno, MPI_ERR_ARG,
"**arg", "**arg %s", "disp_unit must be positive");
MPIU_ERR_CHKANDJUMP1(size < 0, mpi_errno, MPI_ERR_SIZE,
"**rmasize", "**rmasize %d", size);
MPIU_ERR_CHKANDJUMP1(size > 0 && baseptr == NULL, mpi_errno, MPI_ERR_ARG,
"**nullptr", "**nullptr %s",
"NULL base pointer is invalid when size is nonzero");
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPID_Win_allocate_shared(size, disp_unit, info_ptr, comm_ptr, baseptr, &win_ptr);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* Initialize a few fields that have specific defaults */
win_ptr->name[0] = 0;
win_ptr->errhandler = 0;
/* return the handle of the window object to the user */
MPIU_OBJ_PUBLISH_HANDLE(*win, win_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_RMA_FUNC_EXIT(MPID_STATE_MPI_WIN_ALLOCATE_SHARED);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_win_allocate_shared",
"**mpi_win_allocate_shared %d %I %C %p %p", size, info, comm, baseptr, win);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Type_create_darray - Create a datatype representing a distributed array
Input Parameters:
+ size - size of process group (positive integer)
. rank - rank in process group (nonnegative integer)
. ndims - number of array dimensions as well as process grid dimensions (positive integer)
. array_of_gsizes - number of elements of type oldtype in each dimension of global array (array of positive integers)
. array_of_distribs - distribution of array in each dimension (array of state)
. array_of_dargs - distribution argument in each dimension (array of positive integers)
. array_of_psizes - size of process grid in each dimension (array of positive integers)
. order - array storage order flag (state)
- oldtype - old datatype (handle)
Output Parameters:
. newtype - new datatype (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TYPE
.N MPI_ERR_ARG
@*/
int MPI_Type_create_darray(int size,
int rank,
int ndims,
const int array_of_gsizes[],
const int array_of_distribs[],
const int array_of_dargs[],
const int array_of_psizes[],
int order,
MPI_Datatype oldtype,
MPI_Datatype *newtype)
{
static const char FCNAME[] = "MPI_Type_create_darray";
int mpi_errno = MPI_SUCCESS, i;
MPI_Datatype new_handle;
int procs, tmp_rank, tmp_size, blklens[3], *coords;
MPI_Aint *st_offsets, orig_extent, disps[3];
MPI_Datatype type_old, type_new = MPI_DATATYPE_NULL, types[3];
# ifdef HAVE_ERROR_CHECKING
MPI_Aint size_with_aint;
MPI_Offset size_with_offset;
# endif
int *ints;
MPID_Datatype *datatype_ptr = NULL;
MPIU_CHKLMEM_DECL(3);
MPID_MPI_STATE_DECL(MPID_STATE_MPI_TYPE_CREATE_DARRAY);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_TYPE_CREATE_DARRAY);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_DATATYPE(oldtype, "datatype", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPID_Datatype_get_ptr(oldtype, datatype_ptr);
MPID_Datatype_get_extent_macro(oldtype, orig_extent);
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Check parameters */
MPIR_ERRTEST_ARGNONPOS(size, "size", mpi_errno, MPI_ERR_ARG);
/* use MPI_ERR_RANK class for PE-MPI compatibility */
MPIU_ERR_CHKANDJUMP3((rank < 0 || rank >= size), mpi_errno, MPI_ERR_RANK,
"**argrange", "**argrange %s %d %d", "rank", rank, (size-1));
MPIR_ERRTEST_ARGNONPOS(ndims, "ndims", mpi_errno, MPI_ERR_DIMS);
MPIR_ERRTEST_ARGNULL(array_of_gsizes, "array_of_gsizes", mpi_errno);
MPIR_ERRTEST_ARGNULL(array_of_distribs, "array_of_distribs", mpi_errno);
MPIR_ERRTEST_ARGNULL(array_of_dargs, "array_of_dargs", mpi_errno);
MPIR_ERRTEST_ARGNULL(array_of_psizes, "array_of_psizes", mpi_errno);
if (order != MPI_ORDER_C && order != MPI_ORDER_FORTRAN) {
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
FCNAME,
__LINE__,
MPI_ERR_ARG,
"**arg",
"**arg %s",
"order");
goto fn_fail;
}
tmp_size = 1;
for (i=0; mpi_errno == MPI_SUCCESS && i < ndims; i++) {
MPIR_ERRTEST_ARGNONPOS(array_of_gsizes[i], "gsize", mpi_errno, MPI_ERR_ARG);
MPIR_ERRTEST_ARGNONPOS(array_of_psizes[i], "psize", mpi_errno, MPI_ERR_ARG);
if ((array_of_distribs[i] != MPI_DISTRIBUTE_NONE) &&
(array_of_distribs[i] != MPI_DISTRIBUTE_BLOCK) &&
(array_of_distribs[i] != MPI_DISTRIBUTE_CYCLIC))
{
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
FCNAME,
__LINE__,
MPI_ERR_ARG,
"**darrayunknown",
0);
goto fn_fail;
}
if ((array_of_dargs[i] != MPI_DISTRIBUTE_DFLT_DARG) &&
(array_of_dargs[i] <= 0))
{
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
FCNAME,
__LINE__,
MPI_ERR_ARG,
"**arg",
"**arg %s",
"array_of_dargs");
goto fn_fail;
}
if ((array_of_distribs[i] == MPI_DISTRIBUTE_NONE) &&
(array_of_psizes[i] != 1))
{
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
FCNAME,
__LINE__,
MPI_ERR_ARG,
"**darraydist",
"**darraydist %d %d",
i, array_of_psizes[i]);
goto fn_fail;
}
tmp_size *= array_of_psizes[i];
}
MPIU_ERR_CHKANDJUMP1((tmp_size != size), mpi_errno, MPI_ERR_ARG,
"**arg", "**arg %s", "array_of_psizes");
/* TODO: GET THIS CHECK IN ALSO */
/* check if MPI_Aint is large enough for size of global array.
if not, complain. */
size_with_aint = orig_extent;
for (i=0; i<ndims; i++) size_with_aint *= array_of_gsizes[i];
size_with_offset = orig_extent;
for (i=0; i<ndims; i++) size_with_offset *= array_of_gsizes[i];
if (size_with_aint != size_with_offset) {
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_FATAL,
FCNAME,
__LINE__,
MPI_ERR_ARG,
"**darrayoverflow",
"**darrayoverflow %L",
size_with_offset);
goto fn_fail;
}
/* Validate datatype_ptr */
MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno);
/* If datatype_ptr is not valid, it will be reset to null */
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno) goto fn_fail;
/* --END ERROR HANDLING-- */
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
/* calculate position in Cartesian grid as MPI would (row-major
ordering) */
MPIU_CHKLMEM_MALLOC_ORJUMP(coords, int *, ndims * sizeof(int), mpi_errno, "position is Cartesian grid");
procs = size;
tmp_rank = rank;
for (i=0; i<ndims; i++) {
procs = procs/array_of_psizes[i];
coords[i] = tmp_rank/procs;
tmp_rank = tmp_rank % procs;
}
MPIU_CHKLMEM_MALLOC_ORJUMP(st_offsets, MPI_Aint *, ndims * sizeof(MPI_Aint), mpi_errno, "st_offsets");
type_old = oldtype;
if (order == MPI_ORDER_FORTRAN) {
/* dimension 0 changes fastest */
for (i=0; i<ndims; i++) {
switch(array_of_distribs[i]) {
case MPI_DISTRIBUTE_BLOCK:
mpi_errno = MPIR_Type_block(array_of_gsizes,
i,
ndims,
array_of_psizes[i],
coords[i],
array_of_dargs[i],
order,
orig_extent,
type_old,
&type_new,
st_offsets+i);
break;
case MPI_DISTRIBUTE_CYCLIC:
mpi_errno = MPIR_Type_cyclic(array_of_gsizes,
i,
ndims,
array_of_psizes[i],
coords[i],
array_of_dargs[i],
order,
orig_extent,
type_old,
&type_new,
st_offsets+i);
break;
case MPI_DISTRIBUTE_NONE:
/* treat it as a block distribution on 1 process */
mpi_errno = MPIR_Type_block(array_of_gsizes,
i,
ndims,
1,
0,
MPI_DISTRIBUTE_DFLT_DARG,
order,
orig_extent,
type_old,
&type_new,
st_offsets+i);
break;
}
if (i)
{
MPIR_Type_free_impl(&type_old);
}
type_old = type_new;
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* --END ERROR HANDLING-- */
}
/* add displacement and UB */
disps[1] = st_offsets[0];
tmp_size = 1;
for (i=1; i<ndims; i++) {
tmp_size *= array_of_gsizes[i-1];
disps[1] += (MPI_Aint) tmp_size * st_offsets[i];
}
/* rest done below for both Fortran and C order */
}
else /* order == MPI_ORDER_C */ {
/* dimension ndims-1 changes fastest */
for (i=ndims-1; i>=0; i--) {
switch(array_of_distribs[i]) {
case MPI_DISTRIBUTE_BLOCK:
mpi_errno = MPIR_Type_block(array_of_gsizes,
i,
ndims,
array_of_psizes[i],
coords[i],
array_of_dargs[i],
order,
orig_extent,
type_old,
&type_new,
st_offsets+i);
break;
case MPI_DISTRIBUTE_CYCLIC:
mpi_errno = MPIR_Type_cyclic(array_of_gsizes,
i,
ndims,
array_of_psizes[i],
coords[i],
array_of_dargs[i],
order,
orig_extent,
type_old,
&type_new,
st_offsets+i);
break;
case MPI_DISTRIBUTE_NONE:
/* treat it as a block distribution on 1 process */
mpi_errno = MPIR_Type_block(array_of_gsizes,
i,
ndims,
array_of_psizes[i],
coords[i],
MPI_DISTRIBUTE_DFLT_DARG,
order,
orig_extent,
type_old,
&type_new,
st_offsets+i);
break;
}
if (i != ndims-1)
{
MPIR_Type_free_impl(&type_old);
}
type_old = type_new;
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* --END ERROR HANDLING-- */
}
/* add displacement and UB */
disps[1] = st_offsets[ndims-1];
tmp_size = 1;
for (i=ndims-2; i>=0; i--) {
tmp_size *= array_of_gsizes[i+1];
disps[1] += (MPI_Aint) tmp_size * st_offsets[i];
}
}
disps[1] *= orig_extent;
disps[2] = orig_extent;
for (i=0; i<ndims; i++) disps[2] *= (MPI_Aint)(array_of_gsizes[i]);
disps[0] = 0;
blklens[0] = blklens[1] = blklens[2] = 1;
types[0] = MPI_LB;
types[1] = type_new;
types[2] = MPI_UB;
mpi_errno = MPID_Type_struct(3,
blklens,
disps,
types,
&new_handle);
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* --END ERROR HANDLING-- */
MPIR_Type_free_impl(&type_new);
/* at this point we have the new type, and we've cleaned up any
* intermediate types created in the process. we just need to save
* all our contents/envelope information.
*/
/* Save contents */
MPIU_CHKLMEM_MALLOC_ORJUMP(ints, int *, (4 * ndims + 4) * sizeof(int), mpi_errno, "content description");
ints[0] = size;
ints[1] = rank;
ints[2] = ndims;
for (i=0; i < ndims; i++) {
ints[i + 3] = array_of_gsizes[i];
}
for (i=0; i < ndims; i++) {
ints[i + ndims + 3] = array_of_distribs[i];
}
for (i=0; i < ndims; i++) {
ints[i + 2*ndims + 3] = array_of_dargs[i];
}
for (i=0; i < ndims; i++) {
ints[i + 3*ndims + 3] = array_of_psizes[i];
}
ints[4*ndims + 3] = order;
MPID_Datatype_get_ptr(new_handle, datatype_ptr);
mpi_errno = MPID_Datatype_set_contents(datatype_ptr,
MPI_COMBINER_DARRAY,
4*ndims + 4,
0,
1,
ints,
NULL,
&oldtype);
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* --END ERROR HANDLING-- */
MPIU_OBJ_PUBLISH_HANDLE(*newtype, new_handle);
/* ... end of body of routine ... */
fn_exit:
MPIU_CHKLMEM_FREEALL();
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TYPE_CREATE_DARRAY);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_type_create_darray",
"**mpi_type_create_darray %d %d %d %p %p %p %p %d %D %p", size, rank, ndims, array_of_gsizes,
array_of_distribs, array_of_dargs, array_of_psizes, order, oldtype, newtype);
}
# endif
mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Comm_dup - Duplicates an existing communicator with all its cached
information
Input Parameters:
. comm - Communicator to be duplicated (handle)
Output Parameters:
. newcomm - A new communicator over the same group as 'comm' but with a new
context. See notes. (handle)
Notes:
This routine is used to create a new communicator that has a new
communication context but contains the same group of processes as
the input communicator. Since all MPI communication is performed
within a communicator (specifies as the group of processes `plus`
the context), this routine provides an effective way to create a
private communicator for use by a software module or library. In
particular, no library routine should use 'MPI_COMM_WORLD' as the
communicator; instead, a duplicate of a user-specified communicator
should always be used. For more information, see Using MPI, 2nd
edition.
Because this routine essentially produces a copy of a communicator,
it also copies any attributes that have been defined on the input
communicator, using the attribute copy function specified by the
'copy_function' argument to 'MPI_Keyval_create'. This is
particularly useful for (a) attributes that describe some property
of the group associated with the communicator, such as its
interconnection topology and (b) communicators that are given back
to the user; the attibutes in this case can track subsequent
'MPI_Comm_dup' operations on this communicator.
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.seealso: MPI_Comm_free, MPI_Keyval_create, MPI_Attr_put, MPI_Attr_delete,
MPI_Comm_create_keyval, MPI_Comm_set_attr, MPI_Comm_delete_attr
@*/
int MPI_Comm_dup(MPI_Comm comm, MPI_Comm *newcomm)
{
int mpi_errno = MPI_SUCCESS;
MPID_Comm *comm_ptr = NULL, *newcomm_ptr;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_COMM_DUP);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_COMM_DUP);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPID_Comm_get_ptr( comm, comm_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr */
MPID_Comm_valid_ptr( comm_ptr, mpi_errno );
if (mpi_errno) goto fn_fail;
/* If comm_ptr is not valid, it will be reset to null */
MPIR_ERRTEST_ARGNULL(newcomm, "newcomm", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Comm_dup_impl(comm_ptr, &newcomm_ptr);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIU_OBJ_PUBLISH_HANDLE(*newcomm, newcomm_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_COMM_DUP);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_dup",
"**mpi_comm_dup %C %p", comm, newcomm);
}
# endif
*newcomm = MPI_COMM_NULL;
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPIX_Comm_shrink - Creates a new communitor from an existing communicator while
excluding failed processes
Input Parameters:
+ comm - communicator (handle)
Output Parameters:
. newcomm - new communicator (handle)
.N Threadsafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
@*/
int MPIX_Comm_shrink(MPI_Comm comm, MPI_Comm *newcomm)
{
int mpi_errno = MPI_SUCCESS;
MPID_Comm *comm_ptr = NULL, *newcomm_ptr;
MPID_MPI_STATE_DECL(MPID_STATE_MPIX_COMM_SHRINK);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPIX_COMM_SHRINK);
/* 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;
MPID_Comm_get_ptr( comm, comm_ptr );
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr */
MPID_Comm_valid_ptr( comm_ptr, mpi_errno, TRUE );
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
#else
{
MPID_Comm_get_ptr( comm, comm_ptr );
}
#endif
/* ... body of routine ... */
mpi_errno = MPIR_Comm_shrink(comm_ptr, &newcomm_ptr);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
if (newcomm_ptr)
MPIU_OBJ_PUBLISH_HANDLE(*newcomm, newcomm_ptr->handle);
else
*newcomm = MPI_COMM_NULL;
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPIX_COMM_SHRINK);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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, "**mpix_comm_shrink",
"**mpix_comm_shrink %C %p", comm, newcomm);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Comm_spawn - Spawn up to maxprocs instances of a single MPI application
Input Parameters:
+ command - name of program to be spawned (string, significant only at root)
. argv - arguments to command (array of strings, significant only at root)
. maxprocs - maximum number of processes to start (integer, significant only
at root)
. info - a set of key-value pairs telling the runtime system where and how
to start the processes (handle, significant only at root)
. root - rank of process in which previous arguments are examined (integer)
- comm - intracommunicator containing group of spawning processes (handle)
Output Parameters:
+ intercomm - intercommunicator between original group and the
newly spawned group (handle)
- array_of_errcodes - one code per process (array of integer)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_ARG
.N MPI_ERR_INFO
.N MPI_ERR_SPAWN
@*/
int MPI_Comm_spawn(const char *command, char *argv[], int maxprocs, MPI_Info info,
int root, MPI_Comm comm, MPI_Comm *intercomm,
int array_of_errcodes[])
{
static const char FCNAME[] = "MPI_Comm_spawn";
int mpi_errno = MPI_SUCCESS;
MPID_Comm *comm_ptr = NULL, *intercomm_ptr;
MPID_Info *info_ptr=NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_COMM_SPAWN);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_COMM_SPAWN);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPID_Comm_get_ptr( comm, comm_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr */
MPID_Comm_valid_ptr( comm_ptr, mpi_errno );
/* If comm_ptr is not valid, it will be reset to null */
if (mpi_errno) goto fn_fail;
MPIR_ERRTEST_COMM_INTRA(comm_ptr, mpi_errno);
MPIR_ERRTEST_RANK(comm_ptr, root, mpi_errno);
if (comm_ptr->rank == root) {
MPIR_ERRTEST_INFO_OR_NULL(info, mpi_errno);
MPIR_ERRTEST_ARGNULL(command, "command", mpi_errno);
MPIR_ERRTEST_ARGNEG(maxprocs, "maxprocs", mpi_errno);
}
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
if (comm_ptr->rank == root) {
MPID_Info_get_ptr( info, info_ptr );
}
/* ... body of routine ... */
/* check if multiple threads are calling this collective function */
MPIDU_ERR_CHECK_MULTIPLE_THREADS_ENTER( comm_ptr );
mpi_errno = MPID_Comm_spawn_multiple(1, (char **) &command, &argv,
&maxprocs, &info_ptr, root,
comm_ptr, &intercomm_ptr,
array_of_errcodes);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPIU_OBJ_PUBLISH_HANDLE(*intercomm, intercomm_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_COMM_SPAWN);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_spawn",
"**mpi_comm_spawn %s %p %d %I %d %C %p %p", command, argv, maxprocs, info, root, comm, intercomm, array_of_errcodes);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Dist_graph_create - MPI_DIST_GRAPH_CREATE returns a handle to a new
communicator to which the distributed graph topology information is
attached.
Input Parameters:
+ comm_old - input communicator (handle)
. n - number of source nodes for which this process specifies edges
(non-negative integer)
. sources - array containing the n source nodes for which this process
specifies edges (array of non-negative integers)
. degrees - array specifying the number of destinations for each source node
in the source node array (array of non-negative integers)
. destinations - destination nodes for the source nodes in the source node
array (array of non-negative integers)
. weights - weights for source to destination edges (array of non-negative
integers or MPI_UNWEIGHTED)
. info - hints on optimization and interpretation of weights (handle)
- reorder - the process may be reordered (true) or not (false) (logical)
Output Parameters:
. comm_dist_graph - communicator with distributed graph topology added (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_ARG
.N MPI_ERR_OTHER
@*/
int MPI_Dist_graph_create(MPI_Comm comm_old, int n, const int sources[],
const int degrees[], const int destinations[],
const int weights[],
MPI_Info info, int reorder, MPI_Comm *comm_dist_graph)
{
int mpi_errno = MPI_SUCCESS;
MPID_Comm *comm_ptr = NULL;
MPID_Comm *comm_dist_graph_ptr = NULL;
MPI_Request *reqs = NULL;
MPIR_Topology *topo_ptr = NULL;
MPIR_Dist_graph_topology *dist_graph_ptr = NULL;
int i;
int j;
int idx;
int comm_size = 0;
int in_capacity;
int out_capacity;
int **rout = NULL;
int **rin = NULL;
int *rin_sizes;
int *rout_sizes;
int *rin_idx;
int *rout_idx;
int *rs;
int in_out_peers[2] = {-1, -1};
int errflag = FALSE;
MPIU_CHKLMEM_DECL(9);
MPIU_CHKPMEM_DECL(1);
MPID_MPI_STATE_DECL(MPID_STATE_MPI_DIST_GRAPH_CREATE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_DIST_GRAPH_CREATE);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm_old, mpi_errno);
MPIR_ERRTEST_INFO_OR_NULL(info, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPID_Comm_get_ptr(comm_old, comm_ptr);
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr */
MPID_Comm_valid_ptr(comm_ptr, mpi_errno);
/* If comm_ptr is not valid, it will be reset to null */
if (comm_ptr) {
MPIR_ERRTEST_COMM_INTRA(comm_ptr, mpi_errno);
}
MPIR_ERRTEST_ARGNEG(n, "n", mpi_errno);
if (n > 0) {
int have_degrees = 0;
MPIR_ERRTEST_ARGNULL(sources, "sources", mpi_errno);
MPIR_ERRTEST_ARGNULL(degrees, "degrees", mpi_errno);
for (i = 0; i < n; ++i) {
if (degrees[i]) {
have_degrees = 1;
break;
}
}
if (have_degrees) {
MPIR_ERRTEST_ARGNULL(destinations, "destinations", mpi_errno);
if (weights != MPI_UNWEIGHTED)
MPIR_ERRTEST_ARGNULL(weights, "weights", mpi_errno);
}
}
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
/* Implementation based on Torsten Hoefler's reference implementation
* attached to MPI-2.2 ticket #33. */
*comm_dist_graph = MPI_COMM_NULL;
comm_size = comm_ptr->local_size;
/* following the spirit of the old topo interface, attributes do not
* propagate to the new communicator (see MPI-2.1 pp. 243 line 11) */
mpi_errno = MPIR_Comm_copy(comm_ptr, comm_size, &comm_dist_graph_ptr);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIU_Assert(comm_dist_graph_ptr != NULL);
/* rin is an array of size comm_size containing pointers to arrays of
* rin_sizes[x]. rin[x] is locally known number of edges into this process
* from rank x.
*
* rout is an array of comm_size containing pointers to arrays of
* rout_sizes[x]. rout[x] is the locally known number of edges out of this
* process to rank x. */
MPIU_CHKLMEM_MALLOC(rout, int **, comm_size*sizeof(int*), mpi_errno, "rout");
MPIU_CHKLMEM_MALLOC(rin, int **, comm_size*sizeof(int*), mpi_errno, "rin");
MPIU_CHKLMEM_MALLOC(rin_sizes, int *, comm_size*sizeof(int), mpi_errno, "rin_sizes");
MPIU_CHKLMEM_MALLOC(rout_sizes, int *, comm_size*sizeof(int), mpi_errno, "rout_sizes");
MPIU_CHKLMEM_MALLOC(rin_idx, int *, comm_size*sizeof(int), mpi_errno, "rin_idx");
MPIU_CHKLMEM_MALLOC(rout_idx, int *, comm_size*sizeof(int), mpi_errno, "rout_idx");
memset(rout, 0, comm_size*sizeof(int*));
memset(rin, 0, comm_size*sizeof(int*));
memset(rin_sizes, 0, comm_size*sizeof(int));
memset(rout_sizes, 0, comm_size*sizeof(int));
memset(rin_idx, 0, comm_size*sizeof(int));
memset(rout_idx, 0, comm_size*sizeof(int));
/* compute array sizes */
idx = 0;
for (i = 0; i < n; ++i) {
MPIU_Assert(sources[i] < comm_size);
for (j = 0; j < degrees[i]; ++j) {
MPIU_Assert(destinations[idx] < comm_size);
/* rout_sizes[i] is twice as long as the number of edges to be
* sent to rank i by this process */
rout_sizes[sources[i]] += 2;
rin_sizes[destinations[idx]] += 2;
++idx;
}
}
/* allocate arrays */
for (i = 0; i < comm_size; ++i) {
/* can't use CHKLMEM macros b/c we are in a loop */
if (rin_sizes[i]) {
rin[i] = MPIU_Malloc(rin_sizes[i] * sizeof(int));
}
if (rout_sizes[i]) {
rout[i] = MPIU_Malloc(rout_sizes[i] * sizeof(int));
}
}
/* populate arrays */
idx = 0;
for (i = 0; i < n; ++i) {
/* TODO add this assert as proper error checking above */
int s_rank = sources[i];
MPIU_Assert(s_rank < comm_size);
MPIU_Assert(s_rank >= 0);
for (j = 0; j < degrees[i]; ++j) {
int d_rank = destinations[idx];
int weight = (weights == MPI_UNWEIGHTED ? 0 : weights[idx]);
/* TODO add this assert as proper error checking above */
MPIU_Assert(d_rank < comm_size);
MPIU_Assert(d_rank >= 0);
/* XXX DJG what about self-edges? do we need to drop one of these
* cases when there is a self-edge to avoid double-counting? */
/* rout[s][2*x] is the value of d for the j'th edge between (s,d)
* with weight rout[s][2*x+1], where x is the current end of the
* outgoing edge list for s. x==(rout_idx[s]/2) */
rout[s_rank][rout_idx[s_rank]++] = d_rank;
rout[s_rank][rout_idx[s_rank]++] = weight;
/* rin[d][2*x] is the value of s for the j'th edge between (s,d)
* with weight rout[d][2*x+1], where x is the current end of the
* incoming edge list for d. x==(rin_idx[d]/2) */
rin[d_rank][rin_idx[d_rank]++] = s_rank;
rin[d_rank][rin_idx[d_rank]++] = weight;
++idx;
}
}
for (i = 0; i < comm_size; ++i) {
/* sanity check that all arrays are fully populated*/
MPIU_Assert(rin_idx[i] == rin_sizes[i]);
MPIU_Assert(rout_idx[i] == rout_sizes[i]);
}
MPIU_CHKLMEM_MALLOC(rs, int *, 2*comm_size*sizeof(int), mpi_errno, "red-scat source buffer");
for (i = 0; i < comm_size; ++i) {
rs[2*i] = (rin_sizes[i] ? 1 : 0);
rs[2*i+1] = (rout_sizes[i] ? 1 : 0);
}
/* compute the number of peers I will recv from */
mpi_errno = MPIR_Reduce_scatter_block_impl(rs, in_out_peers, 2, MPI_INT, MPI_SUM, comm_ptr, &errflag);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIU_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
MPIU_Assert(in_out_peers[0] <= comm_size && in_out_peers[0] >= 0);
MPIU_Assert(in_out_peers[1] <= comm_size && in_out_peers[1] >= 0);
idx = 0;
/* must be 2*comm_size requests because we will possibly send inbound and
* outbound edges to everyone in our communicator */
MPIU_CHKLMEM_MALLOC(reqs, MPI_Request *, 2*comm_size*sizeof(MPI_Request), mpi_errno, "temp request array");
for (i = 0; i < comm_size; ++i) {
if (rin_sizes[i]) {
/* send edges where i is a destination to process i */
mpi_errno = MPIC_Isend(&rin[i][0], rin_sizes[i], MPI_INT, i, MPIR_TOPO_A_TAG, comm_old, &reqs[idx++]);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
}
if (rout_sizes[i]) {
/* send edges where i is a source to process i */
mpi_errno = MPIC_Isend(&rout[i][0], rout_sizes[i], MPI_INT, i, MPIR_TOPO_B_TAG, comm_old, &reqs[idx++]);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
}
}
MPIU_Assert(idx <= (2 * comm_size));
/* Create the topology structure */
MPIU_CHKPMEM_MALLOC(topo_ptr, MPIR_Topology *, sizeof(MPIR_Topology), mpi_errno, "topo_ptr");
topo_ptr->kind = MPI_DIST_GRAPH;
dist_graph_ptr = &topo_ptr->topo.dist_graph;
dist_graph_ptr->indegree = 0;
dist_graph_ptr->in = NULL;
dist_graph_ptr->in_weights = NULL;
dist_graph_ptr->outdegree = 0;
dist_graph_ptr->out = NULL;
dist_graph_ptr->out_weights = NULL;
dist_graph_ptr->is_weighted = (weights != MPI_UNWEIGHTED);
/* can't use CHKPMEM macros for this b/c we need to realloc */
in_capacity = 10; /* arbitrary */
dist_graph_ptr->in = MPIU_Malloc(in_capacity*sizeof(int));
if (dist_graph_ptr->is_weighted)
dist_graph_ptr->in_weights = MPIU_Malloc(in_capacity*sizeof(int));
out_capacity = 10; /* arbitrary */
dist_graph_ptr->out = MPIU_Malloc(out_capacity*sizeof(int));
if (dist_graph_ptr->is_weighted)
dist_graph_ptr->out_weights = MPIU_Malloc(out_capacity*sizeof(int));
for (i = 0; i < in_out_peers[0]; ++i) {
MPI_Status status;
int count;
int *buf;
/* receive inbound edges */
mpi_errno = MPIC_Probe(MPI_ANY_SOURCE, MPIR_TOPO_A_TAG, comm_old, &status);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIR_Get_count_impl(&status, MPI_INT, &count);
/* can't use CHKLMEM macros b/c we are in a loop */
buf = MPIU_Malloc(count*sizeof(int));
MPIU_ERR_CHKANDJUMP(!buf, mpi_errno, MPIR_ERR_RECOVERABLE, "**nomem");
mpi_errno = MPIC_Recv(buf, count, MPI_INT, MPI_ANY_SOURCE, MPIR_TOPO_A_TAG, comm_old, MPI_STATUS_IGNORE);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
for (j = 0; j < count/2; ++j) {
int deg = dist_graph_ptr->indegree++;
if (deg >= in_capacity) {
in_capacity *= 2;
MPIU_REALLOC_ORJUMP(dist_graph_ptr->in, in_capacity*sizeof(int), mpi_errno);
if (dist_graph_ptr->is_weighted)
MPIU_REALLOC_ORJUMP(dist_graph_ptr->in_weights, in_capacity*sizeof(int), mpi_errno);
}
dist_graph_ptr->in[deg] = buf[2*j];
if (dist_graph_ptr->is_weighted)
dist_graph_ptr->in_weights[deg] = buf[2*j+1];
}
MPIU_Free(buf);
}
for (i = 0; i < in_out_peers[1]; ++i) {
MPI_Status status;
int count;
int *buf;
/* receive outbound edges */
mpi_errno = MPIC_Probe(MPI_ANY_SOURCE, MPIR_TOPO_B_TAG, comm_old, &status);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIR_Get_count_impl(&status, MPI_INT, &count);
/* can't use CHKLMEM macros b/c we are in a loop */
buf = MPIU_Malloc(count*sizeof(int));
MPIU_ERR_CHKANDJUMP(!buf, mpi_errno, MPIR_ERR_RECOVERABLE, "**nomem");
mpi_errno = MPIC_Recv(buf, count, MPI_INT, MPI_ANY_SOURCE, MPIR_TOPO_B_TAG, comm_old, MPI_STATUS_IGNORE);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
for (j = 0; j < count/2; ++j) {
int deg = dist_graph_ptr->outdegree++;
if (deg >= out_capacity) {
out_capacity *= 2;
MPIU_REALLOC_ORJUMP(dist_graph_ptr->out, out_capacity*sizeof(int), mpi_errno);
if (dist_graph_ptr->is_weighted)
MPIU_REALLOC_ORJUMP(dist_graph_ptr->out_weights, out_capacity*sizeof(int), mpi_errno);
}
dist_graph_ptr->out[deg] = buf[2*j];
if (dist_graph_ptr->is_weighted)
dist_graph_ptr->out_weights[deg] = buf[2*j+1];
}
MPIU_Free(buf);
}
mpi_errno = MPIR_Waitall_impl(idx, reqs, MPI_STATUSES_IGNORE);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
/* remove any excess memory allocation */
MPIU_REALLOC_ORJUMP(dist_graph_ptr->in, dist_graph_ptr->indegree*sizeof(int), mpi_errno);
MPIU_REALLOC_ORJUMP(dist_graph_ptr->out, dist_graph_ptr->outdegree*sizeof(int), mpi_errno);
if (dist_graph_ptr->is_weighted) {
MPIU_REALLOC_ORJUMP(dist_graph_ptr->in_weights, dist_graph_ptr->indegree*sizeof(int), mpi_errno);
MPIU_REALLOC_ORJUMP(dist_graph_ptr->out_weights, dist_graph_ptr->outdegree*sizeof(int), mpi_errno);
}
mpi_errno = MPIR_Topology_put(comm_dist_graph_ptr, topo_ptr);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIU_CHKPMEM_COMMIT();
MPIU_OBJ_PUBLISH_HANDLE(*comm_dist_graph, comm_dist_graph_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
for (i = 0; i < comm_size; ++i) {
if (rin[i])
MPIU_Free(rin[i]);
if (rout[i])
MPIU_Free(rout[i]);
}
MPIU_CHKLMEM_FREEALL();
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_DIST_GRAPH_CREATE);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
fn_fail:
if (dist_graph_ptr && dist_graph_ptr->in)
MPIU_Free(dist_graph_ptr->in);
if (dist_graph_ptr && dist_graph_ptr->in_weights)
MPIU_Free(dist_graph_ptr->in_weights);
if (dist_graph_ptr && dist_graph_ptr->out)
MPIU_Free(dist_graph_ptr->out);
if (dist_graph_ptr && dist_graph_ptr->out_weights)
MPIU_Free(dist_graph_ptr->out_weights);
MPIU_CHKPMEM_REAP();
#ifdef HAVE_ERROR_CHECKING
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_dist_graph_create", "**mpi_dist_graph_create %C %d %p %p %p %p %I %d %p",
comm_old, n, sources, degrees, destinations, weights, info, reorder, comm_dist_graph);
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Group_intersection - Produces a group as the intersection of two existing
groups
Input Parameters:
+ group1 - first group (handle)
- group2 - second group (handle)
Output Parameters:
. newgroup - intersection group (handle)
Notes:
The output group contains those processes that are in both 'group1' and
'group2'.
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_GROUP
.N MPI_ERR_EXHAUSTED
.seealso: MPI_Group_free
@*/
int MPI_Group_intersection(MPI_Group group1, MPI_Group group2, MPI_Group *newgroup)
{
int mpi_errno = MPI_SUCCESS;
MPID_Group *group_ptr1 = NULL;
MPID_Group *group_ptr2 = NULL;
MPID_Group *new_group_ptr;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_GROUP_INTERSECTION);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_GROUP_INTERSECTION);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_GROUP(group1, mpi_errno);
MPIR_ERRTEST_GROUP(group2, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPID_Group_get_ptr( group1, group_ptr1 );
MPID_Group_get_ptr( group2, group_ptr2 );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate group_ptr */
MPID_Group_valid_ptr( group_ptr1, mpi_errno );
MPID_Group_valid_ptr( group_ptr2, mpi_errno );
/* If either group_ptr is not valid, it will be reset to null */
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Group_intersection_impl(group_ptr1, group_ptr2, &new_group_ptr);
if (mpi_errno) goto fn_fail;
MPIU_OBJ_PUBLISH_HANDLE(*newgroup, new_group_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_GROUP_INTERSECTION);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_group_intersection",
"**mpi_group_intersection %G %G %p", group1, group2, newgroup);
}
# endif
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Type_create_keyval - Create an attribute keyval for MPI datatypes
Input Parameters:
+ type_copy_attr_fn - copy callback function for type_keyval (function)
. type_delete_attr_fn - delete callback function for type_keyval (function)
- extra_state - extra state for callback functions
Output Parameters:
. type_keyval - key value for future access (integer)
Notes:
Default copy and delete functions are available. These are
+ MPI_TYPE_NULL_COPY_FN - empty copy function
. MPI_TYPE_NULL_DELETE_FN - empty delete function
- MPI_TYPE_DUP_FN - simple dup function
.N AttrErrReturn
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_OTHER
@*/
int MPI_Type_create_keyval(MPI_Type_copy_attr_function *type_copy_attr_fn,
MPI_Type_delete_attr_function *type_delete_attr_fn,
int *type_keyval, void *extra_state)
{
static const char FCNAME[] = "MPI_Type_create_keyval";
int mpi_errno = MPI_SUCCESS;
MPID_Keyval *keyval_ptr;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_TYPE_CREATE_KEYVAL);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_TYPE_CREATE_KEYVAL);
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_ARGNULL(type_keyval,"type_keyval",mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
keyval_ptr = (MPID_Keyval *)MPIU_Handle_obj_alloc( &MPID_Keyval_mem );
MPIU_ERR_CHKANDJUMP(!keyval_ptr,mpi_errno,MPI_ERR_OTHER,"**nomem");
/* Initialize the attribute dup function */
if (!MPIR_Process.attr_dup) {
MPIR_Process.attr_dup = MPIR_Attr_dup_list;
MPIR_Process.attr_free = MPIR_Attr_delete_list;
}
/* The handle encodes the keyval kind. Modify it to have the correct
field */
keyval_ptr->handle = (keyval_ptr->handle & ~(0x03c00000)) |
(MPID_DATATYPE << 22);
MPIU_Object_set_ref(keyval_ptr,1);
keyval_ptr->was_freed = 0;
keyval_ptr->kind = MPID_DATATYPE;
keyval_ptr->extra_state = extra_state;
keyval_ptr->copyfn.user_function = type_copy_attr_fn;
keyval_ptr->copyfn.proxy = MPIR_Attr_copy_c_proxy;
keyval_ptr->delfn.user_function = type_delete_attr_fn;
keyval_ptr->delfn.proxy = MPIR_Attr_delete_c_proxy;
/* Tell finalize to check for attributes on permenant types */
MPIR_DatatypeAttrFinalize();
MPIU_OBJ_PUBLISH_HANDLE(*type_keyval, keyval_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TYPE_CREATE_KEYVAL);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_type_create_keyval",
"**mpi_type_create_keyval %p %p %p %p", type_copy_attr_fn, type_delete_attr_fn, type_keyval, extra_state);
}
# endif
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Group_excl - Produces a group by reordering an existing group and taking
only unlisted members
Input Parameters:
+ group - group (handle)
. n - number of elements in array 'ranks' (integer)
- ranks - array of integer ranks in 'group' not to appear in 'newgroup'
Output Parameter:
. newgroup - new group derived from above, preserving the order defined by
'group' (handle)
Note:
The MPI standard requires that each of the ranks to excluded must be
a valid rank in the group and all elements must be distinct or the
function is erroneous.
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_GROUP
.N MPI_ERR_EXHAUSTED
.N MPI_ERR_ARG
.N MPI_ERR_RANK
.seealso: MPI_Group_free
@*/
int MPI_Group_excl(MPI_Group group, int n, int *ranks, MPI_Group *newgroup)
{
static const char FCNAME[] = "MPI_Group_excl";
int mpi_errno = MPI_SUCCESS;
MPID_Group *group_ptr = NULL, *new_group_ptr;
int size, i, newi;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_GROUP_EXCL);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_GROUP_EXCL);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_GROUP(group, mpi_errno);
MPIR_ERRTEST_ARGNEG(n,"n",mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPID_Group_get_ptr( group, group_ptr );
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate group_ptr */
MPID_Group_valid_ptr( group_ptr, mpi_errno );
/* If group_ptr is not valid, it will be reset to null */
if (group_ptr) {
mpi_errno = MPIR_Group_check_valid_ranks( group_ptr,
ranks, n );
}
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
/* Allocate a new group and lrank_to_lpid array */
size = group_ptr->size;
if (size == n) {
*newgroup = MPI_GROUP_EMPTY;
goto fn_exit;
}
mpi_errno = MPIR_Group_create( size - n, &new_group_ptr );
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno)
{
goto fn_fail;
}
/* --END ERROR HANDLING-- */
new_group_ptr->rank = MPI_UNDEFINED;
/* Use flag fields to mark the members to *exclude* . */
for (i=0; i<size; i++) {
group_ptr->lrank_to_lpid[i].flag = 0;
}
for (i=0; i<n; i++) {
group_ptr->lrank_to_lpid[ranks[i]].flag = 1;
}
newi = 0;
for (i=0; i<size; i++) {
if (group_ptr->lrank_to_lpid[i].flag == 0) {
new_group_ptr->lrank_to_lpid[newi].lrank = newi;
new_group_ptr->lrank_to_lpid[newi].lpid =
group_ptr->lrank_to_lpid[i].lpid;
if (group_ptr->rank == i) new_group_ptr->rank = newi;
newi++;
}
}
new_group_ptr->size = size - n;
new_group_ptr->idx_of_first_lpid = -1;
/* TODO calculate is_local_dense_monotonic */
MPIU_OBJ_PUBLISH_HANDLE(*newgroup, new_group_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_GROUP_EXCL);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_group_excl",
"**mpi_group_excl %G %d %p %p", group, n, ranks, newgroup);
}
# endif
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/* comm create impl for intracommunicators, assumes that the standard error
* checking has already taken place in the calling function */
PMPI_LOCAL int MPIR_Comm_create_intra(MPID_Comm *comm_ptr, MPID_Group *group_ptr, MPI_Comm *newcomm)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Context_id_t new_context_id = 0;
MPID_Comm *newcomm_ptr = NULL;
int *mapping = NULL;
int n;
MPID_MPI_STATE_DECL(MPID_STATE_MPIR_COMM_CREATE_INTRA);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPIR_COMM_CREATE_INTRA);
MPIU_Assert(comm_ptr->comm_kind == MPID_INTRACOMM);
n = group_ptr->size;
*newcomm = MPI_COMM_NULL;
/* Create a new communicator from the specified group members */
/* 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 assumes that the
calling routine already holds the single criticial section */
/* TODO should be converted to use MPIR_Get_contextid_sparse instead */
mpi_errno = MPIR_Get_contextid( comm_ptr, &new_context_id );
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIU_Assert(new_context_id != 0);
if (group_ptr->rank != MPI_UNDEFINED) {
MPID_VCR *mapping_vcr = NULL;
mpi_errno = MPIR_Comm_create_calculate_mapping(group_ptr, comm_ptr,
&mapping_vcr, &mapping);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
/* Get the new communicator structure and context id */
mpi_errno = MPIR_Comm_create( &newcomm_ptr );
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
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->remote_group = group_ptr;
MPIR_Group_add_ref( group_ptr );
newcomm_ptr->context_id = newcomm_ptr->recvcontext_id;
newcomm_ptr->remote_size = newcomm_ptr->local_size = n;
/* Setup the communicator's vc table. This is for the remote group,
which is the same as the local group for intracommunicators */
mpi_errno = MPIR_Comm_create_create_and_map_vcrt(n,
mapping,
mapping_vcr,
&newcomm_ptr->vcrt,
&newcomm_ptr->vcr);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
/* Notify the device of this new communicator */
MPID_Dev_comm_create_hook( newcomm_ptr );
mpi_errno = MPIR_Comm_commit(newcomm_ptr);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIU_OBJ_PUBLISH_HANDLE(*newcomm, newcomm_ptr->handle);
}
else {
/* This process is not in the group */
MPIR_Free_contextid( new_context_id );
new_context_id = 0;
}
fn_exit:
if (mapping)
MPIU_Free(mapping);
MPID_MPI_FUNC_EXIT(MPID_STATE_MPIR_COMM_CREATE_INTRA);
return mpi_errno;
fn_fail:
if (newcomm_ptr != NULL) {
MPIR_Comm_release(newcomm_ptr, 0/*isDisconnect*/);
new_context_id = 0; /* MPIR_Comm_release frees the new ctx id */
}
if (new_context_id != 0)
MPIR_Free_contextid(new_context_id);
*newcomm = MPI_COMM_NULL;
goto fn_exit;
}
int MPIR_Graph_create( MPID_Comm *comm_ptr, int nnodes,
const int indx[], const int edges[], int reorder,
MPI_Comm *comm_graph)
{
int mpi_errno = MPI_SUCCESS;
int i, nedges;
MPID_Comm *newcomm_ptr = NULL;
MPIR_Topology *graph_ptr = NULL;
MPIU_CHKPMEM_DECL(3);
/* Set this to null in case there is an error */
*comm_graph = MPI_COMM_NULL;
/* Create a new communicator */
if (reorder) {
int nrank;
/* Allow the cart map routine to remap the assignment of ranks to
processes */
mpi_errno = MPIR_Graph_map_impl(comm_ptr, nnodes, indx, edges, &nrank);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
/* Create the new communicator with split, since we need to reorder
the ranks (including the related internals, such as the connection
tables */
mpi_errno = MPIR_Comm_split_impl( comm_ptr,
nrank == MPI_UNDEFINED ? MPI_UNDEFINED : 1,
nrank, &newcomm_ptr );
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
} else {
/* Just use the first nnodes processes in the communicator */
mpi_errno = MPIR_Comm_copy( (MPID_Comm *)comm_ptr, nnodes,
&newcomm_ptr );
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
}
/* If this process is not in the resulting communicator, return a
null communicator and exit */
if (!newcomm_ptr) {
*comm_graph = MPI_COMM_NULL;
goto fn_exit;
}
nedges = indx[nnodes-1];
MPIU_CHKPMEM_MALLOC(graph_ptr,MPIR_Topology*,sizeof(MPIR_Topology),
mpi_errno,"graph_ptr");
graph_ptr->kind = MPI_GRAPH;
graph_ptr->topo.graph.nnodes = nnodes;
graph_ptr->topo.graph.nedges = nedges;
MPIU_CHKPMEM_MALLOC(graph_ptr->topo.graph.index,int*,
nnodes*sizeof(int),mpi_errno,"graph.index");
MPIU_CHKPMEM_MALLOC(graph_ptr->topo.graph.edges,int*,
nedges*sizeof(int),mpi_errno,"graph.edges");
for (i=0; i<nnodes; i++)
graph_ptr->topo.graph.index[i] = indx[i];
for (i=0; i<nedges; i++)
graph_ptr->topo.graph.edges[i] = edges[i];
/* Finally, place the topology onto the new communicator and return the
handle */
mpi_errno = MPIR_Topology_put( newcomm_ptr, graph_ptr );
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPIU_OBJ_PUBLISH_HANDLE(*comm_graph, newcomm_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
MPIU_CHKPMEM_REAP();
# ifdef HAVE_ERROR_CHECKING
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_graph_create",
"**mpi_graph_create %C %d %p %p %d %p", comm_ptr->handle,
nnodes, indx,
edges, reorder, comm_graph);
}
# endif
mpi_errno = MPIR_Err_return_comm( (MPID_Comm*)comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Type_create_subarray - Create a datatype for a subarray of a regular,
multidimensional array
Input Parameters:
+ ndims - number of array dimensions (positive integer)
. array_of_sizes - number of elements of type oldtype in each dimension of the
full array (array of positive integers)
. array_of_subsizes - number of elements of type oldtype in each dimension of
the subarray (array of positive integers)
. array_of_starts - starting coordinates of the subarray in each dimension
(array of nonnegative integers)
. order - array storage order flag (state)
- oldtype - array element datatype (handle)
Output Parameters:
. newtype - new datatype (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TYPE
.N MPI_ERR_ARG
@*/
int MPI_Type_create_subarray(int ndims,
const int array_of_sizes[],
const int array_of_subsizes[],
const int array_of_starts[],
int order,
MPI_Datatype oldtype,
MPI_Datatype *newtype)
{
static const char FCNAME[] = "MPI_Type_create_subarray";
int mpi_errno = MPI_SUCCESS, i;
MPI_Datatype new_handle;
/* these variables are from the original version in ROMIO */
MPI_Aint size, extent, disps[3];
MPI_Datatype tmp1, tmp2;
# ifdef HAVE_ERROR_CHECKING
MPI_Aint size_with_aint;
MPI_Offset size_with_offset;
# endif
/* for saving contents */
int *ints;
MPID_Datatype *new_dtp;
MPIU_CHKLMEM_DECL(1);
MPID_MPI_STATE_DECL(MPID_STATE_MPI_TYPE_CREATE_SUBARRAY);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_TYPE_CREATE_SUBARRAY);
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPID_Datatype *datatype_ptr = NULL;
/* Check parameters */
MPIR_ERRTEST_ARGNONPOS(ndims, "ndims", mpi_errno, MPI_ERR_DIMS);
MPIR_ERRTEST_ARGNULL(array_of_sizes, "array_of_sizes", mpi_errno);
MPIR_ERRTEST_ARGNULL(array_of_subsizes, "array_of_subsizes", mpi_errno);
MPIR_ERRTEST_ARGNULL(array_of_starts, "array_of_starts", mpi_errno);
for (i=0; mpi_errno == MPI_SUCCESS && i < ndims; i++) {
MPIR_ERRTEST_ARGNONPOS(array_of_sizes[i], "size", mpi_errno, MPI_ERR_ARG);
MPIR_ERRTEST_ARGNONPOS(array_of_subsizes[i], "subsize", mpi_errno, MPI_ERR_ARG);
MPIR_ERRTEST_ARGNEG(array_of_starts[i], "start", mpi_errno);
if (array_of_subsizes[i] > array_of_sizes[i]) {
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
FCNAME,
__LINE__,
MPI_ERR_ARG,
"**argrange",
"**argrange %s %d %d",
"array_of_subsizes",
array_of_subsizes[i],
array_of_sizes[i]);
goto fn_fail;
}
if (array_of_starts[i] > (array_of_sizes[i] - array_of_subsizes[i]))
{
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
FCNAME,
__LINE__,
MPI_ERR_ARG,
"**argrange",
"**argrange %s %d %d",
"array_of_starts",
array_of_starts[i],
array_of_sizes[i] -
array_of_subsizes[i]);
goto fn_fail;
}
}
if (order != MPI_ORDER_FORTRAN && order != MPI_ORDER_C) {
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
FCNAME,
__LINE__,
MPI_ERR_ARG,
"**arg",
"**arg %s",
"order");
goto fn_fail;
}
MPIR_Type_extent_impl(oldtype, &extent);
/* check if MPI_Aint is large enough for size of global array.
if not, complain. */
size_with_aint = extent;
for (i=0; i<ndims; i++) size_with_aint *= array_of_sizes[i];
size_with_offset = extent;
for (i=0; i<ndims; i++) size_with_offset *= array_of_sizes[i];
if (size_with_aint != size_with_offset) {
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_FATAL,
FCNAME,
__LINE__,
MPI_ERR_ARG,
"**subarrayoflow",
"**subarrayoflow %L",
size_with_offset);
goto fn_fail;
}
/* Get handles to MPI objects. */
MPID_Datatype_get_ptr(oldtype, datatype_ptr);
/* Validate datatype_ptr */
MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno);
/* If datatype_ptr is not valid, it will be reset to null */
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
/* TODO: CHECK THE ERROR RETURNS FROM ALL THESE!!! */
/* TODO: GRAB EXTENT WITH A MACRO OR SOMETHING FASTER */
MPIR_Type_extent_impl(oldtype, &extent);
if (order == MPI_ORDER_FORTRAN) {
if (ndims == 1)
mpi_errno = MPID_Type_contiguous(array_of_subsizes[0],
oldtype,
&tmp1);
else {
mpi_errno = MPID_Type_vector(array_of_subsizes[1],
array_of_subsizes[0],
(MPI_Aint)(array_of_sizes[0]),
0, /* stride in types */
oldtype,
&tmp1);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
size = ((MPI_Aint)(array_of_sizes[0])) * extent;
for (i=2; i<ndims; i++) {
size *= (MPI_Aint)(array_of_sizes[i-1]);
mpi_errno = MPID_Type_vector(array_of_subsizes[i],
1,
size,
1, /* stride in bytes */
tmp1,
&tmp2);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIR_Type_free_impl(&tmp1);
tmp1 = tmp2;
}
}
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
/* add displacement and UB */
disps[1] = (MPI_Aint)(array_of_starts[0]);
size = 1;
for (i=1; i<ndims; i++) {
size *= (MPI_Aint)(array_of_sizes[i-1]);
disps[1] += size * (MPI_Aint)(array_of_starts[i]);
}
/* rest done below for both Fortran and C order */
}
else /* MPI_ORDER_C */ {
/* dimension ndims-1 changes fastest */
if (ndims == 1) {
mpi_errno = MPID_Type_contiguous(array_of_subsizes[0],
oldtype,
&tmp1);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
}
else {
mpi_errno = MPID_Type_vector(array_of_subsizes[ndims-2],
array_of_subsizes[ndims-1],
(MPI_Aint)(array_of_sizes[ndims-1]),
0, /* stride in types */
oldtype,
&tmp1);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
size = (MPI_Aint)(array_of_sizes[ndims-1]) * extent;
for (i=ndims-3; i>=0; i--) {
size *= (MPI_Aint)(array_of_sizes[i+1]);
mpi_errno = MPID_Type_vector(array_of_subsizes[i],
1, /* blocklen */
size, /* stride */
1, /* stride in bytes */
tmp1, /* old type */
&tmp2);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIR_Type_free_impl(&tmp1);
tmp1 = tmp2;
}
}
/* add displacement and UB */
disps[1] = (MPI_Aint)(array_of_starts[ndims-1]);
size = 1;
for (i=ndims-2; i>=0; i--) {
size *= (MPI_Aint)(array_of_sizes[i+1]);
disps[1] += size * (MPI_Aint)(array_of_starts[i]);
}
}
disps[1] *= extent;
disps[2] = extent;
for (i=0; i<ndims; i++) disps[2] *= (MPI_Aint)(array_of_sizes[i]);
disps[0] = 0;
/* Instead of using MPI_LB/MPI_UB, which have been removed from MPI in MPI-3,
use MPI_Type_create_resized. Use hindexed_block to set the starting displacement
of the datatype (disps[1]) and type_create_resized to set lb to 0 (disps[0])
and extent to disps[2], which makes ub = disps[2].
*/
mpi_errno = MPID_Type_blockindexed(1, 1, &disps[1],
1, /* 1 means disp is in bytes */
tmp1, &tmp2);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
mpi_errno = MPID_Type_create_resized(tmp2, 0, disps[2], &new_handle);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIR_Type_free_impl(&tmp1);
MPIR_Type_free_impl(&tmp2);
/* at this point we have the new type, and we've cleaned up any
* intermediate types created in the process. we just need to save
* all our contents/envelope information.
*/
/* Save contents */
MPIU_CHKLMEM_MALLOC_ORJUMP(ints, int *, (3 * ndims + 2) * sizeof(int), mpi_errno, "content description");
ints[0] = ndims;
for (i=0; i < ndims; i++) {
ints[i + 1] = array_of_sizes[i];
}
for(i=0; i < ndims; i++) {
ints[i + ndims + 1] = array_of_subsizes[i];
}
for(i=0; i < ndims; i++) {
ints[i + 2*ndims + 1] = array_of_starts[i];
}
ints[3*ndims + 1] = order;
MPID_Datatype_get_ptr(new_handle, new_dtp);
mpi_errno = MPID_Datatype_set_contents(new_dtp,
MPI_COMBINER_SUBARRAY,
3 * ndims + 2, /* ints */
0, /* aints */
1, /* types */
ints,
NULL,
&oldtype);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIU_OBJ_PUBLISH_HANDLE(*newtype, new_handle);
/* ... end of body of routine ... */
fn_exit:
MPIU_CHKLMEM_FREEALL();
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TYPE_CREATE_SUBARRAY);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_type_create_subarray",
"**mpi_type_create_subarray %d %p %p %p %d %D %p", ndims, array_of_sizes, array_of_subsizes,
array_of_starts, order, oldtype, newtype);
}
# endif
mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Bsend_init - Builds a handle for a buffered send
Input Parameters:
+ buf - initial address of send buffer (choice)
. count - number of elements sent (integer)
. datatype - type of each element (handle)
. dest - rank of destination (integer)
. tag - message tag (integer)
- comm - communicator (handle)
Output Parameters:
. request - communication request (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_COUNT
.N MPI_ERR_TYPE
.N MPI_ERR_RANK
.N MPI_ERR_TAG
.seealso: MPI_Buffer_attach
@*/
int MPI_Bsend_init(const void *buf, int count, MPI_Datatype datatype,
int dest, int tag, MPI_Comm comm, MPI_Request *request)
{
static const char FCNAME[] = "MPI_Bsend_init";
int mpi_errno = MPI_SUCCESS;
MPID_Request *request_ptr = NULL;
MPID_Comm *comm_ptr = NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_BSEND_INIT);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_PT2PT_FUNC_ENTER(MPID_STATE_MPI_BSEND_INIT);
/* Validate handle parameters needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPID_Comm_get_ptr( comm, comm_ptr );
/* Validate parameters if error checking is enabled */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPID_Comm_valid_ptr( comm_ptr, mpi_errno );
if (mpi_errno) goto fn_fail;
MPIR_ERRTEST_COUNT(count, mpi_errno);
MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno);
MPIR_ERRTEST_SEND_RANK(comm_ptr, dest, mpi_errno);
MPIR_ERRTEST_SEND_TAG(tag, mpi_errno);
MPIR_ERRTEST_ARGNULL(request,"request",mpi_errno);
/* Validate datatype object */
if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN)
{
MPID_Datatype *datatype_ptr = NULL;
MPID_Datatype_get_ptr(datatype, datatype_ptr);
MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno);
if (mpi_errno) goto fn_fail;
MPID_Datatype_committed_ptr(datatype_ptr, mpi_errno);
if (mpi_errno) goto fn_fail;
}
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPID_Bsend_init(buf, count, datatype, dest, tag, comm_ptr,
MPID_CONTEXT_INTRA_PT2PT, &request_ptr);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* return the handle of the request to the user */
MPIU_OBJ_PUBLISH_HANDLE(*request, request_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_PT2PT_FUNC_EXIT(MPID_STATE_MPI_BSEND_INIT);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_bsend_init",
"**mpi_bsend_init %p %d %D %i %t %C %p", buf, count, datatype, dest, tag, comm, request);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Type_create_hvector - Create a datatype with a constant stride given
in bytes
Input Parameters:
+ count - number of blocks (nonnegative integer)
. blocklength - number of elements in each block (nonnegative integer)
. stride - number of bytes between start of each block (address integer)
- oldtype - old datatype (handle)
Output Parameters:
. newtype - new datatype (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TYPE
.N MPI_ERR_ARG
@*/
int MPI_Type_create_hvector(int count,
int blocklength,
MPI_Aint stride,
MPI_Datatype oldtype,
MPI_Datatype *newtype)
{
static const char FCNAME[] = "MPI_Type_create_hvector";
int mpi_errno = MPI_SUCCESS;
MPI_Datatype new_handle;
MPID_Datatype *new_dtp;
int ints[2];
MPID_MPI_STATE_DECL(MPID_STATE_MPI_TYPE_CREATE_HVECTOR);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_TYPE_CREATE_HVECTOR);
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPID_Datatype *datatype_ptr = NULL;
MPIR_ERRTEST_COUNT(count, mpi_errno);
MPIR_ERRTEST_ARGNEG(blocklength, "blocklen", mpi_errno);
MPIR_ERRTEST_DATATYPE(oldtype, "datatype", mpi_errno);
if (HANDLE_GET_KIND(oldtype) != HANDLE_KIND_BUILTIN) {
MPID_Datatype_get_ptr(oldtype, datatype_ptr);
MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPIR_ERRTEST_ARGNULL(newtype, "newtype", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPID_Type_vector(count,
blocklength,
stride,
1, /* stride in bytes */
oldtype,
&new_handle);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
ints[0] = count;
ints[1] = blocklength;
MPID_Datatype_get_ptr(new_handle, new_dtp);
mpi_errno = MPID_Datatype_set_contents(new_dtp,
MPI_COMBINER_HVECTOR,
2, /* ints (count, blocklength) */
1, /* aints */
1, /* types */
ints,
&stride,
&oldtype);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPIU_OBJ_PUBLISH_HANDLE(*newtype, new_handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TYPE_CREATE_HVECTOR);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_type_create_hvector",
"**mpi_type_create_hvector %d %d %d %D %p", count,
blocklength, stride, oldtype, newtype);
}
# endif
mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Comm_join - Create a communicator by joining two processes connected by
a socket.
Input Parameter:
. fd - socket file descriptor
Output Parameter:
. intercomm - new intercommunicator (handle)
Notes:
The socket must be quiescent before 'MPI_COMM_JOIN' is called and after
'MPI_COMM_JOIN' returns. More specifically, on entry to 'MPI_COMM_JOIN', a
read on the socket will not read any data that was written to the socket
before the remote process called 'MPI_COMM_JOIN'.
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_ARG
@*/
int MPI_Comm_join(int fd, MPI_Comm *intercomm)
{
static const char FCNAME[] = "MPI_Comm_join";
int mpi_errno = MPI_SUCCESS, err;
MPID_Comm *intercomm_ptr;
char *local_port, *remote_port;
MPIU_CHKLMEM_DECL(2);
MPID_MPI_STATE_DECL(MPID_STATE_MPI_COMM_JOIN);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_COMM_JOIN);
/* ... body of routine ... */
MPIU_CHKLMEM_MALLOC(local_port, char *, MPI_MAX_PORT_NAME, mpi_errno, "local port name");
MPIU_CHKLMEM_MALLOC(remote_port, char *, MPI_MAX_PORT_NAME, mpi_errno, "remote port name");
mpi_errno = MPIR_Open_port_impl(NULL, local_port);
MPIU_ERR_CHKANDJUMP((mpi_errno != MPI_SUCCESS), mpi_errno, MPI_ERR_OTHER, "**openportfailed");
err = MPIR_fd_send(fd, local_port, MPI_MAX_PORT_NAME);
MPIU_ERR_CHKANDJUMP1((err != 0), mpi_errno, MPI_ERR_INTERN, "**join_send", "**join_send %d", err);
err = MPIR_fd_recv(fd, remote_port, MPI_MAX_PORT_NAME);
MPIU_ERR_CHKANDJUMP1((err != 0), mpi_errno, MPI_ERR_INTERN, "**join_recv", "**join_recv %d", err);
MPIU_ERR_CHKANDJUMP2((strcmp(local_port, remote_port) == 0), mpi_errno, MPI_ERR_INTERN, "**join_portname",
"**join_portname %s %s", local_port, remote_port);
if (strcmp(local_port, remote_port) < 0) {
MPID_Comm *comm_self_ptr;
MPID_Comm_get_ptr( MPI_COMM_SELF, comm_self_ptr );
mpi_errno = MPIR_Comm_accept_impl(local_port, NULL, 0, comm_self_ptr, &intercomm_ptr);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
} else {
MPID_Comm *comm_self_ptr;
MPID_Comm_get_ptr( MPI_COMM_SELF, comm_self_ptr );
mpi_errno = MPIR_Comm_connect_impl(remote_port, NULL, 0, comm_self_ptr, &intercomm_ptr);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
}
mpi_errno = MPIR_Close_port_impl(local_port);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIU_OBJ_PUBLISH_HANDLE(*intercomm, intercomm_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPIU_CHKLMEM_FREEALL();
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_COMM_JOIN);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_join",
"**mpi_comm_join %d %p", fd, intercomm);
}
# endif
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Comm_dup - Duplicates an existing communicator with all its cached
information
Input Parameter:
. comm - Communicator to be duplicated (handle)
Output Parameter:
. newcomm - A new communicator over the same group as 'comm' but with a new
context. See notes. (handle)
Notes:
This routine is used to create a new communicator that has a new
communication context but contains the same group of processes as
the input communicator. Since all MPI communication is performed
within a communicator (specifies as the group of processes `plus`
the context), this routine provides an effective way to create a
private communicator for use by a software module or library. In
particular, no library routine should use 'MPI_COMM_WORLD' as the
communicator; instead, a duplicate of a user-specified communicator
should always be used. For more information, see Using MPI, 2nd
edition.
Because this routine essentially produces a copy of a communicator,
it also copies any attributes that have been defined on the input
communicator, using the attribute copy function specified by the
'copy_function' argument to 'MPI_Keyval_create'. This is
particularly useful for (a) attributes that describe some property
of the group associated with the communicator, such as its
interconnection topology and (b) communicators that are given back
to the user; the attibutes in this case can track subsequent
'MPI_Comm_dup' operations on this communicator.
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.seealso: MPI_Comm_free, MPI_Keyval_create, MPI_Attr_put, MPI_Attr_delete,
MPI_Comm_create_keyval, MPI_Comm_set_attr, MPI_Comm_delete_attr
@*/
int MPI_Comm_dup(MPI_Comm comm, MPI_Comm *newcomm)
{
int mpi_errno = MPI_SUCCESS;
MPID_Comm *comm_ptr = NULL, *newcomm_ptr;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_COMM_DUP);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_COMM_DUP);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPID_Comm_get_ptr( comm, comm_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr */
MPID_Comm_valid_ptr( comm_ptr, mpi_errno );
/* If comm_ptr is not valid, it will be reset to null */
MPIR_ERRTEST_ARGNULL(newcomm, "newcomm", mpi_errno);
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Comm_dup_impl(comm_ptr, &newcomm_ptr);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIU_OBJ_PUBLISH_HANDLE(*newcomm, newcomm_ptr->handle);
#if defined(_OSU_MVAPICH_) || defined(_OSU_PSM_)
if (enable_shmem_collectives){
if (check_split_comm(pthread_self())){
if (*newcomm != MPI_COMM_NULL){
int flag;
PMPI_Comm_test_inter(*newcomm, &flag);
if (flag == 0){
int my_id, size;
mpi_errno = PMPI_Comm_rank(*newcomm, &my_id);
if(mpi_errno) {
MPIU_ERR_POP(mpi_errno);
}
mpi_errno = PMPI_Comm_size(*newcomm, &size);
if(mpi_errno) {
MPIU_ERR_POP(mpi_errno);
}
disable_split_comm(pthread_self());
mpi_errno = create_2level_comm(*newcomm, size, my_id);
if(mpi_errno) {
MPIU_ERR_POP(mpi_errno);
}
enable_split_comm(pthread_self());
}
}
}
}
#endif /* defined(_OSU_MVAPICH_) || defined(_OSU_PSM_) */
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_COMM_DUP);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_dup",
"**mpi_comm_dup %C %p", comm, newcomm);
}
# endif
*newcomm = MPI_COMM_NULL;
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Type_hindexed - Creates an indexed datatype with offsets in bytes
Input Parameters:
+ count - number of blocks -- also number of entries in indices and blocklens
. blocklens - number of elements in each block (array of nonnegative integers)
. indices - byte displacement of each block (array of MPI_Aint)
- old_type - old datatype (handle)
Output Parameter:
. newtype - new datatype (handle)
.N Deprecated
This routine is replaced by 'MPI_Type_create_hindexed'.
.N ThreadSafe
.N Fortran
The indices are displacements, and are based on a zero origin. A common error
is to do something like to following
.vb
integer a(100)
integer blens(10), indices(10)
do i=1,10
blens(i) = 1
10 indices(i) = (1 + (i-1)*10) * sizeofint
call MPI_TYPE_HINDEXED(10,blens,indices,MPI_INTEGER,newtype,ierr)
call MPI_TYPE_COMMIT(newtype,ierr)
call MPI_SEND(a,1,newtype,...)
.ve
expecting this to send 'a(1),a(11),...' because the indices have values
'1,11,...'. Because these are `displacements` from the beginning of 'a',
it actually sends 'a(1+1),a(1+11),...'.
If you wish to consider the displacements as indices into a Fortran array,
consider declaring the Fortran array with a zero origin
.vb
integer a(0:99)
.ve
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TYPE
.N MPI_ERR_COUNT
.N MPI_ERR_EXHAUSTED
.N MPI_ERR_ARG
@*/
int MPI_Type_hindexed(int count,
int blocklens[],
MPI_Aint indices[],
MPI_Datatype old_type,
MPI_Datatype *newtype)
{
static const char FCNAME[] = "MPI_Type_hindexed";
int mpi_errno = MPI_SUCCESS;
MPI_Datatype new_handle;
MPID_Datatype *new_dtp;
int i, *ints;
MPIU_CHKLMEM_DECL(1);
MPID_MPI_STATE_DECL(MPID_STATE_MPI_TYPE_HINDEXED);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_TYPE_HINDEXED);
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
int j;
MPID_Datatype *datatype_ptr = NULL;
MPIR_ERRTEST_COUNT(count, mpi_errno);
MPIR_ERRTEST_DATATYPE(old_type, "datatype", mpi_errno);
if (count > 0) {
MPIR_ERRTEST_ARGNULL(blocklens, "blocklens", mpi_errno);
MPIR_ERRTEST_ARGNULL(indices, "indices", mpi_errno);
}
if (mpi_errno == MPI_SUCCESS) {
if (HANDLE_GET_KIND(old_type) != HANDLE_KIND_BUILTIN) {
MPID_Datatype_get_ptr( old_type, datatype_ptr );
MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno);
}
/* verify that all blocklengths are >= 0 */
for (j=0; j < count; j++) {
MPIR_ERRTEST_ARGNEG(blocklens[j], "blocklen", mpi_errno);
}
}
MPIR_ERRTEST_ARGNULL(newtype, "newtype", mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPID_Type_indexed(count,
blocklens,
indices,
1, /* displacements in bytes */
old_type,
&new_handle);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPIU_CHKLMEM_MALLOC(ints, int *, (count + 1) * sizeof(int), mpi_errno, "contents integer array");
/* copy ints into temporary buffer (count and blocklengths) */
ints[0] = count;
for (i=0; i < count; i++)
{
ints[i+1] = blocklens[i];
}
MPID_Datatype_get_ptr(new_handle, new_dtp);
mpi_errno = MPID_Datatype_set_contents(new_dtp,
MPI_COMBINER_HINDEXED,
count+1, /* ints */
count, /* aints (displs) */
1, /* types */
ints,
indices,
&old_type);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPIU_OBJ_PUBLISH_HANDLE(*newtype, new_handle);
/* ... end of body of routine ... */
fn_exit:
MPIU_CHKLMEM_FREEALL();
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TYPE_HINDEXED);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_type_hindexed",
"**mpi_type_hindexed %d %p %p %D %p", count, blocklens, indices, old_type, newtype);
}
# endif
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Group_difference - Makes a group from the difference of two groups
Input Parameters:
+ group1 - first group (handle)
- group2 - second group (handle)
Output Parameter:
. newgroup - difference group (handle)
Notes:
The generated group containc the members of 'group1' that are not in 'group2'.
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_GROUP
.N MPI_ERR_EXHAUSTED
.seealso: MPI_Group_free
@*/
int MPI_Group_difference(MPI_Group group1, MPI_Group group2, MPI_Group *newgroup)
{
static const char FCNAME[] = "MPI_Group_difference";
int mpi_errno = MPI_SUCCESS;
MPID_Group *group_ptr1 = NULL;
MPID_Group *group_ptr2 = NULL;
MPID_Group *new_group_ptr;
int size1, i, k, g1_idx, g2_idx, l1_pid, l2_pid, nnew;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_GROUP_DIFFERENCE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_GROUP_DIFFERENCE);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_GROUP(group1, mpi_errno);
MPIR_ERRTEST_GROUP(group2, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPID_Group_get_ptr( group1, group_ptr1 );
MPID_Group_get_ptr( group2, group_ptr2 );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate group_ptr */
MPID_Group_valid_ptr( group_ptr1, mpi_errno );
MPID_Group_valid_ptr( group_ptr2, mpi_errno );
/* If either group_ptr is not valid, it will be reset to null */
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
/* Return a group consisting of the members of group1 that are *not*
in group2 */
size1 = group_ptr1->size;
/* Insure that the lpid lists are setup */
MPIR_Group_setup_lpid_pairs( group_ptr1, group_ptr2 );
for (i=0; i<size1; i++) {
group_ptr1->lrank_to_lpid[i].flag = 0;
}
g1_idx = group_ptr1->idx_of_first_lpid;
g2_idx = group_ptr2->idx_of_first_lpid;
nnew = size1;
while (g1_idx >= 0 && g2_idx >= 0) {
l1_pid = group_ptr1->lrank_to_lpid[g1_idx].lpid;
l2_pid = group_ptr2->lrank_to_lpid[g2_idx].lpid;
if (l1_pid < l2_pid) {
g1_idx = group_ptr1->lrank_to_lpid[g1_idx].next_lpid;
}
else if (l1_pid > l2_pid) {
g2_idx = group_ptr2->lrank_to_lpid[g2_idx].next_lpid;
}
else {
/* Equal */
group_ptr1->lrank_to_lpid[g1_idx].flag = 1;
g1_idx = group_ptr1->lrank_to_lpid[g1_idx].next_lpid;
g2_idx = group_ptr2->lrank_to_lpid[g2_idx].next_lpid;
nnew --;
}
}
/* Create the group */
if (nnew == 0) {
/* See 5.3.2, Group Constructors. For many group routines,
the standard explicitly says to return MPI_GROUP_EMPTY;
for others it is implied */
*newgroup = MPI_GROUP_EMPTY;
goto fn_exit;
}
else {
mpi_errno = MPIR_Group_create( nnew, &new_group_ptr );
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno) {
goto fn_fail;
}
/* --END ERROR HANDLING-- */
new_group_ptr->rank = MPI_UNDEFINED;
k = 0;
for (i=0; i<size1; i++) {
if (!group_ptr1->lrank_to_lpid[i].flag) {
new_group_ptr->lrank_to_lpid[k].lrank = k;
new_group_ptr->lrank_to_lpid[k].lpid =
group_ptr1->lrank_to_lpid[i].lpid;
if (i == group_ptr1->rank)
new_group_ptr->rank = k;
k++;
}
}
/* TODO calculate is_local_dense_monotonic */
}
MPIU_OBJ_PUBLISH_HANDLE(*newgroup, new_group_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_GROUP_DIFFERENCE);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_group_difference",
"**mpi_group_difference %G %G %p", group1, group2, newgroup);
}
# endif
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
