/*@
MPI_Comm_spawn_multiple - short description
Input Parameters:
+ count - number of commands (positive integer, significant to MPI only at
root
. array_of_commands - programs to be executed (array of strings, significant
only at root)
. array_of_argv - arguments for commands (array of array of strings,
significant only at root)
. array_of_maxprocs - maximum number of processes to start for each command
(array of integer, significant only at root)
. array_of_info - info objects telling the runtime system where and how to
start processes (array of handles, 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 newly spawned group
(handle)
- array_of_errcodes - one error code per process (array of integer)
.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_multiple(int count, char *array_of_commands[],
char **array_of_argv[], const int array_of_maxprocs[],
const MPI_Info array_of_info[], int root, MPI_Comm comm,
MPI_Comm *intercomm, int array_of_errcodes[])
{
static const char FCNAME[] = "MPI_Comm_spawn_multiple";
int mpi_errno = MPI_SUCCESS, i;
MPID_Comm *comm_ptr = NULL;
MPID_Comm *intercomm_ptr = NULL;
MPID_Info **array_of_info_ptrs = NULL;
MPIU_CHKLMEM_DECL(1);
MPID_MPI_STATE_DECL(MPID_STATE_MPI_COMM_SPAWN_MULTIPLE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_COMM_SPAWN_MULTIPLE);
/* 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_ARGNULL(array_of_commands, "array_of_commands", mpi_errno);
MPIR_ERRTEST_ARGNULL(array_of_maxprocs, "array_of_maxprocs", mpi_errno);
MPIR_ERRTEST_ARGNONPOS(count, "count", mpi_errno, MPI_ERR_COUNT);
for (i = 0; i < count; i++)
{
MPIR_ERRTEST_INFO_OR_NULL(array_of_info[i], mpi_errno);
MPIR_ERRTEST_ARGNULL(array_of_commands[i], "array_of_commands[i]", mpi_errno);
MPIR_ERRTEST_ARGNEG(array_of_maxprocs[i], "array_of_maxprocs[i]", mpi_errno);
}
}
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
if (comm_ptr->rank == root) {
MPIU_CHKLMEM_MALLOC(array_of_info_ptrs, MPID_Info **, count * sizeof(MPID_Info*), mpi_errno, "array of info pointers");
for (i=0; i<count; i++)
{
MPID_Info_get_ptr(array_of_info[i], array_of_info_ptrs[i]);
}
}
/*@
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;
MPIR_Comm *comm_ptr = NULL;
MPIR_Comm *comm_dist_graph_ptr = NULL;
MPIR_Request **reqs = NULL;
MPIR_Topology *topo_ptr = NULL;
MPII_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 };
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
MPIR_CHKLMEM_DECL(9);
MPIR_CHKPMEM_DECL(1);
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_DIST_GRAPH_CREATE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_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 */
MPIR_Comm_get_ptr(comm_old, comm_ptr);
/* Validate parameters and objects (post conversion) */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr */
MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, FALSE);
/* If comm_ptr is not valid, it will be reset to null */
if (comm_ptr) {
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 = MPII_Comm_copy(comm_ptr, comm_size, &comm_dist_graph_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_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. */
MPIR_CHKLMEM_MALLOC(rout, int **, comm_size * sizeof(int *), mpi_errno, "rout", MPL_MEM_COMM);
MPIR_CHKLMEM_MALLOC(rin, int **, comm_size * sizeof(int *), mpi_errno, "rin", MPL_MEM_COMM);
MPIR_CHKLMEM_MALLOC(rin_sizes, int *, comm_size * sizeof(int), mpi_errno, "rin_sizes",
MPL_MEM_COMM);
MPIR_CHKLMEM_MALLOC(rout_sizes, int *, comm_size * sizeof(int), mpi_errno, "rout_sizes",
MPL_MEM_COMM);
MPIR_CHKLMEM_MALLOC(rin_idx, int *, comm_size * sizeof(int), mpi_errno, "rin_idx",
MPL_MEM_COMM);
MPIR_CHKLMEM_MALLOC(rout_idx, int *, comm_size * sizeof(int), mpi_errno, "rout_idx",
MPL_MEM_COMM);
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) {
MPIR_Assert(sources[i] < comm_size);
for (j = 0; j < degrees[i]; ++j) {
MPIR_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] = MPL_malloc(rin_sizes[i] * sizeof(int), MPL_MEM_COMM);
}
if (rout_sizes[i]) {
rout[i] = MPL_malloc(rout_sizes[i] * sizeof(int), MPL_MEM_COMM);
}
}
/* populate arrays */
idx = 0;
for (i = 0; i < n; ++i) {
/* TODO add this assert as proper error checking above */
int s_rank = sources[i];
MPIR_Assert(s_rank < comm_size);
MPIR_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 */
MPIR_Assert(d_rank < comm_size);
MPIR_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 */
MPIR_Assert(rin_idx[i] == rin_sizes[i]);
MPIR_Assert(rout_idx[i] == rout_sizes[i]);
}
MPIR_CHKLMEM_MALLOC(rs, int *, 2 * comm_size * sizeof(int), mpi_errno, "red-scat source buffer",
MPL_MEM_COMM);
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(rs, in_out_peers, 2, MPI_INT, MPI_SUM, comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
MPIR_Assert(in_out_peers[0] <= comm_size && in_out_peers[0] >= 0);
MPIR_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 */
MPIR_CHKLMEM_MALLOC(reqs, MPIR_Request **, 2 * comm_size * sizeof(MPIR_Request *), mpi_errno,
"temp request array", MPL_MEM_COMM);
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_ptr,
&reqs[idx++], &errflag);
if (mpi_errno)
MPIR_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_ptr,
&reqs[idx++], &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
}
MPIR_Assert(idx <= (2 * comm_size));
/* Create the topology structure */
MPIR_CHKPMEM_MALLOC(topo_ptr, MPIR_Topology *, sizeof(MPIR_Topology), mpi_errno, "topo_ptr",
MPL_MEM_COMM);
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 = MPL_malloc(in_capacity * sizeof(int), MPL_MEM_COMM);
if (dist_graph_ptr->is_weighted) {
dist_graph_ptr->in_weights = MPL_malloc(in_capacity * sizeof(int), MPL_MEM_COMM);
MPIR_Assert(dist_graph_ptr->in_weights != NULL);
}
out_capacity = 10; /* arbitrary */
dist_graph_ptr->out = MPL_malloc(out_capacity * sizeof(int), MPL_MEM_COMM);
if (dist_graph_ptr->is_weighted) {
dist_graph_ptr->out_weights = MPL_malloc(out_capacity * sizeof(int), MPL_MEM_COMM);
MPIR_Assert(dist_graph_ptr->out_weights);
}
for (i = 0; i < in_out_peers[0]; ++i) {
MPI_Status status;
MPI_Aint count;
int *buf;
/* receive inbound edges */
mpi_errno = MPIC_Probe(MPI_ANY_SOURCE, MPIR_TOPO_A_TAG, comm_old, &status);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_Get_count_impl(&status, MPI_INT, &count);
/* can't use CHKLMEM macros b/c we are in a loop */
/* FIXME: Why not - there is only one allocated at a time. Is it only
* that there is no defined macro to pop and free an item? */
buf = MPL_malloc(count * sizeof(int), MPL_MEM_COMM);
MPIR_ERR_CHKANDJUMP(!buf, mpi_errno, MPI_ERR_OTHER, "**nomem");
mpi_errno =
MPIC_Recv(buf, count, MPI_INT, MPI_ANY_SOURCE, MPIR_TOPO_A_TAG, comm_ptr,
MPI_STATUS_IGNORE, &errflag);
/* FIXME: buf is never freed on error! */
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
for (j = 0; j < count / 2; ++j) {
int deg = dist_graph_ptr->indegree++;
if (deg >= in_capacity) {
in_capacity *= 2;
/* FIXME: buf is never freed on error! */
MPIR_REALLOC_ORJUMP(dist_graph_ptr->in, in_capacity * sizeof(int), MPL_MEM_COMM,
mpi_errno);
if (dist_graph_ptr->is_weighted)
/* FIXME: buf is never freed on error! */
MPIR_REALLOC_ORJUMP(dist_graph_ptr->in_weights, in_capacity * sizeof(int),
MPL_MEM_COMM, 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];
}
MPL_free(buf);
}
for (i = 0; i < in_out_peers[1]; ++i) {
MPI_Status status;
MPI_Aint count;
int *buf;
/* receive outbound edges */
mpi_errno = MPIC_Probe(MPI_ANY_SOURCE, MPIR_TOPO_B_TAG, comm_old, &status);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_Get_count_impl(&status, MPI_INT, &count);
/* can't use CHKLMEM macros b/c we are in a loop */
/* Why not? */
buf = MPL_malloc(count * sizeof(int), MPL_MEM_COMM);
MPIR_ERR_CHKANDJUMP(!buf, mpi_errno, MPI_ERR_OTHER, "**nomem");
mpi_errno =
MPIC_Recv(buf, count, MPI_INT, MPI_ANY_SOURCE, MPIR_TOPO_B_TAG, comm_ptr,
MPI_STATUS_IGNORE, &errflag);
/* FIXME: buf is never freed on error! */
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
for (j = 0; j < count / 2; ++j) {
int deg = dist_graph_ptr->outdegree++;
if (deg >= out_capacity) {
out_capacity *= 2;
/* FIXME: buf is never freed on error! */
MPIR_REALLOC_ORJUMP(dist_graph_ptr->out, out_capacity * sizeof(int), MPL_MEM_COMM,
mpi_errno);
if (dist_graph_ptr->is_weighted)
/* FIXME: buf is never freed on error! */
MPIR_REALLOC_ORJUMP(dist_graph_ptr->out_weights, out_capacity * sizeof(int),
MPL_MEM_COMM, 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];
}
MPL_free(buf);
}
mpi_errno = MPIC_Waitall(idx, reqs, MPI_STATUSES_IGNORE, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* remove any excess memory allocation */
MPIR_REALLOC_ORJUMP(dist_graph_ptr->in, dist_graph_ptr->indegree * sizeof(int), MPL_MEM_COMM,
mpi_errno);
MPIR_REALLOC_ORJUMP(dist_graph_ptr->out, dist_graph_ptr->outdegree * sizeof(int), MPL_MEM_COMM,
mpi_errno);
if (dist_graph_ptr->is_weighted) {
MPIR_REALLOC_ORJUMP(dist_graph_ptr->in_weights, dist_graph_ptr->indegree * sizeof(int),
MPL_MEM_COMM, mpi_errno);
MPIR_REALLOC_ORJUMP(dist_graph_ptr->out_weights, dist_graph_ptr->outdegree * sizeof(int),
MPL_MEM_COMM, mpi_errno);
}
mpi_errno = MPIR_Topology_put(comm_dist_graph_ptr, topo_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_CHKPMEM_COMMIT();
MPIR_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) {
MPL_free(rin[i]);
MPL_free(rout[i]);
}
MPIR_CHKLMEM_FREEALL();
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_DIST_GRAPH_CREATE);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
fn_fail:
if (dist_graph_ptr) {
MPL_free(dist_graph_ptr->in);
MPL_free(dist_graph_ptr->in_weights);
MPL_free(dist_graph_ptr->out);
MPL_free(dist_graph_ptr->out_weights);
}
MPIR_CHKPMEM_REAP();
#ifdef HAVE_ERROR_CHECKING
mpi_errno =
MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, __func__, __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, __func__, 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_Exscan - Computes the exclusive scan (partial reductions) of data on a
collection of processes
Input Parameters:
+ sendbuf - starting address of send buffer (choice)
. count - number of elements in input buffer (integer)
. datatype - data type of elements of input buffer (handle)
. op - operation (handle)
- comm - communicator (handle)
Output Parameter:
. recvbuf - starting address of receive buffer (choice)
Notes:
'MPI_Exscan' is like 'MPI_Scan', except that the contribution from the
calling process is not included in the result at the calling process
(it is contributed to the subsequent processes, of course).
.N ThreadSafe
.N Fortran
.N collops
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_COUNT
.N MPI_ERR_TYPE
.N MPI_ERR_BUFFER
.N MPI_ERR_BUFFER_ALIAS
@*/
int MPI_Exscan(void *sendbuf, void *recvbuf, int count, MPI_Datatype datatype,
MPI_Op op, MPI_Comm comm)
{
int mpi_errno = MPI_SUCCESS;
MPID_Comm *comm_ptr = NULL;
int errflag = FALSE;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_EXSCAN);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_COLL_FUNC_ENTER(MPID_STATE_MPI_EXSCAN);
/* 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;
{
MPID_Datatype *datatype_ptr = NULL;
MPID_Op *op_ptr = NULL;
int rank;
MPID_Comm_valid_ptr( comm_ptr, mpi_errno );
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPIR_ERRTEST_COMM_INTRA(comm_ptr, mpi_errno);
MPIR_ERRTEST_COUNT(count, mpi_errno);
MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno);
MPIR_ERRTEST_OP(op, mpi_errno);
if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) {
MPID_Datatype_get_ptr(datatype, datatype_ptr);
MPID_Datatype_valid_ptr( datatype_ptr, mpi_errno );
MPID_Datatype_committed_ptr( datatype_ptr, mpi_errno );
}
rank = comm_ptr->rank;
MPIR_ERRTEST_USERBUFFER(sendbuf,count,datatype,mpi_errno);
if (rank != 0) {
MPIR_ERRTEST_RECVBUF_INPLACE(recvbuf, count, mpi_errno);
MPIR_ERRTEST_USERBUFFER(recvbuf,count,datatype,mpi_errno);
}
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
if (HANDLE_GET_KIND(op) != HANDLE_KIND_BUILTIN) {
MPID_Op_get_ptr(op, op_ptr);
MPID_Op_valid_ptr( op_ptr, mpi_errno );
}
if (HANDLE_GET_KIND(op) == HANDLE_KIND_BUILTIN) {
mpi_errno =
( * MPIR_Op_check_dtype_table[op%16 - 1] )(datatype);
}
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Exscan_impl(sendbuf, recvbuf, count, datatype, op, comm_ptr, &errflag);
if (mpi_errno) goto fn_fail;
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_COLL_FUNC_EXIT(MPID_STATE_MPI_EXSCAN);
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_exscan",
"**mpi_exscan %p %p %d %D %O %C", sendbuf, recvbuf, count, datatype, op, comm);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_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_Comm_create_group - Creates a new communicator
Input Parameters:
+ comm - communicator (handle)
. group - group, which is a subset of the group of 'comm' (handle)
- tag - safe tag unused by other communication
Output Parameters:
. newcomm - new communicator (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_GROUP
.seealso: MPI_Comm_free
@*/
int MPI_Comm_create_group(MPI_Comm comm, MPI_Group group, int tag, MPI_Comm * newcomm)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL, *newcomm_ptr;
MPIR_Group *group_ptr;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_COMM_CREATE_GROUP);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_COMM_CREATE_GROUP);
/* Validate parameters, and convert MPI object handles to object pointers */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
MPIR_Comm_get_ptr( comm, comm_ptr );
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr */
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
if (mpi_errno) goto fn_fail;
/* If comm_ptr is not valid, it will be reset to null */
MPIR_ERRTEST_COMM_INTRA(comm_ptr, mpi_errno);
/* only test for MPI_GROUP_NULL after attempting to convert the comm
* so that any errhandlers on comm will (correctly) be invoked */
MPIR_ERRTEST_GROUP(group, mpi_errno);
MPIR_ERRTEST_COMM_TAG(tag, mpi_errno);
}
MPID_END_ERROR_CHECKS;
MPIR_Group_get_ptr( group, group_ptr );
MPID_BEGIN_ERROR_CHECKS;
{
/* Check the group ptr */
MPIR_Group_valid_ptr( group_ptr, mpi_errno );
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# else
{
MPIR_Comm_get_ptr( comm, comm_ptr );
MPIR_Group_get_ptr( group, group_ptr );
}
# endif
/* ... body of routine ... */
mpi_errno = MPIR_Comm_create_group(comm_ptr, group_ptr, tag, &newcomm_ptr);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
if (newcomm_ptr)
MPIR_OBJ_PUBLISH_HANDLE(*newcomm, newcomm_ptr->handle);
else
*newcomm = MPI_COMM_NULL;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_COMM_CREATE_GROUP);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
#ifdef HAVE_ERROR_CHECKING
{
mpi_errno =
MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__,
MPI_ERR_OTHER, "**mpi_comm_create_group",
"**mpi_comm_create_group %C %G %d %p", comm, group, tag,
newcomm);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Iexscan - XXX description here
Input Parameters:
+ sendbuf - starting address of the send buffer (choice)
. count - number of elements in input buffer (non-negative integer)
. datatype - data type of elements of input buffer (handle)
. op - operation (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_Iexscan(const void *sendbuf, void *recvbuf, int count, MPI_Datatype datatype, MPI_Op op, MPI_Comm comm, MPI_Request *request)
{
int mpi_errno = MPI_SUCCESS;
MPID_Comm *comm_ptr = NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_IEXSCAN);
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_IEXSCAN);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno);
MPIR_ERRTEST_OP(op, 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);
MPIR_ERRTEST_COMM_INTRA(comm_ptr, mpi_errno);
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 != MPI_SUCCESS) goto fn_fail;
MPID_Datatype_committed_ptr(datatype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
if (HANDLE_GET_KIND(op) != HANDLE_KIND_BUILTIN) {
MPID_Op *op_ptr = NULL;
MPID_Op_get_ptr(op, op_ptr);
MPID_Op_valid_ptr(op_ptr, mpi_errno);
}
else if (HANDLE_GET_KIND(op) == HANDLE_KIND_BUILTIN) {
mpi_errno = ( * MPIR_OP_HDL_TO_DTYPE_FN(op) )(datatype);
}
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_Iexscan_impl(sendbuf, recvbuf, count, datatype, op, 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_IEXSCAN);
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_iexscan", "**mpi_iexscan %p %p %d %D %O %C %p", sendbuf, recvbuf, count, datatype, op, comm, request);
}
# endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
goto fn_exit;
}
/*@
MPI_Graph_create - Makes a new communicator to which topology information
has been attached
Input Parameters:
+ comm_old - input communicator without topology (handle)
. nnodes - number of nodes in graph (integer)
. indx - array of integers describing node degrees (see below)
. edges - array of integers describing graph edges (see below)
- reorder - ranking may be reordered (true) or not (false) (logical)
Output Parameters:
. comm_graph - communicator with graph topology added (handle)
Notes:
Each process must provide a description of the entire graph, not just the
neigbors of the calling process.
Algorithm:
We ignore the 'reorder' info currently.
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TOPOLOGY
.N MPI_ERR_COMM
.N MPI_ERR_ARG
@*/
int MPI_Graph_create(MPI_Comm comm_old, int nnodes, const int indx[],
const int edges[], int reorder, MPI_Comm *comm_graph)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_GRAPH_CREATE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_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);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr( comm_old, comm_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr */
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
if (mpi_errno) 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(nnodes,"nnodes",mpi_errno);
if (nnodes > 0) {
MPIR_ERRTEST_ARGNULL(indx,"index",mpi_errno);
MPIR_ERRTEST_ARGNULL(edges,"edges",mpi_errno);
}
MPIR_ERRTEST_ARGNULL(comm_graph,"comm_graph",mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
int comm_size = comm_ptr->remote_size;
int i;
/* Check that the communicator is large enough */
if (nnodes > comm_size) {
mpi_errno = MPIR_Err_create_code( MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
FCNAME, __LINE__,
MPI_ERR_ARG,
"**topotoolarge", "**topotoolarge %d %d",
nnodes, comm_size );
}
/* Perform the remaining tests only if nnodes is valid.
This avoids SEGVs from accessing invalid parts of the
edges or index arrays */
if (mpi_errno) goto fn_fail;
/* Check that index is monotone nondecreasing */
/* Use ERR_ARG instead of ERR_TOPOLOGY because there is no
topology yet */
for (i=0; i<nnodes; i++) {
if (indx[i] < 0) {
mpi_errno = MPIR_Err_create_code( MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
FCNAME, __LINE__,
MPI_ERR_ARG,
"**indexneg", "**indexneg %d %d", i, indx[i] );
}
if (i+1<nnodes && indx[i] > indx[i+1]) {
mpi_errno = MPIR_Err_create_code( MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
FCNAME, __LINE__,
MPI_ERR_ARG,
"**indexnonmonotone", "**indexnonmonotone %d %d %d",
i, indx[i], indx[i+1] );
}
}
/* Check that edge number is in range. Note that the
edges refer to a rank in the communicator, and can
be greater than nnodes */
if (nnodes > 0) {
for (i=0; i<indx[nnodes-1]; i++) {
if (edges[i] > comm_size || edges[i] < 0) {
mpi_errno = MPIR_Err_create_code( MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
FCNAME, __LINE__,
MPI_ERR_ARG,
"**edgeoutrange", "**edgeoutrange %d %d %d",
i, edges[i], comm_size );
}
}
}
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
/* Test for empty communicator */
if (nnodes == 0) {
*comm_graph = MPI_COMM_NULL;
goto fn_exit;
}
if (comm_ptr->topo_fns != NULL &&
comm_ptr->topo_fns->graphCreate != NULL) {
/* --BEGIN USEREXTENSION-- */
mpi_errno = comm_ptr->topo_fns->graphCreate( comm_ptr, nnodes,
(const int *)indx,
(const int *)edges,
reorder, comm_graph );
/* --END USEREXTENSION-- */
}
else {
mpi_errno = MPIR_Graph_create( comm_ptr, nnodes,
(const int *)indx,
(const int *)edges,
reorder, comm_graph );
}
if (mpi_errno) goto fn_fail;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_GRAPH_CREATE);
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_graph_create",
"**mpi_graph_create %C %d %p %p %d %p", comm_old, nnodes, indx,
edges, reorder, comm_graph);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Intercomm_create - Creates an intercommuncator from two intracommunicators
Input Parameters:
+ local_comm - Local (intra)communicator
. local_leader - Rank in local_comm of leader (often 0)
. peer_comm - Communicator used to communicate between a
designated process in the other communicator.
Significant only at the process in 'local_comm' with
rank 'local_leader'.
. remote_leader - Rank in peer_comm of remote leader (often 0)
- tag - Message tag to use in constructing intercommunicator; if multiple
'MPI_Intercomm_creates' are being made, they should use different tags (more
precisely, ensure that the local and remote leaders are using different
tags for each 'MPI_intercomm_create').
Output Parameters:
. newintercomm - Created intercommunicator
Notes:
'peer_comm' is significant only for the process designated the
'local_leader' in the 'local_comm'.
The MPI 1.1 Standard contains two mutually exclusive comments on the
input intercommunicators. One says that their repective groups must be
disjoint; the other that the leaders can be the same process. After
some discussion by the MPI Forum, it has been decided that the groups must
be disjoint. Note that the `reason` given for this in the standard is
`not` the reason for this choice; rather, the `other` operations on
intercommunicators (like 'MPI_Intercomm_merge') do not make sense if the
groups are not disjoint.
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_TAG
.N MPI_ERR_EXHAUSTED
.N MPI_ERR_RANK
.seealso: MPI_Intercomm_merge, MPI_Comm_free, MPI_Comm_remote_group,
MPI_Comm_remote_size
@*/
int MPI_Intercomm_create(MPI_Comm local_comm, int local_leader,
MPI_Comm peer_comm, int remote_leader, int tag,
MPI_Comm *newintercomm)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *local_comm_ptr = NULL;
MPIR_Comm *peer_comm_ptr = NULL;
MPIR_Comm *new_intercomm_ptr;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_INTERCOMM_CREATE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_INTERCOMM_CREATE);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM_TAG(tag, mpi_errno);
MPIR_ERRTEST_COMM(local_comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr( local_comm, local_comm_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate local_comm_ptr */
MPIR_Comm_valid_ptr( local_comm_ptr, mpi_errno, FALSE );
if (local_comm_ptr) {
/* Only check if local_comm_ptr valid */
MPIR_ERRTEST_COMM_INTRA(local_comm_ptr, mpi_errno );
if ((local_leader < 0 ||
local_leader >= local_comm_ptr->local_size)) {
MPIR_ERR_SET2(mpi_errno,MPI_ERR_RANK,
"**ranklocal", "**ranklocal %d %d",
local_leader, local_comm_ptr->local_size - 1 );
/* If local_comm_ptr is not valid, it will be reset to null */
if (mpi_errno) goto fn_fail;
}
if (local_comm_ptr->rank == local_leader) {
MPIR_ERRTEST_COMM(peer_comm, mpi_errno);
}
}
MPIR_ERRTEST_ARGNULL(newintercomm, "newintercomm", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
if (local_comm_ptr->rank == local_leader) {
MPIR_Comm_get_ptr( peer_comm, peer_comm_ptr );
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_Comm_valid_ptr( peer_comm_ptr, mpi_errno, FALSE );
/* Note: In MPI 1.0, peer_comm was restricted to
intracommunicators. In 1.1, it may be any communicator */
/* In checking the rank of the remote leader,
allow the peer_comm to be in intercommunicator
by checking against the remote size */
if (!mpi_errno && peer_comm_ptr &&
(remote_leader < 0 ||
remote_leader >= peer_comm_ptr->remote_size)) {
MPIR_ERR_SET2(mpi_errno,MPI_ERR_RANK,
"**rankremote", "**rankremote %d %d",
remote_leader, peer_comm_ptr->remote_size - 1 );
}
/* Check that the local leader and the remote leader are
different processes. This test requires looking at
the lpid for the two ranks in their respective
communicators. However, an easy test is for
the same ranks in an intracommunicator; we only
need the lpid comparison for intercommunicators */
/* Here is the test. We restrict this test to the
process that is the local leader (local_comm_ptr->rank ==
local_leader because we can then use peer_comm_ptr->rank
to get the rank in peer_comm of the local leader. */
if (peer_comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM &&
local_comm_ptr->rank == local_leader &&
peer_comm_ptr->rank == remote_leader) {
MPIR_ERR_SET(mpi_errno,MPI_ERR_RANK,"**ranksdistinct");
}
if (mpi_errno) goto fn_fail;
MPIR_ERRTEST_ARGNULL(newintercomm, "newintercomm", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
}
/* ... body of routine ... */
mpi_errno = MPIR_Intercomm_create_impl(local_comm_ptr, local_leader, peer_comm_ptr,
remote_leader, tag, &new_intercomm_ptr);
if (mpi_errno) goto fn_fail;
MPIR_OBJ_PUBLISH_HANDLE(*newintercomm, new_intercomm_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_INTERCOMM_CREATE);
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_create",
"**mpi_intercomm_create %C %d %C %d %d %p", local_comm,
local_leader, peer_comm, remote_leader, tag, newintercomm);
}
# endif /* HAVE_ERROR_CHECKING */
mpi_errno = MPIR_Err_return_comm( local_comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Iscan - Computes the scan (partial reductions) of data on a collection of
processes in a nonblocking way
Input Parameters:
+ sendbuf - starting address of the send buffer (choice)
. count - number of elements in input buffer (non-negative integer)
. datatype - data type of elements of input buffer (handle)
. op - operation (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_Iscan(const void *sendbuf, void *recvbuf, int count, MPI_Datatype datatype,
MPI_Op op, MPI_Comm comm, MPI_Request * request)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Request *request_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_ISCAN);
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_ISCAN);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno);
MPIR_ERRTEST_COUNT(count, mpi_errno);
MPIR_ERRTEST_OP(op, 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 */
MPIR_Comm_get_ptr(comm, comm_ptr);
/* Validate parameters and objects (post conversion) */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, FALSE);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
MPIR_ERRTEST_COMM_INTRA(comm_ptr, mpi_errno);
if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype *datatype_ptr = NULL;
MPIR_Datatype_get_ptr(datatype, datatype_ptr);
MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
MPIR_Datatype_committed_ptr(datatype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
}
if (HANDLE_GET_KIND(op) != HANDLE_KIND_BUILTIN) {
MPIR_Op *op_ptr = NULL;
MPIR_Op_get_ptr(op, op_ptr);
MPIR_Op_valid_ptr(op_ptr, mpi_errno);
} else if (HANDLE_GET_KIND(op) == HANDLE_KIND_BUILTIN) {
mpi_errno = (*MPIR_OP_HDL_TO_DTYPE_FN(op)) (datatype);
}
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
MPIR_ERRTEST_ARGNULL(request, "request", mpi_errno);
if (sendbuf != MPI_IN_PLACE && count != 0)
MPIR_ERRTEST_ALIAS_COLL(sendbuf, recvbuf, mpi_errno);
/* TODO more checks may be appropriate (counts, in_place, etc) */
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Iscan(sendbuf, recvbuf, count, datatype, op, comm_ptr, &request_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* create a complete request, if needed */
if (!request_ptr)
request_ptr = MPIR_Request_create_complete(MPIR_REQUEST_KIND__COLL);
/* return the handle of the request to the user */
*request = request_ptr->handle;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_ISCAN);
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, __func__, __LINE__, MPI_ERR_OTHER,
"**mpi_iscan", "**mpi_iscan %p %p %d %D %O %C %p", sendbuf,
recvbuf, count, datatype, op, comm, request);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, __func__, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
