/* maps rank r in comm_ptr to the rank of the leader for r's node in
comm_ptr->node_roots_comm and returns this value.
This function does NOT use mpich error handling.
*/
int MPIR_Get_internode_rank(MPIR_Comm * comm_ptr, int r)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, TRUE);
MPIR_Assert(mpi_errno == MPI_SUCCESS);
MPIR_Assert(r < comm_ptr->remote_size);
MPIR_Assert(comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM);
MPIR_Assert(comm_ptr->internode_table != NULL);
return comm_ptr->internode_table[r];
}
/* maps rank r in comm_ptr to the rank in comm_ptr->node_comm or -1 if r is not
a member of comm_ptr->node_comm.
This function does NOT use mpich error handling.
*/
int MPIR_Get_intranode_rank(MPIR_Comm * comm_ptr, int r)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, TRUE);
MPIR_Assert(mpi_errno == MPI_SUCCESS);
MPIR_Assert(r < comm_ptr->remote_size);
MPIR_Assert(comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM);
MPIR_Assert(comm_ptr->intranode_table != NULL);
/* FIXME this could/should be a list of ranks on the local node, which
* should take up much less space on a typical thin(ish)-node system. */
return comm_ptr->intranode_table[r];
}
/*@
MPI_Ssend - Blocking synchronous send
Input Parameters:
+ buf - initial address of send buffer (choice)
. count - number of elements in send buffer (nonnegative integer)
. datatype - datatype of each send buffer element (handle)
. dest - rank of destination (integer)
. tag - message tag (integer)
- comm - communicator (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_COUNT
.N MPI_ERR_TYPE
.N MPI_ERR_TAG
.N MPI_ERR_RANK
@*/
int MPI_Ssend(const void *buf, int count, MPI_Datatype datatype, int dest, int tag,
MPI_Comm comm)
{
static const char FCNAME[] = "MPI_Ssend";
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Request * request_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_SSEND);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_PT2PT_ENTER_FRONT(MPID_STATE_MPI_SSEND);
/* Validate handle parameters needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr( comm, comm_ptr );
/* Validate parameters if error checking is enabled */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
if (mpi_errno) goto fn_fail;
MPIR_ERRTEST_COUNT(count, mpi_errno);
MPIR_ERRTEST_SEND_RANK(comm_ptr, dest, mpi_errno);
MPIR_ERRTEST_SEND_TAG(tag, 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 ... */
mpi_errno = MPID_Ssend(buf, count, datatype, dest, tag, comm_ptr,
MPIR_CONTEXT_INTRA_PT2PT, &request_ptr);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
if (request_ptr == NULL)
{
goto fn_exit;
}
/* If a request was returned, then we need to block until the request
is complete */
mpi_errno = MPIR_Progress_wait_request(request_ptr);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = request_ptr->status.MPI_ERROR;
MPIR_Request_free(request_ptr);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_PT2PT_EXIT(MPID_STATE_MPI_SSEND);
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_ssend",
"**mpi_ssend %p %d %D %i %t %C", buf, count, datatype, dest, tag, comm);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPIX_Comm_failure_get_acked - Get the group of acknowledged failures.
Input Parameters:
. comm - Communicator (handle)
Output Parameters:
. failed_group - Group (handle)
Notes:
.N COMMNULL
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
@*/
int MPIX_Comm_failure_get_acked( MPI_Comm comm, MPI_Group *failedgrp )
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Group *group_ptr;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPIX_COMM_FAILURE_GET_ACKED);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPIX_COMM_FAILURE_GET_ACKED);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, 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, TRUE );
/* If comm_ptr is not valid, it will be reset to null */
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPID_Comm_failure_get_acked(comm_ptr, &group_ptr);
if (mpi_errno) goto fn_fail;
*failedgrp = group_ptr->handle;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPIX_COMM_FAILURE_GET_ACKED);
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, "**mpix_comm_failure_get_acked",
"**mpix_comm_failure_get_acked %C %p", comm, failedgrp);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Errhandler_set - Sets the error handler for a communicator
Input Parameters:
+ comm - communicator to set the error handler for (handle)
- errhandler - new MPI error handler for communicator (handle)
.N ThreadSafe
.N Deprecated
The replacement for this routine is 'MPI_Comm_set_errhandler'.
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_ARG
.seealso: MPI_Comm_set_errhandler, MPI_Errhandler_create, MPI_Comm_create_errhandler
@*/
int MPI_Errhandler_set(MPI_Comm comm, MPI_Errhandler errhandler)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Errhandler *errhan_ptr;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_ERRHANDLER_SET);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_ERRHANDLER_SET);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr( comm, comm_ptr );
MPIR_Errhandler_get_ptr( errhandler, errhan_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr; if comm_ptr is not value, it will be reset to null */
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, TRUE );
if (mpi_errno) goto fn_fail;
MPIR_ERRTEST_ERRHANDLER(errhandler, mpi_errno);
if (HANDLE_GET_KIND(errhandler) != HANDLE_KIND_BUILTIN) {
MPIR_Errhandler_valid_ptr( errhan_ptr, mpi_errno );
if (mpi_errno) goto fn_fail;
}
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
MPIR_Comm_set_errhandler_impl(comm_ptr, errhan_ptr);
/* ... end of body of routine ... */
# ifdef HAVE_ERROR_CHECKING
fn_exit:
# endif
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_ERRHANDLER_SET);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
# ifdef HAVE_ERROR_CHECKING
fn_fail:
/* --BEGIN ERROR HANDLING-- */
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_errhandler_set",
"**mpi_errhandler_set %C %E", comm, errhandler);
}
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
# endif
}
/*@
MPI_Sendrecv - Sends and receives a message
Input Parameters:
+ sendbuf - initial address of send buffer (choice)
. sendcount - number of elements in send buffer (integer)
. sendtype - type of elements in send buffer (handle)
. dest - rank of destination (integer)
. sendtag - send tag (integer)
. recvcount - number of elements in receive buffer (integer)
. recvtype - type of elements in receive buffer (handle)
. source - rank of source (integer)
. recvtag - receive tag (integer)
- comm - communicator (handle)
Output Parameters:
+ recvbuf - initial address of receive buffer (choice)
- status - status object (Status). This refers to the receive operation.
.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
@*/
int MPI_Sendrecv(const void *sendbuf, int sendcount, MPI_Datatype sendtype,
int dest, int sendtag,
void *recvbuf, int recvcount, MPI_Datatype recvtype,
int source, int recvtag, MPI_Comm comm, MPI_Status * status)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Request *sreq = NULL;
MPIR_Request *rreq = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_SENDRECV);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(VCI_GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_PT2PT_ENTER_BOTH(MPID_STATE_MPI_SENDRECV);
/* Validate handle parameters needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* Convert 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(sendcount, mpi_errno);
MPIR_ERRTEST_COUNT(recvcount, 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 */
if (comm_ptr) {
MPIR_ERRTEST_SEND_RANK(comm_ptr, dest, mpi_errno);
MPIR_ERRTEST_RECV_RANK(comm_ptr, source, mpi_errno);
}
/* Validate datatype handles */
MPIR_ERRTEST_DATATYPE(sendtype, "datatype", mpi_errno);
MPIR_ERRTEST_DATATYPE(recvtype, "datatype", mpi_errno);
/* Validate datatype objects */
if (HANDLE_GET_KIND(sendtype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype *datatype_ptr = NULL;
MPIR_Datatype_get_ptr(sendtype, 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;
}
if (HANDLE_GET_KIND(recvtype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype *datatype_ptr = NULL;
MPIR_Datatype_get_ptr(recvtype, 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 buffers */
MPIR_ERRTEST_USERBUFFER(sendbuf, sendcount, sendtype, mpi_errno);
MPIR_ERRTEST_USERBUFFER(recvbuf, recvcount, recvtype, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno =
MPID_Irecv(recvbuf, recvcount, recvtype, source, recvtag, comm_ptr,
MPIR_CONTEXT_INTRA_PT2PT, &rreq);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
/* FIXME - Performance for small messages might be better if MPID_Send() were used here instead of MPID_Isend() */
mpi_errno =
MPID_Isend(sendbuf, sendcount, sendtype, dest, sendtag, comm_ptr, MPIR_CONTEXT_INTRA_PT2PT,
&sreq);
if (mpi_errno != MPI_SUCCESS) {
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno == MPIX_ERR_NOREQ)
MPIR_ERR_SET(mpi_errno, MPI_ERR_OTHER, "**nomem");
/* 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-- */
}
if (unlikely(MPIR_Request_is_anysrc_mismatched(rreq))) {
/* --BEGIN ERROR HANDLING-- */
mpi_errno = MPIR_Request_handle_proc_failed(rreq);
if (!MPIR_Request_is_complete(sreq)) {
MPID_Cancel_send(sreq);
MPIR_STATUS_SET_CANCEL_BIT(sreq->status, FALSE);
}
goto fn_fail;
/* --END ERROR HANDLING-- */
}
}
MPID_Progress_end(&progress_state);
}
mpi_errno = rreq->status.MPI_ERROR;
MPIR_Request_extract_status(rreq, status);
MPIR_Request_free(rreq);
if (mpi_errno == MPI_SUCCESS) {
mpi_errno = sreq->status.MPI_ERROR;
}
MPIR_Request_free(sreq);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_PT2PT_EXIT_BOTH(MPID_STATE_MPI_SENDRECV);
MPID_THREAD_CS_EXIT(VCI_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_sendrecv",
"**mpi_sendrecv %p %d %D %i %t %p %d %D %i %t %C %p", sendbuf,
sendcount, sendtype, dest, sendtag, recvbuf, recvcount, recvtype,
source, recvtag, comm, status);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, __func__, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPIX_Comm_revoke - Prevent a communicator from being used in the future
Input Parameters:
. comm - communicator to revoke
Notes:
Asynchronously notifies all MPI processes associated with the communicator 'comm'.
This will be manifest by returning the MPIX_ERR_REVOKED during a subsequent MPI
call.
.N Fortran
.N Errors
.N MPI_SUCCESS
@*/
int MPIX_Comm_revoke(MPI_Comm comm)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPIX_COMM_REVOKE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPIX_COMM_REVOKE);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, 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, TRUE);
if (mpi_errno)
goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
#endif
/* ... body of routine ... */
mpi_errno = MPID_Comm_revoke(comm_ptr, 0);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPIX_COMM_REVOKE);
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,
"**mpix_comm_revoke", "**mpix_comm_revoke %C", comm);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Comm_idup - nonblocking communicator duplication
Input Parameters:
. comm - communicator (handle)
Output Parameters:
+ newcomm - copy of comm (handle)
- request - communication request (handle)
.N ThreadSafe
.N Fortran
.N Errors
@*/
int MPI_Comm_idup(MPI_Comm comm, MPI_Comm *newcomm, MPI_Request *request)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Comm *newcomm_ptr = NULL;
MPIR_Request *dreq = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_COMM_IDUP);
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_COMM_IDUP);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
/* TODO more checks may be appropriate */
}
MPID_END_ERROR_CHECKS
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, comm_ptr);
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPIR_ERRTEST_ARGNULL(request, "request", mpi_errno);
/* TODO more checks may be appropriate (counts, in_place, buffer aliasing, etc) */
}
MPID_END_ERROR_CHECKS
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
*request = MPI_REQUEST_NULL;
*newcomm = MPI_COMM_NULL;
mpi_errno = MPIR_Comm_idup_impl(comm_ptr, &newcomm_ptr, &dreq);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* NOTE: this is a publication for most of the comm, but the context ID
* won't be valid yet, so we must "republish" relative to the request
* handle at request completion time. */
MPIR_OBJ_PUBLISH_HANDLE(*newcomm, newcomm_ptr->handle);
*request = dreq->handle;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_COMM_IDUP);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_comm_idup", "**mpi_comm_idup %C %p %p", comm, newcomm, request);
}
# endif
mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Recv_init - Create a persistent request for a receive
Input Parameters:
+ buf - initial address of receive buffer (choice)
. count - number of elements received (integer)
. datatype - type of each element (handle)
. source - rank of source or 'MPI_ANY_SOURCE' (integer)
. tag - message tag or 'MPI_ANY_TAG' (integer)
- comm - communicator (handle)
Output Parameters:
. request - communication request (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COUNT
.N MPI_ERR_TYPE
.N MPI_ERR_RANK
.N MPI_ERR_TAG
.N MPI_ERR_COMM
.N MPI_ERR_EXHAUSTED
.seealso: MPI_Start, MPI_Startall, MPI_Request_free
@*/
int MPI_Recv_init(void *buf, int count, MPI_Datatype datatype, int source,
int tag, MPI_Comm comm, MPI_Request * request)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Request *request_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_RECV_INIT);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_PT2PT_ENTER(MPID_STATE_MPI_RECV_INIT);
/* Validate handle parameters needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, comm_ptr);
/* Validate parameters if error checking is enabled */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, FALSE);
if (mpi_errno)
goto fn_fail;
MPIR_ERRTEST_COUNT(count, mpi_errno);
MPIR_ERRTEST_RECV_RANK(comm_ptr, source, mpi_errno);
MPIR_ERRTEST_RECV_TAG(tag, mpi_errno);
MPIR_ERRTEST_ARGNULL(request, "request", 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 ... */
mpi_errno = MPID_Recv_init(buf, count, datatype, source, tag, comm_ptr,
MPIR_CONTEXT_INTRA_PT2PT, &request_ptr);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
/* return the handle of the request to the user */
MPIR_OBJ_PUBLISH_HANDLE(*request, request_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_PT2PT_EXIT(MPID_STATE_MPI_RECV_INIT);
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_recv_init", "**mpi_recv_init %p %d %D %i %t %C %p", buf,
count, datatype, source, tag, comm, request);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Gatherv - Gathers into specified locations from all processes in a group
Input Parameters:
+ sendbuf - starting address of send buffer (choice)
. sendcount - number of elements in send buffer (integer)
. sendtype - data type of send buffer elements (handle)
. recvcounts - integer array (of length group size)
containing the number of elements that are received from each process
(significant only at 'root')
. displs - integer array (of length group size). Entry
'i' specifies the displacement relative to recvbuf at
which to place the incoming data from process 'i' (significant only
at root)
. recvtype - data type of recv buffer elements
(significant only at 'root') (handle)
. root - rank of receiving process (integer)
- comm - communicator (handle)
Output Parameters:
. recvbuf - address of receive buffer (choice, significant only at 'root')
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_TYPE
.N MPI_ERR_BUFFER
@*/
int MPI_Gatherv(const void *sendbuf, int sendcount, MPI_Datatype sendtype,
void *recvbuf, const int *recvcounts, const int *displs,
MPI_Datatype recvtype, int root, MPI_Comm comm)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_GATHERV);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_COLL_ENTER(MPID_STATE_MPI_GATHERV);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, comm_ptr);
/* Validate parameters and objects (post conversion) */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_Datatype *sendtype_ptr = NULL, *recvtype_ptr = NULL;
int i, rank, comm_size;
MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, FALSE);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
if (comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM) {
MPIR_ERRTEST_INTRA_ROOT(comm_ptr, root, mpi_errno);
if (sendbuf != MPI_IN_PLACE) {
MPIR_ERRTEST_COUNT(sendcount, mpi_errno);
MPIR_ERRTEST_DATATYPE(sendtype, "sendtype", mpi_errno);
if (HANDLE_GET_KIND(sendtype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype_get_ptr(sendtype, sendtype_ptr);
MPIR_Datatype_valid_ptr(sendtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
MPIR_Datatype_committed_ptr(sendtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
}
MPIR_ERRTEST_USERBUFFER(sendbuf, sendcount, sendtype, mpi_errno);
}
rank = comm_ptr->rank;
if (rank == root) {
comm_size = comm_ptr->local_size;
for (i = 0; i < comm_size; i++) {
MPIR_ERRTEST_COUNT(recvcounts[i], mpi_errno);
MPIR_ERRTEST_DATATYPE(recvtype, "recvtype", mpi_errno);
}
if (HANDLE_GET_KIND(recvtype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype_get_ptr(recvtype, recvtype_ptr);
MPIR_Datatype_valid_ptr(recvtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
MPIR_Datatype_committed_ptr(recvtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
}
for (i = 0; i < comm_size; i++) {
if (recvcounts[i] > 0) {
MPIR_ERRTEST_RECVBUF_INPLACE(recvbuf, recvcounts[i], mpi_errno);
MPIR_ERRTEST_USERBUFFER(recvbuf, recvcounts[i], recvtype, mpi_errno);
break;
}
}
/* catch common aliasing cases */
if (sendbuf != MPI_IN_PLACE && sendtype == recvtype &&
recvcounts[comm_ptr->rank] != 0 && sendcount != 0) {
int recvtype_size;
MPIR_Datatype_get_size_macro(recvtype, recvtype_size);
MPIR_ERRTEST_ALIAS_COLL(sendbuf,
(char *) recvbuf +
displs[comm_ptr->rank] * recvtype_size, mpi_errno);
}
} else
MPIR_ERRTEST_SENDBUF_INPLACE(sendbuf, sendcount, mpi_errno);
}
if (comm_ptr->comm_kind == MPIR_COMM_KIND__INTERCOMM) {
MPIR_ERRTEST_INTER_ROOT(comm_ptr, root, mpi_errno);
if (root == MPI_ROOT) {
comm_size = comm_ptr->remote_size;
for (i = 0; i < comm_size; i++) {
MPIR_ERRTEST_COUNT(recvcounts[i], mpi_errno);
MPIR_ERRTEST_DATATYPE(recvtype, "recvtype", mpi_errno);
}
if (HANDLE_GET_KIND(recvtype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype_get_ptr(recvtype, recvtype_ptr);
MPIR_Datatype_valid_ptr(recvtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
MPIR_Datatype_committed_ptr(recvtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
}
for (i = 0; i < comm_size; i++) {
if (recvcounts[i] > 0) {
MPIR_ERRTEST_RECVBUF_INPLACE(recvbuf, recvcounts[i], mpi_errno);
MPIR_ERRTEST_USERBUFFER(recvbuf, recvcounts[i], recvtype, mpi_errno);
break;
}
}
} else if (root != MPI_PROC_NULL) {
MPIR_ERRTEST_COUNT(sendcount, mpi_errno);
MPIR_ERRTEST_DATATYPE(sendtype, "sendtype", mpi_errno);
if (HANDLE_GET_KIND(sendtype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype_get_ptr(sendtype, sendtype_ptr);
MPIR_Datatype_valid_ptr(sendtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
MPIR_Datatype_committed_ptr(sendtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
}
MPIR_ERRTEST_SENDBUF_INPLACE(sendbuf, sendcount, mpi_errno);
MPIR_ERRTEST_USERBUFFER(sendbuf, sendcount, sendtype, mpi_errno);
}
}
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Gatherv(sendbuf, sendcount, sendtype,
recvbuf, recvcounts, displs, recvtype, root, comm_ptr, &errflag);
if (mpi_errno)
goto fn_fail;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_COLL_EXIT(MPID_STATE_MPI_GATHERV);
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_gatherv", "**mpi_gatherv %p %d %D %p %p %p %D %d %C",
sendbuf, sendcount, sendtype, recvbuf, recvcounts, displs,
recvtype, root, comm);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, __func__, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Neighbor_alltoall - In this function, each process i receives data items
from each process j if an edge (j,i) exists in the topology graph or Cartesian
topology. Similarly, each process i sends data items to all processes j where an
edge (i,j) exists. This call is more general than MPI_NEIGHBOR_ALLGATHER in that
different data items can be sent to each neighbor. The k-th block in send buffer
is sent to the k-th neighboring process and the l-th block in the receive buffer
is received from the l-th neighbor.
Input Parameters:
+ sendbuf - starting address of the send buffer (choice)
. sendcount - number of elements sent to each neighbor (non-negative integer)
. sendtype - data type of send buffer elements (handle)
. recvcount - number of elements received from each neighbor (non-negative integer)
. recvtype - data type of receive buffer elements (handle)
- comm - communicator (handle)
Output Parameters:
. recvbuf - starting address of the receive buffer (choice)
.N ThreadSafe
.N Fortran
.N Errors
@*/
int MPI_Neighbor_alltoall(const void *sendbuf, int sendcount, MPI_Datatype sendtype, void *recvbuf, int recvcount, MPI_Datatype recvtype, MPI_Comm comm)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_NEIGHBOR_ALLTOALL);
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_NEIGHBOR_ALLTOALL);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
MPIR_ERRTEST_DATATYPE(sendtype, "sendtype", mpi_errno);
MPIR_ERRTEST_DATATYPE(recvtype, "recvtype", mpi_errno);
MPIR_ERRTEST_COMM(comm, mpi_errno);
/* TODO more checks may be appropriate */
}
MPID_END_ERROR_CHECKS
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, comm_ptr);
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
if (HANDLE_GET_KIND(sendtype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype *sendtype_ptr = NULL;
MPID_Datatype_get_ptr(sendtype, sendtype_ptr);
MPIR_Datatype_valid_ptr(sendtype_ptr, mpi_errno);
MPID_Datatype_committed_ptr(sendtype_ptr, mpi_errno);
}
if (HANDLE_GET_KIND(recvtype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype *recvtype_ptr = NULL;
MPID_Datatype_get_ptr(recvtype, recvtype_ptr);
MPIR_Datatype_valid_ptr(recvtype_ptr, mpi_errno);
MPID_Datatype_committed_ptr(recvtype_ptr, mpi_errno);
}
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
/* TODO more checks may be appropriate (counts, in_place, buffer aliasing, etc) */
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPID_END_ERROR_CHECKS
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPID_Neighbor_alltoall(sendbuf, sendcount, sendtype, recvbuf, recvcount, recvtype, comm_ptr);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_NEIGHBOR_ALLTOALL);
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_neighbor_alltoall", "**mpi_neighbor_alltoall %p %d %D %p %d %D %C", sendbuf, sendcount, sendtype, recvbuf, recvcount, recvtype, comm);
}
# endif
mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Cart_coords - Determines process coords in cartesian topology given
rank in group
Input Parameters:
+ comm - communicator with cartesian structure (handle)
. rank - rank of a process within group of 'comm' (integer)
- maxdims - length of vector 'coords' in the calling program (integer)
Output Parameters:
. coords - integer array (of size 'ndims') containing the Cartesian
coordinates of specified process (integer)
.N SignalSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TOPOLOGY
.N MPI_ERR_RANK
.N MPI_ERR_DIMS
.N MPI_ERR_ARG
@*/
int MPI_Cart_coords(MPI_Comm comm, int rank, int maxdims, int coords[])
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Topology *cart_ptr;
int i, nnodes;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_CART_COORDS);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_CART_COORDS);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, 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, TRUE);
/* If comm_ptr is not valid, it will be reset to null */
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
MPIR_ERRTEST_RANK(comm_ptr, rank, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
cart_ptr = MPIR_Topology_get(comm_ptr);
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERR_CHKANDJUMP((!cart_ptr ||
cart_ptr->kind != MPI_CART), mpi_errno, MPI_ERR_TOPOLOGY,
"**notcarttopo");
MPIR_ERR_CHKANDJUMP2((cart_ptr->topo.cart.ndims > maxdims), mpi_errno, MPI_ERR_ARG,
"**dimsmany", "**dimsmany %d %d", cart_ptr->topo.cart.ndims,
maxdims);
if (cart_ptr->topo.cart.ndims) {
MPIR_ERRTEST_ARGNULL(coords, "coords", mpi_errno);
}
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
/* Calculate coords */
nnodes = cart_ptr->topo.cart.nnodes;
for (i = 0; i < cart_ptr->topo.cart.ndims; i++) {
nnodes = nnodes / cart_ptr->topo.cart.dims[i];
coords[i] = rank / nnodes;
rank = rank % nnodes;
}
/* ... end of body of routine ... */
#ifdef HAVE_ERROR_CHECKING
fn_exit:
#endif
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_CART_COORDS);
return mpi_errno;
#ifdef HAVE_ERROR_CHECKING
fn_fail:
/* --BEGIN ERROR HANDLING-- */
{
mpi_errno =
MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_cart_coords", "**mpi_cart_coords %C %d %d %p", comm, rank,
maxdims, coords);
}
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
#endif
}
/*@
MPI_Comm_create_group - Creates a new communicator
Input Parameters:
+ comm - communicator (handle)
. group - group, which is a subset of the group of 'comm' (handle)
- tag - safe tag unused by other communication
Output Parameters:
. newcomm - new communicator (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_GROUP
.seealso: MPI_Comm_free
@*/
int MPI_Comm_create_group(MPI_Comm comm, MPI_Group group, int tag, MPI_Comm * newcomm)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL, *newcomm_ptr;
MPIR_Group *group_ptr;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_COMM_CREATE_GROUP);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_COMM_CREATE_GROUP);
/* Validate parameters, and convert MPI object handles to object pointers */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
MPIR_Comm_get_ptr( comm, comm_ptr );
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr */
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
if (mpi_errno) goto fn_fail;
/* If comm_ptr is not valid, it will be reset to null */
MPIR_ERRTEST_COMM_INTRA(comm_ptr, mpi_errno);
/* only test for MPI_GROUP_NULL after attempting to convert the comm
* so that any errhandlers on comm will (correctly) be invoked */
MPIR_ERRTEST_GROUP(group, mpi_errno);
MPIR_ERRTEST_COMM_TAG(tag, mpi_errno);
}
MPID_END_ERROR_CHECKS;
MPIR_Group_get_ptr( group, group_ptr );
MPID_BEGIN_ERROR_CHECKS;
{
/* Check the group ptr */
MPIR_Group_valid_ptr( group_ptr, mpi_errno );
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# else
{
MPIR_Comm_get_ptr( comm, comm_ptr );
MPIR_Group_get_ptr( group, group_ptr );
}
# endif
/* ... body of routine ... */
mpi_errno = MPIR_Comm_create_group(comm_ptr, group_ptr, tag, &newcomm_ptr);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
if (newcomm_ptr)
MPIR_OBJ_PUBLISH_HANDLE(*newcomm, newcomm_ptr->handle);
else
*newcomm = MPI_COMM_NULL;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_COMM_CREATE_GROUP);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
#ifdef HAVE_ERROR_CHECKING
{
mpi_errno =
MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__,
MPI_ERR_OTHER, "**mpi_comm_create_group",
"**mpi_comm_create_group %C %G %d %p", comm, group, tag,
newcomm);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_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);
}
/*@
MPI_Iallgather - Gathers data from all tasks and distribute the combined data
to all tasks in a nonblocking way
Input Parameters:
+ sendbuf - starting address of the send buffer (choice)
. sendcount - number of elements in send buffer (non-negative integer)
. sendtype - data type of send buffer elements (handle)
. recvcount - number of elements in receive buffer (non-negative integer)
. recvtype - data type of receive buffer elements (handle)
- comm - communicator (handle)
Output Parameters:
+ recvbuf - starting address of the receive buffer (choice)
- request - communication request (handle)
.N ThreadSafe
.N Fortran
.N Errors
@*/
int MPI_Iallgather(const void *sendbuf, int sendcount, MPI_Datatype sendtype,
void *recvbuf, int recvcount, MPI_Datatype recvtype,
MPI_Comm comm, MPI_Request *request)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Request *request_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_IALLGATHER);
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_IALLGATHER);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
if (sendbuf != MPI_IN_PLACE) {
MPIR_ERRTEST_DATATYPE(sendtype, "sendtype", mpi_errno);
MPIR_ERRTEST_COUNT(sendcount, mpi_errno);
}
MPIR_ERRTEST_DATATYPE(recvtype, "recvtype", mpi_errno);
MPIR_ERRTEST_COMM(comm, mpi_errno);
/* TODO more checks may be appropriate */
}
MPID_END_ERROR_CHECKS
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, comm_ptr);
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
if (sendbuf != MPI_IN_PLACE && HANDLE_GET_KIND(sendtype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype *sendtype_ptr = NULL;
MPIR_Datatype_get_ptr(sendtype, sendtype_ptr);
MPIR_Datatype_valid_ptr(sendtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPIR_Datatype_committed_ptr(sendtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
if (HANDLE_GET_KIND(recvtype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype *recvtype_ptr = NULL;
MPIR_Datatype_get_ptr(recvtype, recvtype_ptr);
MPIR_Datatype_valid_ptr(recvtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPIR_Datatype_committed_ptr(recvtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPIR_ERRTEST_ARGNULL(request,"request", mpi_errno);
/* catch common aliasing cases */
if (comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM && recvbuf != MPI_IN_PLACE && sendtype == recvtype && sendcount == recvcount && sendcount != 0) {
int recvtype_size;
MPIR_Datatype_get_size_macro(recvtype, recvtype_size);
MPIR_ERRTEST_ALIAS_COLL(sendbuf, (char*)recvbuf + comm_ptr->rank*recvcount*recvtype_size, mpi_errno);
}
/* TODO more checks may be appropriate (counts, in_place, etc) */
}
MPID_END_ERROR_CHECKS
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Iallgather(sendbuf, sendcount, sendtype, recvbuf, recvcount,
recvtype, comm_ptr, &request_ptr);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* return the handle of the request to the user */
if(request_ptr)
*request = request_ptr->handle;
else *request = MPI_REQUEST_NULL;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_IALLGATHER);
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_iallgather", "**mpi_iallgather %p %d %D %p %d %D %C %p", sendbuf, sendcount, sendtype, recvbuf, recvcount, recvtype, comm, request);
}
# endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Topo_test - Determines the type of topology (if any) associated with a
communicator
Input Parameters:
. comm - communicator (handle)
Output Parameters:
. status - topology type of communicator 'comm' (integer). If the
communicator has no associated topology, returns 'MPI_UNDEFINED'.
.N SignalSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_ARG
.seealso: MPI_Graph_create, MPI_Cart_create
@*/
int MPI_Topo_test(MPI_Comm comm, int *status)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Topology *topo_ptr;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TOPO_TEST);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TOPO_TEST);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, 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, TRUE);
if (mpi_errno)
goto fn_fail;
/* If comm_ptr is not valid, it will be reset to null */
MPIR_ERRTEST_ARGNULL(status, "status", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
topo_ptr = MPIR_Topology_get(comm_ptr);
if (topo_ptr) {
*status = (int) (topo_ptr->kind);
} else {
*status = MPI_UNDEFINED;
}
/* ... end of body of routine ... */
#ifdef HAVE_ERROR_CHECKING
fn_exit:
#endif
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TOPO_TEST);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
#ifdef HAVE_ERROR_CHECKING
fn_fail:
{
mpi_errno =
MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_OTHER,
"**mpi_topo_test", "**mpi_topo_test %C %p", comm, status);
}
mpi_errno = MPIR_Err_return_comm(comm_ptr, __func__, mpi_errno);
goto fn_exit;
#endif
/* --END ERROR HANDLING-- */
}
/*@
MPI_Graph_get - Retrieves graph topology information associated with a
communicator
Input Parameters:
+ comm - communicator with graph structure (handle)
. maxindex - length of vector 'indx' in the calling program (integer)
- maxedges - length of vector 'edges' in the calling program (integer)
Output Parameters:
+ indx - array of integers containing the graph structure (for details see the definition of 'MPI_GRAPH_CREATE')
- edges - array of integers containing the graph structure
.N SignalSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TOPOLOGY
.N MPI_ERR_COMM
.N MPI_ERR_ARG
@*/
int MPI_Graph_get(MPI_Comm comm, int maxindex, int maxedges, int indx[], int edges[])
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Topology *topo_ptr;
int i, n, *vals;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_GRAPH_GET);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_GRAPH_GET);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, 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, TRUE);
if (mpi_errno)
goto fn_fail;
/* If comm_ptr is not valid, it will be reset to null */
MPIR_ERRTEST_ARGNULL(edges, "edges", mpi_errno);
MPIR_ERRTEST_ARGNULL(indx, "indx", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
topo_ptr = MPIR_Topology_get(comm_ptr);
MPIR_ERR_CHKANDJUMP((!topo_ptr ||
topo_ptr->kind != MPI_GRAPH), mpi_errno, MPI_ERR_TOPOLOGY,
"**notgraphtopo");
MPIR_ERR_CHKANDJUMP3((topo_ptr->topo.graph.nnodes > maxindex), mpi_errno, MPI_ERR_ARG,
"**argtoosmall", "**argtoosmall %s %d %d", "maxindex", maxindex,
topo_ptr->topo.graph.nnodes);
MPIR_ERR_CHKANDJUMP3((topo_ptr->topo.graph.nedges > maxedges), mpi_errno, MPI_ERR_ARG,
"**argtoosmall", "**argtoosmall %s %d %d", "maxedges", maxedges,
topo_ptr->topo.graph.nedges);
/* Get index */
n = topo_ptr->topo.graph.nnodes;
vals = topo_ptr->topo.graph.index;
for (i = 0; i < n; i++)
*indx++ = *vals++;
/* Get edges */
n = topo_ptr->topo.graph.nedges;
vals = topo_ptr->topo.graph.edges;
for (i = 0; i < n; i++)
*edges++ = *vals++;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_GRAPH_GET);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
#ifdef HAVE_ERROR_CHECKING
{
mpi_errno =
MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_graph_get", "**mpi_graph_get %C %d %d %p %p", comm,
maxindex, maxedges, indx, edges);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Exscan - Computes the exclusive scan (partial reductions) of data on a
collection of processes
Input Parameters:
+ sendbuf - starting address of send buffer (choice)
. count - number of elements in input buffer (integer)
. datatype - data type of elements of input buffer (handle)
. op - operation (handle)
- comm - communicator (handle)
Output Parameters:
. recvbuf - starting address of receive buffer (choice)
Notes:
'MPI_Exscan' is like 'MPI_Scan', except that the contribution from the
calling process is not included in the result at the calling process
(it is contributed to the subsequent processes, of course).
.N ThreadSafe
.N Fortran
.N collops
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_COUNT
.N MPI_ERR_TYPE
.N MPI_ERR_BUFFER
.N MPI_ERR_BUFFER_ALIAS
@*/
int MPI_Exscan(const void *sendbuf, void *recvbuf, int count, MPI_Datatype datatype,
MPI_Op op, MPI_Comm comm)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_EXSCAN);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_COLL_ENTER(MPID_STATE_MPI_EXSCAN);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr( comm, comm_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_Datatype *datatype_ptr = NULL;
MPIR_Op *op_ptr = NULL;
int rank;
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPIR_ERRTEST_COMM_INTRA(comm_ptr, mpi_errno);
MPIR_ERRTEST_COUNT(count, mpi_errno);
MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno);
MPIR_ERRTEST_OP(op, mpi_errno);
if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) {
MPID_Datatype_get_ptr(datatype, datatype_ptr);
MPIR_Datatype_valid_ptr( datatype_ptr, mpi_errno );
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPID_Datatype_committed_ptr( datatype_ptr, mpi_errno );
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
rank = comm_ptr->rank;
MPIR_ERRTEST_USERBUFFER(sendbuf,count,datatype,mpi_errno);
if (rank != 0) {
MPIR_ERRTEST_RECVBUF_INPLACE(recvbuf, count, mpi_errno);
MPIR_ERRTEST_USERBUFFER(recvbuf,count,datatype,mpi_errno);
}
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
if (HANDLE_GET_KIND(op) != HANDLE_KIND_BUILTIN) {
MPIR_Op_get_ptr(op, op_ptr);
MPIR_Op_valid_ptr( op_ptr, mpi_errno );
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
if (HANDLE_GET_KIND(op) == HANDLE_KIND_BUILTIN) {
mpi_errno =
( * MPIR_OP_HDL_TO_DTYPE_FN(op) )(datatype);
}
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
if (sendbuf != MPI_IN_PLACE && count != 0)
MPIR_ERRTEST_ALIAS_COLL(sendbuf, recvbuf, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPID_Exscan(sendbuf, recvbuf, count, datatype, op, comm_ptr, &errflag);
if (mpi_errno) goto fn_fail;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_COLL_EXIT(MPID_STATE_MPI_EXSCAN);
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_exscan",
"**mpi_exscan %p %p %d %D %O %C", sendbuf, recvbuf, count, datatype, op, comm);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Ibsend - Starts a nonblocking buffered send
Input Parameters:
+ buf - initial address of send buffer (choice)
. count - number of elements in send buffer (integer)
. datatype - datatype of each send buffer element (handle)
. dest - rank of destination (integer)
. tag - message tag (integer)
- comm - communicator (handle)
Output Parameters:
. request - communication request (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_COUNT
.N MPI_ERR_TYPE
.N MPI_ERR_TAG
.N MPI_ERR_RANK
.N MPI_ERR_BUFFER
@*/
int MPI_Ibsend(const void *buf, int count, MPI_Datatype datatype, int dest, int tag,
MPI_Comm comm, MPI_Request * request)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_IBSEND);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_PT2PT_ENTER_FRONT(MPID_STATE_MPI_IBSEND);
/* Validate handle parameters needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, comm_ptr);
/* Validate parameters if error checking is enabled */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COUNT(count, mpi_errno);
/* Validate comm_ptr */
MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, FALSE);
if (mpi_errno)
goto fn_fail;
/* If comm_ptr is not valid, it will be reset to null */
if (comm_ptr) {
MPIR_ERRTEST_SEND_TAG(tag, mpi_errno);
MPIR_ERRTEST_SEND_RANK(comm_ptr, dest, 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 ... */
mpi_errno = MPIR_Ibsend_impl(buf, count, datatype, dest, tag, comm_ptr, request);
if (mpi_errno)
goto fn_fail;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_PT2PT_EXIT(MPID_STATE_MPI_IBSEND);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
/* FIXME: should we be setting the request at all in the case of an error? */
*request = MPI_REQUEST_NULL;
#ifdef HAVE_ERROR_REPORTING
{
mpi_errno =
MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_ibsend", "**mpi_ibsend %p %d %D %i %t %C %p", buf, count,
datatype, dest, tag, comm, request);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPIX_Comm_shrink - Creates a new communitor from an existing communicator while
excluding failed processes
Input Parameters:
. comm - communicator (handle)
Output Parameters:
. newcomm - new communicator (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
@*/
int MPIX_Comm_shrink(MPI_Comm comm, MPI_Comm * newcomm)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL, *newcomm_ptr;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPIX_COMM_SHRINK);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPIX_COMM_SHRINK);
/* Validate parameters, and convert MPI object handles to object pointers */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
MPIR_Comm_get_ptr(comm, comm_ptr);
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr */
MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, TRUE);
if (mpi_errno)
goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
#else
{
MPIR_Comm_get_ptr(comm, comm_ptr);
}
#endif
/* ... body of routine ... */
mpi_errno = MPIR_Comm_shrink(comm_ptr, &newcomm_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
if (newcomm_ptr)
MPIR_OBJ_PUBLISH_HANDLE(*newcomm, newcomm_ptr->handle);
else
*newcomm = MPI_COMM_NULL;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPIX_COMM_SHRINK);
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, "**mpix_comm_shrink",
"**mpix_comm_shrink %C %p", comm, newcomm);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, __func__, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Cartdim_get - Retrieves Cartesian topology information associated with a
communicator
Input Parameters:
. comm - communicator with cartesian structure (handle)
Output Parameters:
. ndims - number of dimensions of the cartesian structure (integer)
.N SignalSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_ARG
@*/
int MPI_Cartdim_get(MPI_Comm comm, int *ndims)
{
static const char FCNAME[] = "MPI_Cartdim_get";
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Topology *cart_ptr;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_CARTDIM_GET);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_CARTDIM_GET);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr( comm, comm_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_ARGNULL(ndims,"ndims",mpi_errno);
/* Validate comm_ptr */
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, TRUE );
/* If comm_ptr is not valid, it will be reset to null */
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
cart_ptr = MPIR_Topology_get( comm_ptr );
MPIR_ERR_CHKANDJUMP((!cart_ptr || cart_ptr->kind != MPI_CART), mpi_errno, MPI_ERR_TOPOLOGY, "**notcarttopo");
*ndims = cart_ptr->topo.cart.ndims;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_CARTDIM_GET);
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_cartdim_get",
"**mpi_cartdim_get %C %p", comm, ndims);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Win_create - Create an MPI Window object for one-sided communication
This is a collective call executed by all processes in the group of comm. It
returns a window object that can be used by these processes to perform RMA
operations. Each process specifies a window of existing memory that it exposes
to RMA accesses by the processes in the group of comm. The window consists of
size bytes, starting at address base. In C, base is the starting address of a
memory region. In Fortran, one can pass the first element of a memory region or
a whole array, which must be ''simply contiguous'' (for ''simply contiguous'', see
also MPI 3.0, Section 17.1.12 on page 626). A process may elect to expose no
memory by specifying size = 0.
Input Parameters:
+ base - initial address of window (choice)
. size - size of window in bytes (nonnegative integer)
. disp_unit - local unit size for displacements, in bytes (positive integer)
. info - info argument (handle)
- comm - communicator (handle)
Output Parameters:
. win - window object returned by the call (handle)
Notes:
The displacement unit argument is provided to facilitate address arithmetic in
RMA operations: the target displacement argument of an RMA operation is scaled
by the factor disp_unit specified by the target process, at window creation.
The info argument provides optimization hints to the runtime about the expected
usage pattern of the window. The following info keys are predefined.
. no_locks - If set to true, then the implementation may assume that passive
target synchronization (i.e., 'MPI_Win_lock', 'MPI_Win_lock_all') will not be used on
the given window. This implies that this window is not used for 3-party
communication, and RMA can be implemented with no (less) asynchronous agent
activity at this process.
. accumulate_ordering - Controls the ordering of accumulate operations at the
target. The argument string should contain a comma-separated list of the
following read/write ordering rules, where e.g. "raw" means read-after-write:
"rar,raw,war,waw".
. accumulate_ops - If set to same_op, the implementation will assume that all
concurrent accumulate calls to the same target address will use the same
operation. If set to same_op_no_op, then the implementation will assume that
all concurrent accumulate calls to the same target address will use the same
operation or 'MPI_NO_OP'. This can eliminate the need to protect access for
certain operation types where the hardware can guarantee atomicity. The default
is same_op_no_op.
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_ARG
.N MPI_ERR_COMM
.N MPI_ERR_INFO
.N MPI_ERR_OTHER
.N MPI_ERR_SIZE
.seealso: MPI_Win_allocate MPI_Win_allocate_shared MPI_Win_create_dynamic MPI_Win_free
@*/
int MPI_Win_create(void *base, MPI_Aint size, int disp_unit, MPI_Info info,
MPI_Comm comm, MPI_Win *win)
{
static const char FCNAME[] = "MPI_Win_create";
int mpi_errno = MPI_SUCCESS;
MPIR_Win *win_ptr = NULL;
MPIR_Comm *comm_ptr = NULL;
MPIR_Info *info_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_WIN_CREATE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_RMA_ENTER(MPID_STATE_MPI_WIN_CREATE);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
MPIR_ERRTEST_INFO_OR_NULL(info, mpi_errno);
MPIR_ERRTEST_ARGNULL(win, "win", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr( comm, comm_ptr );
MPIR_Info_get_ptr( info, info_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate pointers */
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
if (size < 0)
mpi_errno = MPIR_Err_create_code( MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
FCNAME, __LINE__,
MPI_ERR_SIZE,
"**rmasize",
"**rmasize %d", size);
if (disp_unit <= 0)
mpi_errno = MPIR_Err_create_code( MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
FCNAME, __LINE__,
MPI_ERR_ARG,
"**arg", "**arg %s",
"disp_unit must be positive");
if (size > 0 && base == NULL)
mpi_errno = MPIR_Err_create_code( MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
FCNAME, __LINE__,
MPI_ERR_ARG,
"**nullptr",
"**nullptr %s",
"NULL base pointer is invalid when size is nonzero");
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPID_Win_create(base, size, disp_unit, info_ptr,
comm_ptr, &win_ptr);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* Initialize a few fields that have specific defaults */
win_ptr->name[0] = 0;
win_ptr->errhandler = 0;
/* return the handle of the window object to the user */
MPIR_OBJ_PUBLISH_HANDLE(*win, win_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_RMA_EXIT(MPID_STATE_MPI_WIN_CREATE);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_win_create",
"**mpi_win_create %p %d %d %I %C %p", base, size, disp_unit, info, comm, win);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Igather - Gathers together values from a group of processes in
a nonblocking way
Input Parameters:
+ sendbuf - starting address of the send buffer (choice)
. sendcount - number of elements in send buffer (non-negative integer)
. sendtype - data type of send buffer elements (handle)
. recvcount - number of elements for any single receive (non-negative integer, significant only at root)
. recvtype - data type of receive buffer elements (significant only at root) (handle)
. root - rank of receiving process (integer)
- comm - communicator (handle)
Output Parameters:
+ recvbuf - starting address of the receive buffer (significant only at root) (choice)
- request - communication request (handle)
.N ThreadSafe
.N Fortran
.N Errors
@*/
int MPI_Igather(const void *sendbuf, int sendcount, MPI_Datatype sendtype,
void *recvbuf, int recvcount, MPI_Datatype recvtype,
int root, MPI_Comm comm, MPI_Request * request)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Request *request_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_IGATHER);
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_IGATHER);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, comm_ptr);
/* Validate parameters and objects (post conversion) */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_Datatype *sendtype_ptr = NULL, *recvtype_ptr = NULL;
int rank;
MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, FALSE);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
if (comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM) {
MPIR_ERRTEST_INTRA_ROOT(comm_ptr, root, mpi_errno);
if (sendbuf != MPI_IN_PLACE) {
MPIR_ERRTEST_COUNT(sendcount, mpi_errno);
MPIR_ERRTEST_DATATYPE(sendtype, "sendtype", mpi_errno);
if (HANDLE_GET_KIND(sendtype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype_get_ptr(sendtype, sendtype_ptr);
MPIR_Datatype_valid_ptr(sendtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
MPIR_Datatype_committed_ptr(sendtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
}
MPIR_ERRTEST_USERBUFFER(sendbuf, sendcount, sendtype, mpi_errno);
}
rank = comm_ptr->rank;
if (rank == root) {
MPIR_ERRTEST_COUNT(recvcount, mpi_errno);
MPIR_ERRTEST_DATATYPE(recvtype, "recvtype", mpi_errno);
if (HANDLE_GET_KIND(recvtype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype_get_ptr(recvtype, recvtype_ptr);
MPIR_Datatype_valid_ptr(recvtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
MPIR_Datatype_committed_ptr(recvtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
}
MPIR_ERRTEST_RECVBUF_INPLACE(recvbuf, recvcount, mpi_errno);
MPIR_ERRTEST_USERBUFFER(recvbuf, recvcount, recvtype, mpi_errno);
/* catch common aliasing cases */
if (recvbuf != MPI_IN_PLACE && sendtype == recvtype && sendcount == recvcount &&
sendcount != 0) {
MPI_Aint recvtype_size;
MPIR_Datatype_get_size_macro(recvtype, recvtype_size);
MPIR_ERRTEST_ALIAS_COLL(sendbuf,
(char *) recvbuf +
comm_ptr->rank * recvcount * recvtype_size,
mpi_errno);
}
} else
MPIR_ERRTEST_SENDBUF_INPLACE(sendbuf, sendcount, mpi_errno);
}
if (comm_ptr->comm_kind == MPIR_COMM_KIND__INTERCOMM) {
MPIR_ERRTEST_INTER_ROOT(comm_ptr, root, mpi_errno);
if (root == MPI_ROOT) {
MPIR_ERRTEST_COUNT(recvcount, mpi_errno);
MPIR_ERRTEST_DATATYPE(recvtype, "recvtype", mpi_errno);
if (HANDLE_GET_KIND(recvtype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype_get_ptr(recvtype, recvtype_ptr);
MPIR_Datatype_valid_ptr(recvtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
MPIR_Datatype_committed_ptr(recvtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
}
MPIR_ERRTEST_RECVBUF_INPLACE(recvbuf, recvcount, mpi_errno);
MPIR_ERRTEST_USERBUFFER(recvbuf, recvcount, recvtype, mpi_errno);
}
else if (root != MPI_PROC_NULL) {
MPIR_ERRTEST_COUNT(sendcount, mpi_errno);
MPIR_ERRTEST_DATATYPE(sendtype, "sendtype", mpi_errno);
if (HANDLE_GET_KIND(sendtype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype_get_ptr(sendtype, sendtype_ptr);
MPIR_Datatype_valid_ptr(sendtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
MPIR_Datatype_committed_ptr(sendtype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
}
MPIR_ERRTEST_SENDBUF_INPLACE(sendbuf, sendcount, mpi_errno);
MPIR_ERRTEST_USERBUFFER(sendbuf, sendcount, sendtype, mpi_errno);
}
}
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Igather(sendbuf, sendcount, sendtype, recvbuf, recvcount, recvtype,
root, comm_ptr, &request_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* create a complete request, if needed */
if (!request_ptr)
request_ptr = MPIR_Request_create_complete(MPIR_REQUEST_KIND__COLL);
/* return the handle of the request to the user */
*request = request_ptr->handle;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_IGATHER);
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_igather", "**mpi_igather %p %d %D %p %d %D %d %C %p",
sendbuf, sendcount, sendtype, recvbuf, recvcount, recvtype, root,
comm, request);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, __func__, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Bcast - Broadcasts a message from the process with rank "root" to
all other processes of the communicator
Input/Output Parameters:
. buffer - starting address of buffer (choice)
Input Parameters:
+ count - number of entries in buffer (integer)
. datatype - data type of buffer (handle)
. root - rank of broadcast root (integer)
- comm - communicator (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_COUNT
.N MPI_ERR_TYPE
.N MPI_ERR_BUFFER
.N MPI_ERR_ROOT
@*/
int MPI_Bcast(void *buffer, int count, MPI_Datatype datatype, int root, MPI_Comm comm)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_BCAST);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_COLL_ENTER(MPID_STATE_MPI_BCAST);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, comm_ptr);
/* Validate parameters and objects (post conversion) */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_Datatype *datatype_ptr = NULL;
MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, FALSE);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
MPIR_ERRTEST_COUNT(count, mpi_errno);
MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno);
if (comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM) {
MPIR_ERRTEST_INTRA_ROOT(comm_ptr, root, mpi_errno);
} else {
MPIR_ERRTEST_INTER_ROOT(comm_ptr, root, mpi_errno);
}
if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype_get_ptr(datatype, datatype_ptr);
MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
MPIR_Datatype_committed_ptr(datatype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
}
MPIR_ERRTEST_BUF_INPLACE(buffer, count, mpi_errno);
MPIR_ERRTEST_USERBUFFER(buffer, count, datatype, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Bcast(buffer, count, datatype, root, comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_COLL_EXIT(MPID_STATE_MPI_BCAST);
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_bcast", "**mpi_bcast %p %d %D %d %C", buffer, count,
datatype, root, comm);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, __func__, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Ialltoallw - Nonblocking generalized all-to-all communication allowing
different datatypes, counts, and displacements for each partner
Input Parameters:
+ sendbuf - starting address of the send buffer (choice)
. sendcounts - non-negative integer array (of length group size) specifying the number of elements to send to each processor
. sdispls - integer array (of length group size). Entry j specifies the displacement relative to sendbuf from which to take the outgoing data destined for process j
. sendtypes - array of datatypes (of length group size). Entry j specifies the type of data to send to process j (array of handles)
. recvcounts - non-negative integer array (of length group size) specifying the number of elements that can be received from each processor
. rdispls - integer array (of length group size). Entry i specifies the displacement relative to recvbuf at which to place the incoming data from process i
. recvtypes - array of datatypes (of length group size). Entry i specifies the type of data received from process i (array of handles)
- comm - communicator (handle)
Output Parameters:
+ recvbuf - starting address of the receive buffer (choice)
- request - communication request (handle)
.N ThreadSafe
.N Fortran
.N Errors
@*/
int MPI_Ialltoallw(const void *sendbuf, const int sendcounts[], const int sdispls[],
const MPI_Datatype sendtypes[], void *recvbuf, const int recvcounts[],
const int rdispls[], const MPI_Datatype recvtypes[], MPI_Comm comm,
MPI_Request *request)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Request *request_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_IALLTOALLW);
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_IALLTOALLW);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
/* TODO more checks may be appropriate */
}
MPID_END_ERROR_CHECKS
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, comm_ptr);
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
if (sendbuf != MPI_IN_PLACE) {
MPIR_ERRTEST_ARGNULL(sendcounts,"sendcounts", mpi_errno);
MPIR_ERRTEST_ARGNULL(sdispls,"sdispls", mpi_errno);
MPIR_ERRTEST_ARGNULL(sendtypes,"sendtypes", mpi_errno);
if (comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM &&
sendcounts == recvcounts &&
sendtypes == recvtypes)
MPIR_ERRTEST_ALIAS_COLL(sendbuf,recvbuf,mpi_errno);
}
MPIR_ERRTEST_ARGNULL(recvcounts,"recvcounts", mpi_errno);
MPIR_ERRTEST_ARGNULL(rdispls,"rdispls", mpi_errno);
MPIR_ERRTEST_ARGNULL(recvtypes,"recvtypes", mpi_errno);
if (comm_ptr->comm_kind == MPIR_COMM_KIND__INTERCOMM && sendbuf == MPI_IN_PLACE) {
MPIR_ERR_SETANDJUMP(mpi_errno, MPI_ERR_OTHER, "**sendbuf_inplace");
}
MPIR_ERRTEST_ARGNULL(request,"request", mpi_errno);
/* TODO more checks may be appropriate (counts, in_place, etc) */
}
MPID_END_ERROR_CHECKS
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Ialltoallw(sendbuf, sendcounts, sdispls, sendtypes, recvbuf,
recvcounts, rdispls, recvtypes, comm_ptr, &request_ptr);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* return the handle of the request to the user */
if(request_ptr)
*request = request_ptr->handle;
else *request = MPI_REQUEST_NULL;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_IALLTOALLW);
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_ialltoallw", "**mpi_ialltoallw %p %p %p %p %p %p %p %p %C %p", sendbuf, sendcounts, sdispls, sendtypes, recvbuf, recvcounts, rdispls, recvtypes, comm, request);
}
# endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Dist_graph_create - MPI_DIST_GRAPH_CREATE returns a handle to a new
communicator to which the distributed graph topology information is
attached.
Input Parameters:
+ comm_old - input communicator (handle)
. n - number of source nodes for which this process specifies edges
(non-negative integer)
. sources - array containing the n source nodes for which this process
specifies edges (array of non-negative integers)
. degrees - array specifying the number of destinations for each source node
in the source node array (array of non-negative integers)
. destinations - destination nodes for the source nodes in the source node
array (array of non-negative integers)
. weights - weights for source to destination edges (array of non-negative
integers or MPI_UNWEIGHTED)
. info - hints on optimization and interpretation of weights (handle)
- reorder - the process may be reordered (true) or not (false) (logical)
Output Parameters:
. comm_dist_graph - communicator with distributed graph topology added (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_ARG
.N MPI_ERR_OTHER
@*/
int MPI_Dist_graph_create(MPI_Comm comm_old, int n, const int sources[],
const int degrees[], const int destinations[],
const int weights[],
MPI_Info info, int reorder, MPI_Comm * comm_dist_graph)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Comm *comm_dist_graph_ptr = NULL;
MPIR_Request **reqs = NULL;
MPIR_Topology *topo_ptr = NULL;
MPII_Dist_graph_topology *dist_graph_ptr = NULL;
int i;
int j;
int idx;
int comm_size = 0;
int in_capacity;
int out_capacity;
int **rout = NULL;
int **rin = NULL;
int *rin_sizes;
int *rout_sizes;
int *rin_idx;
int *rout_idx;
int *rs;
int in_out_peers[2] = { -1, -1 };
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
MPIR_CHKLMEM_DECL(9);
MPIR_CHKPMEM_DECL(1);
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_DIST_GRAPH_CREATE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_DIST_GRAPH_CREATE);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm_old, mpi_errno);
MPIR_ERRTEST_INFO_OR_NULL(info, mpi_errno);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
#endif
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm_old, comm_ptr);
/* Validate parameters and objects (post conversion) */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr */
MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, FALSE);
/* If comm_ptr is not valid, it will be reset to null */
if (comm_ptr) {
MPIR_ERRTEST_COMM_INTRA(comm_ptr, mpi_errno);
}
MPIR_ERRTEST_ARGNEG(n, "n", mpi_errno);
if (n > 0) {
int have_degrees = 0;
MPIR_ERRTEST_ARGNULL(sources, "sources", mpi_errno);
MPIR_ERRTEST_ARGNULL(degrees, "degrees", mpi_errno);
for (i = 0; i < n; ++i) {
if (degrees[i]) {
have_degrees = 1;
break;
}
}
if (have_degrees) {
MPIR_ERRTEST_ARGNULL(destinations, "destinations", mpi_errno);
if (weights != MPI_UNWEIGHTED)
MPIR_ERRTEST_ARGNULL(weights, "weights", mpi_errno);
}
}
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
/* Implementation based on Torsten Hoefler's reference implementation
* attached to MPI-2.2 ticket #33. */
*comm_dist_graph = MPI_COMM_NULL;
comm_size = comm_ptr->local_size;
/* following the spirit of the old topo interface, attributes do not
* propagate to the new communicator (see MPI-2.1 pp. 243 line 11) */
mpi_errno = MPII_Comm_copy(comm_ptr, comm_size, &comm_dist_graph_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_Assert(comm_dist_graph_ptr != NULL);
/* rin is an array of size comm_size containing pointers to arrays of
* rin_sizes[x]. rin[x] is locally known number of edges into this process
* from rank x.
*
* rout is an array of comm_size containing pointers to arrays of
* rout_sizes[x]. rout[x] is the locally known number of edges out of this
* process to rank x. */
MPIR_CHKLMEM_MALLOC(rout, int **, comm_size * sizeof(int *), mpi_errno, "rout", MPL_MEM_COMM);
MPIR_CHKLMEM_MALLOC(rin, int **, comm_size * sizeof(int *), mpi_errno, "rin", MPL_MEM_COMM);
MPIR_CHKLMEM_MALLOC(rin_sizes, int *, comm_size * sizeof(int), mpi_errno, "rin_sizes",
MPL_MEM_COMM);
MPIR_CHKLMEM_MALLOC(rout_sizes, int *, comm_size * sizeof(int), mpi_errno, "rout_sizes",
MPL_MEM_COMM);
MPIR_CHKLMEM_MALLOC(rin_idx, int *, comm_size * sizeof(int), mpi_errno, "rin_idx",
MPL_MEM_COMM);
MPIR_CHKLMEM_MALLOC(rout_idx, int *, comm_size * sizeof(int), mpi_errno, "rout_idx",
MPL_MEM_COMM);
memset(rout, 0, comm_size * sizeof(int *));
memset(rin, 0, comm_size * sizeof(int *));
memset(rin_sizes, 0, comm_size * sizeof(int));
memset(rout_sizes, 0, comm_size * sizeof(int));
memset(rin_idx, 0, comm_size * sizeof(int));
memset(rout_idx, 0, comm_size * sizeof(int));
/* compute array sizes */
idx = 0;
for (i = 0; i < n; ++i) {
MPIR_Assert(sources[i] < comm_size);
for (j = 0; j < degrees[i]; ++j) {
MPIR_Assert(destinations[idx] < comm_size);
/* rout_sizes[i] is twice as long as the number of edges to be
* sent to rank i by this process */
rout_sizes[sources[i]] += 2;
rin_sizes[destinations[idx]] += 2;
++idx;
}
}
/* allocate arrays */
for (i = 0; i < comm_size; ++i) {
/* can't use CHKLMEM macros b/c we are in a loop */
if (rin_sizes[i]) {
rin[i] = MPL_malloc(rin_sizes[i] * sizeof(int), MPL_MEM_COMM);
}
if (rout_sizes[i]) {
rout[i] = MPL_malloc(rout_sizes[i] * sizeof(int), MPL_MEM_COMM);
}
}
/* populate arrays */
idx = 0;
for (i = 0; i < n; ++i) {
/* TODO add this assert as proper error checking above */
int s_rank = sources[i];
MPIR_Assert(s_rank < comm_size);
MPIR_Assert(s_rank >= 0);
for (j = 0; j < degrees[i]; ++j) {
int d_rank = destinations[idx];
int weight = (weights == MPI_UNWEIGHTED ? 0 : weights[idx]);
/* TODO add this assert as proper error checking above */
MPIR_Assert(d_rank < comm_size);
MPIR_Assert(d_rank >= 0);
/* XXX DJG what about self-edges? do we need to drop one of these
* cases when there is a self-edge to avoid double-counting? */
/* rout[s][2*x] is the value of d for the j'th edge between (s,d)
* with weight rout[s][2*x+1], where x is the current end of the
* outgoing edge list for s. x==(rout_idx[s]/2) */
rout[s_rank][rout_idx[s_rank]++] = d_rank;
rout[s_rank][rout_idx[s_rank]++] = weight;
/* rin[d][2*x] is the value of s for the j'th edge between (s,d)
* with weight rout[d][2*x+1], where x is the current end of the
* incoming edge list for d. x==(rin_idx[d]/2) */
rin[d_rank][rin_idx[d_rank]++] = s_rank;
rin[d_rank][rin_idx[d_rank]++] = weight;
++idx;
}
}
for (i = 0; i < comm_size; ++i) {
/* sanity check that all arrays are fully populated */
MPIR_Assert(rin_idx[i] == rin_sizes[i]);
MPIR_Assert(rout_idx[i] == rout_sizes[i]);
}
MPIR_CHKLMEM_MALLOC(rs, int *, 2 * comm_size * sizeof(int), mpi_errno, "red-scat source buffer",
MPL_MEM_COMM);
for (i = 0; i < comm_size; ++i) {
rs[2 * i] = (rin_sizes[i] ? 1 : 0);
rs[2 * i + 1] = (rout_sizes[i] ? 1 : 0);
}
/* compute the number of peers I will recv from */
mpi_errno =
MPIR_Reduce_scatter_block(rs, in_out_peers, 2, MPI_INT, MPI_SUM, comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
MPIR_Assert(in_out_peers[0] <= comm_size && in_out_peers[0] >= 0);
MPIR_Assert(in_out_peers[1] <= comm_size && in_out_peers[1] >= 0);
idx = 0;
/* must be 2*comm_size requests because we will possibly send inbound and
* outbound edges to everyone in our communicator */
MPIR_CHKLMEM_MALLOC(reqs, MPIR_Request **, 2 * comm_size * sizeof(MPIR_Request *), mpi_errno,
"temp request array", MPL_MEM_COMM);
for (i = 0; i < comm_size; ++i) {
if (rin_sizes[i]) {
/* send edges where i is a destination to process i */
mpi_errno =
MPIC_Isend(&rin[i][0], rin_sizes[i], MPI_INT, i, MPIR_TOPO_A_TAG, comm_ptr,
&reqs[idx++], &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
if (rout_sizes[i]) {
/* send edges where i is a source to process i */
mpi_errno =
MPIC_Isend(&rout[i][0], rout_sizes[i], MPI_INT, i, MPIR_TOPO_B_TAG, comm_ptr,
&reqs[idx++], &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
}
MPIR_Assert(idx <= (2 * comm_size));
/* Create the topology structure */
MPIR_CHKPMEM_MALLOC(topo_ptr, MPIR_Topology *, sizeof(MPIR_Topology), mpi_errno, "topo_ptr",
MPL_MEM_COMM);
topo_ptr->kind = MPI_DIST_GRAPH;
dist_graph_ptr = &topo_ptr->topo.dist_graph;
dist_graph_ptr->indegree = 0;
dist_graph_ptr->in = NULL;
dist_graph_ptr->in_weights = NULL;
dist_graph_ptr->outdegree = 0;
dist_graph_ptr->out = NULL;
dist_graph_ptr->out_weights = NULL;
dist_graph_ptr->is_weighted = (weights != MPI_UNWEIGHTED);
/* can't use CHKPMEM macros for this b/c we need to realloc */
in_capacity = 10; /* arbitrary */
dist_graph_ptr->in = MPL_malloc(in_capacity * sizeof(int), MPL_MEM_COMM);
if (dist_graph_ptr->is_weighted) {
dist_graph_ptr->in_weights = MPL_malloc(in_capacity * sizeof(int), MPL_MEM_COMM);
MPIR_Assert(dist_graph_ptr->in_weights != NULL);
}
out_capacity = 10; /* arbitrary */
dist_graph_ptr->out = MPL_malloc(out_capacity * sizeof(int), MPL_MEM_COMM);
if (dist_graph_ptr->is_weighted) {
dist_graph_ptr->out_weights = MPL_malloc(out_capacity * sizeof(int), MPL_MEM_COMM);
MPIR_Assert(dist_graph_ptr->out_weights);
}
for (i = 0; i < in_out_peers[0]; ++i) {
MPI_Status status;
MPI_Aint count;
int *buf;
/* receive inbound edges */
mpi_errno = MPIC_Probe(MPI_ANY_SOURCE, MPIR_TOPO_A_TAG, comm_old, &status);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_Get_count_impl(&status, MPI_INT, &count);
/* can't use CHKLMEM macros b/c we are in a loop */
/* FIXME: Why not - there is only one allocated at a time. Is it only
* that there is no defined macro to pop and free an item? */
buf = MPL_malloc(count * sizeof(int), MPL_MEM_COMM);
MPIR_ERR_CHKANDJUMP(!buf, mpi_errno, MPI_ERR_OTHER, "**nomem");
mpi_errno =
MPIC_Recv(buf, count, MPI_INT, MPI_ANY_SOURCE, MPIR_TOPO_A_TAG, comm_ptr,
MPI_STATUS_IGNORE, &errflag);
/* FIXME: buf is never freed on error! */
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
for (j = 0; j < count / 2; ++j) {
int deg = dist_graph_ptr->indegree++;
if (deg >= in_capacity) {
in_capacity *= 2;
/* FIXME: buf is never freed on error! */
MPIR_REALLOC_ORJUMP(dist_graph_ptr->in, in_capacity * sizeof(int), MPL_MEM_COMM,
mpi_errno);
if (dist_graph_ptr->is_weighted)
/* FIXME: buf is never freed on error! */
MPIR_REALLOC_ORJUMP(dist_graph_ptr->in_weights, in_capacity * sizeof(int),
MPL_MEM_COMM, mpi_errno);
}
dist_graph_ptr->in[deg] = buf[2 * j];
if (dist_graph_ptr->is_weighted)
dist_graph_ptr->in_weights[deg] = buf[2 * j + 1];
}
MPL_free(buf);
}
for (i = 0; i < in_out_peers[1]; ++i) {
MPI_Status status;
MPI_Aint count;
int *buf;
/* receive outbound edges */
mpi_errno = MPIC_Probe(MPI_ANY_SOURCE, MPIR_TOPO_B_TAG, comm_old, &status);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_Get_count_impl(&status, MPI_INT, &count);
/* can't use CHKLMEM macros b/c we are in a loop */
/* Why not? */
buf = MPL_malloc(count * sizeof(int), MPL_MEM_COMM);
MPIR_ERR_CHKANDJUMP(!buf, mpi_errno, MPI_ERR_OTHER, "**nomem");
mpi_errno =
MPIC_Recv(buf, count, MPI_INT, MPI_ANY_SOURCE, MPIR_TOPO_B_TAG, comm_ptr,
MPI_STATUS_IGNORE, &errflag);
/* FIXME: buf is never freed on error! */
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
for (j = 0; j < count / 2; ++j) {
int deg = dist_graph_ptr->outdegree++;
if (deg >= out_capacity) {
out_capacity *= 2;
/* FIXME: buf is never freed on error! */
MPIR_REALLOC_ORJUMP(dist_graph_ptr->out, out_capacity * sizeof(int), MPL_MEM_COMM,
mpi_errno);
if (dist_graph_ptr->is_weighted)
/* FIXME: buf is never freed on error! */
MPIR_REALLOC_ORJUMP(dist_graph_ptr->out_weights, out_capacity * sizeof(int),
MPL_MEM_COMM, mpi_errno);
}
dist_graph_ptr->out[deg] = buf[2 * j];
if (dist_graph_ptr->is_weighted)
dist_graph_ptr->out_weights[deg] = buf[2 * j + 1];
}
MPL_free(buf);
}
mpi_errno = MPIC_Waitall(idx, reqs, MPI_STATUSES_IGNORE, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* remove any excess memory allocation */
MPIR_REALLOC_ORJUMP(dist_graph_ptr->in, dist_graph_ptr->indegree * sizeof(int), MPL_MEM_COMM,
mpi_errno);
MPIR_REALLOC_ORJUMP(dist_graph_ptr->out, dist_graph_ptr->outdegree * sizeof(int), MPL_MEM_COMM,
mpi_errno);
if (dist_graph_ptr->is_weighted) {
MPIR_REALLOC_ORJUMP(dist_graph_ptr->in_weights, dist_graph_ptr->indegree * sizeof(int),
MPL_MEM_COMM, mpi_errno);
MPIR_REALLOC_ORJUMP(dist_graph_ptr->out_weights, dist_graph_ptr->outdegree * sizeof(int),
MPL_MEM_COMM, mpi_errno);
}
mpi_errno = MPIR_Topology_put(comm_dist_graph_ptr, topo_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_CHKPMEM_COMMIT();
MPIR_OBJ_PUBLISH_HANDLE(*comm_dist_graph, comm_dist_graph_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
for (i = 0; i < comm_size; ++i) {
MPL_free(rin[i]);
MPL_free(rout[i]);
}
MPIR_CHKLMEM_FREEALL();
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_DIST_GRAPH_CREATE);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
fn_fail:
if (dist_graph_ptr) {
MPL_free(dist_graph_ptr->in);
MPL_free(dist_graph_ptr->in_weights);
MPL_free(dist_graph_ptr->out);
MPL_free(dist_graph_ptr->out_weights);
}
MPIR_CHKPMEM_REAP();
#ifdef HAVE_ERROR_CHECKING
mpi_errno =
MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_OTHER,
"**mpi_dist_graph_create",
"**mpi_dist_graph_create %C %d %p %p %p %p %I %d %p", comm_old, n,
sources, degrees, destinations, weights, info, reorder,
comm_dist_graph);
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, __func__, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Comm_connect - Make a request to form a new intercommunicator
Input Parameters:
+ port_name - network address (string, used only on root)
. info - implementation-dependent information (handle, used only on root)
. root - rank in comm of root node (integer)
- comm - intracommunicator over which call is collective (handle)
Output Parameters:
. newcomm - intercommunicator with server as remote group (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_INFO
.N MPI_ERR_PORT
@*/
int MPI_Comm_connect(const char *port_name, MPI_Info info, int root, MPI_Comm comm,
MPI_Comm *newcomm)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Comm *newcomm_ptr = NULL;
MPIR_Info *info_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_COMM_CONNECT);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_COMM_CONNECT);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
MPIR_ERRTEST_INFO_OR_NULL(info, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr( comm, comm_ptr );
MPIR_Info_get_ptr( info, info_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 (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Comm_connect_impl(port_name, info_ptr, root, comm_ptr, &newcomm_ptr);
if (mpi_errno) goto fn_fail;
MPIR_OBJ_PUBLISH_HANDLE(*newcomm, newcomm_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_COMM_CONNECT);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_comm_connect",
"**mpi_comm_connect %s %I %d %C %p", port_name, info, root, comm, newcomm);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Comm_delete_attr - Deletes an attribute value associated with a key on
a communicator
Input Parameters:
+ comm - communicator to which attribute is attached (handle)
- comm_keyval - The key value of the deleted attribute (integer)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_PERM_KEY
.seealso MPI_Comm_set_attr, MPI_Comm_create_keyval
@*/
int MPI_Comm_delete_attr(MPI_Comm comm, int comm_keyval)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPII_Keyval *keyval_ptr;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_COMM_DELETE_ATTR);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_COMM_DELETE_ATTR);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
MPIR_ERRTEST_KEYVAL(comm_keyval, MPIR_COMM, "communicator", mpi_errno);
MPIR_ERRTEST_KEYVAL_PERM(comm_keyval, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, comm_ptr);
MPII_Keyval_get_ptr(comm_keyval, keyval_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, TRUE);
/* If comm_ptr is not valid, it will be reset to null */
/* Validate keyval_ptr */
MPII_Keyval_valid_ptr(keyval_ptr, mpi_errno);
if (mpi_errno)
goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Comm_delete_attr_impl(comm_ptr, keyval_ptr);
if (mpi_errno)
goto fn_fail;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_COMM_DELETE_ATTR);
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_comm_delete_attr", "**mpi_comm_delete_attr %C %d", comm,
comm_keyval);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, __func__, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Cart_rank - Determines process rank in communicator given Cartesian
location
Input Parameters:
+ comm - communicator with cartesian structure (handle)
- coords - integer array (of size 'ndims', the number of dimensions of
the Cartesian topology associated with 'comm') specifying the cartesian
coordinates of a process
Output Parameters:
. rank - rank of specified process (integer)
Notes:
Out-of-range coordinates are erroneous for non-periodic dimensions.
Versions of MPICH before 1.2.2 returned 'MPI_PROC_NULL' for the rank in this
case.
.N SignalSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TOPOLOGY
.N MPI_ERR_RANK
.N MPI_ERR_ARG
@*/
int MPI_Cart_rank(MPI_Comm comm, const int coords[], int *rank)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Topology *cart_ptr;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_CART_RANK);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_CART_RANK);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr( comm, comm_ptr );
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr */
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, TRUE );
if (mpi_errno) goto fn_fail;
/* If comm_ptr is not valid, it will be reset to null */
MPIR_ERRTEST_ARGNULL(rank,"rank",mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
cart_ptr = MPIR_Topology_get( comm_ptr );
MPIR_ERR_CHKANDJUMP((!cart_ptr || cart_ptr->kind != MPI_CART), mpi_errno, MPI_ERR_TOPOLOGY, "**notcarttopo");
/* Validate coordinates */
# ifdef HAVE_ERROR_CHECKING
{
int i, ndims, coord;
MPID_BEGIN_ERROR_CHECKS;
{
ndims = cart_ptr->topo.cart.ndims;
if (ndims != 0) {
MPIR_ERRTEST_ARGNULL(coords,"coords",mpi_errno);
}
for (i=0; i<ndims; i++) {
if (!cart_ptr->topo.cart.periodic[i]) {
coord = coords[i];
MPIR_ERR_CHKANDJUMP3(
(coord < 0 || coord >= cart_ptr->topo.cart.dims[i] ), mpi_errno, MPI_ERR_ARG, "**cartcoordinvalid",
"**cartcoordinvalid %d %d %d",i, coords[i], cart_ptr->topo.cart.dims[i]-1 );
}
}
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
MPIR_Cart_rank_impl(cart_ptr, coords, rank);
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_CART_RANK);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_cart_rank",
"**mpi_cart_rank %C %p %p", comm, coords, rank);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Comm_free - Marks the communicator object for deallocation
Input Parameters:
. comm - Communicator to be destroyed (handle)
Notes:
This routine `frees` a communicator. Because the communicator may still
be in use by other MPI routines, the actual communicator storage will not
be freed until all references to this communicator are removed. For most
users, the effect of this routine is the same as if it was in fact freed
at this time of this call.
Null Handles:
The MPI 1.1 specification, in the section on opaque objects, explicitly
disallows freeing a null communicator. The text from the standard is:
.vb
A null handle argument is an erroneous IN argument in MPI calls, unless an
exception is explicitly stated in the text that defines the function. Such
exception is allowed for handles to request objects in Wait and Test calls
(sections Communication Completion and Multiple Completions). Otherwise, a
null handle can only be passed to a function that allocates a new object and
returns a reference to it in the handle.
.ve
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_ARG
@*/
int MPI_Comm_free(MPI_Comm * comm)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_COMM_FREE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_COMM_FREE);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(*comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* Get handles to MPI objects. */
MPIR_Comm_get_ptr(*comm, 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, TRUE);
/* If comm_ptr is not valid, it will be reset to null */
/* Cannot free the predefined communicators */
if (HANDLE_GET_KIND(*comm) == HANDLE_KIND_BUILTIN) {
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_RECOVERABLE, FCNAME, __LINE__,
MPI_ERR_COMM, "**commperm", "**commperm %s",
comm_ptr->name);
}
if (mpi_errno)
goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Comm_free_impl(comm_ptr);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
*comm = MPI_COMM_NULL;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_COMM_FREE);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
#ifdef HAVE_ERROR_CHECKING
{
mpi_errno =
MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_comm_free", "**mpi_comm_free %p", comm);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
