int MPID_nem_ptl_init_id(MPIDI_VC_t *vc)
{
int mpi_errno = MPI_SUCCESS;
MPID_nem_ptl_vc_area *const vc_ptl = VC_PTL(vc);
char *bc;
int pmi_errno;
int val_max_sz;
MPIR_CHKLMEM_DECL(1);
MPIR_FUNC_VERBOSE_STATE_DECL(MPID_STATE_MPID_NEM_PTL_INIT_ID);
MPIR_FUNC_VERBOSE_ENTER(MPID_STATE_MPID_NEM_PTL_INIT_ID);
pmi_errno = PMI_KVS_Get_value_length_max(&val_max_sz);
MPIR_ERR_CHKANDJUMP1(pmi_errno, mpi_errno, MPI_ERR_OTHER, "**fail", "**fail %d", pmi_errno);
MPIR_CHKLMEM_MALLOC(bc, char *, val_max_sz, mpi_errno, "bc");
mpi_errno = vc->pg->getConnInfo(vc->pg_rank, bc, val_max_sz, vc->pg);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPID_nem_ptl_get_id_from_bc(bc, &vc_ptl->id, &vc_ptl->pt, &vc_ptl->ptg, &vc_ptl->ptc, &vc_ptl->ptr, &vc_ptl->ptrg, &vc_ptl->ptrc);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
vc_ptl->id_initialized = TRUE;
MPIDI_CHANGE_VC_STATE(vc, ACTIVE);
fn_exit:
MPIR_CHKLMEM_FREEALL();
MPIR_FUNC_VERBOSE_EXIT(MPID_STATE_MPID_NEM_PTL_INIT_ID);
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Reduce_scatter_block_inter_remote_reduce_local_scatter(const void *sendbuf,
void *recvbuf,
int recvcount,
MPI_Datatype datatype,
MPI_Op op,
MPIR_Comm * comm_ptr,
MPIR_Errflag_t * errflag)
{
int rank, mpi_errno, root, local_size, total_count;
int mpi_errno_ret = MPI_SUCCESS;
MPI_Aint true_extent, true_lb = 0, extent;
void *tmp_buf = NULL;
MPIR_Comm *newcomm_ptr = NULL;
MPIR_CHKLMEM_DECL(1);
rank = comm_ptr->rank;
local_size = comm_ptr->local_size;
total_count = local_size * recvcount;
if (rank == 0) {
/* In each group, rank 0 allocates a temp. buffer for the
* reduce */
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
MPIR_Datatype_get_extent_macro(datatype, extent);
MPIR_CHKLMEM_MALLOC(tmp_buf, void *, total_count * (MPL_MAX(extent, true_extent)),
mpi_errno, "tmp_buf", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *) ((char *) tmp_buf - true_lb);
}
int MPIR_Scan_intra_smp(const void *sendbuf, void *recvbuf, int count,
MPI_Datatype datatype, MPI_Op op, MPIR_Comm * comm_ptr,
MPIR_Errflag_t * errflag)
{
int mpi_errno = MPI_SUCCESS;
int mpi_errno_ret = MPI_SUCCESS;
MPIR_CHKLMEM_DECL(3);
int rank = comm_ptr->rank;
MPI_Status status;
void *tempbuf = NULL, *localfulldata = NULL, *prefulldata = NULL;
MPI_Aint true_lb, true_extent, extent;
int noneed = 1; /* noneed=1 means no need to bcast tempbuf and
* reduce tempbuf & recvbuf */
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
MPIR_Datatype_get_extent_macro(datatype, extent);
MPIR_Ensure_Aint_fits_in_pointer(count * MPL_MAX(extent, true_extent));
MPIR_CHKLMEM_MALLOC(tempbuf, void *, count * (MPL_MAX(extent, true_extent)),
mpi_errno, "temporary buffer", MPL_MEM_BUFFER);
tempbuf = (void *) ((char *) tempbuf - true_lb);
/* Create prefulldata and localfulldata on local roots of all nodes */
if (comm_ptr->node_roots_comm != NULL) {
MPIR_CHKLMEM_MALLOC(prefulldata, void *, count * (MPL_MAX(extent, true_extent)),
mpi_errno, "prefulldata for scan", MPL_MEM_BUFFER);
prefulldata = (void *) ((char *) prefulldata - true_lb);
if (comm_ptr->node_comm != NULL) {
MPIR_CHKLMEM_MALLOC(localfulldata, void *, count * (MPL_MAX(extent, true_extent)),
mpi_errno, "localfulldata for scan", MPL_MEM_BUFFER);
localfulldata = (void *) ((char *) localfulldata - true_lb);
}
int MPIR_Reduce_intra_reduce_scatter_gather (
const void *sendbuf,
void *recvbuf,
int count,
MPI_Datatype datatype,
MPI_Op op,
int root,
MPIR_Comm *comm_ptr,
MPIR_Errflag_t *errflag )
{
int mpi_errno = MPI_SUCCESS;
int mpi_errno_ret = MPI_SUCCESS;
int comm_size, rank, type_size ATTRIBUTE((unused)), pof2, rem, newrank;
int mask, *cnts, *disps, i, j, send_idx=0;
int recv_idx, last_idx=0, newdst;
int dst, send_cnt, recv_cnt, newroot, newdst_tree_root, newroot_tree_root;
MPI_Aint true_lb, true_extent, extent;
void *tmp_buf;
MPIR_CHKLMEM_DECL(4);
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
/* set op_errno to 0. stored in perthread structure */
{
MPIR_Per_thread_t *per_thread = NULL;
int err = 0;
MPID_THREADPRIV_KEY_GET_ADDR(MPIR_ThreadInfo.isThreaded, MPIR_Per_thread_key,
MPIR_Per_thread, per_thread, &err);
MPIR_Assert(err == 0);
per_thread->op_errno = 0;
}
/* Create a temporary buffer */
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
MPIR_Datatype_get_extent_macro(datatype, extent);
/* I think this is the worse case, so we can avoid an assert()
* inside the for loop */
/* should be buf+{this}? */
MPIR_Ensure_Aint_fits_in_pointer(count * MPL_MAX(extent, true_extent));
MPIR_CHKLMEM_MALLOC(tmp_buf, void *, count*(MPL_MAX(extent,true_extent)),
mpi_errno, "temporary buffer", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *)((char*)tmp_buf - true_lb);
/* If I'm not the root, then my recvbuf may not be valid, therefore
I have to allocate a temporary one */
if (rank != root) {
MPIR_CHKLMEM_MALLOC(recvbuf, void *,
count*(MPL_MAX(extent,true_extent)),
mpi_errno, "receive buffer", MPL_MEM_BUFFER);
recvbuf = (void *)((char*)recvbuf - true_lb);
}
/*@
MPI_Waitsome - Waits for some given MPI Requests to complete
Input Parameters:
+ incount - length of array_of_requests (integer)
- array_of_requests - array of requests (array of handles)
Output Parameters:
+ outcount - number of completed requests (integer)
. array_of_indices - array of indices of operations that
completed (array of integers)
- array_of_statuses - array of status objects for
operations that completed (array of Status). May be 'MPI_STATUSES_IGNORE'.
Notes:
The array of indicies are in the range '0' to 'incount - 1' for C and
in the range '1' to 'incount' for Fortran.
Null requests are ignored; if all requests are null, then the routine
returns with 'outcount' set to 'MPI_UNDEFINED'.
While it is possible to list a request handle more than once in the
array_of_requests, such an action is considered erroneous and may cause the
program to unexecpectedly terminate or produce incorrect results.
'MPI_Waitsome' provides an interface much like the Unix 'select' or 'poll'
calls and, in a high qualilty implementation, indicates all of the requests
that have completed when 'MPI_Waitsome' is called.
However, 'MPI_Waitsome' only guarantees that at least one
request has completed; there is no guarantee that `all` completed requests
will be returned, or that the entries in 'array_of_indices' will be in
increasing order. Also, requests that are completed while 'MPI_Waitsome' is
executing may or may not be returned, depending on the timing of the
completion of the message.
.N waitstatus
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_REQUEST
.N MPI_ERR_ARG
.N MPI_ERR_IN_STATUS
@*/
int MPI_Waitsome(int incount, MPI_Request array_of_requests[],
int *outcount, int array_of_indices[],
MPI_Status array_of_statuses[])
{
static const char FCNAME[] = "MPI_Waitsome";
MPIR_Request * request_ptr_array[MPIR_REQUEST_PTR_ARRAY_SIZE];
MPIR_Request ** request_ptrs = request_ptr_array;
MPI_Status * status_ptr;
MPID_Progress_state progress_state;
int i;
int n_active;
int n_inactive;
int active_flag;
int rc = MPI_SUCCESS;
int disabled_anysource = FALSE;
int mpi_errno = MPI_SUCCESS;
MPIR_CHKLMEM_DECL(1);
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_WAITSOME);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_PT2PT_ENTER(MPID_STATE_MPI_WAITSOME);
/* Check the arguments */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COUNT(incount, mpi_errno);
if (incount != 0) {
MPIR_ERRTEST_ARGNULL(array_of_requests, "array_of_requests", mpi_errno);
MPIR_ERRTEST_ARGNULL(array_of_indices, "array_of_indices", mpi_errno);
/* NOTE: MPI_STATUSES_IGNORE != NULL */
MPIR_ERRTEST_ARGNULL(array_of_statuses, "array_of_statuses", mpi_errno);
}
MPIR_ERRTEST_ARGNULL(outcount, "outcount", mpi_errno);
for (i = 0; i < incount; i++) {
MPIR_ERRTEST_ARRAYREQUEST_OR_NULL(array_of_requests[i], i, mpi_errno);
}
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
*outcount = 0;
/* Convert MPI request handles to a request object pointers */
if (incount > MPIR_REQUEST_PTR_ARRAY_SIZE)
{
MPIR_CHKLMEM_MALLOC_ORJUMP(request_ptrs, MPIR_Request **, incount * sizeof(MPIR_Request *), mpi_errno, "request pointers", MPL_MEM_OBJECT);
}
static int MPIDI_CH3I_Win_detect_shm(MPIR_Win ** win_ptr)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Win *shm_win_ptr = NULL;
int i, node_size;
MPI_Aint *base_shm_offs;
MPIR_CHKPMEM_DECL(1);
MPIR_CHKLMEM_DECL(1);
MPIR_FUNC_VERBOSE_STATE_DECL(MPID_STATE_MPIDI_CH3I_WIN_DETECT_SHM);
MPIR_FUNC_VERBOSE_RMA_ENTER(MPID_STATE_MPIDI_CH3I_WIN_DETECT_SHM);
if ((*win_ptr)->comm_ptr->node_comm == NULL) {
goto fn_exit;
}
node_size = (*win_ptr)->comm_ptr->node_comm->local_size;
MPIR_CHKLMEM_MALLOC(base_shm_offs, MPI_Aint *, node_size * sizeof(MPI_Aint),
mpi_errno, "base_shm_offs");
/* Return the first matched shared window.
* It is noted that the shared windows including all local processes are
* stored in every local process in the same order, hence the first matched
* shared window on every local process should be the same. */
mpi_errno = MPIDI_CH3I_SHM_Wins_match(win_ptr, &shm_win_ptr, &base_shm_offs);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
if (shm_win_ptr == NULL)
goto fn_exit;
(*win_ptr)->shm_allocated = TRUE;
MPIR_CHKPMEM_MALLOC((*win_ptr)->shm_base_addrs, void **,
node_size * sizeof(void *), mpi_errno, "(*win_ptr)->shm_base_addrs");
/* Compute the base address of shm buffer on each process.
* shm_base_addrs[i] = my_shm_base_addr + off[i] */
for (i = 0; i < node_size; i++) {
(*win_ptr)->shm_base_addrs[i] =
(void *) ((MPI_Aint) shm_win_ptr->shm_base_addr + base_shm_offs[i]);
}
/* TODO: should we use the same mutex or create a new one ?
* It causes unnecessary synchronization.*/
(*win_ptr)->shm_mutex = shm_win_ptr->shm_mutex;
fn_exit:
MPIR_CHKLMEM_FREEALL();
MPIR_FUNC_VERBOSE_RMA_EXIT(MPID_STATE_MPIDI_CH3I_WIN_DETECT_SHM);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
fn_fail:
MPIR_CHKPMEM_REAP();
goto fn_exit;
/* --END ERROR HANDLING-- */
}
int MPIR_Ineighbor_alltoallw_sched_allcomm_linear(const void *sendbuf, const int sendcounts[],
const MPI_Aint sdispls[],
const MPI_Datatype sendtypes[], void *recvbuf,
const int recvcounts[], const MPI_Aint rdispls[],
const MPI_Datatype recvtypes[],
MPIR_Comm * comm_ptr, MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int indegree, outdegree, weighted;
int k, l;
int *srcs, *dsts;
MPIR_CHKLMEM_DECL(2);
mpi_errno = MPIR_Topo_canon_nhb_count(comm_ptr, &indegree, &outdegree, &weighted);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_CHKLMEM_MALLOC(srcs, int *, indegree * sizeof(int), mpi_errno, "srcs", MPL_MEM_COMM);
MPIR_CHKLMEM_MALLOC(dsts, int *, outdegree * sizeof(int), mpi_errno, "dsts", MPL_MEM_COMM);
mpi_errno = MPIR_Topo_canon_nhb(comm_ptr,
indegree, srcs, MPI_UNWEIGHTED,
outdegree, dsts, MPI_UNWEIGHTED);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
for (k = 0; k < outdegree; ++k) {
char *sb;
MPIR_Ensure_Aint_fits_in_pointer(MPIR_VOID_PTR_CAST_TO_MPI_AINT sendbuf + sdispls[k]);
sb = ((char *) sendbuf) + sdispls[k];
mpi_errno = MPIR_Sched_send(sb, sendcounts[k], sendtypes[k], dsts[k], comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
for (l = 0; l < indegree; ++l) {
char *rb;
MPIR_Ensure_Aint_fits_in_pointer(MPIR_VOID_PTR_CAST_TO_MPI_AINT recvbuf + rdispls[l]);
rb = ((char *) recvbuf) + rdispls[l];
mpi_errno = MPIR_Sched_recv(rb, recvcounts[l], recvtypes[l], srcs[l], comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
MPIR_SCHED_BARRIER(s);
fn_exit:
MPIR_CHKLMEM_FREEALL();
return mpi_errno;
fn_fail:
goto fn_exit;
}
/*@
MPI_Testany - Tests for completion of any previdously initiated
requests
Input Parameters:
+ count - list length (integer)
- array_of_requests - array of requests (array of handles)
Output Parameters:
+ indx - index of operation that completed, or 'MPI_UNDEFINED' if none
completed (integer)
. flag - true if one of the operations is complete (logical)
- status - status object (Status). May be 'MPI_STATUS_IGNORE'.
Notes:
While it is possible to list a request handle more than once in the
'array_of_requests', such an action is considered erroneous and may cause the
program to unexecpectedly terminate or produce incorrect results.
.N ThreadSafe
.N waitstatus
.N Fortran
.N Errors
.N MPI_SUCCESS
@*/
int MPI_Testany(int count, MPI_Request array_of_requests[], int *indx,
int *flag, MPI_Status * status)
{
MPIR_Request *request_ptr_array[MPIR_REQUEST_PTR_ARRAY_SIZE];
MPIR_Request **request_ptrs = request_ptr_array;
int i;
int n_inactive;
int last_disabled_anysource = -1;
int first_nonnull = count;
int mpi_errno = MPI_SUCCESS;
MPIR_CHKLMEM_DECL(1);
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TESTANY);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(VCI_GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_REQUEST_ENTER(MPID_STATE_MPI_TESTANY);
/* Check the arguments */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COUNT(count, mpi_errno);
if (count != 0) {
MPIR_ERRTEST_ARGNULL(array_of_requests, "array_of_requests", mpi_errno);
/* NOTE: MPI_STATUS_IGNORE != NULL */
MPIR_ERRTEST_ARGNULL(status, "status", mpi_errno);
}
MPIR_ERRTEST_ARGNULL(indx, "indx", mpi_errno);
MPIR_ERRTEST_ARGNULL(flag, "flag", mpi_errno);
for (i = 0; i < count; i++) {
MPIR_ERRTEST_ARRAYREQUEST_OR_NULL(array_of_requests[i], i, mpi_errno);
}
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
/* Convert MPI request handles to a request object pointers */
if (count > MPIR_REQUEST_PTR_ARRAY_SIZE) {
MPIR_CHKLMEM_MALLOC_ORJUMP(request_ptrs, MPIR_Request **, count * sizeof(MPIR_Request *),
mpi_errno, "request pointers", MPL_MEM_OBJECT);
}
/*@
MPI_Waitany - Waits for any specified MPI Request to complete
Input Parameters:
+ count - list length (integer)
- array_of_requests - array of requests (array of handles)
Output Parameters:
+ indx - index of handle for operation that completed (integer). In the
range '0' to 'count-1'. In Fortran, the range is '1' to 'count'.
- status - status object (Status). May be 'MPI_STATUS_IGNORE'.
Notes:
If all of the requests are 'MPI_REQUEST_NULL', then 'indx' is returned as
'MPI_UNDEFINED', and 'status' is returned as an empty status.
While it is possible to list a request handle more than once in the
array_of_requests, such an action is considered erroneous and may cause the
program to unexecpectedly terminate or produce incorrect results.
.N waitstatus
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_REQUEST
.N MPI_ERR_ARG
@*/
int MPI_Waitany(int count, MPI_Request array_of_requests[], int *indx,
MPI_Status *status)
{
static const char FCNAME[] = "MPI_Waitany";
MPIR_Request * request_ptr_array[MPIR_REQUEST_PTR_ARRAY_SIZE];
MPIR_Request ** request_ptrs = request_ptr_array;
MPID_Progress_state progress_state;
int i;
int n_inactive;
int active_flag;
int init_req_array;
int found_nonnull_req;
int last_disabled_anysource = -1;
int mpi_errno = MPI_SUCCESS;
MPIR_CHKLMEM_DECL(1);
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_WAITANY);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_PT2PT_ENTER(MPID_STATE_MPI_WAITANY);
/* Check the arguments */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COUNT(count, mpi_errno);
if (count != 0) {
MPIR_ERRTEST_ARGNULL(array_of_requests, "array_of_requests", mpi_errno);
/* NOTE: MPI_STATUS_IGNORE != NULL */
MPIR_ERRTEST_ARGNULL(status, "status", mpi_errno);
}
MPIR_ERRTEST_ARGNULL(indx, "indx", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
/* Convert MPI request handles to a request object pointers */
if (count > MPIR_REQUEST_PTR_ARRAY_SIZE)
{
MPIR_CHKLMEM_MALLOC_ORJUMP(request_ptrs, MPIR_Request **, count * sizeof(MPIR_Request *), mpi_errno, "request pointers");
}
int MPIR_Ineighbor_allgatherv_sched_allcomm_linear(const void *sendbuf, int sendcount,
MPI_Datatype sendtype, void *recvbuf,
const int recvcounts[], const int displs[],
MPI_Datatype recvtype, MPIR_Comm * comm_ptr,
MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int indegree, outdegree, weighted;
int k, l;
int *srcs, *dsts;
MPI_Aint recvtype_extent;
MPIR_CHKLMEM_DECL(2);
MPIR_Datatype_get_extent_macro(recvtype, recvtype_extent);
mpi_errno = MPIR_Topo_canon_nhb_count(comm_ptr, &indegree, &outdegree, &weighted);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_CHKLMEM_MALLOC(srcs, int *, indegree * sizeof(int), mpi_errno, "srcs", MPL_MEM_COMM);
MPIR_CHKLMEM_MALLOC(dsts, int *, outdegree * sizeof(int), mpi_errno, "dsts", MPL_MEM_COMM);
mpi_errno = MPIR_Topo_canon_nhb(comm_ptr,
indegree, srcs, MPI_UNWEIGHTED,
outdegree, dsts, MPI_UNWEIGHTED);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
for (k = 0; k < outdegree; ++k) {
mpi_errno = MPIR_Sched_send(sendbuf, sendcount, sendtype, dsts[k], comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
for (l = 0; l < indegree; ++l) {
char *rb = ((char *) recvbuf) + displs[l] * recvtype_extent;
mpi_errno = MPIR_Sched_recv(rb, recvcounts[l], recvtype, srcs[l], comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
MPIR_SCHED_BARRIER(s);
fn_exit:
MPIR_CHKLMEM_FREEALL();
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Type_indexed_impl(int count, const int *array_of_blocklengths,
const int *array_of_displacements,
MPI_Datatype oldtype, MPI_Datatype * newtype)
{
int mpi_errno = MPI_SUCCESS;
MPI_Datatype new_handle;
MPIR_Datatype *new_dtp;
int i, *ints;
MPIR_CHKLMEM_DECL(1);
mpi_errno = MPIR_Type_indexed(count, array_of_blocklengths, array_of_displacements, 0, /* displacements not in bytes */
oldtype, &new_handle);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* copy all integer values into a temporary buffer; this
* includes the count, the blocklengths, and the displacements.
*/
MPIR_CHKLMEM_MALLOC(ints, int *, (2 * count + 1) * sizeof(int), mpi_errno,
"contents integer array", MPL_MEM_BUFFER);
ints[0] = count;
for (i = 0; i < count; i++) {
ints[i + 1] = array_of_blocklengths[i];
}
for (i = 0; i < count; i++) {
ints[i + count + 1] = array_of_displacements[i];
}
MPIR_Datatype_get_ptr(new_handle, new_dtp);
mpi_errno = MPIR_Datatype_set_contents(new_dtp, MPI_COMBINER_INDEXED, 2 * count + 1, /* ints */
0, /* aints */
1, /* types */
ints, NULL, &oldtype);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_OBJ_PUBLISH_HANDLE(*newtype, new_handle);
fn_exit:
MPIR_CHKLMEM_FREEALL();
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPII_Genutil_sched_sink(MPII_Genutil_sched_t * sched)
{
MPL_DBG_MSG_FMT(MPIR_DBG_COLL, VERBOSE,
(MPL_DBG_FDEST, "Gentran: sched [sink] total=%d", sched->total_vtcs));
vtx_t *vtxp;
int i, n_in_vtcs = 0, vtx_id;
int *in_vtcs;
int mpi_errno = MPI_SUCCESS;
MPIR_CHKLMEM_DECL(1);
/* assign a new vertex */
vtx_id = MPII_Genutil_vtx_create(sched, &vtxp);
vtxp->vtx_kind = MPII_GENUTIL_VTX_KIND__SINK;
MPIR_CHKLMEM_MALLOC(in_vtcs, int *, sizeof(int) * vtx_id,
mpi_errno, "in_vtcs buffer", MPL_MEM_COLL);
/* record incoming vertices */
for (i = vtx_id - 1; i >= 0; i--) {
vtx_t *sched_fence = (vtx_t *) utarray_eltptr(sched->vtcs, i);
MPIR_Assert(sched_fence != NULL);
if (sched_fence->vtx_kind == MPII_GENUTIL_VTX_KIND__FENCE)
/* no need to record this and any vertex before fence.
* Dependency on the last fence call will be added by
* the subsequent call to MPIC_Genutil_vtx_add_dependencies function */
break;
else {
in_vtcs[vtx_id - 1 - i] = i;
n_in_vtcs++;
}
}
MPII_Genutil_vtx_add_dependencies(sched, vtx_id, n_in_vtcs, in_vtcs);
fn_exit:
MPIR_CHKLMEM_FREEALL();
return vtx_id;
fn_fail:
goto fn_exit;
}
/* This function implements a binomial tree reduce.
Cost = lgp.alpha + n.lgp.beta + n.lgp.gamma
*/
int MPIR_Reduce_intra_binomial(const void *sendbuf,
void *recvbuf,
int count,
MPI_Datatype datatype,
MPI_Op op, int root, MPIR_Comm * comm_ptr, MPIR_Errflag_t * errflag)
{
int mpi_errno = MPI_SUCCESS;
int mpi_errno_ret = MPI_SUCCESS;
MPI_Status status;
int comm_size, rank, is_commutative, type_size ATTRIBUTE((unused));
int mask, relrank, source, lroot;
MPI_Aint true_lb, true_extent, extent;
void *tmp_buf;
MPIR_CHKLMEM_DECL(2);
if (count == 0)
return MPI_SUCCESS;
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
/* Create a temporary buffer */
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
MPIR_Datatype_get_extent_macro(datatype, extent);
is_commutative = MPIR_Op_is_commutative(op);
MPIR_CHKLMEM_MALLOC(tmp_buf, void *, count * (MPL_MAX(extent, true_extent)),
mpi_errno, "temporary buffer", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *) ((char *) tmp_buf - true_lb);
/* If I'm not the root, then my recvbuf may not be valid, therefore
* I have to allocate a temporary one */
if (rank != root) {
MPIR_CHKLMEM_MALLOC(recvbuf, void *,
count * (MPL_MAX(extent, true_extent)),
mpi_errno, "receive buffer", MPL_MEM_BUFFER);
recvbuf = (void *) ((char *) recvbuf - true_lb);
}
int MPIR_Waitall_impl(int count, MPI_Request array_of_requests[],
MPI_Status array_of_statuses[])
{
int mpi_errno = MPI_SUCCESS;
MPIR_Request * request_ptr_array[MPIR_REQUEST_PTR_ARRAY_SIZE];
MPIR_Request ** request_ptrs = request_ptr_array;
MPI_Status * status_ptr = NULL;
MPID_Progress_state progress_state;
int i, j;
int n_completed;
int active_flag;
int rc = MPI_SUCCESS;
int n_greqs;
int proc_failure = FALSE;
int disabled_anysource = FALSE;
const int ignoring_statuses = (array_of_statuses == MPI_STATUSES_IGNORE);
int optimize = ignoring_statuses; /* see NOTE-O1 */
MPIR_CHKLMEM_DECL(1);
/* Convert MPI request handles to a request object pointers */
if (count > MPIR_REQUEST_PTR_ARRAY_SIZE)
{
MPIR_CHKLMEM_MALLOC(request_ptrs, MPIR_Request **, count * sizeof(MPIR_Request *), mpi_errno, "request pointers", MPL_MEM_OBJECT);
}
/*@
MPI_Startall - Starts a collection of persistent requests
Input Parameters:
+ count - list length (integer)
- array_of_requests - array of requests (array of handle)
Notes:
Unlike 'MPI_Waitall', 'MPI_Startall' does not provide a mechanism for
returning multiple errors nor pinpointing the request(s) involved.
Furthermore, the behavior of 'MPI_Startall' after an error occurs is not
defined by the MPI standard. If well-defined error reporting and behavior
are required, multiple calls to 'MPI_Start' should be used instead.
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_ARG
.N MPI_ERR_REQUEST
@*/
int MPI_Startall(int count, MPI_Request array_of_requests[])
{
static const char FCNAME[] = "MPI_Startall";
MPIR_Request * request_ptr_array[MPIR_REQUEST_PTR_ARRAY_SIZE];
MPIR_Request ** request_ptrs = request_ptr_array;
int i;
int mpi_errno = MPI_SUCCESS;
MPIR_CHKLMEM_DECL(1);
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_STARTALL);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_PT2PT_ENTER(MPID_STATE_MPI_STARTALL);
/* Validate handle parameters needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COUNT(count, mpi_errno);
MPIR_ERRTEST_ARGNULL(array_of_requests,"array_of_requests", mpi_errno);
for (i = 0; i < count; i++) {
MPIR_ERRTEST_REQUEST(array_of_requests[i], mpi_errno);
}
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI request handles to a request object pointers */
if (count > MPIR_REQUEST_PTR_ARRAY_SIZE)
{
MPIR_CHKLMEM_MALLOC_ORJUMP(request_ptrs, MPIR_Request **, count * sizeof(MPIR_Request *), mpi_errno, "request pointers");
}
int MPIR_Allgather_intra_brucks (
const void *sendbuf,
int sendcount,
MPI_Datatype sendtype,
void *recvbuf,
int recvcount,
MPI_Datatype recvtype,
MPIR_Comm *comm_ptr,
MPIR_Errflag_t *errflag )
{
int comm_size, rank;
int mpi_errno = MPI_SUCCESS;
int mpi_errno_ret = MPI_SUCCESS;
MPI_Aint recvtype_extent;
MPI_Aint recvtype_true_extent, recvbuf_extent, recvtype_true_lb;
int pof2, src, rem;
void *tmp_buf = NULL;
int curr_cnt, dst;
MPIR_CHKLMEM_DECL(1);
if (((sendcount == 0) && (sendbuf != MPI_IN_PLACE)) || (recvcount == 0))
return MPI_SUCCESS;
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
MPIR_Datatype_get_extent_macro( recvtype, recvtype_extent );
/* This is the largest offset we add to recvbuf */
MPIR_Ensure_Aint_fits_in_pointer(MPIR_VOID_PTR_CAST_TO_MPI_AINT recvbuf +
(comm_size * recvcount * recvtype_extent));
/* allocate a temporary buffer of the same size as recvbuf. */
/* get true extent of recvtype */
MPIR_Type_get_true_extent_impl(recvtype, &recvtype_true_lb, &recvtype_true_extent);
recvbuf_extent = recvcount * comm_size * (MPL_MAX(recvtype_true_extent, recvtype_extent));
MPIR_CHKLMEM_MALLOC(tmp_buf, void*, recvbuf_extent, mpi_errno, "tmp_buf", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *)((char*)tmp_buf - recvtype_true_lb);
/* copy local data to the top of tmp_buf */
if (sendbuf != MPI_IN_PLACE) {
mpi_errno = MPIR_Localcopy (sendbuf, sendcount, sendtype,
tmp_buf, recvcount, recvtype);
if (mpi_errno) {
MPIR_ERR_POP(mpi_errno);
}
}
else {
mpi_errno = MPIR_Localcopy (((char *)recvbuf +
rank * recvcount * recvtype_extent),
recvcount, recvtype, tmp_buf,
recvcount, recvtype);
if (mpi_errno) {
MPIR_ERR_POP(mpi_errno);
}
}
/* do the first \floor(\lg p) steps */
curr_cnt = recvcount;
pof2 = 1;
while (pof2 <= comm_size/2) {
src = (rank + pof2) % comm_size;
dst = (rank - pof2 + comm_size) % comm_size;
mpi_errno = MPIC_Sendrecv(tmp_buf, curr_cnt, recvtype, dst,
MPIR_ALLGATHER_TAG,
((char *)tmp_buf + curr_cnt*recvtype_extent),
curr_cnt, recvtype,
src, MPIR_ALLGATHER_TAG, comm_ptr,
MPI_STATUS_IGNORE, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
curr_cnt *= 2;
pof2 *= 2;
}
/* if comm_size is not a power of two, one more step is needed */
rem = comm_size - pof2;
if (rem) {
src = (rank + pof2) % comm_size;
dst = (rank - pof2 + comm_size) % comm_size;
mpi_errno = MPIC_Sendrecv(tmp_buf, rem * recvcount, recvtype,
dst, MPIR_ALLGATHER_TAG,
((char *)tmp_buf + curr_cnt*recvtype_extent),
rem * recvcount, recvtype,
src, MPIR_ALLGATHER_TAG, comm_ptr,
MPI_STATUS_IGNORE, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
}
/* Rotate blocks in tmp_buf down by (rank) blocks and store
* result in recvbuf. */
mpi_errno = MPIR_Localcopy(tmp_buf, (comm_size-rank)*recvcount,
recvtype, (char *) recvbuf + rank*recvcount*recvtype_extent,
(comm_size-rank)*recvcount, recvtype);
if (mpi_errno) {
MPIR_ERR_POP(mpi_errno);
}
if (rank) {
mpi_errno = MPIR_Localcopy((char *) tmp_buf +
(comm_size-rank)*recvcount*recvtype_extent,
rank*recvcount, recvtype, recvbuf,
rank*recvcount, recvtype);
if (mpi_errno) {
MPIR_ERR_POP(mpi_errno);
}
}
fn_exit:
MPIR_CHKLMEM_FREEALL();
if (mpi_errno_ret)
mpi_errno = mpi_errno_ret;
else if (*errflag != MPIR_ERR_NONE)
MPIR_ERR_SET(mpi_errno, *errflag, "**coll_fail");
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Allreduce_intra_reduce_scatter_allgather(
const void *sendbuf,
void *recvbuf,
int count,
MPI_Datatype datatype,
MPI_Op op,
MPIR_Comm * comm_ptr,
MPIR_Errflag_t * errflag)
{
MPIR_CHKLMEM_DECL(3);
#ifdef MPID_HAS_HETERO
int is_homogeneous;
int rc;
#endif
int comm_size, rank;
int mpi_errno = MPI_SUCCESS;
int mpi_errno_ret = MPI_SUCCESS;
int mask, dst, pof2, newrank, rem, newdst, i,
send_idx, recv_idx, last_idx, send_cnt, recv_cnt, *cnts, *disps;
MPI_Aint true_extent, true_lb, extent;
void *tmp_buf;
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
/* need to allocate temporary buffer to store incoming data*/
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
MPIR_Datatype_get_extent_macro(datatype, extent);
MPIR_Ensure_Aint_fits_in_pointer(count * MPL_MAX(extent, true_extent));
MPIR_CHKLMEM_MALLOC(tmp_buf, void *, count*(MPL_MAX(extent,true_extent)), mpi_errno, "temporary buffer", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *)((char*)tmp_buf - true_lb);
/* copy local data into recvbuf */
if (sendbuf != MPI_IN_PLACE) {
mpi_errno = MPIR_Localcopy(sendbuf, count, datatype, recvbuf,
count, datatype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
/* get nearest power-of-two less than or equal to comm_size */
pof2 = comm_ptr->pof2;
rem = comm_size - pof2;
/* In the non-power-of-two case, all even-numbered
processes of rank < 2*rem send their data to
(rank+1). These even-numbered processes no longer
participate in the algorithm until the very end. The
remaining processes form a nice power-of-two. */
if (rank < 2*rem) {
if (rank % 2 == 0) { /* even */
mpi_errno = MPIC_Send(recvbuf, count,
datatype, rank+1,
MPIR_ALLREDUCE_TAG, comm_ptr, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
/* temporarily set the rank to -1 so that this
process does not pariticipate in recursive
doubling */
newrank = -1;
}
else { /* odd */
mpi_errno = MPIC_Recv(tmp_buf, count,
datatype, rank-1,
MPIR_ALLREDUCE_TAG, comm_ptr,
MPI_STATUS_IGNORE, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
/* do the reduction on received data. since the
ordering is right, it doesn't matter whether
the operation is commutative or not. */
mpi_errno = MPIR_Reduce_local(tmp_buf, recvbuf, count, datatype, op);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* change the rank */
newrank = rank / 2;
}
}
else /* rank >= 2*rem */
newrank = rank - rem;
/* If op is user-defined or count is less than pof2, use
recursive doubling algorithm. Otherwise do a reduce-scatter
followed by allgather. (If op is user-defined,
derived datatypes are allowed and the user could pass basic
datatypes on one process and derived on another as long as
the type maps are the same. Breaking up derived
datatypes to do the reduce-scatter is tricky, therefore
using recursive doubling in that case.) */
#ifdef HAVE_ERROR_CHECKING
MPIR_Assert(HANDLE_GET_KIND(op)==HANDLE_KIND_BUILTIN);
MPIR_Assert(count >= pof2);
#endif /* HAVE_ERROR_CHECKING */
if (newrank != -1) {
MPIR_CHKLMEM_MALLOC(cnts, int *, pof2*sizeof(int), mpi_errno, "counts", MPL_MEM_BUFFER);
MPIR_CHKLMEM_MALLOC(disps, int *, pof2*sizeof(int), mpi_errno, "displacements", MPL_MEM_BUFFER);
for (i=0; i<pof2; i++)
cnts[i] = count/pof2;
if ((count % pof2) > 0) {
for (i=0; i<(count % pof2); i++)
cnts[i] += 1;
}
disps[0] = 0;
for (i=1; i<pof2; i++)
disps[i] = disps[i-1] + cnts[i-1];
mask = 0x1;
send_idx = recv_idx = 0;
last_idx = pof2;
while (mask < pof2) {
newdst = newrank ^ mask;
/* find real rank of dest */
dst = (newdst < rem) ? newdst*2 + 1 : newdst + rem;
send_cnt = recv_cnt = 0;
if (newrank < newdst) {
send_idx = recv_idx + pof2/(mask*2);
for (i=send_idx; i<last_idx; i++)
send_cnt += cnts[i];
for (i=recv_idx; i<send_idx; i++)
recv_cnt += cnts[i];
}
else {
recv_idx = send_idx + pof2/(mask*2);
for (i=send_idx; i<recv_idx; i++)
send_cnt += cnts[i];
for (i=recv_idx; i<last_idx; i++)
recv_cnt += cnts[i];
}
/* Send data from recvbuf. Recv into tmp_buf */
mpi_errno = MPIC_Sendrecv((char *) recvbuf +
disps[send_idx]*extent,
send_cnt, datatype,
dst, MPIR_ALLREDUCE_TAG,
(char *) tmp_buf +
disps[recv_idx]*extent,
recv_cnt, datatype, dst,
MPIR_ALLREDUCE_TAG, comm_ptr,
MPI_STATUS_IGNORE, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
/* tmp_buf contains data received in this step.
recvbuf contains data accumulated so far */
/* This algorithm is used only for predefined ops
and predefined ops are always commutative. */
mpi_errno = MPIR_Reduce_local(((char *) tmp_buf + disps[recv_idx]*extent),
((char *) recvbuf + disps[recv_idx]*extent),
recv_cnt, datatype, op);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* update send_idx for next iteration */
send_idx = recv_idx;
mask <<= 1;
/* update last_idx, but not in last iteration
because the value is needed in the allgather
step below. */
if (mask < pof2)
last_idx = recv_idx + pof2/mask;
}
/* now do the allgather */
mask >>= 1;
while (mask > 0) {
newdst = newrank ^ mask;
/* find real rank of dest */
dst = (newdst < rem) ? newdst*2 + 1 : newdst + rem;
send_cnt = recv_cnt = 0;
if (newrank < newdst) {
/* update last_idx except on first iteration */
if (mask != pof2/2)
last_idx = last_idx + pof2/(mask*2);
recv_idx = send_idx + pof2/(mask*2);
for (i=send_idx; i<recv_idx; i++)
send_cnt += cnts[i];
for (i=recv_idx; i<last_idx; i++)
recv_cnt += cnts[i];
}
else {
recv_idx = send_idx - pof2/(mask*2);
for (i=send_idx; i<last_idx; i++)
send_cnt += cnts[i];
for (i=recv_idx; i<send_idx; i++)
recv_cnt += cnts[i];
}
mpi_errno = MPIC_Sendrecv((char *) recvbuf +
disps[send_idx]*extent,
send_cnt, datatype,
dst, MPIR_ALLREDUCE_TAG,
(char *) recvbuf +
disps[recv_idx]*extent,
recv_cnt, datatype, dst,
MPIR_ALLREDUCE_TAG, comm_ptr,
MPI_STATUS_IGNORE, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
if (newrank > newdst) send_idx = recv_idx;
mask >>= 1;
}
}
static int MPIDI_CH3I_SHM_Wins_match(MPIR_Win ** win_ptr, MPIR_Win ** matched_win,
MPI_Aint ** base_shm_offs_ptr)
{
int mpi_errno = MPI_SUCCESS;
int i, comm_size;
int node_size, node_rank, shm_node_size;
int group_diff;
int base_diff;
MPIR_Comm *node_comm_ptr = NULL, *shm_node_comm_ptr = NULL;
int *node_ranks = NULL, *node_ranks_in_shm_node = NULL;
MPIR_Group *node_group_ptr = NULL, *shm_node_group_ptr = NULL;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
MPI_Aint *base_shm_offs;
MPIDI_SHM_Win_t *elem = shm_wins_list;
MPIR_CHKLMEM_DECL(2);
MPIR_FUNC_VERBOSE_STATE_DECL(MPID_STATE_MPIDI_CH3I_SHM_WINS_MATCH);
MPIR_FUNC_VERBOSE_RMA_ENTER(MPID_STATE_MPIDI_CH3I_SHM_WINS_MATCH);
*matched_win = NULL;
base_shm_offs = *base_shm_offs_ptr;
node_comm_ptr = (*win_ptr)->comm_ptr->node_comm;
MPIR_Assert(node_comm_ptr != NULL);
node_size = node_comm_ptr->local_size;
node_rank = node_comm_ptr->rank;
comm_size = (*win_ptr)->comm_ptr->local_size;
MPIR_CHKLMEM_MALLOC(node_ranks, int *, node_size * sizeof(int), mpi_errno, "node_ranks");
MPIR_CHKLMEM_MALLOC(node_ranks_in_shm_node, int *, node_size * sizeof(int),
mpi_errno, "node_ranks_in_shm_comm");
for (i = 0; i < node_size; i++) {
node_ranks[i] = i;
}
mpi_errno = MPIR_Comm_group_impl(node_comm_ptr, &node_group_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
while (elem != NULL) {
MPIR_Win *shm_win = elem->win;
if (!shm_win)
MPIDI_SHM_Wins_next_and_continue(elem);
/* Compare node_comm.
*
* Only support shm if new node_comm is equal to or a subset of shm node_comm.
* Shm node_comm == a subset of node_comm is not supported, because it means
* some processes of node_comm cannot be shared, but RMA operation simply checks
* the node_id of a target process for distinguishing shm target. */
shm_node_comm_ptr = shm_win->comm_ptr->node_comm;
shm_node_size = shm_node_comm_ptr->local_size;
if (node_size > shm_node_size)
MPIDI_SHM_Wins_next_and_continue(elem);
mpi_errno = MPIR_Comm_group_impl(shm_win->comm_ptr, &shm_node_group_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Group_translate_ranks_impl(node_group_ptr, node_size,
node_ranks, shm_node_group_ptr,
node_ranks_in_shm_node);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Group_free_impl(shm_node_group_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
shm_node_group_ptr = NULL;
group_diff = 0;
for (i = 0; i < node_size; i++) {
/* not exist in shm_comm->node_comm */
if (node_ranks_in_shm_node[i] == MPI_UNDEFINED) {
group_diff = 1;
break;
}
}
if (group_diff)
MPIDI_SHM_Wins_next_and_continue(elem);
/* Gather the offset of base_addr from all local processes. Match only
* when all of them are included in the shm segment in current shm_win.
*
* Note that this collective call must be called after checking the
* group match in order to guarantee all the local processes can perform
* this call. */
base_shm_offs[node_rank] = (MPI_Aint) ((*win_ptr)->base)
- (MPI_Aint) (shm_win->shm_base_addr);
mpi_errno = MPIR_Allgather_impl(MPI_IN_PLACE, 0, MPI_DATATYPE_NULL,
base_shm_offs, 1, MPI_AINT, node_comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
base_diff = 0;
for (i = 0; i < comm_size; ++i) {
int i_node_rank = (*win_ptr)->comm_ptr->intranode_table[i];
if (i_node_rank >= 0) {
MPIR_Assert(i_node_rank < node_size);
if (base_shm_offs[i_node_rank] < 0 ||
base_shm_offs[i_node_rank] + (*win_ptr)->basic_info_table[i].size >
shm_win->shm_segment_len) {
base_diff = 1;
break;
}
}
}
if (base_diff)
MPIDI_SHM_Wins_next_and_continue(elem);
/* Found the first matched shm_win */
*matched_win = shm_win;
break;
}
fn_exit:
if (node_group_ptr != NULL)
mpi_errno = MPIR_Group_free_impl(node_group_ptr);
/* Only free it here when group_translate_ranks fails. */
if (shm_node_group_ptr != NULL)
mpi_errno = MPIR_Group_free_impl(shm_node_group_ptr);
MPIR_CHKLMEM_FREEALL();
MPIR_FUNC_VERBOSE_RMA_EXIT(MPID_STATE_MPIDI_CH3I_SHM_WINS_MATCH);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
fn_fail:
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Type_create_hindexed - Create a datatype for an indexed datatype with
displacements in bytes
Input Parameters:
+ count - number of blocks --- also number of entries in
array_of_displacements and array_of_blocklengths (integer)
. array_of_blocklengths - number of elements in each block (array of nonnegative integers)
. array_of_displacements - byte displacement of each block (array of address integers)
- 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_hindexed(int count,
const int array_of_blocklengths[],
const MPI_Aint array_of_displacements[],
MPI_Datatype oldtype,
MPI_Datatype *newtype)
{
static const char FCNAME[] = "MPI_Type_create_hindexed";
int mpi_errno = MPI_SUCCESS;
MPI_Datatype new_handle;
MPIR_Datatype *new_dtp;
int i, *ints;
MPIR_CHKLMEM_DECL(1);
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_CREATE_HINDEXED);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TYPE_CREATE_HINDEXED);
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
int j;
MPIR_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) {
MPIR_Datatype_get_ptr(oldtype, datatype_ptr);
MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
for (j=0; j < count; j++) {
MPIR_ERRTEST_ARGNEG(array_of_blocklengths[j], "blocklength", mpi_errno);
}
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Type_indexed(count,
array_of_blocklengths,
array_of_displacements,
1, /* displacements in bytes */
oldtype,
&new_handle);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPIR_CHKLMEM_MALLOC_ORJUMP(ints, int *, (count + 1) * sizeof(int), mpi_errno, "content description", MPL_MEM_BUFFER);
ints[0] = count;
for (i=0; i < count; i++)
{
ints[i+1] = array_of_blocklengths[i];
}
MPIR_Datatype_get_ptr(new_handle, new_dtp);
mpi_errno = MPIR_Datatype_set_contents(new_dtp,
MPI_COMBINER_HINDEXED,
count+1, /* ints (count, blocklengths) */
count, /* aints (displacements) */
1, /* types */
ints,
array_of_displacements,
&oldtype);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPIR_OBJ_PUBLISH_HANDLE(*newtype, new_handle);
/* ... end of body of routine ... */
fn_exit:
MPIR_CHKLMEM_FREEALL();
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_CREATE_HINDEXED);
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_hindexed",
"**mpi_type_create_hindexed %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-- */
}
int MPIR_Alltoall_intra_scattered(
const void *sendbuf,
int sendcount,
MPI_Datatype sendtype,
void *recvbuf,
int recvcount,
MPI_Datatype recvtype,
MPIR_Comm *comm_ptr,
MPIR_Errflag_t *errflag )
{
int comm_size, i, j;
MPI_Aint sendtype_extent, recvtype_extent;
int mpi_errno=MPI_SUCCESS, dst, rank;
int mpi_errno_ret = MPI_SUCCESS;
MPI_Datatype newtype = MPI_DATATYPE_NULL;
MPIR_Request **reqarray;
MPI_Status *starray;
MPIR_CHKLMEM_DECL(6);
if (recvcount == 0) return MPI_SUCCESS;
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
#ifdef HAVE_ERROR_CHECKING
MPIR_Assert(sendbuf != MPI_IN_PLACE);
#endif /* HAVE_ERROR_CHECKING */
/* Get extent of send and recv types */
MPIR_Datatype_get_extent_macro(recvtype, recvtype_extent);
MPIR_Datatype_get_extent_macro(sendtype, sendtype_extent);
int ii, ss, bblock;
bblock = MPIR_CVAR_ALLTOALL_THROTTLE;
if (bblock == 0) bblock = comm_size;
MPIR_CHKLMEM_MALLOC(reqarray, MPIR_Request **, 2*bblock*sizeof(MPIR_Request*), mpi_errno, "reqarray", MPL_MEM_BUFFER);
MPIR_CHKLMEM_MALLOC(starray, MPI_Status *, 2*bblock*sizeof(MPI_Status), mpi_errno, "starray", MPL_MEM_BUFFER);
for (ii=0; ii<comm_size; ii+=bblock) {
ss = comm_size-ii < bblock ? comm_size-ii : bblock;
/* do the communication -- post ss sends and receives: */
for ( i=0; i<ss; i++ ) {
dst = (rank+i+ii) % comm_size;
mpi_errno = MPIC_Irecv((char *)recvbuf +
dst*recvcount*recvtype_extent,
recvcount, recvtype, dst,
MPIR_ALLTOALL_TAG, comm_ptr,
&reqarray[i]);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
for ( i=0; i<ss; i++ ) {
dst = (rank-i-ii+comm_size) % comm_size;
mpi_errno = MPIC_Isend((char *)sendbuf +
dst*sendcount*sendtype_extent,
sendcount, sendtype, dst,
MPIR_ALLTOALL_TAG, comm_ptr,
&reqarray[i+ss], errflag);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
/* ... then wait for them to finish: */
mpi_errno = MPIC_Waitall(2*ss,reqarray,starray, errflag);
if (mpi_errno && mpi_errno != MPI_ERR_IN_STATUS) MPIR_ERR_POP(mpi_errno);
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno == MPI_ERR_IN_STATUS) {
for (j=0; j<2*ss; j++) {
if (starray[j].MPI_ERROR != MPI_SUCCESS) {
mpi_errno = starray[j].MPI_ERROR;
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
}
}
}
/* --END ERROR HANDLING-- */
}
fn_exit:
MPIR_CHKLMEM_FREEALL();
if (mpi_errno_ret)
mpi_errno = mpi_errno_ret;
else if (*errflag != MPIR_ERR_NONE)
MPIR_ERR_SET(mpi_errno, *errflag, "**coll_fail");
return mpi_errno;
fn_fail:
if (newtype != MPI_DATATYPE_NULL)
MPIR_Type_free_impl(&newtype);
goto fn_exit;
}
/* MPIR_Find_external -- from the list of processes in comm,
* builds a list of external processes, i.e., one process from each node.
* You can think of this as the root or master process for each node.
*
* Note that this will not work correctly for spawned or attached
* processes.
*
* OUT:
* external_size_p - number of external processes
* external_rank_p - rank of this process among the external
* processes, or -1 if this process is not external
* external_ranks_p - (*external_ranks_p)[i] = the rank in comm
* of the process with external rank i.
* This is of size (*external_size_p)
* internode_table_p - (*internode_table_p)[i] = the rank in
* (optional) *external_ranks_p of the root of the node
* containing rank i in comm. It is of size
* comm->remote_size. No return if NULL is specified.
*/
int MPIR_Find_external(MPIR_Comm * comm, int *external_size_p, int *external_rank_p,
int **external_ranks_p, int **internode_table_p)
{
int mpi_errno = MPI_SUCCESS;
int *nodes;
int i, external_size, external_rank;
int *external_ranks, *internode_table;
int max_node_id, node_id;
MPIR_CHKLMEM_DECL(1);
MPIR_CHKPMEM_DECL(2);
/* Scan through the list of processes in comm and add one
* process from each node to the list of "external" processes. We
* add the first process we find from each node. nodes[] is an
* array where we keep track of whether we have already added that
* node to the list. */
/* external_ranks will be realloc'ed later to the appropriate size (currently unknown) */
/* FIXME: realloc doesn't guarantee that the allocated area will be
* shrunk - so using realloc is not an appropriate strategy. */
MPIR_CHKPMEM_MALLOC(external_ranks, int *, sizeof(int) * comm->remote_size, mpi_errno,
"external_ranks", MPL_MEM_COMM);
MPIR_CHKPMEM_MALLOC(internode_table, int *, sizeof(int) * comm->remote_size, mpi_errno,
"internode_table", MPL_MEM_COMM);
mpi_errno = MPID_Get_max_node_id(comm, &max_node_id);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_Assert(max_node_id >= 0);
MPIR_CHKLMEM_MALLOC(nodes, int *, sizeof(int) * (max_node_id + 1), mpi_errno, "nodes",
MPL_MEM_COMM);
/* nodes maps node_id to rank in external_ranks of leader for that node */
for (i = 0; i < (max_node_id + 1); ++i)
nodes[i] = -1;
external_size = 0;
external_rank = -1;
for (i = 0; i < comm->remote_size; ++i) {
mpi_errno = MPID_Get_node_id(comm, i, &node_id);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* The upper level can catch this non-fatal error and should be
* able to recover gracefully. */
MPIR_ERR_CHKANDJUMP(node_id < 0, mpi_errno, MPI_ERR_OTHER, "**dynamic_node_ids");
MPIR_Assert(node_id <= max_node_id);
/* build list of external processes */
if (nodes[node_id] == -1) {
if (i == comm->rank)
external_rank = external_size;
nodes[node_id] = external_size;
external_ranks[external_size] = i;
++external_size;
}
/* build the map from rank in comm to rank in external_ranks */
internode_table[i] = nodes[node_id];
}
#ifdef ENABLE_DEBUG
printf("------------------------------------------------------------------------\n");
printf("[%d]comm = %p\n", comm->rank, comm);
printf("[%d]comm->size = %d\n", comm->rank, comm->remote_size);
printf("[%d]comm->rank = %d\n", comm->rank, comm->rank);
printf("[%d]external_size = %d\n", comm->rank, external_size);
printf("[%d]external_rank = %d\n", comm->rank, external_rank);
printf("[%d]external_ranks = %p\n", comm->rank, external_ranks);
for (i = 0; i < external_size; ++i)
printf("[%d] external_ranks[%d] = %d\n", comm->rank, i, external_ranks[i]);
printf("[%d]internode_table = %p\n", comm->rank, internode_table);
for (i = 0; i < comm->remote_size; ++i)
printf("[%d] internode_table[%d] = %d\n", comm->rank, i, internode_table[i]);
printf("[%d]nodes = %p\n", comm->rank, nodes);
for (i = 0; i < (max_node_id + 1); ++i)
printf("[%d] nodes[%d] = %d\n", comm->rank, i, nodes[i]);
#endif
MPIR_CHKPMEM_COMMIT();
*external_size_p = external_size;
*external_rank_p = external_rank;
*external_ranks_p = MPL_realloc(external_ranks, sizeof(int) * external_size, MPL_MEM_COMM);
MPIR_ERR_CHKANDJUMP(*external_ranks_p == NULL, mpi_errno, MPI_ERR_OTHER, "**nomem2");
if (internode_table_p)
*internode_table_p = internode_table; /* no need to realloc */
else
MPL_free(internode_table); /* free internally if caller passes NULL */
fn_exit:
MPIR_CHKLMEM_FREEALL();
return mpi_errno;
fn_fail:
MPIR_CHKPMEM_REAP();
goto fn_exit;
}
/*@
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-- */
}
static int MPIDI_CH3I_Win_gather_info(void *base, MPI_Aint size, int disp_unit, MPIR_Info * info,
MPIR_Comm * comm_ptr, MPIR_Win ** win_ptr)
{
MPIR_Comm *node_comm_ptr = NULL;
int node_rank;
int comm_rank, comm_size;
MPI_Aint *tmp_buf = NULL;
int i, k;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
int mpi_errno = MPI_SUCCESS;
MPIR_CHKLMEM_DECL(1);
MPIR_FUNC_VERBOSE_STATE_DECL(MPID_STATE_MPIDI_CH3I_WIN_GATHER_INFO);
MPIR_FUNC_VERBOSE_RMA_ENTER(MPID_STATE_MPIDI_CH3I_WIN_GATHER_INFO);
if ((*win_ptr)->comm_ptr->node_comm == NULL) {
mpi_errno = MPIDI_CH3U_Win_gather_info(base, size, disp_unit, info, comm_ptr, win_ptr);
goto fn_exit;
}
comm_size = (*win_ptr)->comm_ptr->local_size;
comm_rank = (*win_ptr)->comm_ptr->rank;
node_comm_ptr = (*win_ptr)->comm_ptr->node_comm;
MPIR_Assert(node_comm_ptr != NULL);
node_rank = node_comm_ptr->rank;
(*win_ptr)->info_shm_segment_len = comm_size * sizeof(MPIDI_Win_basic_info_t);
mpi_errno = MPL_shm_hnd_init(&(*win_ptr)->info_shm_segment_handle);
if (mpi_errno != MPI_SUCCESS)
MPIR_ERR_POP(mpi_errno);
if (node_rank == 0) {
char *serialized_hnd_ptr = NULL;
/* create shared memory region for all processes in win and map. */
mpi_errno = MPL_shm_seg_create_and_attach((*win_ptr)->info_shm_segment_handle,
(*win_ptr)->info_shm_segment_len,
(char **) &(*win_ptr)->info_shm_base_addr, 0);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* serialize handle and broadcast it to the other processes in win */
mpi_errno =
MPL_shm_hnd_get_serialized_by_ref((*win_ptr)->info_shm_segment_handle,
&serialized_hnd_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno =
MPIR_Bcast_impl(serialized_hnd_ptr, MPL_SHM_GHND_SZ, MPI_CHAR, 0, node_comm_ptr,
&errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* wait for other processes to attach to win */
mpi_errno = MPIR_Barrier_impl(node_comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* unlink shared memory region so it gets deleted when all processes exit */
mpi_errno = MPL_shm_seg_remove((*win_ptr)->info_shm_segment_handle);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
else {
char serialized_hnd[MPL_SHM_GHND_SZ] = { 0 };
/* get serialized handle from rank 0 and deserialize it */
mpi_errno =
MPIR_Bcast_impl(serialized_hnd, MPL_SHM_GHND_SZ, MPI_CHAR, 0, node_comm_ptr,
&errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
mpi_errno = MPL_shm_hnd_deserialize((*win_ptr)->info_shm_segment_handle, serialized_hnd,
strlen(serialized_hnd));
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* attach to shared memory region created by rank 0 */
mpi_errno =
MPL_shm_seg_attach((*win_ptr)->info_shm_segment_handle,
(*win_ptr)->info_shm_segment_len,
(char **) &(*win_ptr)->info_shm_base_addr, 0);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Barrier_impl(node_comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
}
(*win_ptr)->basic_info_table = (MPIDI_Win_basic_info_t *) ((*win_ptr)->info_shm_base_addr);
MPIR_CHKLMEM_MALLOC(tmp_buf, MPI_Aint *, 4 * comm_size * sizeof(MPI_Aint),
mpi_errno, "tmp_buf");
tmp_buf[4 * comm_rank] = MPIR_Ptr_to_aint(base);
tmp_buf[4 * comm_rank + 1] = size;
tmp_buf[4 * comm_rank + 2] = (MPI_Aint) disp_unit;
tmp_buf[4 * comm_rank + 3] = (MPI_Aint) (*win_ptr)->handle;
mpi_errno = MPIR_Allgather_impl(MPI_IN_PLACE, 0, MPI_DATATYPE_NULL, tmp_buf, 4, MPI_AINT,
(*win_ptr)->comm_ptr, &errflag);
if (mpi_errno != MPI_SUCCESS)
MPIR_ERR_POP(mpi_errno);
if (node_rank == 0) {
/* only node_rank == 0 writes results to basic_info_table on shared memory region. */
k = 0;
for (i = 0; i < comm_size; i++) {
(*win_ptr)->basic_info_table[i].base_addr = MPIR_Aint_to_ptr(tmp_buf[k++]);
(*win_ptr)->basic_info_table[i].size = tmp_buf[k++];
(*win_ptr)->basic_info_table[i].disp_unit = (int) tmp_buf[k++];
(*win_ptr)->basic_info_table[i].win_handle = (MPI_Win) tmp_buf[k++];
}
}
/* Make sure that all local processes see the results written by node_rank == 0 */
mpi_errno = MPIR_Barrier_impl(node_comm_ptr, &errflag);
if (mpi_errno != MPI_SUCCESS)
MPIR_ERR_POP(mpi_errno);
fn_exit:
MPIR_CHKLMEM_FREEALL();
MPIR_FUNC_VERBOSE_RMA_EXIT(MPID_STATE_MPIDI_CH3I_WIN_GATHER_INFO);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
fn_fail:
goto fn_exit;
/* --END ERROR HANDLING-- */
}
static int MPIDI_CH3I_Win_allocate_shm(MPI_Aint size, int disp_unit, MPIR_Info * info,
MPIR_Comm * comm_ptr, void *base_ptr, MPIR_Win ** win_ptr)
{
int mpi_errno = MPI_SUCCESS;
void **base_pp = (void **) base_ptr;
int i, node_size, node_rank;
MPIR_Comm *node_comm_ptr;
MPI_Aint *node_sizes;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
int noncontig = FALSE;
MPIR_CHKPMEM_DECL(1);
MPIR_CHKLMEM_DECL(1);
MPIR_FUNC_VERBOSE_STATE_DECL(MPID_STATE_MPIDI_CH3I_WIN_ALLOCATE_SHM);
MPIR_FUNC_VERBOSE_RMA_ENTER(MPID_STATE_MPIDI_CH3I_WIN_ALLOCATE_SHM);
if ((*win_ptr)->comm_ptr->node_comm == NULL) {
mpi_errno =
MPIDI_CH3U_Win_allocate_no_shm(size, disp_unit, info, comm_ptr, base_ptr, win_ptr);
goto fn_exit;
}
/* see if we can allocate all windows contiguously */
noncontig = (*win_ptr)->info_args.alloc_shared_noncontig;
(*win_ptr)->shm_allocated = TRUE;
/* When allocating shared memory region segment, we need comm of processes
* that are on the same node as this process (node_comm).
* If node_comm == NULL, this process is the only one on this node, therefore
* we use comm_self as node comm. */
node_comm_ptr = (*win_ptr)->comm_ptr->node_comm;
MPIR_Assert(node_comm_ptr != NULL);
node_size = node_comm_ptr->local_size;
node_rank = node_comm_ptr->rank;
MPIR_T_PVAR_TIMER_START(RMA, rma_wincreate_allgather);
/* allocate memory for the base addresses, disp_units, and
* completion counters of all processes */
MPIR_CHKPMEM_MALLOC((*win_ptr)->shm_base_addrs, void **,
node_size * sizeof(void *), mpi_errno, "(*win_ptr)->shm_base_addrs");
/* get the sizes of the windows and window objectsof
* all processes. allocate temp. buffer for communication */
MPIR_CHKLMEM_MALLOC(node_sizes, MPI_Aint *, node_size * sizeof(MPI_Aint), mpi_errno,
"node_sizes");
/* FIXME: This needs to be fixed for heterogeneous systems */
node_sizes[node_rank] = (MPI_Aint) size;
mpi_errno = MPIR_Allgather_impl(MPI_IN_PLACE, 0, MPI_DATATYPE_NULL,
node_sizes, sizeof(MPI_Aint), MPI_BYTE,
node_comm_ptr, &errflag);
MPIR_T_PVAR_TIMER_END(RMA, rma_wincreate_allgather);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
(*win_ptr)->shm_segment_len = 0;
for (i = 0; i < node_size; i++) {
if (noncontig)
/* Round up to next page size */
(*win_ptr)->shm_segment_len += MPIDI_CH3_ROUND_UP_PAGESIZE(node_sizes[i]);
else
(*win_ptr)->shm_segment_len += node_sizes[i];
}
if ((*win_ptr)->shm_segment_len == 0) {
(*win_ptr)->base = NULL;
}
else {
mpi_errno = MPL_shm_hnd_init(&(*win_ptr)->shm_segment_handle);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
if (node_rank == 0) {
char *serialized_hnd_ptr = NULL;
/* create shared memory region for all processes in win and map */
mpi_errno =
MPL_shm_seg_create_and_attach((*win_ptr)->shm_segment_handle,
(*win_ptr)->shm_segment_len,
(char **) &(*win_ptr)->shm_base_addr, 0);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* serialize handle and broadcast it to the other processes in win */
mpi_errno =
MPL_shm_hnd_get_serialized_by_ref((*win_ptr)->shm_segment_handle,
&serialized_hnd_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno =
MPIR_Bcast_impl(serialized_hnd_ptr, MPL_SHM_GHND_SZ, MPI_CHAR, 0, node_comm_ptr,
&errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* wait for other processes to attach to win */
mpi_errno = MPIR_Barrier_impl(node_comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* unlink shared memory region so it gets deleted when all processes exit */
mpi_errno = MPL_shm_seg_remove((*win_ptr)->shm_segment_handle);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
else {
char serialized_hnd[MPL_SHM_GHND_SZ] = { 0 };
/* get serialized handle from rank 0 and deserialize it */
mpi_errno =
MPIR_Bcast_impl(serialized_hnd, MPL_SHM_GHND_SZ, MPI_CHAR, 0, node_comm_ptr,
&errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
mpi_errno =
MPL_shm_hnd_deserialize((*win_ptr)->shm_segment_handle, serialized_hnd,
strlen(serialized_hnd));
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* attach to shared memory region created by rank 0 */
mpi_errno =
MPL_shm_seg_attach((*win_ptr)->shm_segment_handle, (*win_ptr)->shm_segment_len,
(char **) &(*win_ptr)->shm_base_addr, 0);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Barrier_impl(node_comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
}
/* Allocated the interprocess mutex segment. */
mpi_errno = MPL_shm_hnd_init(&(*win_ptr)->shm_mutex_segment_handle);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
if (node_rank == 0) {
char *serialized_hnd_ptr = NULL;
/* create shared memory region for all processes in win and map */
mpi_errno =
MPL_shm_seg_create_and_attach((*win_ptr)->shm_mutex_segment_handle,
sizeof(MPIDI_CH3I_SHM_MUTEX),
(char **) &(*win_ptr)->shm_mutex, 0);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIDI_CH3I_SHM_MUTEX_INIT(*win_ptr);
/* serialize handle and broadcast it to the other processes in win */
mpi_errno =
MPL_shm_hnd_get_serialized_by_ref((*win_ptr)->shm_mutex_segment_handle,
&serialized_hnd_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno =
MPIR_Bcast_impl(serialized_hnd_ptr, MPL_SHM_GHND_SZ, MPI_CHAR, 0, node_comm_ptr,
&errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* wait for other processes to attach to win */
mpi_errno = MPIR_Barrier_impl(node_comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* unlink shared memory region so it gets deleted when all processes exit */
mpi_errno = MPL_shm_seg_remove((*win_ptr)->shm_mutex_segment_handle);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
else {
char serialized_hnd[MPL_SHM_GHND_SZ] = { 0 };
/* get serialized handle from rank 0 and deserialize it */
mpi_errno =
MPIR_Bcast_impl(serialized_hnd, MPL_SHM_GHND_SZ, MPI_CHAR, 0, node_comm_ptr,
&errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
mpi_errno =
MPL_shm_hnd_deserialize((*win_ptr)->shm_mutex_segment_handle, serialized_hnd,
strlen(serialized_hnd));
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* attach to shared memory region created by rank 0 */
mpi_errno =
MPL_shm_seg_attach((*win_ptr)->shm_mutex_segment_handle,
sizeof(MPIDI_CH3I_SHM_MUTEX), (char **) &(*win_ptr)->shm_mutex,
0);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Barrier_impl(node_comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
}
/* compute the base addresses of each process within the shared memory segment */
{
char *cur_base;
int cur_rank;
cur_base = (*win_ptr)->shm_base_addr;
cur_rank = 0;
((*win_ptr)->shm_base_addrs)[0] = (*win_ptr)->shm_base_addr;
for (i = 1; i < node_size; ++i) {
if (node_sizes[i]) {
/* For the base addresses, we track the previous
* process that has allocated non-zero bytes of shared
* memory. We can not simply use "i-1" for the
* previous process because rank "i-1" might not have
* allocated any memory. */
if (noncontig) {
((*win_ptr)->shm_base_addrs)[i] =
cur_base + MPIDI_CH3_ROUND_UP_PAGESIZE(node_sizes[cur_rank]);
}
else {
((*win_ptr)->shm_base_addrs)[i] = cur_base + node_sizes[cur_rank];
}
cur_base = ((*win_ptr)->shm_base_addrs)[i];
cur_rank = i;
}
else {
((*win_ptr)->shm_base_addrs)[i] = NULL;
}
}
}
(*win_ptr)->base = (*win_ptr)->shm_base_addrs[node_rank];
}
*base_pp = (*win_ptr)->base;
/* gather window information among processes via shared memory region. */
mpi_errno = MPIDI_CH3I_Win_gather_info((*base_pp), size, disp_unit, info, comm_ptr, win_ptr);
if (mpi_errno != MPI_SUCCESS)
MPIR_ERR_POP(mpi_errno);
/* Cache SHM windows */
MPIDI_CH3I_SHM_Wins_append(&shm_wins_list, (*win_ptr));
fn_exit:
MPIR_CHKLMEM_FREEALL();
MPIR_FUNC_VERBOSE_RMA_EXIT(MPID_STATE_MPIDI_CH3I_WIN_ALLOCATE_SHM);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
fn_fail:
MPIR_CHKPMEM_REAP();
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Type_create_darray - Create a datatype representing a distributed array
Input Parameters:
+ size - size of process group (positive integer)
. rank - rank in process group (nonnegative integer)
. ndims - number of array dimensions as well as process grid dimensions (positive integer)
. array_of_gsizes - number of elements of type oldtype in each dimension of global array (array of positive integers)
. array_of_distribs - distribution of array in each dimension (array of state)
. array_of_dargs - distribution argument in each dimension (array of positive integers)
. array_of_psizes - size of process grid in each dimension (array of positive integers)
. order - array storage order flag (state)
- oldtype - old datatype (handle)
Output Parameters:
. newtype - new datatype (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TYPE
.N MPI_ERR_ARG
@*/
int MPI_Type_create_darray(int size,
int rank,
int ndims,
const int array_of_gsizes[],
const int array_of_distribs[],
const int array_of_dargs[],
const int array_of_psizes[],
int order, MPI_Datatype oldtype, MPI_Datatype * newtype)
{
int mpi_errno = MPI_SUCCESS, i;
MPI_Datatype new_handle;
int procs, tmp_rank, tmp_size, *coords;
MPI_Aint *st_offsets, orig_extent, disps[3];
MPI_Datatype type_old, type_new = MPI_DATATYPE_NULL, tmp_type;
#ifdef HAVE_ERROR_CHECKING
MPI_Aint size_with_aint;
MPI_Offset size_with_offset;
#endif
int *ints;
MPIR_Datatype *datatype_ptr = NULL;
MPIR_CHKLMEM_DECL(3);
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_CREATE_DARRAY);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_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 */
MPIR_Datatype_get_ptr(oldtype, datatype_ptr);
MPIR_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 */
MPIR_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,
__func__,
__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,
__func__,
__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,
__func__,
__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,
__func__,
__LINE__,
MPI_ERR_ARG,
"**darraydist",
"**darraydist %d %d", i, array_of_psizes[i]);
goto fn_fail;
}
tmp_size *= array_of_psizes[i];
}
MPIR_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,
__func__,
__LINE__,
MPI_ERR_ARG,
"**darrayoverflow",
"**darrayoverflow %L", size_with_offset);
goto fn_fail;
}
/* Validate datatype_ptr */
MPIR_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) */
MPIR_CHKLMEM_MALLOC_ORJUMP(coords, int *, ndims * sizeof(int), mpi_errno,
"position is Cartesian grid", MPL_MEM_COMM);
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;
}
MPIR_CHKLMEM_MALLOC_ORJUMP(st_offsets, MPI_Aint *, ndims * sizeof(MPI_Aint), mpi_errno,
"st_offsets", MPL_MEM_COMM);
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;
/* Instead of using MPI_LB/MPI_UB, which have been removed from MPI in MPI-3,
use MPI_Type_create_resized. Use hindexed_block to set the starting displacement
of the datatype (disps[1]) and type_create_resized to set lb to 0 (disps[0])
and extent to disps[2], which makes ub = disps[2].
*/
mpi_errno = MPIR_Type_blockindexed(1, 1, &disps[1], 1, /* 1 means disp is in bytes */
type_new, &tmp_type);
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
/* --END ERROR HANDLING-- */
mpi_errno = MPIR_Type_create_resized(tmp_type, 0, disps[2], &new_handle);
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
/* --END ERROR HANDLING-- */
MPIR_Type_free_impl(&tmp_type);
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 */
MPIR_CHKLMEM_MALLOC_ORJUMP(ints, int *, (4 * ndims + 4) * sizeof(int), mpi_errno,
"content description", MPL_MEM_BUFFER);
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;
MPIR_Datatype_get_ptr(new_handle, datatype_ptr);
mpi_errno = MPIR_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-- */
MPIR_OBJ_PUBLISH_HANDLE(*newtype, new_handle);
/* ... end of body of routine ... */
fn_exit:
MPIR_CHKLMEM_FREEALL();
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_CREATE_DARRAY);
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_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, __func__, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/* comm create impl for intercommunicators, assumes that the standard error
* checking has already taken place in the calling function */
PMPI_LOCAL int MPIR_Comm_create_inter(MPIR_Comm *comm_ptr, MPIR_Group *group_ptr,
MPIR_Comm **newcomm_ptr)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Context_id_t new_context_id;
int *mapping = NULL;
int *remote_mapping = NULL;
MPIR_Comm *mapping_comm = NULL;
int remote_size = -1;
int rinfo[2];
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
MPIR_CHKLMEM_DECL(1);
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPIR_COMM_CREATE_INTER);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPIR_COMM_CREATE_INTER);
MPIR_Assert(comm_ptr->comm_kind == MPIR_COMM_KIND__INTERCOMM);
/* Create a new communicator from the specified group members */
/* If there is a context id cache in oldcomm, use it here. Otherwise,
use the appropriate algorithm to get a new context id.
Creating the context id is collective over the *input* communicator,
so it must be created before we decide if this process is a
member of the group */
/* In the multi-threaded case, MPIR_Get_contextid_sparse assumes that the
calling routine already holds the single criticial section */
if (!comm_ptr->local_comm) {
MPII_Setup_intercomm_localcomm( comm_ptr );
}
mpi_errno = MPIR_Get_contextid_sparse( comm_ptr->local_comm, &new_context_id, FALSE );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_Assert(new_context_id != 0);
MPIR_Assert(new_context_id != comm_ptr->recvcontext_id);
mpi_errno = MPII_Comm_create_calculate_mapping(group_ptr, comm_ptr,
&mapping, &mapping_comm);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
*newcomm_ptr = NULL;
if (group_ptr->rank != MPI_UNDEFINED) {
/* Get the new communicator structure and context id */
mpi_errno = MPIR_Comm_create( newcomm_ptr );
if (mpi_errno) goto fn_fail;
(*newcomm_ptr)->recvcontext_id = new_context_id;
(*newcomm_ptr)->rank = group_ptr->rank;
(*newcomm_ptr)->comm_kind = comm_ptr->comm_kind;
/* Since the group has been provided, let the new communicator know
about the group */
(*newcomm_ptr)->local_comm = 0;
(*newcomm_ptr)->local_group = group_ptr;
MPIR_Group_add_ref( group_ptr );
(*newcomm_ptr)->local_size = group_ptr->size;
(*newcomm_ptr)->pof2 = MPL_pof2((*newcomm_ptr)->local_size);
(*newcomm_ptr)->remote_group = 0;
(*newcomm_ptr)->is_low_group = comm_ptr->is_low_group;
}
/* There is an additional step. We must communicate the
information on the local context id and the group members,
given by the ranks so that the remote process can construct the
appropriate network address mapping.
First we exchange group sizes and context ids. Then the ranks
in the remote group, from which the remote network address
mapping can be constructed. We need to use the "collective"
context in the original intercommunicator */
if (comm_ptr->rank == 0) {
int info[2];
info[0] = new_context_id;
info[1] = group_ptr->size;
mpi_errno = MPIC_Sendrecv(info, 2, MPI_INT, 0, 0,
rinfo, 2, MPI_INT, 0, 0,
comm_ptr, MPI_STATUS_IGNORE, &errflag );
if (mpi_errno) { MPIR_ERR_POP( mpi_errno ); }
if (*newcomm_ptr != NULL) {
(*newcomm_ptr)->context_id = rinfo[0];
}
remote_size = rinfo[1];
MPIR_CHKLMEM_MALLOC(remote_mapping,int*,
remote_size*sizeof(int),
mpi_errno,"remote_mapping",MPL_MEM_ADDRESS);
/* Populate and exchange the ranks */
mpi_errno = MPIC_Sendrecv( mapping, group_ptr->size, MPI_INT, 0, 0,
remote_mapping, remote_size, MPI_INT, 0, 0,
comm_ptr, MPI_STATUS_IGNORE, &errflag );
if (mpi_errno) { MPIR_ERR_POP( mpi_errno ); }
/* Broadcast to the other members of the local group */
mpi_errno = MPID_Bcast( rinfo, 2, MPI_INT, 0,
comm_ptr->local_comm, &errflag);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPID_Bcast( remote_mapping, remote_size, MPI_INT, 0,
comm_ptr->local_comm, &errflag);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
}
int MPIR_Exscan (
const void *sendbuf,
void *recvbuf,
int count,
MPI_Datatype datatype,
MPI_Op op,
MPIR_Comm *comm_ptr,
MPIR_Errflag_t *errflag )
{
MPI_Status status;
int rank, comm_size;
int mpi_errno = MPI_SUCCESS;
int mpi_errno_ret = MPI_SUCCESS;
int mask, dst, is_commutative, flag;
MPI_Aint true_extent, true_lb, extent;
void *partial_scan, *tmp_buf;
MPIR_Op *op_ptr;
MPIR_CHKLMEM_DECL(2);
if (count == 0) return MPI_SUCCESS;
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
/* set op_errno to 0. stored in perthread structure */
{
MPIR_Per_thread_t *per_thread = NULL;
int err = 0;
MPID_THREADPRIV_KEY_GET_ADDR(MPIR_ThreadInfo.isThreaded, MPIR_Per_thread_key,
MPIR_Per_thread, per_thread, &err);
MPIR_Assert(err == 0);
per_thread->op_errno = 0;
}
if (HANDLE_GET_KIND(op) == HANDLE_KIND_BUILTIN) {
is_commutative = 1;
}
else {
MPIR_Op_get_ptr(op, op_ptr);
if (op_ptr->kind == MPIR_OP_KIND__USER_NONCOMMUTE)
is_commutative = 0;
else
is_commutative = 1;
}
/* need to allocate temporary buffer to store partial scan*/
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
MPID_Datatype_get_extent_macro( datatype, extent );
MPIR_CHKLMEM_MALLOC(partial_scan, void *, (count*(MPL_MAX(true_extent,extent))), mpi_errno, "partial_scan");
/* adjust for potential negative lower bound in datatype */
partial_scan = (void *)((char*)partial_scan - true_lb);
/* need to allocate temporary buffer to store incoming data*/
MPIR_CHKLMEM_MALLOC(tmp_buf, void *, (count*(MPL_MAX(true_extent,extent))), mpi_errno, "tmp_buf");
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *)((char*)tmp_buf - true_lb);
mpi_errno = MPIR_Localcopy((sendbuf == MPI_IN_PLACE ? (const void *)recvbuf : sendbuf), count, datatype,
partial_scan, count, datatype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
flag = 0;
mask = 0x1;
while (mask < comm_size) {
dst = rank ^ mask;
if (dst < comm_size) {
/* Send partial_scan to dst. Recv into tmp_buf */
mpi_errno = MPIC_Sendrecv(partial_scan, count, datatype,
dst, MPIR_EXSCAN_TAG, tmp_buf,
count, datatype, dst,
MPIR_EXSCAN_TAG, comm_ptr,
&status, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
if (rank > dst) {
mpi_errno = MPIR_Reduce_local_impl( tmp_buf, partial_scan,
count, datatype, op );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* On rank 0, recvbuf is not defined. For sendbuf==MPI_IN_PLACE
recvbuf must not change (per MPI-2.2).
On rank 1, recvbuf is to be set equal to the value
in sendbuf on rank 0.
On others, recvbuf is the scan of values in the
sendbufs on lower ranks. */
if (rank != 0) {
if (flag == 0) {
/* simply copy data recd from rank 0 into recvbuf */
mpi_errno = MPIR_Localcopy(tmp_buf, count, datatype,
recvbuf, count, datatype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
flag = 1;
}
else {
mpi_errno = MPIR_Reduce_local_impl( tmp_buf,
recvbuf, count, datatype, op );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
}
}
else {
if (is_commutative) {
mpi_errno = MPIR_Reduce_local_impl( tmp_buf, partial_scan,
count, datatype, op );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
else {
mpi_errno = MPIR_Reduce_local_impl( partial_scan,
tmp_buf, count, datatype, op );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Localcopy(tmp_buf, count, datatype,
partial_scan,
count, datatype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
}
}
mask <<= 1;
}
{
MPIR_Per_thread_t *per_thread = NULL;
int err = 0;
MPID_THREADPRIV_KEY_GET_ADDR(MPIR_ThreadInfo.isThreaded, MPIR_Per_thread_key,
MPIR_Per_thread, per_thread, &err);
MPIR_Assert(err == 0);
if (per_thread->op_errno)
mpi_errno = per_thread->op_errno;
}
fn_exit:
MPIR_CHKLMEM_FREEALL();
if (mpi_errno_ret)
mpi_errno = mpi_errno_ret;
else if (*errflag != MPIR_ERR_NONE)
MPIR_ERR_SET(mpi_errno, MPI_ERR_OTHER, "**coll_fail");
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Allreduce_intra_recursive_doubling(
const void *sendbuf,
void *recvbuf,
int count,
MPI_Datatype datatype,
MPI_Op op,
MPIR_Comm * comm_ptr,
MPIR_Errflag_t * errflag)
{
MPIR_CHKLMEM_DECL(1);
#ifdef MPID_HAS_HETERO
int is_homogeneous;
int rc;
#endif
int comm_size, rank;
int mpi_errno = MPI_SUCCESS;
int mpi_errno_ret = MPI_SUCCESS;
int mask, dst, is_commutative, pof2, newrank, rem, newdst;
MPI_Aint true_extent, true_lb, extent;
void *tmp_buf;
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
is_commutative = MPIR_Op_is_commutative(op);
/* need to allocate temporary buffer to store incoming data*/
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
MPIR_Datatype_get_extent_macro(datatype, extent);
MPIR_Ensure_Aint_fits_in_pointer(count * MPL_MAX(extent, true_extent));
MPIR_CHKLMEM_MALLOC(tmp_buf, void *, count*(MPL_MAX(extent,true_extent)), mpi_errno, "temporary buffer", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *)((char*)tmp_buf - true_lb);
/* copy local data into recvbuf */
if (sendbuf != MPI_IN_PLACE) {
mpi_errno = MPIR_Localcopy(sendbuf, count, datatype, recvbuf,
count, datatype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
/* get nearest power-of-two less than or equal to comm_size */
pof2 = comm_ptr->pof2;
rem = comm_size - pof2;
/* In the non-power-of-two case, all even-numbered
processes of rank < 2*rem send their data to
(rank+1). These even-numbered processes no longer
participate in the algorithm until the very end. The
remaining processes form a nice power-of-two. */
if (rank < 2*rem) {
if (rank % 2 == 0) { /* even */
mpi_errno = MPIC_Send(recvbuf, count,
datatype, rank+1,
MPIR_ALLREDUCE_TAG, comm_ptr, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
/* temporarily set the rank to -1 so that this
process does not pariticipate in recursive
doubling */
newrank = -1;
}
else { /* odd */
mpi_errno = MPIC_Recv(tmp_buf, count,
datatype, rank-1,
MPIR_ALLREDUCE_TAG, comm_ptr,
MPI_STATUS_IGNORE, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
/* do the reduction on received data. since the
ordering is right, it doesn't matter whether
the operation is commutative or not. */
mpi_errno = MPIR_Reduce_local(tmp_buf, recvbuf, count, datatype, op);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* change the rank */
newrank = rank / 2;
}
}
else /* rank >= 2*rem */
newrank = rank - rem;
/* If op is user-defined or count is less than pof2, use
recursive doubling algorithm. Otherwise do a reduce-scatter
followed by allgather. (If op is user-defined,
derived datatypes are allowed and the user could pass basic
datatypes on one process and derived on another as long as
the type maps are the same. Breaking up derived
datatypes to do the reduce-scatter is tricky, therefore
using recursive doubling in that case.) */
if (newrank != -1) {
mask = 0x1;
while (mask < pof2) {
newdst = newrank ^ mask;
/* find real rank of dest */
dst = (newdst < rem) ? newdst*2 + 1 : newdst + rem;
/* Send the most current data, which is in recvbuf. Recv
into tmp_buf */
mpi_errno = MPIC_Sendrecv(recvbuf, count, datatype,
dst, MPIR_ALLREDUCE_TAG, tmp_buf,
count, datatype, dst,
MPIR_ALLREDUCE_TAG, comm_ptr,
MPI_STATUS_IGNORE, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
/* tmp_buf contains data received in this step.
recvbuf contains data accumulated so far */
if (is_commutative || (dst < rank)) {
/* op is commutative OR the order is already right */
mpi_errno = MPIR_Reduce_local(tmp_buf, recvbuf, count, datatype, op);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
else {
/* op is noncommutative and the order is not right */
mpi_errno = MPIR_Reduce_local(recvbuf, tmp_buf, count, datatype, op);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* copy result back into recvbuf */
mpi_errno = MPIR_Localcopy(tmp_buf, count, datatype,
recvbuf, count, datatype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
mask <<= 1;
}
}
/* In the non-power-of-two case, all odd-numbered
processes of rank < 2*rem send the result to
(rank-1), the ranks who didn't participate above. */
if (rank < 2*rem) {
if (rank % 2) /* odd */
mpi_errno = MPIC_Send(recvbuf, count,
datatype, rank-1,
MPIR_ALLREDUCE_TAG, comm_ptr, errflag);
else /* even */
mpi_errno = MPIC_Recv(recvbuf, count,
datatype, rank+1,
MPIR_ALLREDUCE_TAG, comm_ptr,
MPI_STATUS_IGNORE, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
}
fn_exit:
MPIR_CHKLMEM_FREEALL();
return mpi_errno;
fn_fail:
goto fn_exit;
}
/*@
MPI_Sendrecv_replace - Sends and receives using a single buffer
Input Parameters:
+ count - number of elements in send and receive buffer (integer)
. datatype - type of elements in send and receive buffer (handle)
. dest - rank of destination (integer)
. sendtag - send message tag (integer)
. source - rank of source (integer)
. recvtag - receive message tag (integer)
- comm - communicator (handle)
Output Parameters:
+ buf - initial address of send and receive buffer (choice)
- status - status object (Status)
.N ThreadSafe
.N Fortran
.N FortranStatus
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_COUNT
.N MPI_ERR_TYPE
.N MPI_ERR_TAG
.N MPI_ERR_RANK
.N MPI_ERR_TRUNCATE
.N MPI_ERR_EXHAUSTED
@*/
int MPI_Sendrecv_replace(void *buf, int count, MPI_Datatype datatype,
int dest, int sendtag, int source, int recvtag,
MPI_Comm comm, MPI_Status *status)
{
static const char FCNAME[] = "MPI_Sendrecv_replace";
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_CHKLMEM_DECL(1);
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_SENDRECV_REPLACE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_PT2PT_ENTER_BOTH(MPID_STATE_MPI_SENDRECV_REPLACE);
/* Convert handles to MPI objects. */
MPIR_Comm_get_ptr(comm, comm_ptr);
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate communicator */
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
if (mpi_errno) goto fn_fail;
/* Validate count */
MPIR_ERRTEST_COUNT(count, mpi_errno);
/* Validate status (status_ignore is not the same as null) */
MPIR_ERRTEST_ARGNULL(status, "status", mpi_errno);
/* Validate tags */
MPIR_ERRTEST_SEND_TAG(sendtag, mpi_errno);
MPIR_ERRTEST_RECV_TAG(recvtag, mpi_errno);
/* Validate source and destination */
MPIR_ERRTEST_SEND_RANK(comm_ptr, dest, mpi_errno);
MPIR_ERRTEST_RECV_RANK(comm_ptr, source, mpi_errno);
/* Validate datatype handle */
MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno);
/* Validate datatype object */
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) goto fn_fail;
MPIR_Datatype_committed_ptr(datatype_ptr, mpi_errno);
if (mpi_errno) goto fn_fail;
}
/* Validate buffer */
MPIR_ERRTEST_USERBUFFER(buf,count,datatype,mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
# if defined(MPID_Sendrecv_replace)
{
mpi_errno = MPID_Sendrecv_replace(buf, count, datatype, dest,
sendtag, source, recvtag, comm_ptr,
status)
}
# else
{
MPIR_Request * sreq;
MPIR_Request * rreq;
void * tmpbuf = NULL;
MPI_Aint tmpbuf_size = 0;
MPI_Aint tmpbuf_count = 0;
if (count > 0 && dest != MPI_PROC_NULL)
{
MPIR_Pack_size_impl(count, datatype, &tmpbuf_size);
MPIR_CHKLMEM_MALLOC_ORJUMP(tmpbuf, void *, tmpbuf_size, mpi_errno, "temporary send buffer", MPL_MEM_BUFFER);
mpi_errno = MPIR_Pack_impl(buf, count, datatype, tmpbuf, tmpbuf_size, &tmpbuf_count);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
mpi_errno = MPID_Irecv(buf, count, datatype, source, recvtag,
comm_ptr, MPIR_CONTEXT_INTRA_PT2PT, &rreq);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
mpi_errno = MPID_Isend(tmpbuf, tmpbuf_count, MPI_PACKED, dest,
sendtag, comm_ptr, MPIR_CONTEXT_INTRA_PT2PT,
&sreq);
if (mpi_errno != MPI_SUCCESS)
{
/* --BEGIN ERROR HANDLING-- */
/* FIXME: should we cancel the pending (possibly completed) receive request or wait for it to complete? */
MPIR_Request_free(rreq);
goto fn_fail;
/* --END ERROR HANDLING-- */
}
if (!MPIR_Request_is_complete(sreq) || !MPIR_Request_is_complete(rreq))
{
MPID_Progress_state progress_state;
MPID_Progress_start(&progress_state);
while (!MPIR_Request_is_complete(sreq) || !MPIR_Request_is_complete(rreq))
{
mpi_errno = MPID_Progress_wait(&progress_state);
if (mpi_errno != MPI_SUCCESS)
{
/* --BEGIN ERROR HANDLING-- */
MPID_Progress_end(&progress_state);
goto fn_fail;
/* --END ERROR HANDLING-- */
}
}
MPID_Progress_end(&progress_state);
}
if (status != MPI_STATUS_IGNORE)
{
*status = rreq->status;
}
if (mpi_errno == MPI_SUCCESS)
{
mpi_errno = rreq->status.MPI_ERROR;
if (mpi_errno == MPI_SUCCESS)
{
mpi_errno = sreq->status.MPI_ERROR;
}
}
MPIR_Request_free(sreq);
MPIR_Request_free(rreq);
}
int MPIR_Alltoall_intra(
const void *sendbuf,
int sendcount,
MPI_Datatype sendtype,
void *recvbuf,
int recvcount,
MPI_Datatype recvtype,
MPIR_Comm *comm_ptr,
MPIR_Errflag_t *errflag )
{
int comm_size, i, j, pof2;
MPI_Aint sendtype_extent, recvtype_extent;
MPI_Aint recvtype_true_extent, recvbuf_extent, recvtype_true_lb;
int mpi_errno=MPI_SUCCESS, src, dst, rank, nbytes;
int mpi_errno_ret = MPI_SUCCESS;
MPI_Status status;
int sendtype_size, block, *displs, count;
MPI_Aint pack_size, position;
MPI_Datatype newtype = MPI_DATATYPE_NULL;
void *tmp_buf;
MPIR_Request **reqarray;
MPI_Status *starray;
MPIR_CHKLMEM_DECL(6);
if (recvcount == 0) return MPI_SUCCESS;
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
/* Get extent of send and recv types */
MPID_Datatype_get_extent_macro(recvtype, recvtype_extent);
MPID_Datatype_get_extent_macro(sendtype, sendtype_extent);
MPID_Datatype_get_size_macro(sendtype, sendtype_size);
nbytes = sendtype_size * sendcount;
if (sendbuf == MPI_IN_PLACE) {
/* We use pair-wise sendrecv_replace in order to conserve memory usage,
* which is keeping with the spirit of the MPI-2.2 Standard. But
* because of this approach all processes must agree on the global
* schedule of sendrecv_replace operations to avoid deadlock.
*
* Note that this is not an especially efficient algorithm in terms of
* time and there will be multiple repeated malloc/free's rather than
* maintaining a single buffer across the whole loop. Something like
* MADRE is probably the best solution for the MPI_IN_PLACE scenario. */
for (i = 0; i < comm_size; ++i) {
/* start inner loop at i to avoid re-exchanging data */
for (j = i; j < comm_size; ++j) {
if (rank == i) {
/* also covers the (rank == i && rank == j) case */
mpi_errno = MPIC_Sendrecv_replace(((char *)recvbuf + j*recvcount*recvtype_extent),
recvcount, recvtype,
j, MPIR_ALLTOALL_TAG,
j, MPIR_ALLTOALL_TAG,
comm_ptr, &status, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
}
else if (rank == j) {
/* same as above with i/j args reversed */
mpi_errno = MPIC_Sendrecv_replace(((char *)recvbuf + i*recvcount*recvtype_extent),
recvcount, recvtype,
i, MPIR_ALLTOALL_TAG,
i, MPIR_ALLTOALL_TAG,
comm_ptr, &status, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
}
}
}
}
else if ((nbytes <= MPIR_CVAR_ALLTOALL_SHORT_MSG_SIZE) && (comm_size >= 8)) {
/* use the indexing algorithm by Jehoshua Bruck et al,
* IEEE TPDS, Nov. 97 */
/* allocate temporary buffer */
MPIR_Pack_size_impl(recvcount*comm_size, recvtype, &pack_size);
MPIR_CHKLMEM_MALLOC(tmp_buf, void *, pack_size, mpi_errno, "tmp_buf");
/* Do Phase 1 of the algorithim. Shift the data blocks on process i
* upwards by a distance of i blocks. Store the result in recvbuf. */
mpi_errno = MPIR_Localcopy((char *) sendbuf +
rank*sendcount*sendtype_extent,
(comm_size - rank)*sendcount, sendtype, recvbuf,
(comm_size - rank)*recvcount, recvtype);
if (mpi_errno) { MPIR_ERR_POP(mpi_errno); }
mpi_errno = MPIR_Localcopy(sendbuf, rank*sendcount, sendtype,
(char *) recvbuf +
(comm_size-rank)*recvcount*recvtype_extent,
rank*recvcount, recvtype);
if (mpi_errno) { MPIR_ERR_POP(mpi_errno); }
/* Input data is now stored in recvbuf with datatype recvtype */
/* Now do Phase 2, the communication phase. It takes
ceiling(lg p) steps. In each step i, each process sends to rank+2^i
and receives from rank-2^i, and exchanges all data blocks
whose ith bit is 1. */
/* allocate displacements array for indexed datatype used in
communication */
MPIR_CHKLMEM_MALLOC(displs, int *, comm_size * sizeof(int), mpi_errno, "displs");
pof2 = 1;
while (pof2 < comm_size) {
dst = (rank + pof2) % comm_size;
src = (rank - pof2 + comm_size) % comm_size;
/* Exchange all data blocks whose ith bit is 1 */
/* Create an indexed datatype for the purpose */
count = 0;
for (block=1; block<comm_size; block++) {
if (block & pof2) {
displs[count] = block * recvcount;
count++;
}
}
mpi_errno = MPIR_Type_create_indexed_block_impl(count, recvcount,
displs, recvtype, &newtype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Type_commit_impl(&newtype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
position = 0;
mpi_errno = MPIR_Pack_impl(recvbuf, 1, newtype, tmp_buf, pack_size, &position);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIC_Sendrecv(tmp_buf, position, MPI_PACKED, dst,
MPIR_ALLTOALL_TAG, recvbuf, 1, newtype,
src, MPIR_ALLTOALL_TAG, comm_ptr,
MPI_STATUS_IGNORE, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
MPIR_Type_free_impl(&newtype);
pof2 *= 2;
}
/* Rotate blocks in recvbuf upwards by (rank + 1) blocks. Need
* a temporary buffer of the same size as recvbuf. */
/* get true extent of recvtype */
MPIR_Type_get_true_extent_impl(recvtype, &recvtype_true_lb, &recvtype_true_extent);
recvbuf_extent = recvcount * comm_size *
(MPL_MAX(recvtype_true_extent, recvtype_extent));
MPIR_CHKLMEM_MALLOC(tmp_buf, void *, recvbuf_extent, mpi_errno, "tmp_buf");
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *)((char*)tmp_buf - recvtype_true_lb);
mpi_errno = MPIR_Localcopy((char *) recvbuf + (rank+1)*recvcount*recvtype_extent,
(comm_size - rank - 1)*recvcount, recvtype, tmp_buf,
(comm_size - rank - 1)*recvcount, recvtype);
if (mpi_errno) { MPIR_ERR_POP(mpi_errno); }
mpi_errno = MPIR_Localcopy(recvbuf, (rank+1)*recvcount, recvtype,
(char *) tmp_buf + (comm_size-rank-1)*recvcount*recvtype_extent,
(rank+1)*recvcount, recvtype);
if (mpi_errno) { MPIR_ERR_POP(mpi_errno); }
/* Blocks are in the reverse order now (comm_size-1 to 0).
* Reorder them to (0 to comm_size-1) and store them in recvbuf. */
for (i=0; i<comm_size; i++){
mpi_errno = MPIR_Localcopy((char *) tmp_buf + i*recvcount*recvtype_extent,
recvcount, recvtype,
(char *) recvbuf + (comm_size-i-1)*recvcount*recvtype_extent,
recvcount, recvtype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
}
