/*@
MPI_Group_range_incl - Creates a new group from ranges of ranks in an
existing group
Input Parameters:
+ group - group (handle)
. n - number of triplets in array 'ranges' (integer)
- ranges - a one-dimensional array of integer triplets, of the
form (first rank, last rank, stride) indicating ranks in
'group' or processes to be included in 'newgroup'.
Output Parameters:
. newgroup - new group derived from above, in the
order defined by 'ranges' (handle)
.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_range_incl(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_INCL);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_GROUP_RANGE_INCL);
/* 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 value, it will be reset to null */
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_incl_impl(group_ptr, n, ranges, &new_group_ptr);
if (mpi_errno) goto fn_fail;
MPIR_OBJ_PUBLISH_HANDLE(*newgroup, new_group_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_GROUP_RANGE_INCL);
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_group_range_incl",
"**mpi_group_range_incl %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_Errhandler_get - Gets the error handler for a communicator
Input Parameters:
. comm - communicator to get the error handler from (handle)
Output Parameters:
. errhandler - MPI error handler currently associated with communicator
(handle)
.N ThreadSafe
.N Fortran
Note on Implementation:
The MPI Standard was unclear on whether this routine required the user to call
'MPI_Errhandler_free' once for each call made to this routine in order to
free the error handler. After some debate, the MPI Forum added an explicit
statement that users are required to call 'MPI_Errhandler_free' when the
return value from this routine is no longer needed. This behavior is similar
to the other MPI routines for getting objects; for example, 'MPI_Comm_group'
requires that the user call 'MPI_Group_free' when the group returned
by 'MPI_Comm_group' is no longer needed.
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_ARG
@*/
int MPI_Errhandler_get(MPI_Comm comm, MPI_Errhandler *errhandler)
{
int mpi_errno = MPI_SUCCESS;
MPID_Comm *comm_ptr = NULL;
MPID_Errhandler *errhandler_ptr;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_ERRHANDLER_GET);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_ERRHANDLER_GET);
/* 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; if comm_ptr is not value, it will be reset to null */
MPID_Comm_valid_ptr( comm_ptr, mpi_errno, TRUE );
if (mpi_errno) goto fn_fail;
MPIR_ERRTEST_ARGNULL(errhandler, "errhandler", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
MPIR_Comm_get_errhandler_impl( comm_ptr, &errhandler_ptr );
if (errhandler_ptr)
*errhandler = errhandler_ptr->handle;
else
*errhandler = MPI_ERRORS_ARE_FATAL;
/* ... end of body of routine ... */
# ifdef HAVE_ERROR_CHECKING
fn_exit:
# endif
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_ERRHANDLER_GET);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
# ifdef HAVE_ERROR_CHECKING
fn_fail:
/* --BEGIN ERROR HANDLING-- */
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_errhandler_get",
"**mpi_errhandler_get %C %p", comm, errhandler);
}
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
# endif
/* --END ERROR HANDLING-- */
}
/*@
MPI_Win_get_errhandler - Get the error handler for the MPI RMA window
Input Parameters:
. win - window (handle)
Output Parameters:
. errhandler - error handler currently associated with window (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_WIN
.N MPI_ERR_OTHER
@*/
int MPI_Win_get_errhandler(MPI_Win win, MPI_Errhandler *errhandler)
{
#ifdef HAVE_ERROR_CHECKING
static const char FCNAME[] = "MPI_Win_get_errhandler";
#endif
int mpi_errno = MPI_SUCCESS;
MPID_Win *win_ptr = NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_WIN_GET_ERRHANDLER);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_WIN_GET_ERRHANDLER);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_WIN(win, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPID_Win_get_ptr( win, win_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_ARGNULL(errhandler,"errhandler",mpi_errno);
/* Validate win_ptr */
MPID_Win_valid_ptr( win_ptr, mpi_errno );
/* If win_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 ... */
MPIU_THREAD_CS_ENTER(MPI_OBJ, win_ptr);
if (win_ptr->errhandler) {
*errhandler = win_ptr->errhandler->handle;
MPIR_Errhandler_add_ref(win_ptr->errhandler);
}
else {
/* Use the default */
*errhandler = MPI_ERRORS_ARE_FATAL;
}
MPIU_THREAD_CS_EXIT(MPI_OBJ, win_ptr);
/* ... end of body of routine ... */
#ifdef HAVE_ERROR_CHECKING
fn_exit:
#endif
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_WIN_GET_ERRHANDLER);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
fn_fail:
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_win_get_errhandler",
"**mpi_win_get_errhandler %W %p", win, errhandler);
}
mpi_errno = MPIR_Err_return_win(win_ptr, FCNAME, mpi_errno);
goto fn_exit;
# endif
/* --END ERROR HANDLING-- */
}
/*@
MPI_Type_create_struct - Create an MPI datatype from a general set of
datatypes, displacements, and block sizes
Input Parameters:
+ count - number of blocks (integer) --- also number of entries in arrays
array_of_types, array_of_displacements and array_of_blocklengths
. array_of_blocklength - number of elements in each block (array of integer)
. array_of_displacements - byte displacement of each block (array of address integer)
- array_of_types - type of elements in each block (array of handles to
datatype objects)
Output Parameter:
. newtype - new datatype (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_ARG
.N MPI_ERR_TYPE
@*/
int MPI_Type_create_struct(int count,
int array_of_blocklengths[],
MPI_Aint array_of_displacements[],
MPI_Datatype array_of_types[],
MPI_Datatype *newtype)
{
int mpi_errno = MPI_SUCCESS;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_TYPE_CREATE_STRUCT);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_TYPE_CREATE_STRUCT);
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
int j;
MPID_Datatype *datatype_ptr = NULL;
MPIR_ERRTEST_COUNT(count,mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
if (count > 0) {
MPIR_ERRTEST_ARGNULL(array_of_blocklengths, "blocklens", mpi_errno);
MPIR_ERRTEST_ARGNULL(array_of_displacements, "indices", mpi_errno);
MPIR_ERRTEST_ARGNULL(array_of_types, "types", mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
for (j=0; j < count; j++) {
MPIR_ERRTEST_ARGNEG(array_of_blocklengths[j], "blocklen", mpi_errno);
MPIR_ERRTEST_DATATYPE(array_of_types[j], "datatype[j]",
mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
if (array_of_types[j] != MPI_DATATYPE_NULL && HANDLE_GET_KIND(array_of_types[j]) != HANDLE_KIND_BUILTIN) {
MPID_Datatype_get_ptr(array_of_types[j], datatype_ptr);
MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
}
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Type_create_struct_impl(count, array_of_blocklengths, array_of_displacements,
array_of_types, newtype);
if (mpi_errno) goto fn_exit;
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TYPE_CREATE_STRUCT);
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_struct",
"**mpi_type_create_struct %d %p %p %p %p", count, array_of_blocklengths, array_of_displacements,
array_of_types, newtype);
}
# endif
mpi_errno = MPIR_Err_return_comm(NULL, 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();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
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, FALSE );
/* 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;
MPID_OBJ_PUBLISH_HANDLE(*intercomm, intercomm_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_COMM_SPAWN);
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_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_Comm_test_inter - Tests to see if a comm is an inter-communicator
Input Parameter:
. comm - communicator to test (handle)
Output Parameter:
. flag - true if this is an inter-communicator(logical)
.N SignalSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_ARG
@*/
int MPI_Comm_test_inter(MPI_Comm comm, int *flag)
{
int mpi_errno = MPI_SUCCESS;
MPID_Comm *comm_ptr = NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_COMM_TEST_INTER);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_COMM_TEST_INTER);
/* 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(flag,"flag",mpi_errno);
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
*flag = (comm_ptr->comm_kind == MPID_INTERCOMM);
/* ... end of body of routine ... */
#ifdef HAVE_ERROR_CHECKING
fn_exit:
#endif
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_COMM_TEST_INTER);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
fn_fail:
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_comm_test_inter",
"**mpi_comm_test_inter %C %p", comm, flag);
}
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
# endif
/* --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-- */
}
int MPI_Info_get_nthkey( MPI_Info info, int n, char *key )
{
int mpi_errno = MPI_SUCCESS;
MPID_Info *info_ptr=0;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_INFO_GET_NTHKEY);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_INFO_GET_NTHKEY);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_INFO(info, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPID_Info_get_ptr( info, info_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate info_ptr */
MPID_Info_valid_ptr( info_ptr, mpi_errno );
if (mpi_errno) goto fn_fail;
MPIR_ERR_CHKANDJUMP((!key), mpi_errno, MPI_ERR_INFO_KEY, "**infokeynull");
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Info_get_nthkey_impl(info_ptr, n, key);
if (mpi_errno) goto fn_fail;
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_INFO_GET_NTHKEY);
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_info_get_nthkey",
"**mpi_info_get_nthkey %I %d %p", info, n, key);
}
# endif
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Unpack - Unpack a buffer according to a datatype into contiguous memory
Input Parameters:
+ inbuf - input buffer start (choice)
. insize - size of input buffer, in bytes (integer)
. outcount - number of items to be unpacked (integer)
. datatype - datatype of each output data item (handle)
- comm - communicator for packed message (handle)
Output Parameters:
. outbuf - output buffer start (choice)
Inout/Output Parameters:
. position - current position in bytes (integer)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_COUNT
.N MPI_ERR_TYPE
.N MPI_ERR_ARG
.seealso: MPI_Pack, MPI_Pack_size
@*/
int MPI_Unpack(const void *inbuf, int insize, int *position,
void *outbuf, int outcount, MPI_Datatype datatype,
MPI_Comm comm)
{
int mpi_errno = MPI_SUCCESS;
MPI_Aint position_x;
MPID_Comm *comm_ptr = NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_UNPACK);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_UNPACK);
/* 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;
{
if (insize > 0) {
MPIR_ERRTEST_ARGNULL(inbuf, "input buffer", mpi_errno);
}
/* Note: outbuf could be MPI_BOTTOM; don't test for NULL */
MPIR_ERRTEST_COUNT(insize, mpi_errno);
MPIR_ERRTEST_COUNT(outcount, mpi_errno);
/* Validate comm_ptr */
MPID_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* If comm_ptr is not valid, it will be reset to null */
MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno);
if (datatype != MPI_DATATYPE_NULL &&
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);
MPID_Datatype_committed_ptr(datatype_ptr, mpi_errno);
}
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
position_x = *position;
mpi_errno = MPIR_Unpack_impl(inbuf, insize, &position_x, outbuf, outcount, datatype);
if (mpi_errno) goto fn_fail;
MPIU_Assign_trunc(*position, position_x, int);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_UNPACK);
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_unpack",
"**mpi_unpack %p %d %p %p %d %D %C", inbuf, insize, position, outbuf, outcount, datatype, comm);
}
# endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Win_set_name - Set the print name for an MPI RMA window
Input Parameters:
+ win - window whose identifier is to be set (handle)
- win_name - the character string which is remembered as the name (string)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_WIN
.N MPI_ERR_OTHER
.N MPI_ERR_ARG
@*/
int MPI_Win_set_name(MPI_Win win, const char *win_name)
{
static const char FCNAME[] = "MPI_Win_set_name";
int mpi_errno = MPI_SUCCESS;
MPID_Win *win_ptr = NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_WIN_SET_NAME);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_WIN_SET_NAME);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_WIN(win, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPID_Win_get_ptr( win, win_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate win_ptr */
MPID_Win_valid_ptr( win_ptr, mpi_errno );
if (mpi_errno) goto fn_fail;
/* If win_ptr is not valid, it will be reset to null */
MPIR_ERRTEST_ARGNULL(win_name, "win_name", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
MPL_strncpy( win_ptr->name, win_name, MPI_MAX_OBJECT_NAME );
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_WIN_SET_NAME);
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_set_name",
"**mpi_win_set_name %W %s", win, win_name);
}
# endif
mpi_errno = MPIR_Err_return_win( win_ptr, 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_set_info - Set new values for the hints of the
communicator associated with comm. The call is collective on the
group of comm. The info object may be different on each process,
but any info entries that an implementation requires to be the same
on all processes must appear with the same value in each process''
info object.
Input Parameters:
+ comm - communicator object (handle)
- info - info argument (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_ARG
.N MPI_ERR_INFO
.N MPI_ERR_OTHER
@*/
int MPI_Comm_set_info(MPI_Comm comm, MPI_Info info)
{
int mpi_errno = MPI_SUCCESS;
MPID_Comm *comm_ptr = NULL;
MPID_Info *info_ptr = NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_COMM_SET_INFO);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_COMM_SET_INFO);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_ARGNULL(info, "info", 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);
if (mpi_errno)
goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Comm_set_info_impl(comm_ptr, info_ptr);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_COMM_SET_INFO);
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_set_info",
"**mpi_comm_set_info %W %p", comm, info);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
int MPIR_Group_range_incl_impl(MPID_Group *group_ptr, int n, int ranges[][3], MPID_Group **new_group_ptr)
{
int mpi_errno = MPI_SUCCESS;
int first, last, stride, nnew, i, j, k;
MPID_MPI_STATE_DECL(MPID_STATE_MPIR_GROUP_RANGE_INCL_IMPL);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPIR_GROUP_RANGE_INCL_IMPL);
/* Compute size, assuming that included ranks are valid (and distinct) */
nnew = 0;
for (i=0; i<n; i++) {
first = ranges[i][0]; last = ranges[i][1]; stride = ranges[i][2];
/* works for stride of either sign. Error checking above
has already guaranteed stride != 0 */
nnew += 1 + (last - first) / stride;
}
if (nnew == 0) {
*new_group_ptr = MPID_Group_empty;
goto fn_exit;
}
/* Allocate a new group and lrank_to_lpid array */
mpi_errno = MPIR_Group_create( nnew, new_group_ptr );
if (mpi_errno) goto fn_fail;
(*new_group_ptr)->rank = MPI_UNDEFINED;
/* Group members taken in order specified by the range array */
/* This could be integrated with the error checking, but since this
is a low-usage routine, we haven't taken that optimization */
k = 0;
for (i=0; i<n; i++) {
first = ranges[i][0]; last = ranges[i][1]; stride = ranges[i][2];
if (stride > 0) {
for (j=first; j<=last; j += stride) {
(*new_group_ptr)->lrank_to_lpid[k].lpid =
group_ptr->lrank_to_lpid[j].lpid;
if (j == group_ptr->rank)
(*new_group_ptr)->rank = k;
k++;
}
}
else {
for (j=first; j>=last; j += stride) {
(*new_group_ptr)->lrank_to_lpid[k].lpid =
group_ptr->lrank_to_lpid[j].lpid;
if (j == group_ptr->rank)
(*new_group_ptr)->rank = k;
k++;
}
}
}
/* TODO calculate is_local_dense_monotonic */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPIR_GROUP_RANGE_INCL_IMPL);
return mpi_errno;
fn_fail:
goto fn_exit;
}
/*@
MPI_File_call_errhandler - Call the error handler installed on a
file
Input Parameters:
+ fh - MPI file with error handler (handle)
- errorcode - error code (integer)
.N ThreadSafeNoUpdate
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_FILE
@*/
int MPI_File_call_errhandler(MPI_File fh, int errorcode)
{
int mpi_errno = MPI_SUCCESS;
#ifdef MPI_MODE_RDONLY
MPID_Errhandler *e;
MPI_Errhandler eh;
#endif
MPIU_THREADPRIV_DECL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_FILE_CALL_ERRHANDLER);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_FILE_CALL_ERRHANDLER);
MPIU_THREADPRIV_GET;
#ifdef MPI_MODE_RDONLY
/* Validate parameters, especially handles needing to be converted */
/* FIXME: check for a valid file handle (fh) before converting to a
pointer */
/* ... body of routine ... */
MPIR_ROMIO_Get_file_errhand( fh, &eh );
/* Check for the special case of errors-throw-exception. In this case
return the error code; the C++ wrapper will cause an exception to
be thrown.
*/
#ifdef HAVE_CXX_BINDING
if (eh == MPIR_ERRORS_THROW_EXCEPTIONS) {
mpi_errno = errorcode;
goto fn_exit;
}
#endif
if (!eh) {
MPID_Errhandler_get_ptr( MPI_ERRORS_RETURN, e );
}
else {
MPID_Errhandler_get_ptr( eh, e );
}
/* Note that, unlike the rest of MPICH, MPI_File objects are pointers,
not integers. */
if (e->handle == MPI_ERRORS_RETURN) {
mpi_errno = errorcode;
goto fn_exit;
}
switch (e->language) {
case MPID_LANG_C:
(*e->errfn.C_File_Handler_function)( &fh, &errorcode );
break;
#ifdef HAVE_CXX_BINDING
case MPID_LANG_CXX:
/* See HAVE_LANGUAGE_FORTRAN below for an explanation */
{ void *fh1 = (void *)&fh;
(*MPIR_Process.cxx_call_errfn)( 1, fh1, &errorcode,
(void (*)(void))*e->errfn.C_File_Handler_function );
}
break;
#endif
#ifdef HAVE_FORTRAN_BINDING
case MPID_LANG_FORTRAN90:
case MPID_LANG_FORTRAN:
/* The assignemt to a local variable prevents the compiler
from generating a warning about a type-punned pointer. Since
the value is really const (but MPI didn't define error handlers
with const), this preserves the intent */
{ void *fh1 = (void *)&fh;
MPI_Fint ferr = errorcode; /* Needed if MPI_Fint and int aren't
the same size */
(*e->errfn.F77_Handler_function)( fh1, &ferr );
}
break;
#endif
}
#else
/* Dummy in case ROMIO is not defined */
mpi_errno = MPI_ERR_INTERN;
#endif
/* ... end of body of routine ... */
#if defined(HAVE_CXX_BINDING) && defined(MPI_MODE_RDONLY)
fn_exit:
#else
fn_exit:
#endif
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_FILE_CALL_ERRHANDLER);
return mpi_errno;
}
/*@
MPI_Win_flush_local_all - Complete locally all outstanding RMA operations at all targets
All RMA operations issued to any target prior to this call in this window will
have completed at the origin when 'MPI_Win_flush_local_all' returns.
Input Parameters:
. win - window object (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_RANK
.N MPI_ERR_WIN
.N MPI_ERR_OTHER
.seealso: MPI_Win_flush MPI_Win_flush_all MPI_Win_flush_local MPI_Win_lock MPI_Win_lock_all
@*/
int MPI_Win_flush_local_all(MPI_Win win)
{
static const char FCNAME[] = "MPI_Win_flush_local_all";
int mpi_errno = MPI_SUCCESS;
MPID_Win *win_ptr = NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_WIN_FLUSH_LOCAL_ALL);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_WIN_FLUSH_LOCAL_ALL);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_WIN(win, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPID_Win_get_ptr( win, win_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate win_ptr */
MPID_Win_valid_ptr( win_ptr, mpi_errno );
if (mpi_errno) goto fn_fail;
/* TODO: Validate that the given window is in passive mode */
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIU_RMA_CALL(win_ptr,Win_flush_local_all(win_ptr));
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_WIN_FLUSH_LOCAL_ALL);
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_flush_local_all",
"**mpi_win_flush_local_all %W", win);
}
# endif
mpi_errno = MPIR_Err_return_win( win_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Dist_graph_create_adjacent - returns a handle to a new communicator to
which the distributed graph topology information is attached.
Input Parameters:
+ comm_old - input communicator (handle)
. indegree - size of sources and sourceweights arrays (non-negative integer)
. sources - ranks of processes for which the calling process is a
destination (array of non-negative integers)
. sourceweights - weights of the edges into the calling
process (array of non-negative integers or MPI_UNWEIGHTED)
. outdegree - size of destinations and destweights arrays (non-negative integer)
. destinations - ranks of processes for which the calling process is a
source (array of non-negative integers)
. destweights - weights of the edges out of the calling process
(array of non-negative integers or MPI_UNWEIGHTED)
. info - hints on optimization and interpretation of weights (handle)
- reorder - the ranks may be reordered (true) or not (false) (logical)
Output Parameters:
. comm_dist_graph - communicator with distributed graph topology (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_ARG
.N MPI_ERR_OTHER
@*/
int MPI_Dist_graph_create_adjacent(MPI_Comm comm_old,
int indegree, const int sources[],
const int sourceweights[],
int outdegree, const int destinations[],
const int destweights[],
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;
MPIR_Topology *topo_ptr = NULL;
MPIR_Dist_graph_topology *dist_graph_ptr = NULL;
MPIU_CHKPMEM_DECL(5);
MPID_MPI_STATE_DECL(MPID_STATE_MPI_DIST_GRAPH_CREATE_ADJACENT);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_DIST_GRAPH_CREATE_ADJACENT);
/* 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);
}
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, FALSE );
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* 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(indegree, "indegree", mpi_errno);
MPIR_ERRTEST_ARGNEG(outdegree, "outdegree", mpi_errno);
if (indegree > 0) {
MPIR_ERRTEST_ARGNULL(sources, "sources", mpi_errno);
if (sourceweights == MPI_UNWEIGHTED && destweights != MPI_UNWEIGHTED) {
MPIU_ERR_SET(mpi_errno, MPI_ERR_TOPOLOGY, "**unweightedboth");
goto fn_fail;
}
/* TODO check ranges for array elements too (**argarrayneg / **rankarray)*/
}
if (outdegree > 0) {
MPIR_ERRTEST_ARGNULL(destinations, "destinations", mpi_errno);
if (destweights == MPI_UNWEIGHTED && sourceweights != MPI_UNWEIGHTED) {
MPIU_ERR_SET(mpi_errno, MPI_ERR_TOPOLOGY, "**unweightedboth");
goto fn_fail;
}
}
MPIR_ERRTEST_ARGNULL(comm_dist_graph, "comm_dist_graph", mpi_errno);
}
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;
/* 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_ptr->local_size, &comm_dist_graph_ptr);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
/* 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 = indegree;
dist_graph_ptr->in = NULL;
dist_graph_ptr->in_weights = NULL;
dist_graph_ptr->outdegree = outdegree;
dist_graph_ptr->out = NULL;
dist_graph_ptr->out_weights = NULL;
dist_graph_ptr->is_weighted = (sourceweights != MPI_UNWEIGHTED);
MPIU_CHKPMEM_MALLOC(dist_graph_ptr->in, int *, indegree*sizeof(int), mpi_errno, "dist_graph_ptr->in");
MPIU_CHKPMEM_MALLOC(dist_graph_ptr->out, int *, outdegree*sizeof(int), mpi_errno, "dist_graph_ptr->out");
MPIU_Memcpy(dist_graph_ptr->in, sources, indegree*sizeof(int));
MPIU_Memcpy(dist_graph_ptr->out, destinations, outdegree*sizeof(int));
if (dist_graph_ptr->is_weighted) {
MPIU_CHKPMEM_MALLOC(dist_graph_ptr->in_weights, int *, indegree*sizeof(int), mpi_errno, "dist_graph_ptr->in_weights");
MPIU_CHKPMEM_MALLOC(dist_graph_ptr->out_weights, int *, outdegree*sizeof(int), mpi_errno, "dist_graph_ptr->out_weights");
MPIU_Memcpy(dist_graph_ptr->in_weights, sourceweights, indegree*sizeof(int));
MPIU_Memcpy(dist_graph_ptr->out_weights, destweights, outdegree*sizeof(int));
}
/*@
MPI_Grequest_complete - Notify MPI that a user-defined request is complete
Input Parameter:
. request - Generalized request to mark as complete
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.seealso: MPI_Grequest_start
@*/
int MPI_Grequest_complete( MPI_Request request )
{
int mpi_errno = MPI_SUCCESS;
MPID_Request *request_ptr;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_GREQUEST_COMPLETE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_GREQUEST_COMPLETE);
/* Validate handle parameters needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_REQUEST(request, mpi_errno);
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPID_Request_get_ptr( request, request_ptr );
/* Validate parameters if error checking is enabled */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPID_Request_valid_ptr(request_ptr,mpi_errno);
if (request_ptr && request_ptr->kind != MPID_UREQUEST) {
mpi_errno = MPIR_Err_create_code( MPI_SUCCESS, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_ARG,
"**notgenreq", 0 );
}
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
MPIR_Grequest_complete_impl(request_ptr);
/* ... end of body of routine ... */
#ifdef HAVE_ERROR_CHECKING
fn_exit:
#endif
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_GREQUEST_COMPLETE);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
fn_fail:
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_grequest_complete",
"**mpi_grequest_complete %R", request);
}
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
# endif
/* --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();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
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;
MPIR_OBJ_PUBLISH_HANDLE(*newtype, new_handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TYPE_CREATE_HVECTOR);
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_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-- */
}
int MPIR_WinSetAttr( MPI_Win win, int win_keyval, void *attribute_val,
MPIR_AttrType attrType )
{
static const char FCNAME[] = "MPI_Win_set_attr";
int mpi_errno = MPI_SUCCESS;
MPID_Win *win_ptr = NULL;
MPID_Keyval *keyval_ptr = NULL;
MPID_Attribute *p, **old_p;
MPID_MPI_STATE_DECL(MPID_STATE_MPIR_WIN_SET_ATTR);
MPIR_ERRTEST_INITIALIZED_ORDIE();
/* The thread lock prevents a valid attr delete on the same window
but in a different thread from causing problems */
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPIR_WIN_SET_ATTR);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_WIN(win, mpi_errno);
MPIR_ERRTEST_KEYVAL(win_keyval, MPID_WIN, "window", mpi_errno);
MPIR_ERRTEST_KEYVAL_PERM(win_keyval, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPID_Win_get_ptr( win, win_ptr );
MPID_Keyval_get_ptr( win_keyval, keyval_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate win_ptr */
MPID_Win_valid_ptr( win_ptr, mpi_errno );
/* If win_ptr is not valid, it will be reset to null */
/* Validate keyval */
MPID_Keyval_valid_ptr( keyval_ptr, mpi_errno );
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
/* Look for attribute. They are ordered by keyval handle. This uses
a simple linear list algorithm because few applications use more than a
handful of attributes */
old_p = &win_ptr->attributes;
p = win_ptr->attributes;
while (p)
{
if (p->keyval->handle == keyval_ptr->handle)
{
/* If found, call the delete function before replacing the
attribute */
mpi_errno = MPIR_Call_attr_delete( win, p );
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno)
{
/* FIXME : communicator of window? */
goto fn_fail;
}
/* --END ERROR HANDLING-- */
p->value = (MPID_AttrVal_t)(MPIR_Pint)attribute_val;
p->attrType = attrType;
/* Does not change the reference count on the keyval */
break;
}
else if (p->keyval->handle > keyval_ptr->handle) {
MPID_Attribute *new_p = MPID_Attr_alloc();
MPIU_ERR_CHKANDJUMP1(!new_p,mpi_errno,MPI_ERR_OTHER,
"**nomem", "**nomem %s", "MPID_Attribute" );
new_p->keyval = keyval_ptr;
new_p->attrType = attrType;
new_p->pre_sentinal = 0;
new_p->value = (MPID_AttrVal_t)(MPIR_Pint)attribute_val;
new_p->post_sentinal = 0;
new_p->next = p->next;
MPIR_Keyval_add_ref( keyval_ptr );
p->next = new_p;
break;
}
old_p = &p->next;
p = p->next;
}
if (!p)
{
MPID_Attribute *new_p = MPID_Attr_alloc();
MPIU_ERR_CHKANDJUMP1(!new_p,mpi_errno,MPI_ERR_OTHER,
"**nomem", "**nomem %s", "MPID_Attribute" );
/* Did not find in list. Add at end */
new_p->attrType = attrType;
new_p->keyval = keyval_ptr;
new_p->pre_sentinal = 0;
new_p->value = (MPID_AttrVal_t)(MPIR_Pint)attribute_val;
new_p->post_sentinal = 0;
new_p->next = 0;
MPIR_Keyval_add_ref( keyval_ptr );
*old_p = new_p;
}
/* Here is where we could add a hook for the device to detect attribute
value changes, using something like
MPID_Dev_win_attr_hook( win_ptr, keyval, attribute_val );
*/
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPIR_WIN_SET_ATTR);
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_set_attr",
"**mpi_win_set_attr %W %d %p", win, win_keyval, attribute_val);
}
# endif
mpi_errno = MPIR_Err_return_win( win_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Win_free_keyval - Frees an attribute key for MPI RMA windows
Input Parameters:
. win_keyval - key value (integer)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_WIN
.N MPI_ERR_OTHER
.N MPI_ERR_KEYVAL
@*/
int MPI_Win_free_keyval(int *win_keyval)
{
#ifdef HAVE_ERROR_CHECKING
static const char FCNAME[] = "MPI_Win_free_keyval";
#endif
int mpi_errno = MPI_SUCCESS;
MPID_Keyval *keyval_ptr = NULL;
int in_use;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_WIN_FREE_KEYVAL);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_WIN_FREE_KEYVAL);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_ARGNULL(*win_keyval, "win_keyval", mpi_errno);
MPIR_ERRTEST_KEYVAL(*win_keyval, MPID_WIN, "window", mpi_errno);
MPIR_ERRTEST_KEYVAL_PERM(*win_keyval, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPID_Keyval_get_ptr( *win_keyval, keyval_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPID_Keyval_valid_ptr( keyval_ptr, mpi_errno );
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
if (!keyval_ptr->was_freed) {
keyval_ptr->was_freed = 1;
MPIR_Keyval_release_ref( keyval_ptr, &in_use);
if (!in_use) {
MPIU_Handle_obj_free( &MPID_Keyval_mem, keyval_ptr );
}
}
*win_keyval = MPI_KEYVAL_INVALID;
/* ... end of body of routine ... */
#ifdef HAVE_ERROR_CHECKING
fn_exit:
#endif
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_WIN_FREE_KEYVAL);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
fn_fail:
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_win_free_keyval",
"**mpi_win_free_keyval %p", win_keyval);
}
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
# endif
/* --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_Cart_shift - Returns the shifted source and destination ranks, given a
shift direction and amount
Input Parameters:
+ comm - communicator with cartesian structure (handle)
. direction - coordinate dimension of shift (integer)
- disp - displacement (> 0: upwards shift, < 0: downwards shift) (integer)
Output Parameters:
+ rank_source - rank of source process (integer)
- rank_dest - rank of destination process (integer)
Notes:
The 'direction' argument is in the range '[0,n-1]' for an n-dimensional
Cartesian mesh.
.N SignalSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TOPOLOGY
.N MPI_ERR_COMM
.N MPI_ERR_ARG
@*/
int MPI_Cart_shift(MPI_Comm comm, int direction, int disp, int *rank_source,
int *rank_dest)
{
int mpi_errno = MPI_SUCCESS;
MPID_Comm *comm_ptr = NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_CART_SHIFT);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_CART_SHIFT);
/* 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 (mpi_errno) goto fn_fail;
/* If comm_ptr is not valid, it will be reset to null */
MPIR_ERRTEST_ARGNULL( rank_source, "rank_source", mpi_errno );
MPIR_ERRTEST_ARGNULL( rank_dest, "rank_dest", mpi_errno );
MPIR_ERRTEST_ARGNEG( direction, "direction", mpi_errno );
/* Nothing in the standard indicates that a zero displacement
is not valid, so we don't check for a zero shift */
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Cart_shift_impl(comm_ptr, direction, disp, rank_source, rank_dest);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_CART_SHIFT);
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_cart_shift",
"**mpi_cart_shift %C %d %d %p %p", comm, direction, disp, rank_source, rank_dest);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Group_compare - Compares two groups
Input Parameters:
+ group1 - group1 (handle)
- group2 - group2 (handle)
Output Parameters:
. result - integer which is 'MPI_IDENT' if the order and members of
the two groups are the same, 'MPI_SIMILAR' if only the members are the same,
and 'MPI_UNEQUAL' otherwise
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_GROUP
.N MPI_ERR_ARG
@*/
int MPI_Group_compare(MPI_Group group1, MPI_Group group2, int *result)
{
int mpi_errno = MPI_SUCCESS;
MPID_Group *group_ptr1 = NULL;
MPID_Group *group_ptr2 = NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_GROUP_COMPARE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
/* The routines that setup the group data structures must be executed
within a mutex. As most of the group routines are not performance
critical, we simple run these routines within the SINGLE_CS */
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_GROUP_COMPARE);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_ARGNULL( result, "result", mpi_errno );
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 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_compare_impl(group_ptr1, group_ptr2, result);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_GROUP_COMPARE);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
fn_fail:
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_group_compare",
"**mpi_group_compare %G %G %p", group1, group2, result);
}
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Type_indexed - Creates an indexed datatype
Input Parameters:
+ count - number of blocks -- also number of entries in array_of_displacements and array_of_blocklengths
. array_of_blocklengths - number of elements in each block (array of nonnegative integers)
. array_of_displacements - displacement of each block in multiples of oldtype (array of
integers)
- oldtype - old datatype (handle)
Output Parameters:
. newtype - new datatype (handle)
.N ThreadSafe
.N Fortran
The array_of_displacements are displacements, and are based on a zero origin. A common error
is to do something like to following
.vb
integer a(100)
integer array_of_blocklengths(10), array_of_displacements(10)
do i=1,10
array_of_blocklengths(i) = 1
10 array_of_displacements(i) = 1 + (i-1)*10
call MPI_TYPE_INDEXED(10,array_of_blocklengths,array_of_displacements,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 array_of_displacements 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 array_of_displacements into a Fortran array,
consider declaring the Fortran array with a zero origin
.vb
integer a(0:99)
.ve
.N Errors
.N MPI_ERR_COUNT
.N MPI_ERR_TYPE
.N MPI_ERR_ARG
.N MPI_ERR_EXHAUSTED
@*/
int MPI_Type_indexed(int count,
const int *array_of_blocklengths,
const int *array_of_displacements,
MPI_Datatype oldtype,
MPI_Datatype *newtype)
{
int mpi_errno = MPI_SUCCESS;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_TYPE_INDEXED);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_TYPE_INDEXED);
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
int j;
MPID_Datatype *datatype_ptr = NULL;
MPIR_ERRTEST_COUNT(count,mpi_errno);
if (count > 0) {
MPIR_ERRTEST_ARGNULL(array_of_blocklengths, "array_of_blocklengths", mpi_errno);
MPIR_ERRTEST_ARGNULL(array_of_displacements, "array_of_displacements", 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 );
}
/* verify that all blocklengths are >= 0 */
for (j=0; j < count; j++) {
MPIR_ERRTEST_ARGNEG(array_of_blocklengths[j], "blocklength", mpi_errno);
}
MPIR_ERRTEST_ARGNULL(newtype, "newtype", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Type_indexed_impl(count, array_of_blocklengths, array_of_displacements, oldtype, newtype);
if (mpi_errno) goto fn_fail;
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TYPE_INDEXED);
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_indexed",
"**mpi_type_indexed %d %p %p %D %p", count,array_of_blocklengths, array_of_displacements, oldtype, newtype);
}
# endif
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Comm_free_keyval - Frees an attribute key for communicators
Input Parameters:
. comm_keyval - Frees the integer key value (integer)
Notes:
Key values are global (they can be used with any and all communicators)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_ARG
.N MPI_ERR_PERM_KEY
@*/
int MPI_Comm_free_keyval(int *comm_keyval)
{
MPID_Keyval *keyval_ptr = NULL;
int mpi_errno = MPI_SUCCESS;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_COMM_FREE_KEYVAL);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_COMM_FREE_KEYVAL);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_ARGNULL(comm_keyval, "comm_keyval", mpi_errno);
MPIR_ERRTEST_KEYVAL(*comm_keyval, MPID_COMM, "communicator", mpi_errno);
MPIR_ERRTEST_KEYVAL_PERM(*comm_keyval, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPID_Keyval_get_ptr( *comm_keyval, keyval_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPID_Keyval_valid_ptr( keyval_ptr, mpi_errno );
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
MPIR_Comm_free_keyval_impl(*comm_keyval);
*comm_keyval = MPI_KEYVAL_INVALID;
/* ... end of body of routine ... */
#ifdef HAVE_ERROR_CHECKING
fn_exit:
#endif
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_COMM_FREE_KEYVAL);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
fn_fail:
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_comm_free_keyval",
"**mpi_comm_free_keyval %p", comm_keyval);
}
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
# endif
/* --END ERROR HANDLING-- */
}
/*@
MPI_Ibarrier - Notifies the process that it has reached the barrier and returns
immediately
Input Parameters:
. comm - communicator (handle)
Output Parameters:
. request - communication request (handle)
Notes:
MPI_Ibarrier is a nonblocking version of MPI_barrier. By calling MPI_Ibarrier,
a process notifies that it has reached the barrier. The call returns
immediately, independent of whether other processes have called MPI_Ibarrier.
The usual barrier semantics are enforced at the corresponding completion
operation (test or wait), which in the intra-communicator case will complete
only after all other processes in the communicator have called MPI_Ibarrier. In
the intercommunicator case, it will complete when all processes in the remote
group have called MPI_Ibarrier.
.N ThreadSafe
.N Fortran
.N Errors
@*/
int MPI_Ibarrier(MPI_Comm comm, MPI_Request *request)
{
int mpi_errno = MPI_SUCCESS;
MPID_Comm *comm_ptr = NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_IBARRIER);
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_IBARRIER);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
/* TODO more checks may be appropriate */
}
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
{
MPID_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPIR_ERRTEST_ARGNULL(request,"request", mpi_errno);
/* TODO more checks may be appropriate (counts, in_place, buffer aliasing, etc) */
}
MPID_END_ERROR_CHECKS
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Ibarrier_impl(comm_ptr, request);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_IBARRIER);
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_ibarrier", "**mpi_ibarrier %C %p", comm, request);
}
# endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
goto fn_exit;
}
/*@
MPI_Ialltoall - Sends data from all to all processes in a nonblocking way
Input Parameters:
+ sendbuf - starting address of the send buffer (choice)
. sendcount - number of elements in send buffer (non-negative integer)
. sendtype - data type of send buffer elements (handle)
. recvcount - number of elements received from any process (non-negative integer)
. recvtype - data type of receive buffer elements (handle)
- comm - communicator (handle)
Output Parameters:
+ recvbuf - starting address of the receive buffer (choice)
- request - communication request (handle)
.N ThreadSafe
.N Fortran
.N Errors
@*/
int MPI_Ialltoall(const void *sendbuf, int sendcount, MPI_Datatype sendtype,
void *recvbuf, int recvcount, MPI_Datatype recvtype,
MPI_Comm comm, MPI_Request *request)
{
int mpi_errno = MPI_SUCCESS;
MPID_Comm *comm_ptr = NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_IALLTOALL);
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_IALLTOALL);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
if (sendbuf != MPI_IN_PLACE)
MPIR_ERRTEST_DATATYPE(sendtype, "sendtype", mpi_errno);
MPIR_ERRTEST_DATATYPE(recvtype, "recvtype", mpi_errno);
MPIR_ERRTEST_COMM(comm, mpi_errno);
/* TODO more checks may be appropriate */
}
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
{
MPID_Comm_valid_ptr(comm_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
if (sendbuf != MPI_IN_PLACE && HANDLE_GET_KIND(sendtype) != HANDLE_KIND_BUILTIN) {
MPID_Datatype *sendtype_ptr = NULL;
MPID_Datatype_get_ptr(sendtype, sendtype_ptr);
MPID_Datatype_valid_ptr(sendtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPID_Datatype_committed_ptr(sendtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
if (HANDLE_GET_KIND(recvtype) != HANDLE_KIND_BUILTIN) {
MPID_Datatype *recvtype_ptr = NULL;
MPID_Datatype_get_ptr(recvtype, recvtype_ptr);
MPID_Datatype_valid_ptr(recvtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPID_Datatype_committed_ptr(recvtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPIR_ERRTEST_ARGNULL(request,"request", mpi_errno);
/* TODO more checks may be appropriate (counts, in_place, buffer aliasing, etc) */
}
MPID_END_ERROR_CHECKS
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Ialltoall_impl(sendbuf, sendcount, sendtype, recvbuf, recvcount, recvtype, comm_ptr, request);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_IALLTOALL);
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_ialltoall", "**mpi_ialltoall %p %d %D %p %d %D %C %p", sendbuf, sendcount, sendtype, recvbuf, recvcount, recvtype, comm, request);
}
# endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
goto fn_exit;
}
/*@
MPI_Intercomm_merge - Creates an intracommuncator from an intercommunicator
Input Parameters:
+ intercomm - Intercommunicator (handle)
- high - Used to order the groups within comm (logical)
when creating the new communicator. This is a boolean value; the group
that sets high true has its processes ordered `after` the group that sets
this value to false. If all processes in the intercommunicator provide
the same value, the choice of which group is ordered first is arbitrary.
Output Parameters:
. newintracomm - Created intracommunicator (handle)
Notes:
While all processes may provide the same value for the 'high' parameter,
this requires the MPI implementation to determine which group of
processes should be ranked first.
.N ThreadSafe
.N Fortran
Algorithm:
.Eb
.i Allocate contexts
.i Local and remote group leaders swap high values
.i Determine the high value.
.i Merge the two groups and make the intra-communicator
.Ee
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_EXHAUSTED
.seealso: MPI_Intercomm_create, MPI_Comm_free
@*/
int MPI_Intercomm_merge(MPI_Comm intercomm, int high, MPI_Comm *newintracomm)
{
int mpi_errno = MPI_SUCCESS;
MPID_Comm *comm_ptr = NULL;
MPID_Comm *new_intracomm_ptr;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_INTERCOMM_MERGE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_INTERCOMM_MERGE);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(intercomm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPID_Comm_get_ptr( intercomm, 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, FALSE );
/* If comm_ptr is not valid, it will be reset to null */
if (comm_ptr && comm_ptr->comm_kind != MPID_INTERCOMM) {
mpi_errno = MPIR_Err_create_code( MPI_SUCCESS,
MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_COMM,
"**commnotinter", 0 );
}
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Make sure that we have a local intercommunicator */
if (!comm_ptr->local_comm) {
/* Manufacture the local communicator */
MPIR_Setup_intercomm_localcomm( comm_ptr );
}
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
int acthigh;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
/* Check for consistent valus of high in each local group.
The Intel test suite checks for this; it is also an easy
error to make */
acthigh = high ? 1 : 0; /* Clamp high into 1 or 0 */
mpi_errno = MPIR_Allreduce_impl( MPI_IN_PLACE, &acthigh, 1, MPI_INT,
MPI_SUM, comm_ptr->local_comm, &errflag );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* acthigh must either == 0 or the size of the local comm */
if (acthigh != 0 && acthigh != comm_ptr->local_size) {
mpi_errno = MPIR_Err_create_code( MPI_SUCCESS,
MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_ARG,
"**notsame",
"**notsame %s %s", "high",
"MPI_Intercomm_merge" );
goto fn_fail;
}
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Intercomm_merge_impl(comm_ptr, high, &new_intracomm_ptr);
if (mpi_errno) goto fn_fail;
MPIR_OBJ_PUBLISH_HANDLE(*newintracomm, new_intracomm_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_INTERCOMM_MERGE);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_intercomm_merge",
"**mpi_intercomm_merge %C %d %p", intercomm, high, newintracomm);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
int MPIR_Localcopy(const void *sendbuf, MPI_Aint sendcount, MPI_Datatype sendtype,
void *recvbuf, MPI_Aint recvcount, MPI_Datatype recvtype)
{
int mpi_errno = MPI_SUCCESS;
int sendtype_iscontig, recvtype_iscontig;
MPI_Aint sendsize, recvsize, sdata_sz, rdata_sz, copy_sz;
MPI_Aint true_extent, sendtype_true_lb, recvtype_true_lb;
MPIU_CHKLMEM_DECL(1);
MPID_MPI_STATE_DECL(MPID_STATE_MPIR_LOCALCOPY);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPIR_LOCALCOPY);
MPID_Datatype_get_size_macro(sendtype, sendsize);
MPID_Datatype_get_size_macro(recvtype, recvsize);
sdata_sz = sendsize * sendcount;
rdata_sz = recvsize * recvcount;
/* if there is no data to copy, bail out */
if (!sdata_sz || !rdata_sz)
goto fn_exit;
#if defined(HAVE_ERROR_CHECKING)
if (sdata_sz > rdata_sz) {
MPIU_ERR_SET2(mpi_errno, MPI_ERR_TRUNCATE, "**truncate", "**truncate %d %d", sdata_sz, rdata_sz);
copy_sz = rdata_sz;
}
else
#endif /* HAVE_ERROR_CHECKING */
copy_sz = sdata_sz;
/* Builtin types is the common case; optimize for it */
if ((HANDLE_GET_KIND(sendtype) == HANDLE_KIND_BUILTIN) &&
HANDLE_GET_KIND(recvtype) == HANDLE_KIND_BUILTIN) {
MPIU_Memcpy(recvbuf, sendbuf, copy_sz);
goto fn_exit;
}
MPIR_Datatype_iscontig(sendtype, &sendtype_iscontig);
MPIR_Datatype_iscontig(recvtype, &recvtype_iscontig);
MPIR_Type_get_true_extent_impl(sendtype, &sendtype_true_lb, &true_extent);
MPIR_Type_get_true_extent_impl(recvtype, &recvtype_true_lb, &true_extent);
if (sendtype_iscontig && recvtype_iscontig)
{
#if defined(HAVE_ERROR_CHECKING)
MPIU_ERR_CHKMEMCPYANDJUMP(mpi_errno,
((char *)recvbuf + recvtype_true_lb),
((char *)sendbuf + sendtype_true_lb),
copy_sz);
#endif
MPIU_Memcpy(((char *) recvbuf + recvtype_true_lb),
((char *) sendbuf + sendtype_true_lb),
copy_sz);
}
else if (sendtype_iscontig)
{
MPID_Segment seg;
MPI_Aint last;
MPID_Segment_init(recvbuf, recvcount, recvtype, &seg, 0);
last = copy_sz;
MPID_Segment_unpack(&seg, 0, &last, (char*)sendbuf + sendtype_true_lb);
MPIU_ERR_CHKANDJUMP(last != copy_sz, mpi_errno, MPI_ERR_TYPE, "**dtypemismatch");
}
else if (recvtype_iscontig)
{
MPID_Segment seg;
MPI_Aint last;
MPID_Segment_init(sendbuf, sendcount, sendtype, &seg, 0);
last = copy_sz;
MPID_Segment_pack(&seg, 0, &last, (char*)recvbuf + recvtype_true_lb);
MPIU_ERR_CHKANDJUMP(last != copy_sz, mpi_errno, MPI_ERR_TYPE, "**dtypemismatch");
}
else
{
char * buf;
MPIDI_msg_sz_t buf_off;
MPID_Segment sseg;
MPIDI_msg_sz_t sfirst;
MPID_Segment rseg;
MPIDI_msg_sz_t rfirst;
MPIU_CHKLMEM_MALLOC(buf, char *, COPY_BUFFER_SZ, mpi_errno, "buf");
MPID_Segment_init(sendbuf, sendcount, sendtype, &sseg, 0);
MPID_Segment_init(recvbuf, recvcount, recvtype, &rseg, 0);
sfirst = 0;
rfirst = 0;
buf_off = 0;
while (1)
{
MPI_Aint last;
char * buf_end;
if (copy_sz - sfirst > COPY_BUFFER_SZ - buf_off)
{
last = sfirst + (COPY_BUFFER_SZ - buf_off);
}
else
{
last = copy_sz;
}
MPID_Segment_pack(&sseg, sfirst, &last, buf + buf_off);
MPIU_Assert(last > sfirst);
buf_end = buf + buf_off + (last - sfirst);
sfirst = last;
MPID_Segment_unpack(&rseg, rfirst, &last, buf);
MPIU_Assert(last > rfirst);
rfirst = last;
if (rfirst == copy_sz)
{
/* successful completion */
break;
}
/* if the send side finished, but the recv side couldn't unpack it, there's a datatype mismatch */
MPIU_ERR_CHKANDJUMP(sfirst == copy_sz, mpi_errno, MPI_ERR_TYPE, "**dtypemismatch");
/* if not all data was unpacked, copy it to the front of the buffer for next time */
buf_off = sfirst - rfirst;
if (buf_off > 0)
{
memmove(buf, buf_end - buf_off, buf_off);
}
}
}
fn_exit:
MPIU_CHKLMEM_FREEALL();
MPID_MPI_FUNC_EXIT(MPID_STATE_MPIR_LOCALCOPY);
return mpi_errno;
fn_fail:
goto fn_exit;
}
