void MPIR_Type_get_envelope(MPI_Datatype datatype, int *num_integers, int *num_addresses, int *num_datatypes, int *combiner) { if (HANDLE_GET_KIND(datatype) == HANDLE_KIND_BUILTIN || datatype == MPI_FLOAT_INT || datatype == MPI_DOUBLE_INT || datatype == MPI_LONG_INT || datatype == MPI_SHORT_INT || datatype == MPI_LONG_DOUBLE_INT) { *combiner = MPI_COMBINER_NAMED; *num_integers = 0; *num_addresses = 0; *num_datatypes = 0; } else { MPIR_Datatype *dtp; MPIR_Datatype_get_ptr(datatype, dtp); *combiner = dtp->contents->combiner; *num_integers = dtp->contents->nr_ints; *num_addresses = dtp->contents->nr_aints; *num_datatypes = dtp->contents->nr_types; } }
/*@ MPI_Type_create_hindexed - Create a datatype for an indexed datatype with displacements in bytes Input Parameters: + count - number of blocks --- also number of entries in array_of_displacements and array_of_blocklengths (integer) . array_of_blocklengths - number of elements in each block (array of nonnegative integers) . array_of_displacements - byte displacement of each block (array of address integers) - oldtype - old datatype (handle) Output Parameters: . newtype - new datatype (handle) .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_TYPE .N MPI_ERR_ARG @*/ int MPI_Type_create_hindexed(int count, const int array_of_blocklengths[], const MPI_Aint array_of_displacements[], MPI_Datatype oldtype, MPI_Datatype *newtype) { static const char FCNAME[] = "MPI_Type_create_hindexed"; int mpi_errno = MPI_SUCCESS; MPI_Datatype new_handle; MPIR_Datatype *new_dtp; int i, *ints; MPIR_CHKLMEM_DECL(1); MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_CREATE_HINDEXED); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TYPE_CREATE_HINDEXED); # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { int j; MPIR_Datatype *datatype_ptr = NULL; MPIR_ERRTEST_COUNT(count, mpi_errno); if (count > 0) { MPIR_ERRTEST_ARGNULL(array_of_blocklengths, "array_of_blocklengths", mpi_errno); MPIR_ERRTEST_ARGNULL(array_of_displacements, "array_of_displacements", mpi_errno); } MPIR_ERRTEST_DATATYPE(oldtype, "datatype", mpi_errno); if (HANDLE_GET_KIND(oldtype) != HANDLE_KIND_BUILTIN) { MPIR_Datatype_get_ptr(oldtype, datatype_ptr); MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } for (j=0; j < count; j++) { MPIR_ERRTEST_ARGNEG(array_of_blocklengths[j], "blocklength", mpi_errno); } } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Type_indexed(count, array_of_blocklengths, array_of_displacements, 1, /* displacements in bytes */ oldtype, &new_handle); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPIR_CHKLMEM_MALLOC_ORJUMP(ints, int *, (count + 1) * sizeof(int), mpi_errno, "content description", MPL_MEM_BUFFER); ints[0] = count; for (i=0; i < count; i++) { ints[i+1] = array_of_blocklengths[i]; } MPIR_Datatype_get_ptr(new_handle, new_dtp); mpi_errno = MPIR_Datatype_set_contents(new_dtp, MPI_COMBINER_HINDEXED, count+1, /* ints (count, blocklengths) */ count, /* aints (displacements) */ 1, /* types */ ints, array_of_displacements, &oldtype); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPIR_OBJ_PUBLISH_HANDLE(*newtype, new_handle); /* ... end of body of routine ... */ fn_exit: MPIR_CHKLMEM_FREEALL(); MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_CREATE_HINDEXED); MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_type_create_hindexed", "**mpi_type_create_hindexed %d %p %p %D %p", count, array_of_blocklengths, array_of_displacements, oldtype, newtype); } # endif mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ 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_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-- */ }
/*@ MPI_Type_dup - Duplicate a datatype Input Parameters: . oldtype - datatype (handle) Output Parameters: . newtype - copy of type (handle) .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_TYPE @*/ int MPI_Type_dup(MPI_Datatype oldtype, MPI_Datatype * newtype) { int mpi_errno = MPI_SUCCESS; MPI_Datatype new_handle; MPIR_Datatype *datatype_ptr = NULL; MPIR_Datatype *new_dtp; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_DUP); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TYPE_DUP); /* Validate parameters, especially handles needing to be converted */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_DATATYPE(oldtype, "datatype", mpi_errno); } MPID_END_ERROR_CHECKS; } #endif /* Convert MPI object handles to object pointers */ MPIR_Datatype_get_ptr(oldtype, datatype_ptr); /* Convert MPI object handles to object pointers */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { /* Validate datatype_ptr */ MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno); /* If comm_ptr is not valid, it will be reset to null */ MPIR_ERRTEST_ARGNULL(newtype, "newtype", mpi_errno); } MPID_END_ERROR_CHECKS; } #endif /* HAVE_ERROR_CHECKING */ MPIR_Assert(datatype_ptr != NULL); /* ... body of routine ... */ mpi_errno = MPIR_Type_dup(oldtype, &new_handle); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPIR_Datatype_get_ptr(new_handle, new_dtp); mpi_errno = MPIR_Datatype_set_contents(new_dtp, MPI_COMBINER_DUP, 0, /* ints */ 0, /* aints */ 1, /* types */ NULL, NULL, &oldtype); mpi_errno = MPIR_Type_commit(&new_handle); if (mpi_errno) { MPIR_ERR_POP(mpi_errno); } /* Copy attributes, executing the attribute copy functions */ /* This accesses the attribute dup function through the perprocess * structure to prevent type_dup from forcing the linking of the * attribute functions. The actual function is (by default) * MPIR_Attr_dup_list */ if (mpi_errno == MPI_SUCCESS && MPIR_Process.attr_dup) { new_dtp->attributes = 0; mpi_errno = MPIR_Process.attr_dup(oldtype, datatype_ptr->attributes, &new_dtp->attributes); if (mpi_errno) { MPIR_Datatype_ptr_release(new_dtp); goto fn_fail; } } MPIR_OBJ_PUBLISH_HANDLE(*newtype, new_handle); /* ... end of body of routine ... */ fn_exit: MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_DUP); MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ *newtype = MPI_DATATYPE_NULL; #ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_OTHER, "**mpi_type_dup", "**mpi_type_dup %D %p", oldtype, newtype); } #endif mpi_errno = MPIR_Err_return_comm(NULL, __func__, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Type_create_darray - Create a datatype representing a distributed array Input Parameters: + size - size of process group (positive integer) . rank - rank in process group (nonnegative integer) . ndims - number of array dimensions as well as process grid dimensions (positive integer) . array_of_gsizes - number of elements of type oldtype in each dimension of global array (array of positive integers) . array_of_distribs - distribution of array in each dimension (array of state) . array_of_dargs - distribution argument in each dimension (array of positive integers) . array_of_psizes - size of process grid in each dimension (array of positive integers) . order - array storage order flag (state) - oldtype - old datatype (handle) Output Parameters: . newtype - new datatype (handle) .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_TYPE .N MPI_ERR_ARG @*/ int MPI_Type_create_darray(int size, int rank, int ndims, const int array_of_gsizes[], const int array_of_distribs[], const int array_of_dargs[], const int array_of_psizes[], int order, MPI_Datatype oldtype, MPI_Datatype * newtype) { int mpi_errno = MPI_SUCCESS, i; MPI_Datatype new_handle; int procs, tmp_rank, tmp_size, *coords; MPI_Aint *st_offsets, orig_extent, disps[3]; MPI_Datatype type_old, type_new = MPI_DATATYPE_NULL, tmp_type; #ifdef HAVE_ERROR_CHECKING MPI_Aint size_with_aint; MPI_Offset size_with_offset; #endif int *ints; MPIR_Datatype *datatype_ptr = NULL; MPIR_CHKLMEM_DECL(3); MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_CREATE_DARRAY); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TYPE_CREATE_DARRAY); /* Validate parameters, especially handles needing to be converted */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_DATATYPE(oldtype, "datatype", mpi_errno); } MPID_END_ERROR_CHECKS; } #endif /* Convert MPI object handles to object pointers */ MPIR_Datatype_get_ptr(oldtype, datatype_ptr); MPIR_Datatype_get_extent_macro(oldtype, orig_extent); /* Validate parameters and objects (post conversion) */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { /* Check parameters */ MPIR_ERRTEST_ARGNONPOS(size, "size", mpi_errno, MPI_ERR_ARG); /* use MPI_ERR_RANK class for PE-MPI compatibility */ MPIR_ERR_CHKANDJUMP3((rank < 0 || rank >= size), mpi_errno, MPI_ERR_RANK, "**argrange", "**argrange %s %d %d", "rank", rank, (size - 1)); MPIR_ERRTEST_ARGNONPOS(ndims, "ndims", mpi_errno, MPI_ERR_DIMS); MPIR_ERRTEST_ARGNULL(array_of_gsizes, "array_of_gsizes", mpi_errno); MPIR_ERRTEST_ARGNULL(array_of_distribs, "array_of_distribs", mpi_errno); MPIR_ERRTEST_ARGNULL(array_of_dargs, "array_of_dargs", mpi_errno); MPIR_ERRTEST_ARGNULL(array_of_psizes, "array_of_psizes", mpi_errno); if (order != MPI_ORDER_C && order != MPI_ORDER_FORTRAN) { mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_ARG, "**arg", "**arg %s", "order"); goto fn_fail; } tmp_size = 1; for (i = 0; mpi_errno == MPI_SUCCESS && i < ndims; i++) { MPIR_ERRTEST_ARGNONPOS(array_of_gsizes[i], "gsize", mpi_errno, MPI_ERR_ARG); MPIR_ERRTEST_ARGNONPOS(array_of_psizes[i], "psize", mpi_errno, MPI_ERR_ARG); if ((array_of_distribs[i] != MPI_DISTRIBUTE_NONE) && (array_of_distribs[i] != MPI_DISTRIBUTE_BLOCK) && (array_of_distribs[i] != MPI_DISTRIBUTE_CYCLIC)) { mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_ARG, "**darrayunknown", 0); goto fn_fail; } if ((array_of_dargs[i] != MPI_DISTRIBUTE_DFLT_DARG) && (array_of_dargs[i] <= 0)) { mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_ARG, "**arg", "**arg %s", "array_of_dargs"); goto fn_fail; } if ((array_of_distribs[i] == MPI_DISTRIBUTE_NONE) && (array_of_psizes[i] != 1)) { mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_ARG, "**darraydist", "**darraydist %d %d", i, array_of_psizes[i]); goto fn_fail; } tmp_size *= array_of_psizes[i]; } MPIR_ERR_CHKANDJUMP1((tmp_size != size), mpi_errno, MPI_ERR_ARG, "**arg", "**arg %s", "array_of_psizes"); /* TODO: GET THIS CHECK IN ALSO */ /* check if MPI_Aint is large enough for size of global array. * if not, complain. */ size_with_aint = orig_extent; for (i = 0; i < ndims; i++) size_with_aint *= array_of_gsizes[i]; size_with_offset = orig_extent; for (i = 0; i < ndims; i++) size_with_offset *= array_of_gsizes[i]; if (size_with_aint != size_with_offset) { mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_FATAL, __func__, __LINE__, MPI_ERR_ARG, "**darrayoverflow", "**darrayoverflow %L", size_with_offset); goto fn_fail; } /* Validate datatype_ptr */ MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno); /* If datatype_ptr is not valid, it will be reset to null */ /* --BEGIN ERROR HANDLING-- */ if (mpi_errno) goto fn_fail; /* --END ERROR HANDLING-- */ } MPID_END_ERROR_CHECKS; } #endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ /* calculate position in Cartesian grid as MPI would (row-major ordering) */ MPIR_CHKLMEM_MALLOC_ORJUMP(coords, int *, ndims * sizeof(int), mpi_errno, "position is Cartesian grid", MPL_MEM_COMM); procs = size; tmp_rank = rank; for (i = 0; i < ndims; i++) { procs = procs / array_of_psizes[i]; coords[i] = tmp_rank / procs; tmp_rank = tmp_rank % procs; } MPIR_CHKLMEM_MALLOC_ORJUMP(st_offsets, MPI_Aint *, ndims * sizeof(MPI_Aint), mpi_errno, "st_offsets", MPL_MEM_COMM); type_old = oldtype; if (order == MPI_ORDER_FORTRAN) { /* dimension 0 changes fastest */ for (i = 0; i < ndims; i++) { switch (array_of_distribs[i]) { case MPI_DISTRIBUTE_BLOCK: mpi_errno = MPIR_Type_block(array_of_gsizes, i, ndims, array_of_psizes[i], coords[i], array_of_dargs[i], order, orig_extent, type_old, &type_new, st_offsets + i); break; case MPI_DISTRIBUTE_CYCLIC: mpi_errno = MPIR_Type_cyclic(array_of_gsizes, i, ndims, array_of_psizes[i], coords[i], array_of_dargs[i], order, orig_extent, type_old, &type_new, st_offsets + i); break; case MPI_DISTRIBUTE_NONE: /* treat it as a block distribution on 1 process */ mpi_errno = MPIR_Type_block(array_of_gsizes, i, ndims, 1, 0, MPI_DISTRIBUTE_DFLT_DARG, order, orig_extent, type_old, &type_new, st_offsets + i); break; } if (i) { MPIR_Type_free_impl(&type_old); } type_old = type_new; /* --BEGIN ERROR HANDLING-- */ if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* --END ERROR HANDLING-- */ } /* add displacement and UB */ disps[1] = st_offsets[0]; tmp_size = 1; for (i = 1; i < ndims; i++) { tmp_size *= array_of_gsizes[i - 1]; disps[1] += (MPI_Aint) tmp_size *st_offsets[i]; } /* rest done below for both Fortran and C order */ } else { /* order == MPI_ORDER_C */ /* dimension ndims-1 changes fastest */ for (i = ndims - 1; i >= 0; i--) { switch (array_of_distribs[i]) { case MPI_DISTRIBUTE_BLOCK: mpi_errno = MPIR_Type_block(array_of_gsizes, i, ndims, array_of_psizes[i], coords[i], array_of_dargs[i], order, orig_extent, type_old, &type_new, st_offsets + i); break; case MPI_DISTRIBUTE_CYCLIC: mpi_errno = MPIR_Type_cyclic(array_of_gsizes, i, ndims, array_of_psizes[i], coords[i], array_of_dargs[i], order, orig_extent, type_old, &type_new, st_offsets + i); break; case MPI_DISTRIBUTE_NONE: /* treat it as a block distribution on 1 process */ mpi_errno = MPIR_Type_block(array_of_gsizes, i, ndims, array_of_psizes[i], coords[i], MPI_DISTRIBUTE_DFLT_DARG, order, orig_extent, type_old, &type_new, st_offsets + i); break; } if (i != ndims - 1) { MPIR_Type_free_impl(&type_old); } type_old = type_new; /* --BEGIN ERROR HANDLING-- */ if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* --END ERROR HANDLING-- */ } /* add displacement and UB */ disps[1] = st_offsets[ndims - 1]; tmp_size = 1; for (i = ndims - 2; i >= 0; i--) { tmp_size *= array_of_gsizes[i + 1]; disps[1] += (MPI_Aint) tmp_size *st_offsets[i]; } } disps[1] *= orig_extent; disps[2] = orig_extent; for (i = 0; i < ndims; i++) disps[2] *= (MPI_Aint) (array_of_gsizes[i]); disps[0] = 0; /* Instead of using MPI_LB/MPI_UB, which have been removed from MPI in MPI-3, use MPI_Type_create_resized. Use hindexed_block to set the starting displacement of the datatype (disps[1]) and type_create_resized to set lb to 0 (disps[0]) and extent to disps[2], which makes ub = disps[2]. */ mpi_errno = MPIR_Type_blockindexed(1, 1, &disps[1], 1, /* 1 means disp is in bytes */ type_new, &tmp_type); /* --BEGIN ERROR HANDLING-- */ if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* --END ERROR HANDLING-- */ mpi_errno = MPIR_Type_create_resized(tmp_type, 0, disps[2], &new_handle); /* --BEGIN ERROR HANDLING-- */ if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* --END ERROR HANDLING-- */ MPIR_Type_free_impl(&tmp_type); MPIR_Type_free_impl(&type_new); /* at this point we have the new type, and we've cleaned up any * intermediate types created in the process. we just need to save * all our contents/envelope information. */ /* Save contents */ MPIR_CHKLMEM_MALLOC_ORJUMP(ints, int *, (4 * ndims + 4) * sizeof(int), mpi_errno, "content description", MPL_MEM_BUFFER); ints[0] = size; ints[1] = rank; ints[2] = ndims; for (i = 0; i < ndims; i++) { ints[i + 3] = array_of_gsizes[i]; } for (i = 0; i < ndims; i++) { ints[i + ndims + 3] = array_of_distribs[i]; } for (i = 0; i < ndims; i++) { ints[i + 2 * ndims + 3] = array_of_dargs[i]; } for (i = 0; i < ndims; i++) { ints[i + 3 * ndims + 3] = array_of_psizes[i]; } ints[4 * ndims + 3] = order; MPIR_Datatype_get_ptr(new_handle, datatype_ptr); mpi_errno = MPIR_Datatype_set_contents(datatype_ptr, MPI_COMBINER_DARRAY, 4 * ndims + 4, 0, 1, ints, NULL, &oldtype); /* --BEGIN ERROR HANDLING-- */ if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* --END ERROR HANDLING-- */ MPIR_OBJ_PUBLISH_HANDLE(*newtype, new_handle); /* ... end of body of routine ... */ fn_exit: MPIR_CHKLMEM_FREEALL(); MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_CREATE_DARRAY); MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ #ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_OTHER, "**mpi_type_create_darray", "**mpi_type_create_darray %d %d %d %p %p %p %p %d %D %p", size, rank, ndims, array_of_gsizes, array_of_distribs, array_of_dargs, array_of_psizes, order, oldtype, newtype); } #endif mpi_errno = MPIR_Err_return_comm(NULL, __func__, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Rget - Get data from a memory window on a remote process 'MPI_Rget' is similar to 'MPI_Get', except that it allocates a communication request object and associates it with the request handle (the argument request) that can be used to wait or test for completion. The completion of an 'MPI_Rget' operation indicates that the data is available in the origin buffer. If origin_addr points to memory attached to a window, then the data becomes available in the private copy of this window. Input Parameters: + origin_addr - Address of the buffer in which to receive the data . origin_count - number of entries in origin buffer (nonnegative integer) . origin_datatype - datatype of each entry in origin buffer (handle) . target_rank - rank of target (nonnegative integer) . target_disp - displacement from window start to the beginning of the target buffer (nonnegative integer) . target_count - number of entries in target buffer (nonnegative integer) . target_datatype - datatype of each entry in target buffer (handle) - win - window object used for communication (handle) Output Parameters: . request - RMA request (handle) .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_ARG .N MPI_ERR_COUNT .N MPI_ERR_RANK .N MPI_ERR_TYPE .N MPI_ERR_WIN .seealso: MPI_Get @*/ int MPI_Rget(void *origin_addr, int origin_count, MPI_Datatype origin_datatype, int target_rank, MPI_Aint target_disp, int target_count, MPI_Datatype target_datatype, MPI_Win win, MPI_Request *request) { static const char FCNAME[] = "MPI_Rget"; int mpi_errno = MPI_SUCCESS; MPIR_Win *win_ptr = NULL; MPIR_Request *request_ptr = NULL; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_RGET); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_RMA_ENTER(MPID_STATE_MPI_RGET); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_WIN(win, mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* Convert MPI object handles to object pointers */ MPIR_Win_get_ptr( win, win_ptr ); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_Comm * comm_ptr; /* Validate win_ptr */ MPIR_Win_valid_ptr( win_ptr, mpi_errno ); if (mpi_errno) goto fn_fail; MPIR_ERRTEST_COUNT(origin_count, mpi_errno); MPIR_ERRTEST_DATATYPE(origin_datatype, "origin_datatype", mpi_errno); MPIR_ERRTEST_USERBUFFER(origin_addr, origin_count, origin_datatype, mpi_errno); MPIR_ERRTEST_COUNT(target_count, mpi_errno); MPIR_ERRTEST_DATATYPE(target_datatype, "target_datatype", mpi_errno); if (win_ptr->create_flavor != MPI_WIN_FLAVOR_DYNAMIC) MPIR_ERRTEST_DISP(target_disp, mpi_errno); if (HANDLE_GET_KIND(origin_datatype) != HANDLE_KIND_BUILTIN) { MPIR_Datatype *datatype_ptr = NULL; MPIR_Datatype_get_ptr(origin_datatype, datatype_ptr); MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPIR_Datatype_committed_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } if (HANDLE_GET_KIND(target_datatype) != HANDLE_KIND_BUILTIN) { MPIR_Datatype *datatype_ptr = NULL; MPIR_Datatype_get_ptr(target_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; } comm_ptr = win_ptr->comm_ptr; MPIR_ERRTEST_SEND_RANK(comm_ptr, target_rank, mpi_errno); MPIR_ERRTEST_ARGNULL(request,"request",mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPID_Rget(origin_addr, origin_count, origin_datatype, target_rank, target_disp, target_count, target_datatype, win_ptr, &request_ptr); if (mpi_errno != MPI_SUCCESS) goto fn_fail; *request = request_ptr->handle; /* ... end of body of routine ... */ fn_exit: MPIR_FUNC_TERSE_RMA_EXIT(MPID_STATE_MPI_RGET); 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_rget", "**mpi_rget %p %d %D %d %d %d %D %W %p", origin_addr, origin_count, origin_datatype, target_rank, target_disp, target_count, target_datatype, win, request); } # endif mpi_errno = MPIR_Err_return_win( win_ptr, 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_Type_size - Return the number of bytes occupied by entries in the datatype Input Parameters: . datatype - datatype (handle) Output Parameters: . size - datatype size (integer) .N SignalSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_TYPE .N MPI_ERR_ARG @*/ int MPI_Type_size(MPI_Datatype datatype, int *size) { int mpi_errno = MPI_SUCCESS; MPI_Count size_x = MPI_UNDEFINED; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_SIZE); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TYPE_SIZE); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* If this is a built-in datatype, then get the size out of the handle */ if (HANDLE_GET_KIND(datatype) == HANDLE_KIND_BUILTIN) { MPIR_Datatype_get_size_macro(datatype, *size); goto fn_exit; } /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_Datatype *datatype_ptr = NULL; /* Convert MPI object handles to object pointers */ MPIR_Datatype_get_ptr( datatype, datatype_ptr ); /* Validate datatype_ptr */ MPIR_Datatype_valid_ptr( datatype_ptr, mpi_errno ); if (mpi_errno) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Type_size_x_impl(datatype, &size_x); if (mpi_errno) MPIR_ERR_POP(mpi_errno); MPIR_Assert(size_x >= 0); /* handle overflow: see MPI-3 p.104 */ *size = (size_x > INT_MAX) ? MPI_UNDEFINED : (int)size_x; /* ... end of body of routine ... */ fn_exit: MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_SIZE); return mpi_errno; /* --BEGIN ERROR HANDLING-- */ fn_fail: { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_type_size", "**mpi_type_size %D %p", datatype, size); } mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ 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-- */ }
/*@ MPI_Get_elements_x - Returns the number of basic elements in a datatype Input Parameters: + status - return status of receive operation (Status) - datatype - datatype used by receive operation (handle) Output Parameters: . count - number of received basic elements (integer) .N ThreadSafe .N Fortran .N Errors @*/ int MPI_Get_elements_x(const MPI_Status *status, MPI_Datatype datatype, MPI_Count *count) { int mpi_errno = MPI_SUCCESS; MPI_Count byte_count; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_GET_ELEMENTS_X); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_GET_ELEMENTS_X); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS { MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno); /* TODO more checks may be appropriate */ if (mpi_errno != MPI_SUCCESS) goto fn_fail; } MPID_END_ERROR_CHECKS } # endif /* HAVE_ERROR_CHECKING */ /* Convert MPI object handles to object pointers */ /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS { 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); MPIR_Datatype_committed_ptr(datatype_ptr, mpi_errno); } /* 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 ... */ byte_count = MPIR_STATUS_GET_COUNT(*status); mpi_errno = MPIR_Get_elements_x_impl(&byte_count, datatype, count); if (mpi_errno) MPIR_ERR_POP(mpi_errno); /* ... end of body of routine ... */ fn_exit: MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_GET_ELEMENTS_X); 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_get_elements_x", "**mpi_get_elements_x %p %D %p", status, datatype, count); } # endif mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/* MPIR_Get_elements_x_impl * * Arguments: * - byte_count - input/output byte count * - datatype - input datatype * - elements - Number of basic elements this byte_count would contain * * Returns number of elements available given the two constraints of number of * bytes and count of types. Also reduces the byte count by the amount taken * up by the types. */ int MPIR_Get_elements_x_impl(MPI_Count *byte_count, MPI_Datatype datatype, MPI_Count *elements) { int mpi_errno = MPI_SUCCESS; MPIR_Datatype *datatype_ptr = NULL; if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) { MPIR_Datatype_get_ptr(datatype, datatype_ptr); } /* three cases: * - nice, simple, single element type * - derived type with a zero size * - type with multiple element types (nastiest) */ if (HANDLE_GET_KIND(datatype) == HANDLE_KIND_BUILTIN || (datatype_ptr->builtin_element_size != -1 && datatype_ptr->size > 0)) { /* QUESTION: WHAT IF SOMEONE GAVE US AN MPI_UB OR MPI_LB??? */ /* in both cases we do not limit the number of types that might * be in bytes */ if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) { MPI_Datatype basic_type = MPI_DATATYPE_NULL; MPIR_Datatype_get_basic_type(datatype_ptr->basic_type, basic_type); *elements = MPIR_Type_get_basic_type_elements(byte_count, -1, basic_type); } else { /* Behaves just like MPI_Get_Count in the predefined case */ MPI_Count size; MPIR_Datatype_get_size_macro(datatype, size); if ((*byte_count % size) != 0) *elements = MPI_UNDEFINED; else *elements = MPIR_Type_get_basic_type_elements(byte_count, -1, datatype); } MPIR_Assert(*byte_count >= 0); } else if (datatype_ptr->size == 0) { if (*byte_count > 0) { /* --BEGIN ERROR HANDLING-- */ /* datatype size of zero and count > 0 should never happen. */ (*elements) = MPI_UNDEFINED; /* --END ERROR HANDLING-- */ } else { /* This is ambiguous. However, discussions on MPI Forum * reached a consensus that this is the correct return * value */ (*elements) = 0; } } else /* derived type with weird element type or weird size */ { MPIR_Assert(datatype_ptr->builtin_element_size == -1); *elements = MPIR_Type_get_elements(byte_count, -1, datatype); } return mpi_errno; }
/* MPIR_Type_get_elements * * Arguments: * - bytes_p - input/output byte count * - count - maximum number of this type to subtract from the bytes; a count * of <0 indicates use as many as we like * - datatype - input datatype * * Returns number of elements available given the two constraints of number of * bytes and count of types. Also reduces the byte count by the amount taken * up by the types. * * This is called from MPI_Get_elements() when it sees a type with multiple * element types (datatype_ptr->element_sz = -1). This function calls itself too. */ PMPI_LOCAL MPI_Count MPIR_Type_get_elements(MPI_Count *bytes_p, MPI_Count count, MPI_Datatype datatype) { MPIR_Datatype *datatype_ptr = NULL; MPIR_Datatype_get_ptr(datatype, datatype_ptr); /* invalid if builtin */ /* if we have gotten down to a type with only one element type, * call MPIR_Type_get_basic_type_elements() and return. */ if (HANDLE_GET_KIND(datatype) == HANDLE_KIND_BUILTIN || datatype == MPI_FLOAT_INT || datatype == MPI_DOUBLE_INT || datatype == MPI_LONG_INT || datatype == MPI_SHORT_INT || datatype == MPI_LONG_DOUBLE_INT) { return MPIR_Type_get_basic_type_elements(bytes_p, count, datatype); } else if (datatype_ptr->builtin_element_size >= 0) { MPI_Datatype basic_type = MPI_DATATYPE_NULL; MPIR_Datatype_get_basic_type(datatype_ptr->basic_type, basic_type); return MPIR_Type_get_basic_type_elements(bytes_p, count * datatype_ptr->n_builtin_elements, basic_type); } else { /* we have bytes left and still don't have a single element size; must * recurse. */ int i, j, *ints; MPI_Count typecount = 0, nr_elements = 0, last_nr_elements; MPI_Aint *aints; MPI_Datatype *types; /* Establish locations of arrays */ MPIR_Type_access_contents(datatype_ptr->handle, &ints, &aints, &types); if (!ints || !aints || !types) return MPI_ERR_TYPE; switch (datatype_ptr->contents->combiner) { case MPI_COMBINER_NAMED: case MPI_COMBINER_DUP: case MPI_COMBINER_RESIZED: return MPIR_Type_get_elements(bytes_p, count, *types); break; case MPI_COMBINER_CONTIGUOUS: case MPI_COMBINER_VECTOR: case MPI_COMBINER_HVECTOR_INTEGER: case MPI_COMBINER_HVECTOR: /* count is first in ints array */ return MPIR_Type_get_elements(bytes_p, count * (*ints), *types); break; case MPI_COMBINER_INDEXED_BLOCK: case MPI_COMBINER_HINDEXED_BLOCK: /* count is first in ints array, blocklength is second */ return MPIR_Type_get_elements(bytes_p, count * ints[0] * ints[1], *types); break; case MPI_COMBINER_INDEXED: case MPI_COMBINER_HINDEXED_INTEGER: case MPI_COMBINER_HINDEXED: for (i=0; i < (*ints); i++) { /* add up the blocklengths to get a max. # of the next type */ typecount += ints[i+1]; } return MPIR_Type_get_elements(bytes_p, count * typecount, *types); break; case MPI_COMBINER_STRUCT_INTEGER: case MPI_COMBINER_STRUCT: /* In this case we can't simply multiply the count of the next * type by the count of the current type, because we need to * cycle through the types just as the struct would. thus the * nested loops. * * We need to keep going until we get less elements than expected * or we run out of bytes. */ last_nr_elements = 1; /* seed value */ for (j=0; (count < 0 || j < count) && *bytes_p > 0 && last_nr_elements > 0; j++) { /* recurse on each type; bytes are reduced in calls */ for (i=0; i < (*ints); i++) { /* skip zero-count elements of the struct */ if (ints[i+1] == 0) continue; last_nr_elements = MPIR_Type_get_elements(bytes_p, ints[i+1], types[i]); nr_elements += last_nr_elements; MPIR_Assert(last_nr_elements >= 0); if (last_nr_elements < ints[i+1]) break; } } return nr_elements; break; case MPI_COMBINER_SUBARRAY: case MPI_COMBINER_DARRAY: case MPI_COMBINER_F90_REAL: case MPI_COMBINER_F90_COMPLEX: case MPI_COMBINER_F90_INTEGER: default: /* --BEGIN ERROR HANDLING-- */ MPIR_Assert(0); return -1; break; /* --END ERROR HANDLING-- */ } } }
int MPIR_Type_indexed(int count, const int *blocklength_array, const void *displacement_array, int dispinbytes, MPI_Datatype oldtype, MPI_Datatype * newtype) { int mpi_errno = MPI_SUCCESS; int is_builtin, old_is_contig; int i; MPI_Aint contig_count; MPI_Aint el_sz, el_ct, old_ct, old_sz; MPI_Aint old_lb, old_ub, old_extent, old_true_lb, old_true_ub; MPI_Aint min_lb = 0, max_ub = 0, eff_disp; MPI_Datatype el_type; MPIR_Datatype *new_dtp; if (count == 0) return MPII_Type_zerolen(newtype); /* sanity check that blocklens are all non-negative */ for (i = 0; i < count; ++i) { DLOOP_Assert(blocklength_array[i] >= 0); } /* allocate new datatype object and handle */ new_dtp = (MPIR_Datatype *) MPIR_Handle_obj_alloc(&MPIR_Datatype_mem); /* --BEGIN ERROR HANDLING-- */ if (!new_dtp) { mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE, "MPIR_Type_indexed", __LINE__, MPI_ERR_OTHER, "**nomem", 0); return mpi_errno; } /* --END ERROR HANDLING-- */ /* handle is filled in by MPIR_Handle_obj_alloc() */ MPIR_Object_set_ref(new_dtp, 1); new_dtp->is_permanent = 0; new_dtp->is_committed = 0; new_dtp->attributes = NULL; new_dtp->cache_id = 0; new_dtp->name[0] = 0; new_dtp->contents = NULL; new_dtp->dataloop = NULL; new_dtp->dataloop_size = -1; new_dtp->dataloop_depth = -1; is_builtin = (HANDLE_GET_KIND(oldtype) == HANDLE_KIND_BUILTIN); if (is_builtin) { /* builtins are handled differently than user-defined types because * they have no associated dataloop or datatype structure. */ el_sz = MPIR_Datatype_get_basic_size(oldtype); old_sz = el_sz; el_ct = 1; el_type = oldtype; old_lb = 0; old_true_lb = 0; old_ub = (MPI_Aint) el_sz; old_true_ub = (MPI_Aint) el_sz; old_extent = (MPI_Aint) el_sz; old_is_contig = 1; new_dtp->has_sticky_ub = 0; new_dtp->has_sticky_lb = 0; MPIR_Assign_trunc(new_dtp->alignsize, el_sz, MPI_Aint); new_dtp->builtin_element_size = el_sz; new_dtp->basic_type = el_type; new_dtp->max_contig_blocks = count; } else { /* user-defined base type (oldtype) */ MPIR_Datatype *old_dtp; MPIR_Datatype_get_ptr(oldtype, old_dtp); /* Ensure that "builtin_element_size" fits into an int datatype. */ MPIR_Ensure_Aint_fits_in_int(old_dtp->builtin_element_size); el_sz = old_dtp->builtin_element_size; old_sz = old_dtp->size; el_ct = old_dtp->n_builtin_elements; el_type = old_dtp->basic_type; old_lb = old_dtp->lb; old_true_lb = old_dtp->true_lb; old_ub = old_dtp->ub; old_true_ub = old_dtp->true_ub; old_extent = old_dtp->extent; MPIR_Datatype_is_contig(oldtype, &old_is_contig); new_dtp->has_sticky_lb = old_dtp->has_sticky_lb; new_dtp->has_sticky_ub = old_dtp->has_sticky_ub; new_dtp->builtin_element_size = (MPI_Aint) el_sz; new_dtp->basic_type = el_type; new_dtp->max_contig_blocks = 0; for (i = 0; i < count; i++) new_dtp->max_contig_blocks += old_dtp->max_contig_blocks * ((MPI_Aint) blocklength_array[i]); } /* find the first nonzero blocklength element */ i = 0; while (i < count && blocklength_array[i] == 0) i++; if (i == count) { MPIR_Handle_obj_free(&MPIR_Datatype_mem, new_dtp); return MPII_Type_zerolen(newtype); } /* priming for loop */ old_ct = blocklength_array[i]; eff_disp = (dispinbytes) ? ((MPI_Aint *) displacement_array)[i] : (((MPI_Aint) ((int *) displacement_array)[i]) * old_extent); MPII_DATATYPE_BLOCK_LB_UB((MPI_Aint) blocklength_array[i], eff_disp, old_lb, old_ub, old_extent, min_lb, max_ub); /* determine min lb, max ub, and count of old types in remaining * nonzero size blocks */ for (i++; i < count; i++) { MPI_Aint tmp_lb, tmp_ub; if (blocklength_array[i] > 0) { old_ct += blocklength_array[i]; /* add more oldtypes */ eff_disp = (dispinbytes) ? ((MPI_Aint *) displacement_array)[i] : (((MPI_Aint) ((int *) displacement_array)[i]) * old_extent); /* calculate ub and lb for this block */ MPII_DATATYPE_BLOCK_LB_UB((MPI_Aint) (blocklength_array[i]), eff_disp, old_lb, old_ub, old_extent, tmp_lb, tmp_ub); if (tmp_lb < min_lb) min_lb = tmp_lb; if (tmp_ub > max_ub) max_ub = tmp_ub; } } new_dtp->size = old_ct * old_sz; new_dtp->lb = min_lb; new_dtp->ub = max_ub; new_dtp->true_lb = min_lb + (old_true_lb - old_lb); new_dtp->true_ub = max_ub + (old_true_ub - old_ub); new_dtp->extent = max_ub - min_lb; new_dtp->n_builtin_elements = old_ct * el_ct; /* new type is only contig for N types if it's all one big * block, its size and extent are the same, and the old type * was also contiguous. */ new_dtp->is_contig = 0; if (old_is_contig) { MPI_Aint *blklens = MPL_malloc(count * sizeof(MPI_Aint), MPL_MEM_DATATYPE); MPIR_Assert(blklens != NULL); for (i = 0; i < count; i++) blklens[i] = blocklength_array[i]; contig_count = MPIR_Type_indexed_count_contig(count, blklens, displacement_array, dispinbytes, old_extent); new_dtp->max_contig_blocks = contig_count; if ((contig_count == 1) && ((MPI_Aint) new_dtp->size == new_dtp->extent)) { new_dtp->is_contig = 1; } MPL_free(blklens); } *newtype = new_dtp->handle; return mpi_errno; }
/*@ MPI_Type_indexed - Creates an indexed datatype Input Parameters: + count - number of blocks -- also number of entries in array_of_displacements and array_of_blocklengths . array_of_blocklengths - number of elements in each block (array of nonnegative integers) . array_of_displacements - displacement of each block in multiples of oldtype (array of integers) - oldtype - old datatype (handle) Output Parameters: . newtype - new datatype (handle) .N ThreadSafe .N Fortran The array_of_displacements are displacements, and are based on a zero origin. A common error is to do something like to following .vb integer a(100) integer array_of_blocklengths(10), array_of_displacements(10) do i=1,10 array_of_blocklengths(i) = 1 10 array_of_displacements(i) = 1 + (i-1)*10 call MPI_TYPE_INDEXED(10,array_of_blocklengths,array_of_displacements,MPI_INTEGER,newtype,ierr) call MPI_TYPE_COMMIT(newtype,ierr) call MPI_SEND(a,1,newtype,...) .ve expecting this to send "a(1),a(11),..." because the array_of_displacements have values "1,11,...". Because these are `displacements` from the beginning of "a", it actually sends "a(1+1),a(1+11),...". If you wish to consider the displacements as array_of_displacements into a Fortran array, consider declaring the Fortran array with a zero origin .vb integer a(0:99) .ve .N Errors .N MPI_ERR_COUNT .N MPI_ERR_TYPE .N MPI_ERR_ARG .N MPI_ERR_EXHAUSTED @*/ int MPI_Type_indexed(int count, const int *array_of_blocklengths, const int *array_of_displacements, MPI_Datatype oldtype, MPI_Datatype * newtype) { int mpi_errno = MPI_SUCCESS; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_INDEXED); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TYPE_INDEXED); /* Validate parameters and objects (post conversion) */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { int j; MPIR_Datatype *datatype_ptr = NULL; MPIR_ERRTEST_COUNT(count, mpi_errno); if (count > 0) { MPIR_ERRTEST_ARGNULL(array_of_blocklengths, "array_of_blocklengths", mpi_errno); MPIR_ERRTEST_ARGNULL(array_of_displacements, "array_of_displacements", mpi_errno); } MPIR_ERRTEST_DATATYPE(oldtype, "datatype", mpi_errno); if (HANDLE_GET_KIND(oldtype) != HANDLE_KIND_BUILTIN) { MPIR_Datatype_get_ptr(oldtype, datatype_ptr); MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno); } /* verify that all blocklengths are >= 0 */ for (j = 0; j < count; j++) { MPIR_ERRTEST_ARGNEG(array_of_blocklengths[j], "blocklength", mpi_errno); } MPIR_ERRTEST_ARGNULL(newtype, "newtype", mpi_errno); } MPID_END_ERROR_CHECKS; } #endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Type_indexed_impl(count, array_of_blocklengths, array_of_displacements, oldtype, newtype); if (mpi_errno) goto fn_fail; /* ... end of body of routine ... */ fn_exit: MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_INDEXED); MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ #ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_type_indexed", "**mpi_type_indexed %d %p %p %D %p", count, array_of_blocklengths, array_of_displacements, oldtype, newtype); } #endif mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Type_size_x - Return the number of bytes occupied by entries in the datatype Input Parameters: . datatype - datatype (handle) Output Parameters: . size - datatype size (integer) .N ThreadSafe .N Fortran .N Errors @*/ int MPI_Type_size_x(MPI_Datatype datatype, MPI_Count * size) { int mpi_errno = MPI_SUCCESS; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_SIZE_X); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TYPE_SIZE_X); /* Validate parameters, especially handles needing to be converted */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno); /* TODO more checks may be appropriate */ } MPID_END_ERROR_CHECKS; } #endif /* HAVE_ERROR_CHECKING */ /* Convert MPI object handles to object pointers */ /* Validate parameters and objects (post conversion) */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { 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); } /* TODO more checks may be appropriate (counts, in_place, buffer aliasing, etc) */ if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPIR_ERRTEST_ARGNULL(size, "size", mpi_errno); } MPID_END_ERROR_CHECKS; } #endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Type_size_x_impl(datatype, size); if (mpi_errno) MPIR_ERR_POP(mpi_errno); /* ... end of body of routine ... */ fn_exit: MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_SIZE_X); MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ #ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_OTHER, "**mpi_type_size_x", "**mpi_type_size_x %D %p", datatype, size); } #endif mpi_errno = MPIR_Err_return_comm(NULL, __func__, 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_allgather - In this function, each process i gathers data items from each process j if an edge (j,i) exists in the topology graph, and each process i sends the same data items to all processes j where an edge (i,j) exists. The send buffer is sent to each 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_allgather(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_ALLGATHER); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_NEIGHBOR_ALLGATHER); /* 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; MPIR_Datatype_get_ptr(sendtype, sendtype_ptr); MPIR_Datatype_valid_ptr(sendtype_ptr, mpi_errno); MPIR_Datatype_committed_ptr(sendtype_ptr, mpi_errno); } 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); MPIR_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 = MPIR_Neighbor_allgather(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_ALLGATHER); 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_neighbor_allgather", "**mpi_neighbor_allgather %p %d %D %p %d %D %C", sendbuf, sendcount, sendtype, recvbuf, recvcount, recvtype, comm); } #endif mpi_errno = MPIR_Err_return_comm(NULL, __func__, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Pack_external_size - Returns the upper bound on the amount of space needed to pack a message using MPI_Pack_external. Input Parameters: + datarep - data representation (string) . incount - number of input data items (integer) - datatype - datatype of each input data item (handle) Output Parameters: . size - output buffer size, in bytes (address integer) .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_TYPE .N MPI_ERR_ARG @*/ int MPI_Pack_external_size(const char datarep[], int incount, MPI_Datatype datatype, MPI_Aint * size) { int mpi_errno = MPI_SUCCESS; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_PACK_EXTERNAL_SIZE); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_PACK_EXTERNAL_SIZE); /* Validate parameters, especially handles needing to be converted */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_COUNT(incount, mpi_errno); MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno); } MPID_END_ERROR_CHECKS; } #endif /* Validate parameters and objects (post conversion) */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_Datatype *datatype_ptr = NULL; /* Convert MPI object handles to object pointers */ MPIR_Datatype_get_ptr(datatype, datatype_ptr); /* Validate datatype_ptr */ MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno); /* If datatype_ptr is not valid, it will be reset to null */ if (mpi_errno) goto fn_fail; } MPID_END_ERROR_CHECKS; } #endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ *size = (MPI_Aint) incount *(MPI_Aint) MPIR_Datatype_size_external32(datatype); /* ... end of body of routine ... */ #ifdef HAVE_ERROR_CHECKING fn_exit: #endif MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_PACK_EXTERNAL_SIZE); return mpi_errno; /* --BEGIN ERROR HANDLING-- */ #ifdef HAVE_ERROR_CHECKING fn_fail: { mpi_errno = MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_pack_external_size", "**mpi_pack_external_size %s %d %D %p", datarep, incount, datatype, size); } mpi_errno = MPIR_Err_return_comm(0, FCNAME, mpi_errno); goto fn_exit; #endif /* --END ERROR HANDLING-- */ }
/*@ MPIR_Type_contiguous - create a contiguous datatype Input Parameters: + count - number of elements in the contiguous block - oldtype - type (using handle) of datatype on which vector is based Output Parameters: . newtype - handle of new contiguous datatype Return Value: MPI_SUCCESS on success, MPI error code on failure. @*/ int MPIR_Type_contiguous(int count, MPI_Datatype oldtype, MPI_Datatype *newtype) { int mpi_errno = MPI_SUCCESS; int is_builtin; MPI_Aint el_sz; MPI_Datatype el_type; MPIR_Datatype *new_dtp; if (count == 0) return MPII_Type_zerolen(newtype); /* allocate new datatype object and handle */ new_dtp = (MPIR_Datatype *) MPIR_Handle_obj_alloc(&MPIR_Datatype_mem); /* --BEGIN ERROR HANDLING-- */ if (!new_dtp) { mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE, "MPIR_Type_contiguous", __LINE__, MPI_ERR_OTHER, "**nomem", 0); return mpi_errno; } /* --END ERROR HANDLING-- */ /* handle is filled in by MPIR_Handle_obj_alloc() */ MPIR_Object_set_ref(new_dtp, 1); new_dtp->is_permanent = 0; new_dtp->is_committed = 0; new_dtp->attributes = NULL; new_dtp->cache_id = 0; new_dtp->name[0] = 0; new_dtp->contents = NULL; new_dtp->dataloop = NULL; new_dtp->dataloop_size = -1; new_dtp->dataloop_depth = -1; new_dtp->hetero_dloop = NULL; new_dtp->hetero_dloop_size = -1; new_dtp->hetero_dloop_depth = -1; is_builtin = (HANDLE_GET_KIND(oldtype) == HANDLE_KIND_BUILTIN); if (is_builtin) { el_sz = MPIR_Datatype_get_basic_size(oldtype); el_type = oldtype; new_dtp->size = count * el_sz; new_dtp->has_sticky_ub = 0; new_dtp->has_sticky_lb = 0; new_dtp->true_lb = 0; new_dtp->lb = 0; new_dtp->true_ub = count * el_sz; new_dtp->ub = new_dtp->true_ub; new_dtp->extent = new_dtp->ub - new_dtp->lb; new_dtp->alignsize = el_sz; new_dtp->n_builtin_elements = count; new_dtp->builtin_element_size = el_sz; new_dtp->basic_type = el_type; new_dtp->is_contig = 1; new_dtp->max_contig_blocks = 1; } else { /* user-defined base type (oldtype) */ MPIR_Datatype *old_dtp; MPIR_Datatype_get_ptr(oldtype, old_dtp); el_sz = old_dtp->builtin_element_size; el_type = old_dtp->basic_type; new_dtp->size = count * old_dtp->size; new_dtp->has_sticky_ub = old_dtp->has_sticky_ub; new_dtp->has_sticky_lb = old_dtp->has_sticky_lb; MPII_DATATYPE_CONTIG_LB_UB((MPI_Aint) count, old_dtp->lb, old_dtp->ub, old_dtp->extent, new_dtp->lb, new_dtp->ub); /* easiest to calc true lb/ub relative to lb/ub; doesn't matter * if there are sticky lb/ubs or not when doing this. */ new_dtp->true_lb = new_dtp->lb + (old_dtp->true_lb - old_dtp->lb); new_dtp->true_ub = new_dtp->ub + (old_dtp->true_ub - old_dtp->ub); new_dtp->extent = new_dtp->ub - new_dtp->lb; new_dtp->alignsize = old_dtp->alignsize; new_dtp->n_builtin_elements = count * old_dtp->n_builtin_elements; new_dtp->builtin_element_size = old_dtp->builtin_element_size; new_dtp->basic_type = el_type; MPIR_Datatype_is_contig(oldtype, &new_dtp->is_contig); if(new_dtp->is_contig) new_dtp->max_contig_blocks = 1; else new_dtp->max_contig_blocks = count * old_dtp->max_contig_blocks; } *newtype = new_dtp->handle; MPL_DBG_MSG_P(MPIR_DBG_DATATYPE,VERBOSE,"contig type %x created.", new_dtp->handle); return mpi_errno; }
/*@ 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_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_Type_get_true_extent - Get the true lower bound and extent for a datatype Input Parameters: . datatype - datatype to get information on (handle) Output Parameters: + true_lb - true lower bound of datatype (address integer) - true_extent - true size of datatype (address integer) .N SignalSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_TYPE .N MPI_ERR_ARG @*/ int MPI_Type_get_true_extent(MPI_Datatype datatype, MPI_Aint * true_lb, MPI_Aint * true_extent) { int mpi_errno = MPI_SUCCESS; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_GET_TRUE_EXTENT); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TYPE_GET_TRUE_EXTENT); /* Validate parameters, especially handles needing to be converted */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno); } MPID_END_ERROR_CHECKS; } #endif /* Validate parameters and objects (post conversion) */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_Datatype *datatype_ptr = NULL; /* Convert MPI object handles to object pointers */ MPIR_Datatype_get_ptr(datatype, datatype_ptr); /* Validate datatype_ptr */ MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno) goto fn_fail; MPIR_ERRTEST_ARGNULL(true_lb, "true_lb", mpi_errno); MPIR_ERRTEST_ARGNULL(true_extent, "true_extent", mpi_errno); } MPID_END_ERROR_CHECKS; } #endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ MPIR_Type_get_true_extent_impl(datatype, true_lb, true_extent); /* ... end of body of routine ... */ #ifdef HAVE_ERROR_CHECKING fn_exit: #endif MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_GET_TRUE_EXTENT); return mpi_errno; /* --BEGIN ERROR HANDLING-- */ #ifdef HAVE_ERROR_CHECKING fn_fail: { mpi_errno = MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_type_get_true_extent", "**mpi_type_get_true_extent %D %p %p", datatype, true_lb, true_extent); } mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno); goto fn_exit; #endif /* --END ERROR HANDLING-- */ }
/*@ MPI_Type_get_envelope - get type envelope Input Parameters: . datatype - datatype to access (handle) Output Parameters: + num_integers - number of input integers used in the call constructing combiner (non-negative integer) . num_addresses - number of input addresses used in the call constructing combiner (non-negative integer) . num_datatypes - number of input datatypes used in the call constructing combiner (non-negative integer) - combiner - combiner (state) Notes: .N Fortran .N Errors .N MPI_SUCCESS @*/ int MPI_Type_get_envelope(MPI_Datatype datatype, int *num_integers, int *num_addresses, int *num_datatypes, int *combiner) { int mpi_errno = MPI_SUCCESS; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_GET_ENVELOPE); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TYPE_GET_ENVELOPE); /* Validate parameters, especially handles needing to be converted */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno); } MPID_END_ERROR_CHECKS; } #endif /* Validate parameters and objects (post conversion) */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_Datatype *datatype_ptr = NULL; /* Convert MPI object handles to object pointers */ MPIR_Datatype_get_ptr(datatype, datatype_ptr); /* Validate datatype_ptr */ MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno); /* If comm_ptr is not value, it will be reset to null */ if (mpi_errno != MPI_SUCCESS) goto fn_fail; } MPID_END_ERROR_CHECKS; } #endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ MPIR_Type_get_envelope(datatype, num_integers, num_addresses, num_datatypes, combiner); /* ... end of body of routine ... */ #ifdef HAVE_ERROR_CHECKING fn_exit: #endif MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_GET_ENVELOPE); return mpi_errno; #ifdef HAVE_ERROR_CHECKING fn_fail: /* --BEGIN ERROR HANDLING-- */ { mpi_errno = MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_OTHER, "**mpi_type_get_envelope", "**mpi_type_get_envelope %D %p %p %p %p", datatype, num_integers, num_addresses, num_datatypes, combiner); } mpi_errno = MPIR_Err_return_comm(NULL, __func__, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ #endif }
/*@ MPIR_Type_dup - create a copy of a datatype Input Parameters: - oldtype - handle of original datatype Output Parameters: . newtype - handle of newly created copy of datatype Return Value: 0 on success, MPI error code on failure. @*/ int MPIR_Type_dup(MPI_Datatype oldtype, MPI_Datatype * newtype) { int mpi_errno = MPI_SUCCESS; MPIR_Datatype *new_dtp = 0, *old_dtp; if (HANDLE_GET_KIND(oldtype) == HANDLE_KIND_BUILTIN) { /* create a new type and commit it. */ mpi_errno = MPIR_Type_contiguous(1, oldtype, newtype); if (mpi_errno) { MPIR_ERR_POP(mpi_errno); } } else { /* allocate new datatype object and handle */ new_dtp = (MPIR_Datatype *) MPIR_Handle_obj_alloc(&MPIR_Datatype_mem); if (!new_dtp) { /* --BEGIN ERROR HANDLING-- */ mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE, "MPIR_Type_dup", __LINE__, MPI_ERR_OTHER, "**nomem", 0); goto fn_fail; /* --END ERROR HANDLING-- */ } MPIR_Datatype_get_ptr(oldtype, old_dtp); /* fill in datatype */ MPIR_Object_set_ref(new_dtp, 1); /* new_dtp->handle is filled in by MPIR_Handle_obj_alloc() */ new_dtp->is_contig = old_dtp->is_contig; new_dtp->size = old_dtp->size; new_dtp->extent = old_dtp->extent; new_dtp->ub = old_dtp->ub; new_dtp->lb = old_dtp->lb; new_dtp->true_ub = old_dtp->true_ub; new_dtp->true_lb = old_dtp->true_lb; new_dtp->alignsize = old_dtp->alignsize; new_dtp->has_sticky_ub = old_dtp->has_sticky_ub; new_dtp->has_sticky_lb = old_dtp->has_sticky_lb; new_dtp->is_committed = old_dtp->is_committed; new_dtp->attributes = NULL; /* Attributes are copied in the * top-level MPI_Type_dup routine */ new_dtp->name[0] = 0; /* The Object name is not copied on * a dup */ new_dtp->n_builtin_elements = old_dtp->n_builtin_elements; new_dtp->builtin_element_size = old_dtp->builtin_element_size; new_dtp->basic_type = old_dtp->basic_type; new_dtp->max_contig_blocks = old_dtp->max_contig_blocks; new_dtp->dataloop = NULL; new_dtp->dataloop_size = old_dtp->dataloop_size; *newtype = new_dtp->handle; if (old_dtp->is_committed) { MPIR_Assert(old_dtp->dataloop != NULL); MPIR_Dataloop_dup(old_dtp->dataloop, old_dtp->dataloop_size, &new_dtp->dataloop); MPID_Type_commit_hook(new_dtp); } } MPL_DBG_MSG_D(MPIR_DBG_DATATYPE, VERBOSE, "dup type %x created.", *newtype); fn_fail: return mpi_errno; }
/*@ MPI_Sendrecv_replace - Sends and receives using a single buffer Input Parameters: + count - number of elements in send and receive buffer (integer) . datatype - type of elements in send and receive buffer (handle) . dest - rank of destination (integer) . sendtag - send message tag (integer) . source - rank of source (integer) . recvtag - receive message tag (integer) - comm - communicator (handle) Output Parameters: + buf - initial address of send and receive buffer (choice) - status - status object (Status) .N ThreadSafe .N Fortran .N FortranStatus .N Errors .N MPI_SUCCESS .N MPI_ERR_COMM .N MPI_ERR_COUNT .N MPI_ERR_TYPE .N MPI_ERR_TAG .N MPI_ERR_RANK .N MPI_ERR_TRUNCATE .N MPI_ERR_EXHAUSTED @*/ int MPI_Sendrecv_replace(void *buf, int count, MPI_Datatype datatype, int dest, int sendtag, int source, int recvtag, MPI_Comm comm, MPI_Status *status) { static const char FCNAME[] = "MPI_Sendrecv_replace"; int mpi_errno = MPI_SUCCESS; MPIR_Comm *comm_ptr = NULL; MPIR_CHKLMEM_DECL(1); MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_SENDRECV_REPLACE); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_PT2PT_ENTER_BOTH(MPID_STATE_MPI_SENDRECV_REPLACE); /* Convert handles to MPI objects. */ MPIR_Comm_get_ptr(comm, comm_ptr); # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { /* Validate communicator */ MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE ); if (mpi_errno) goto fn_fail; /* Validate count */ MPIR_ERRTEST_COUNT(count, mpi_errno); /* Validate status (status_ignore is not the same as null) */ MPIR_ERRTEST_ARGNULL(status, "status", mpi_errno); /* Validate tags */ MPIR_ERRTEST_SEND_TAG(sendtag, mpi_errno); MPIR_ERRTEST_RECV_TAG(recvtag, mpi_errno); /* Validate source and destination */ MPIR_ERRTEST_SEND_RANK(comm_ptr, dest, mpi_errno); MPIR_ERRTEST_RECV_RANK(comm_ptr, source, mpi_errno); /* Validate datatype handle */ MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno); /* Validate datatype object */ if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) { MPIR_Datatype *datatype_ptr = NULL; MPIR_Datatype_get_ptr(datatype, datatype_ptr); MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno) goto fn_fail; MPIR_Datatype_committed_ptr(datatype_ptr, mpi_errno); if (mpi_errno) goto fn_fail; } /* Validate buffer */ MPIR_ERRTEST_USERBUFFER(buf,count,datatype,mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ # if defined(MPID_Sendrecv_replace) { mpi_errno = MPID_Sendrecv_replace(buf, count, datatype, dest, sendtag, source, recvtag, comm_ptr, status) } # else { MPIR_Request * sreq; MPIR_Request * rreq; void * tmpbuf = NULL; MPI_Aint tmpbuf_size = 0; MPI_Aint tmpbuf_count = 0; if (count > 0 && dest != MPI_PROC_NULL) { MPIR_Pack_size_impl(count, datatype, &tmpbuf_size); MPIR_CHKLMEM_MALLOC_ORJUMP(tmpbuf, void *, tmpbuf_size, mpi_errno, "temporary send buffer", MPL_MEM_BUFFER); mpi_errno = MPIR_Pack_impl(buf, count, datatype, tmpbuf, tmpbuf_size, &tmpbuf_count); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } mpi_errno = MPID_Irecv(buf, count, datatype, source, recvtag, comm_ptr, MPIR_CONTEXT_INTRA_PT2PT, &rreq); if (mpi_errno != MPI_SUCCESS) goto fn_fail; mpi_errno = MPID_Isend(tmpbuf, tmpbuf_count, MPI_PACKED, dest, sendtag, comm_ptr, MPIR_CONTEXT_INTRA_PT2PT, &sreq); if (mpi_errno != MPI_SUCCESS) { /* --BEGIN ERROR HANDLING-- */ /* FIXME: should we cancel the pending (possibly completed) receive request or wait for it to complete? */ MPIR_Request_free(rreq); goto fn_fail; /* --END ERROR HANDLING-- */ } if (!MPIR_Request_is_complete(sreq) || !MPIR_Request_is_complete(rreq)) { MPID_Progress_state progress_state; MPID_Progress_start(&progress_state); while (!MPIR_Request_is_complete(sreq) || !MPIR_Request_is_complete(rreq)) { mpi_errno = MPID_Progress_wait(&progress_state); if (mpi_errno != MPI_SUCCESS) { /* --BEGIN ERROR HANDLING-- */ MPID_Progress_end(&progress_state); goto fn_fail; /* --END ERROR HANDLING-- */ } } MPID_Progress_end(&progress_state); } if (status != MPI_STATUS_IGNORE) { *status = rreq->status; } if (mpi_errno == MPI_SUCCESS) { mpi_errno = rreq->status.MPI_ERROR; if (mpi_errno == MPI_SUCCESS) { mpi_errno = sreq->status.MPI_ERROR; } } MPIR_Request_free(sreq); MPIR_Request_free(rreq); }
int MPIR_Create_unnamed_predefined(MPI_Datatype old, int combiner, int r, int p, MPI_Datatype * new_ptr) { int i; int mpi_errno = MPI_SUCCESS; F90Predefined *type; *new_ptr = MPI_DATATYPE_NULL; /* Has this type been defined already? */ for (i = 0; i < nAlloc; i++) { type = &f90Types[i]; if (type->combiner == combiner && type->r == r && type->p == p) { *new_ptr = type->d; return mpi_errno; } } /* Create a new type and remember it */ if (nAlloc >= MAX_F90_TYPES) { return MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE, "MPIF_Create_unnamed_predefined", __LINE__, MPI_ERR_INTERN, "**f90typetoomany", 0); } if (nAlloc == 0) { /* Install the finalize callback that frees these datatyeps. * Set the priority high enough that this will be executed * before the handle allocation check */ MPIR_Add_finalize(MPIR_FreeF90Datatypes, 0, 2); } type = &f90Types[nAlloc++]; type->combiner = combiner; type->r = r; type->p = p; /* Create a contiguous type from one instance of the named type */ mpi_errno = MPIR_Type_contiguous(1, old, &type->d); if (mpi_errno) MPIR_ERR_POP(mpi_errno); /* Initialize the contents data */ { MPIR_Datatype *new_dtp = NULL; int vals[2]; int nvals = 0; switch (combiner) { case MPI_COMBINER_F90_INTEGER: nvals = 1; vals[0] = r; break; case MPI_COMBINER_F90_REAL: case MPI_COMBINER_F90_COMPLEX: nvals = 2; vals[0] = p; vals[1] = r; break; } MPIR_Datatype_get_ptr(type->d, new_dtp); mpi_errno = MPIR_Datatype_set_contents(new_dtp, combiner, nvals, 0, 0, vals, NULL, NULL); if (mpi_errno) MPIR_ERR_POP(mpi_errno); /* FIXME should we be setting type->is_permanent=TRUE here too? If so, * will the cleanup code handle it correctly and not freak out? */ #ifndef NDEBUG { MPI_Datatype old_basic = MPI_DATATYPE_NULL; MPI_Datatype new_basic = MPI_DATATYPE_NULL; /* we used MPIR_Type_contiguous and then stomped it's contents * information, so make sure that the basic_type is usable by * MPIR_Type_commit */ MPIR_Datatype_get_basic_type(old, old_basic); MPIR_Datatype_get_basic_type(new_dtp->handle, new_basic); MPIR_Assert(new_basic == old_basic); } #endif /* the MPI Standard requires that these types are pre-committed * (MPI-2.2, sec 16.2.5, pg 492) */ mpi_errno = MPIR_Type_commit(&type->d); if (mpi_errno) MPIR_ERR_POP(mpi_errno); } *new_ptr = type->d; fn_fail: return mpi_errno; }
/*@ MPI_Reduce - Reduces values on all processes to a single value Input Parameters: + sendbuf - address of send buffer (choice) . count - number of elements in send buffer (integer) . datatype - data type of elements of send buffer (handle) . op - reduce operation (handle) . root - rank of root process (integer) - comm - communicator (handle) Output Parameters: . recvbuf - address of receive buffer (choice, significant only at 'root') .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_Reduce(const void *sendbuf, void *recvbuf, int count, MPI_Datatype datatype, MPI_Op op, 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_REDUCE); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_COLL_ENTER(MPID_STATE_MPI_REDUCE); /* 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; if (comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM) { MPIR_ERRTEST_INTRA_ROOT(comm_ptr, root, mpi_errno); MPIR_ERRTEST_COUNT(count, mpi_errno); MPIR_ERRTEST_DATATYPE(datatype, "datatype", 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; } if (sendbuf != MPI_IN_PLACE) MPIR_ERRTEST_USERBUFFER(sendbuf,count,datatype,mpi_errno); rank = comm_ptr->rank; if (rank == root) { MPIR_ERRTEST_RECVBUF_INPLACE(recvbuf, count, mpi_errno); MPIR_ERRTEST_USERBUFFER(recvbuf,count,datatype,mpi_errno); if (count != 0 && sendbuf != MPI_IN_PLACE) { MPIR_ERRTEST_ALIAS_COLL(sendbuf, recvbuf, mpi_errno); } } else MPIR_ERRTEST_SENDBUF_INPLACE(sendbuf, count, 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(count, mpi_errno); MPIR_ERRTEST_DATATYPE(datatype, "datatype", 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_RECVBUF_INPLACE(recvbuf, count, mpi_errno); MPIR_ERRTEST_USERBUFFER(recvbuf,count,datatype,mpi_errno); } else if (root != MPI_PROC_NULL) { MPIR_ERRTEST_COUNT(count, mpi_errno); MPIR_ERRTEST_DATATYPE(datatype, "datatype", 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_SENDBUF_INPLACE(sendbuf, count, mpi_errno); MPIR_ERRTEST_USERBUFFER(sendbuf,count,datatype,mpi_errno); } } MPIR_ERRTEST_OP(op, 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 (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; } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Reduce(sendbuf, recvbuf, count, datatype, op, 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_REDUCE); 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_reduce", "**mpi_reduce %p %p %d %D %O %d %C", sendbuf, recvbuf, count, datatype, op, root, comm); } # endif mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ 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-- */ }
/*@ MPI_Iscan - Computes the scan (partial reductions) of data on a collection of processes in a nonblocking way Input Parameters: + sendbuf - starting address of the send buffer (choice) . count - number of elements in input buffer (non-negative integer) . datatype - data type of elements of input buffer (handle) . op - operation (handle) - comm - communicator (handle) Output Parameters: + recvbuf - starting address of the receive buffer (choice) - request - communication request (handle) .N ThreadSafe .N Fortran .N Errors @*/ int MPI_Iscan(const void *sendbuf, void *recvbuf, int count, MPI_Datatype datatype, MPI_Op op, MPI_Comm comm, MPI_Request * request) { int mpi_errno = MPI_SUCCESS; MPIR_Comm *comm_ptr = NULL; MPIR_Request *request_ptr = NULL; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_ISCAN); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_ISCAN); /* Validate parameters, especially handles needing to be converted */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno); MPIR_ERRTEST_COUNT(count, mpi_errno); MPIR_ERRTEST_OP(op, mpi_errno); MPIR_ERRTEST_COMM(comm, mpi_errno); /* TODO more checks may be appropriate */ } MPID_END_ERROR_CHECKS; } #endif /* HAVE_ERROR_CHECKING */ /* Convert MPI object handles to object pointers */ MPIR_Comm_get_ptr(comm, comm_ptr); /* Validate parameters and objects (post conversion) */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, FALSE); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPIR_ERRTEST_COMM_INTRA(comm_ptr, mpi_errno); if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) { MPIR_Datatype *datatype_ptr = NULL; MPIR_Datatype_get_ptr(datatype, datatype_ptr); MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPIR_Datatype_committed_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } if (HANDLE_GET_KIND(op) != HANDLE_KIND_BUILTIN) { MPIR_Op *op_ptr = NULL; MPIR_Op_get_ptr(op, op_ptr); MPIR_Op_valid_ptr(op_ptr, mpi_errno); } else if (HANDLE_GET_KIND(op) == HANDLE_KIND_BUILTIN) { mpi_errno = (*MPIR_OP_HDL_TO_DTYPE_FN(op)) (datatype); } if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPIR_ERRTEST_ARGNULL(request, "request", mpi_errno); if (sendbuf != MPI_IN_PLACE && count != 0) MPIR_ERRTEST_ALIAS_COLL(sendbuf, recvbuf, mpi_errno); /* TODO more checks may be appropriate (counts, in_place, etc) */ } MPID_END_ERROR_CHECKS; } #endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Iscan(sendbuf, recvbuf, count, datatype, op, comm_ptr, &request_ptr); if (mpi_errno) MPIR_ERR_POP(mpi_errno); /* create a complete request, if needed */ if (!request_ptr) request_ptr = MPIR_Request_create_complete(MPIR_REQUEST_KIND__COLL); /* return the handle of the request to the user */ *request = request_ptr->handle; /* ... end of body of routine ... */ fn_exit: MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_ISCAN); MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ #ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_OTHER, "**mpi_iscan", "**mpi_iscan %p %p %d %D %O %C %p", sendbuf, recvbuf, count, datatype, op, comm, request); } #endif mpi_errno = MPIR_Err_return_comm(comm_ptr, __func__, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }