int MPII_Type_set_attr(MPI_Datatype datatype, int type_keyval, void *attribute_val, MPIR_Attr_type attrType ) { static const char FCNAME[] = "MPII_Type_set_attr"; int mpi_errno = MPI_SUCCESS; MPIR_Datatype *type_ptr = NULL; MPII_Keyval *keyval_ptr = NULL; MPIR_Attribute *p, **old_p; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPIR_TYPE_SET_ATTR); MPIR_ERRTEST_INITIALIZED_ORDIE(); /* The thread lock prevents a valid attr delete on the same datatype but in a different thread from causing problems */ MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPIR_TYPE_SET_ATTR); /* 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_KEYVAL(type_keyval, MPIR_DATATYPE, "datatype", mpi_errno); MPIR_ERRTEST_KEYVAL_PERM(type_keyval, mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* Convert MPI object handles to object pointers */ MPID_Datatype_get_ptr( datatype, type_ptr ); MPII_Keyval_get_ptr( type_keyval, keyval_ptr ); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { /* Validate type_ptr */ MPIR_Datatype_valid_ptr( type_ptr, mpi_errno ); /* If type_ptr is not valid, it will be reset to null */ /* Validate keyval_ptr */ MPII_Keyval_valid_ptr( keyval_ptr, mpi_errno ); if (mpi_errno) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ /* Look for attribute. They are ordered by keyval handle. This uses a simple linear list algorithm because few applications use more than a handful of attributes */ old_p = &type_ptr->attributes; p = type_ptr->attributes; while (p) { if (p->keyval->handle == keyval_ptr->handle) { /* If found, call the delete function before replacing the attribute */ mpi_errno = MPIR_Call_attr_delete( datatype, p ); /* --BEGIN ERROR HANDLING-- */ if (mpi_errno) { goto fn_fail; } /* --END ERROR HANDLING-- */ p->value = (MPII_Attr_val_t)(intptr_t)attribute_val; p->attrType = attrType; break; } else if (p->keyval->handle > keyval_ptr->handle) { MPIR_Attribute *new_p = MPID_Attr_alloc(); MPIR_ERR_CHKANDJUMP1(!new_p,mpi_errno,MPI_ERR_OTHER, "**nomem","**nomem %s", "MPIR_Attribute" ); new_p->keyval = keyval_ptr; new_p->attrType = attrType; new_p->pre_sentinal = 0; new_p->value = (MPII_Attr_val_t)(intptr_t)attribute_val; new_p->post_sentinal = 0; new_p->next = p->next; MPII_Keyval_add_ref( keyval_ptr ); p->next = new_p; break; } old_p = &p->next; p = p->next; } if (!p) { MPIR_Attribute *new_p = MPID_Attr_alloc(); MPIR_ERR_CHKANDJUMP1(!new_p,mpi_errno,MPI_ERR_OTHER, "**nomem","**nomem %s", "MPIR_Attribute" ); /* Did not find in list. Add at end */ new_p->keyval = keyval_ptr; new_p->attrType = attrType; new_p->pre_sentinal = 0; new_p->value = (MPII_Attr_val_t)(intptr_t)attribute_val; new_p->post_sentinal = 0; new_p->next = 0; MPII_Keyval_add_ref( keyval_ptr ); *old_p = new_p; } /* Here is where we could add a hook for the device to detect attribute value changes, using something like MPID_Type_attr_hook( type_ptr, keyval, attribute_val ); */ /* ... end of body of routine ... */ fn_exit: MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPIR_TYPE_SET_ATTR); MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_type_set_attr", "**mpi_type_set_attr %D %d %p", datatype, type_keyval, attribute_val); } # endif mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Get_elements - 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) Notes: If the size of the datatype is zero and the amount of data returned as determined by 'status' is also zero, this routine will return a count of zero. This is consistent with a clarification made by the MPI Forum. .N Fortran .N Errors .N MPI_SUCCESS @*/ int MPI_Get_elements(const MPI_Status *status, MPI_Datatype datatype, int *count) { int mpi_errno = MPI_SUCCESS; MPI_Count count_x; MPID_MPI_STATE_DECL(MPID_STATE_MPI_GET_ELEMENTS); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_GET_ELEMENTS); /* 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; { MPID_Datatype *datatype_ptr = NULL; MPIR_ERRTEST_ARGNULL(status, "status", mpi_errno); MPIR_ERRTEST_ARGNULL(count, "count", mpi_errno); /* Convert MPI object handles to object pointers */ MPID_Datatype_get_ptr(datatype, datatype_ptr); /* Validate datatype_ptr */ if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) { MPID_Datatype_get_ptr(datatype, datatype_ptr); MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPID_Datatype_committed_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } } MPID_END_ERROR_CHECKS; } # endif /* ... body of routine ... */ mpi_errno = MPIR_Get_elements_x_impl(status, datatype, &count_x); if (mpi_errno) MPIU_ERR_POP(mpi_errno); /* clip the value if it cannot be correctly returned to the user */ *count = (count_x > INT_MAX) ? MPI_UNDEFINED : (int)count_x; /* ... end of body of routine ... */ fn_exit: MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_GET_ELEMENTS); 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_get_elements", "**mpi_get_elements %p %D %p", status, datatype, count); } mpi_errno = MPIR_Err_return_comm(0, FCNAME, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Neighbor_allgatherv - The vector variant of MPI_Neighbor_allgather. 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) . recvcounts - non-negative integer array (of length indegree) containing the number of elements that are received from each neighbor . displs - integer array (of length indegree). Entry i specifies the displacement (relative to recvbuf) at which to place the incoming data from neighbor i. . 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_allgatherv(const void *sendbuf, int sendcount, MPI_Datatype sendtype, void *recvbuf, const int recvcounts[], const int displs[], 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_ALLGATHERV); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_NEIGHBOR_ALLGATHERV); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS { MPIR_ERRTEST_DATATYPE(sendtype, "sendtype", mpi_errno); MPIR_ERRTEST_DATATYPE(recvtype, "recvtype", mpi_errno); MPIR_ERRTEST_COMM(comm, mpi_errno); /* TODO more checks may be appropriate */ } MPID_END_ERROR_CHECKS } # endif /* HAVE_ERROR_CHECKING */ /* Convert MPI object handles to object pointers */ MPIR_Comm_get_ptr(comm, comm_ptr); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS { if (HANDLE_GET_KIND(sendtype) != HANDLE_KIND_BUILTIN) { MPIR_Datatype *sendtype_ptr = NULL; MPID_Datatype_get_ptr(sendtype, sendtype_ptr); MPIR_Datatype_valid_ptr(sendtype_ptr, mpi_errno); MPID_Datatype_committed_ptr(sendtype_ptr, mpi_errno); } if (HANDLE_GET_KIND(recvtype) != HANDLE_KIND_BUILTIN) { MPIR_Datatype *recvtype_ptr = NULL; MPID_Datatype_get_ptr(recvtype, recvtype_ptr); MPIR_Datatype_valid_ptr(recvtype_ptr, mpi_errno); MPID_Datatype_committed_ptr(recvtype_ptr, mpi_errno); } MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE ); /* TODO more checks may be appropriate (counts, in_place, buffer aliasing, etc) */ if (mpi_errno != MPI_SUCCESS) goto fn_fail; } MPID_END_ERROR_CHECKS } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPID_Neighbor_allgatherv(sendbuf, sendcount, sendtype, recvbuf, recvcounts, displs, 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_ALLGATHERV); MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_neighbor_allgatherv", "**mpi_neighbor_allgatherv %p %d %D %p %p %p %D %C", sendbuf, sendcount, sendtype, recvbuf, recvcounts, displs, recvtype, comm); } # endif mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Rsend - Blocking ready 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_Rsend(const void *buf, int count, MPI_Datatype datatype, int dest, int tag, MPI_Comm comm) { static const char FCNAME[] = "MPI_Rsend"; int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPID_Request * request_ptr = NULL; MPID_MPI_STATE_DECL(MPID_STATE_MPI_RSEND); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPID_MPI_PT2PT_FUNC_ENTER_FRONT(MPID_STATE_MPI_RSEND); /* 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 */ MPID_Comm_get_ptr( comm, comm_ptr ); /* Validate parameters if error checking is enabled */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPID_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) { MPID_Datatype *datatype_ptr = NULL; MPID_Datatype_get_ptr(datatype, datatype_ptr); MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno) goto fn_fail; MPID_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_Rsend(buf, count, datatype, dest, tag, comm_ptr, MPID_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 */ if (!MPID_Request_is_complete(request_ptr)) { MPID_Progress_state progress_state; MPID_Progress_start(&progress_state); while (!MPID_Request_is_complete(request_ptr)) { 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); } mpi_errno = request_ptr->status.MPI_ERROR; MPID_Request_release(request_ptr); if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* ... end of body of routine ... */ fn_exit: MPID_MPI_PT2PT_FUNC_EXIT(MPID_STATE_MPI_RSEND); 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_rsend", "**mpi_rsend %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_Recv - Blocking receive for a message Output Parameters: + buf - initial address of receive buffer (choice) - status - status object (Status) Input Parameters: + count - maximum number of elements in receive buffer (integer) . datatype - datatype of each receive buffer element (handle) . source - rank of source (integer) . tag - message tag (integer) - comm - communicator (handle) Notes: The 'count' argument indicates the maximum length of a message; the actual length of the message can be determined with 'MPI_Get_count'. .N ThreadSafe .N Fortran .N FortranStatus .N Errors .N MPI_SUCCESS .N MPI_ERR_COMM .N MPI_ERR_TYPE .N MPI_ERR_COUNT .N MPI_ERR_TAG .N MPI_ERR_RANK @*/ int MPI_Recv(void *buf, int count, MPI_Datatype datatype, int source, int tag, MPI_Comm comm, MPI_Status *status) { static const char FCNAME[] = "MPI_Recv"; int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPID_Request * request_ptr = NULL; MPID_MPI_STATE_DECL(MPID_STATE_MPI_RECV); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIU_THREAD_CS_ENTER(ALLFUNC,); MPID_MPI_PT2PT_FUNC_ENTER_BACK(MPID_STATE_MPI_RECV); /* Validate handle parameters needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_COMM(comm, mpi_errno); /* NOTE: MPI_STATUS_IGNORE != NULL */ MPIR_ERRTEST_ARGNULL(status, "status", mpi_errno); if (mpi_errno) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* Convert MPI object handles to object pointers */ MPID_Comm_get_ptr( comm, comm_ptr ); /* Validate parameters if error checking is enabled */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPID_Comm_valid_ptr( comm_ptr, mpi_errno ); 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); if (mpi_errno) goto fn_fail; /* Validate datatype handle */ MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno); /* Validate datatype object */ if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) { MPID_Datatype *datatype_ptr = NULL; MPID_Datatype_get_ptr(datatype, datatype_ptr); MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno); MPID_Datatype_committed_ptr(datatype_ptr, mpi_errno); if (mpi_errno) goto fn_fail; } /* Validate buffer */ MPIR_ERRTEST_USERBUFFER(buf,count,datatype,mpi_errno); if (mpi_errno) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ /* MT: Note that MPID_Recv may release the SINGLE_CS if it decides to block internally. MPID_Recv in that case will re-aquire the SINGLE_CS before returnning */ mpi_errno = MPID_Recv(buf, count, datatype, source, tag, comm_ptr, MPID_CONTEXT_INTRA_PT2PT, status, &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 */ if (!MPID_Request_is_complete(request_ptr)) { MPID_Progress_state progress_state; MPID_Progress_start(&progress_state); while (!MPID_Request_is_complete(request_ptr)) { /* MT: Progress_wait may release the SINGLE_CS while it waits */ 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); } mpi_errno = request_ptr->status.MPI_ERROR; MPIR_Request_extract_status(request_ptr, status); MPID_Request_release(request_ptr); if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* ... end of body of routine ... */ fn_exit: MPID_MPI_PT2PT_FUNC_EXIT_BACK(MPID_STATE_MPI_RECV); MPIU_THREAD_CS_EXIT(ALLFUNC,); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_recv", "**mpi_recv %p %d %D %i %t %C %p", buf, count, datatype, source, tag, comm, status); } # endif mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Isend - Begins a nonblocking 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 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_EXHAUSTED @*/ int MPI_Isend(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_Request *request_ptr = NULL; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_ISEND); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_PT2PT_ENTER_FRONT(MPID_STATE_MPI_ISEND); /* 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); 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; MPID_Datatype_get_ptr(datatype, datatype_ptr); MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno) goto fn_fail; MPID_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_Isend(buf, count, datatype, dest, tag, comm_ptr, MPIR_CONTEXT_INTRA_PT2PT, &request_ptr); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPII_SENDQ_REMEMBER(request_ptr,dest,tag,comm_ptr->context_id); /* return the handle of the request to the user */ /* MPIU_OBJ_HANDLE_PUBLISH is unnecessary for isend, lower-level access is * responsible for its own consistency, while upper-level field access is * controlled by the completion counter */ *request = request_ptr->handle; /* ... end of body of routine ... */ fn_exit: MPIR_FUNC_TERSE_PT2PT_EXIT(MPID_STATE_MPI_ISEND); 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_isend", "**mpi_isend %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_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 Parameter: . 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, int array_of_gsizes[], int array_of_distribs[], int array_of_dargs[], int array_of_psizes[], int order, MPI_Datatype oldtype, MPI_Datatype *newtype) { static const char FCNAME[] = "MPI_Type_create_darray"; int mpi_errno = MPI_SUCCESS, i; MPI_Datatype new_handle; int procs, tmp_rank, tmp_size, blklens[3], *coords; MPI_Aint *st_offsets, orig_extent, disps[3]; MPI_Datatype type_old, type_new = MPI_DATATYPE_NULL, types[3]; # ifdef HAVE_ERROR_CHECKING MPI_Aint size_with_aint; MPI_Offset size_with_offset; # endif int *ints; MPID_Datatype *datatype_ptr = NULL; MPIU_CHKLMEM_DECL(3); MPID_MPI_STATE_DECL(MPID_STATE_MPI_TYPE_CREATE_DARRAY); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIU_THREAD_CS_ENTER(ALLFUNC,); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_TYPE_CREATE_DARRAY); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_DATATYPE(oldtype, "datatype", mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* Convert MPI object handles to object pointers */ MPID_Datatype_get_ptr(oldtype, datatype_ptr); MPID_Datatype_get_extent_macro(oldtype, orig_extent); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { /* Check parameters */ MPIR_ERRTEST_ARGNEG(rank, "rank", mpi_errno); MPIR_ERRTEST_ARGNONPOS(size, "size", mpi_errno); MPIR_ERRTEST_ARGNONPOS(ndims, "ndims", mpi_errno); MPIR_ERRTEST_ARGNULL(array_of_gsizes, "array_of_gsizes", mpi_errno); MPIR_ERRTEST_ARGNULL(array_of_distribs, "array_of_distribs", mpi_errno); MPIR_ERRTEST_ARGNULL(array_of_dargs, "array_of_dargs", mpi_errno); MPIR_ERRTEST_ARGNULL(array_of_psizes, "array_of_psizes", mpi_errno); if (order != MPI_ORDER_C && order != MPI_ORDER_FORTRAN) { mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_ARG, "**arg", "**arg %s", "order"); } for (i=0; mpi_errno == MPI_SUCCESS && i < ndims; i++) { MPIR_ERRTEST_ARGNONPOS(array_of_gsizes[i], "gsize", mpi_errno); MPIR_ERRTEST_ARGNONPOS(array_of_psizes[i], "psize", mpi_errno); if ((array_of_distribs[i] != MPI_DISTRIBUTE_NONE) && (array_of_distribs[i] != MPI_DISTRIBUTE_BLOCK) && (array_of_distribs[i] != MPI_DISTRIBUTE_CYCLIC)) { mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_ARG, "**darrayunknown", 0); } if ((array_of_dargs[i] != MPI_DISTRIBUTE_DFLT_DARG) && (array_of_dargs[i] <= 0)) { mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_ARG, "**arg", "**arg %s", "array_of_dargs"); } if ((array_of_distribs[i] == MPI_DISTRIBUTE_NONE) && (array_of_psizes[i] != 1)) { mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_ARG, "**darraydist", "**darraydist %d %d", i, array_of_psizes[i]); } } /* TODO: GET THIS CHECK IN ALSO */ /* check if MPI_Aint is large enough for size of global array. if not, complain. */ size_with_aint = orig_extent; for (i=0; i<ndims; i++) size_with_aint *= array_of_gsizes[i]; size_with_offset = orig_extent; for (i=0; i<ndims; i++) size_with_offset *= array_of_gsizes[i]; if (size_with_aint != size_with_offset) { mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_FATAL, FCNAME, __LINE__, MPI_ERR_ARG, "**darrayoverflow", "**darrayoverflow %L", size_with_offset); } /* Validate datatype_ptr */ MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno); /* If datatype_ptr is not valid, it will be reset to null */ /* --BEGIN ERROR HANDLING-- */ if (mpi_errno) goto fn_fail; /* --END ERROR HANDLING-- */ } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ /* calculate position in Cartesian grid as MPI would (row-major ordering) */ MPIU_CHKLMEM_MALLOC_ORJUMP(coords, int *, ndims * sizeof(int), mpi_errno, "position is Cartesian grid"); procs = size; tmp_rank = rank; for (i=0; i<ndims; i++) { procs = procs/array_of_psizes[i]; coords[i] = tmp_rank/procs; tmp_rank = tmp_rank % procs; } MPIU_CHKLMEM_MALLOC_ORJUMP(st_offsets, MPI_Aint *, ndims * sizeof(MPI_Aint), mpi_errno, "st_offsets"); type_old = oldtype; if (order == MPI_ORDER_FORTRAN) { /* dimension 0 changes fastest */ for (i=0; i<ndims; i++) { switch(array_of_distribs[i]) { case MPI_DISTRIBUTE_BLOCK: mpi_errno = MPIR_Type_block(array_of_gsizes, i, ndims, array_of_psizes[i], coords[i], array_of_dargs[i], order, orig_extent, type_old, &type_new, st_offsets+i); break; case MPI_DISTRIBUTE_CYCLIC: mpi_errno = MPIR_Type_cyclic(array_of_gsizes, i, ndims, array_of_psizes[i], coords[i], array_of_dargs[i], order, orig_extent, type_old, &type_new, st_offsets+i); break; case MPI_DISTRIBUTE_NONE: /* treat it as a block distribution on 1 process */ mpi_errno = MPIR_Type_block(array_of_gsizes, i, ndims, 1, 0, MPI_DISTRIBUTE_DFLT_DARG, order, orig_extent, type_old, &type_new, st_offsets+i); break; } if (i) { MPIR_Type_free_impl(&type_old); } type_old = type_new; /* --BEGIN ERROR HANDLING-- */ if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* --END ERROR HANDLING-- */ } /* add displacement and UB */ disps[1] = st_offsets[0]; tmp_size = 1; for (i=1; i<ndims; i++) { tmp_size *= array_of_gsizes[i-1]; disps[1] += (MPI_Aint) tmp_size * st_offsets[i]; } /* rest done below for both Fortran and C order */ } else /* order == MPI_ORDER_C */ { /* dimension ndims-1 changes fastest */ for (i=ndims-1; i>=0; i--) { switch(array_of_distribs[i]) { case MPI_DISTRIBUTE_BLOCK: mpi_errno = MPIR_Type_block(array_of_gsizes, i, ndims, array_of_psizes[i], coords[i], array_of_dargs[i], order, orig_extent, type_old, &type_new, st_offsets+i); break; case MPI_DISTRIBUTE_CYCLIC: mpi_errno = MPIR_Type_cyclic(array_of_gsizes, i, ndims, array_of_psizes[i], coords[i], array_of_dargs[i], order, orig_extent, type_old, &type_new, st_offsets+i); break; case MPI_DISTRIBUTE_NONE: /* treat it as a block distribution on 1 process */ mpi_errno = MPIR_Type_block(array_of_gsizes, i, ndims, array_of_psizes[i], coords[i], MPI_DISTRIBUTE_DFLT_DARG, order, orig_extent, type_old, &type_new, st_offsets+i); break; } if (i != ndims-1) { MPIR_Type_free_impl(&type_old); } type_old = type_new; /* --BEGIN ERROR HANDLING-- */ if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* --END ERROR HANDLING-- */ } /* add displacement and UB */ disps[1] = st_offsets[ndims-1]; tmp_size = 1; for (i=ndims-2; i>=0; i--) { tmp_size *= array_of_gsizes[i+1]; disps[1] += (MPI_Aint) tmp_size * st_offsets[i]; } } disps[1] *= orig_extent; disps[2] = orig_extent; for (i=0; i<ndims; i++) disps[2] *= (MPI_Aint)(array_of_gsizes[i]); disps[0] = 0; blklens[0] = blklens[1] = blklens[2] = 1; types[0] = MPI_LB; types[1] = type_new; types[2] = MPI_UB; mpi_errno = MPID_Type_struct(3, blklens, disps, types, &new_handle); /* --BEGIN ERROR HANDLING-- */ if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* --END ERROR HANDLING-- */ MPIR_Type_free_impl(&type_new); /* at this point we have the new type, and we've cleaned up any * intermediate types created in the process. we just need to save * all our contents/envelope information. */ /* Save contents */ MPIU_CHKLMEM_MALLOC_ORJUMP(ints, int *, (4 * ndims + 4) * sizeof(int), mpi_errno, "content description"); ints[0] = size; ints[1] = rank; ints[2] = ndims; for (i=0; i < ndims; i++) { ints[i + 3] = array_of_gsizes[i]; } for (i=0; i < ndims; i++) { ints[i + ndims + 3] = array_of_distribs[i]; } for (i=0; i < ndims; i++) { ints[i + 2*ndims + 3] = array_of_dargs[i]; } for (i=0; i < ndims; i++) { ints[i + 3*ndims + 3] = array_of_psizes[i]; } ints[4*ndims + 3] = order; MPID_Datatype_get_ptr(new_handle, datatype_ptr); mpi_errno = MPID_Datatype_set_contents(datatype_ptr, MPI_COMBINER_DARRAY, 4*ndims + 4, 0, 1, ints, NULL, &oldtype); /* --BEGIN ERROR HANDLING-- */ if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* --END ERROR HANDLING-- */ MPIU_OBJ_PUBLISH_HANDLE(*newtype, new_handle); /* ... end of body of routine ... */ fn_exit: MPIU_CHKLMEM_FREEALL(); MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TYPE_CREATE_DARRAY); MPIU_THREAD_CS_EXIT(ALLFUNC,); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_type_create_darray", "**mpi_type_create_darray %d %d %d %p %p %p %p %d %D %p", size, rank, ndims, array_of_gsizes, array_of_distribs, array_of_dargs, array_of_psizes, order, oldtype, newtype); } # endif mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_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) { 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 = NULL; MPIR_Request *rreq = NULL; 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-- */ 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-- */ } mpi_errno = MPID_Wait(rreq, MPI_STATUS_IGNORE); if (mpi_errno) MPIR_ERR_POP(mpi_errno); mpi_errno = MPID_Wait(sreq, MPI_STATUS_IGNORE); if (mpi_errno) MPIR_ERR_POP(mpi_errno); if (status != MPI_STATUS_IGNORE) { *status = rreq->status; } if (mpi_errno == MPI_SUCCESS) { mpi_errno = rreq->status.MPI_ERROR; if (mpi_errno == MPI_SUCCESS) { mpi_errno = sreq->status.MPI_ERROR; } } MPIR_Request_free(sreq); MPIR_Request_free(rreq); }
/*@ MPI_Exscan - Computes the exclusive scan (partial reductions) of data on a collection of processes Input Parameters: + sendbuf - starting address of send buffer (choice) . count - number of elements in input buffer (integer) . datatype - data type of elements of input buffer (handle) . op - operation (handle) - comm - communicator (handle) Output Parameters: . recvbuf - starting address of receive buffer (choice) Notes: 'MPI_Exscan' is like 'MPI_Scan', except that the contribution from the calling process is not included in the result at the calling process (it is contributed to the subsequent processes, of course). .N ThreadSafe .N Fortran .N collops .N Errors .N MPI_SUCCESS .N MPI_ERR_COMM .N MPI_ERR_COUNT .N MPI_ERR_TYPE .N MPI_ERR_BUFFER .N MPI_ERR_BUFFER_ALIAS @*/ int MPI_Exscan(const void *sendbuf, void *recvbuf, int count, MPI_Datatype datatype, MPI_Op op, MPI_Comm comm) { int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; int errflag = FALSE; MPID_MPI_STATE_DECL(MPID_STATE_MPI_EXSCAN); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIU_THREAD_CS_ENTER(ALLFUNC,); MPID_MPI_COLL_FUNC_ENTER(MPID_STATE_MPI_EXSCAN); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_COMM(comm, mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* Convert MPI object handles to object pointers */ MPID_Comm_get_ptr( comm, comm_ptr ); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPID_Datatype *datatype_ptr = NULL; MPID_Op *op_ptr = NULL; int rank; MPID_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE ); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPIR_ERRTEST_COMM_INTRA(comm_ptr, mpi_errno); MPIR_ERRTEST_COUNT(count, mpi_errno); MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno); MPIR_ERRTEST_OP(op, mpi_errno); if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) { MPID_Datatype_get_ptr(datatype, datatype_ptr); MPID_Datatype_valid_ptr( datatype_ptr, mpi_errno ); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPID_Datatype_committed_ptr( datatype_ptr, mpi_errno ); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } rank = comm_ptr->rank; MPIR_ERRTEST_USERBUFFER(sendbuf,count,datatype,mpi_errno); if (rank != 0) { MPIR_ERRTEST_RECVBUF_INPLACE(recvbuf, count, mpi_errno); MPIR_ERRTEST_USERBUFFER(recvbuf,count,datatype,mpi_errno); } if (mpi_errno != MPI_SUCCESS) goto fn_fail; if (HANDLE_GET_KIND(op) != HANDLE_KIND_BUILTIN) { MPID_Op_get_ptr(op, op_ptr); MPID_Op_valid_ptr( op_ptr, mpi_errno ); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } if (HANDLE_GET_KIND(op) == HANDLE_KIND_BUILTIN) { mpi_errno = ( * MPIR_OP_HDL_TO_DTYPE_FN(op) )(datatype); } if (mpi_errno != MPI_SUCCESS) goto fn_fail; if (sendbuf != MPI_IN_PLACE && count != 0) MPIR_ERRTEST_ALIAS_COLL(sendbuf, recvbuf, mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Exscan_impl(sendbuf, recvbuf, count, datatype, op, comm_ptr, &errflag); if (mpi_errno) goto fn_fail; /* ... end of body of routine ... */ fn_exit: MPID_MPI_COLL_FUNC_EXIT(MPID_STATE_MPI_EXSCAN); MPIU_THREAD_CS_EXIT(ALLFUNC,); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_exscan", "**mpi_exscan %p %p %d %D %O %C", sendbuf, recvbuf, count, datatype, op, comm); } # endif mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Alltoallw - Generalized all-to-all communication allowing different datatypes, counts, and displacements for each partner Input Parameters: + sendbuf - starting address of send buffer (choice) . sendcounts - integer array equal to the group size specifying the number of elements to send to each processor (integer) . sdispls - integer array (of length group size). Entry j specifies the displacement in bytes (relative to sendbuf) from which to take the outgoing data destined for process j . sendtypes - array of datatypes (of length group size). Entry j specifies the type of data to send to process j (handle) . recvcounts - integer array equal to the group size specifying the number of elements that can be received from each processor (integer) . rdispls - integer array (of length group size). Entry i specifies the displacement in bytes (relative to recvbuf) at which to place the incoming data from process i . recvtypes - array of datatypes (of length group size). Entry i specifies the type of data received from process i (handle) - comm - communicator (handle) Output Parameters: . recvbuf - address of receive buffer (choice) .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_COMM .N MPI_ERR_ARG .N MPI_ERR_COUNT .N MPI_ERR_TYPE @*/ int MPI_Alltoallw(const void *sendbuf, const int sendcounts[], const int sdispls[], const MPI_Datatype sendtypes[], void *recvbuf, const int recvcounts[], const int rdispls[], const MPI_Datatype recvtypes[], MPI_Comm comm) { int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; int errflag = FALSE; MPID_MPI_STATE_DECL(MPID_STATE_MPI_ALLTOALLW); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIU_THREAD_CS_ENTER(ALLFUNC,); MPID_MPI_COLL_FUNC_ENTER(MPID_STATE_MPI_ALLTOALLW); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_COMM(comm, mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* Convert MPI object handles to object pointers */ MPID_Comm_get_ptr( comm, comm_ptr ); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPID_Datatype *sendtype_ptr=NULL, *recvtype_ptr=NULL; int i, comm_size; int check_send; MPID_Comm_valid_ptr( comm_ptr, mpi_errno ); if (mpi_errno != MPI_SUCCESS) goto fn_fail; check_send = (comm_ptr->comm_kind == MPID_INTRACOMM && sendbuf != MPI_IN_PLACE); if (comm_ptr->comm_kind == MPID_INTERCOMM && sendbuf == MPI_IN_PLACE) { MPIU_ERR_SETANDJUMP(mpi_errno, MPI_ERR_OTHER, "**sendbuf_inplace"); } if (comm_ptr->comm_kind == MPID_INTRACOMM) comm_size = comm_ptr->local_size; else comm_size = comm_ptr->remote_size; for (i=0; i<comm_size; i++) { if (check_send) { MPIR_ERRTEST_COUNT(sendcounts[i], mpi_errno); if (sendcounts[i] > 0) { MPIR_ERRTEST_DATATYPE(sendtypes[i], "sendtype[i]", mpi_errno); } if ((sendcounts[i] > 0) && (HANDLE_GET_KIND(sendtypes[i]) != HANDLE_KIND_BUILTIN)) { MPID_Datatype_get_ptr(sendtypes[i], sendtype_ptr); MPID_Datatype_valid_ptr( sendtype_ptr, mpi_errno ); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPID_Datatype_committed_ptr( sendtype_ptr, mpi_errno ); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } } MPIR_ERRTEST_COUNT(recvcounts[i], mpi_errno); if (recvcounts[i] > 0) { MPIR_ERRTEST_DATATYPE(recvtypes[i], "recvtype[i]", mpi_errno); } if ((recvcounts[i] > 0) && (HANDLE_GET_KIND(recvtypes[i]) != HANDLE_KIND_BUILTIN)) { MPID_Datatype_get_ptr(recvtypes[i], recvtype_ptr); MPID_Datatype_valid_ptr( recvtype_ptr, mpi_errno ); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPID_Datatype_committed_ptr( recvtype_ptr, mpi_errno ); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } } for (i=0; i<comm_size && check_send; i++) { if (sendcounts[i] > 0) { MPIR_ERRTEST_USERBUFFER(sendbuf,sendcounts[i],sendtypes[i],mpi_errno); break; } } 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],recvtypes[i],mpi_errno); break; } } if (mpi_errno != MPI_SUCCESS) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Alltoallw_impl(sendbuf, sendcounts, sdispls, sendtypes, recvbuf, recvcounts, rdispls, recvtypes, comm_ptr, &errflag); if (mpi_errno) goto fn_fail; /* ... end of body of routine ... */ fn_exit: MPID_MPI_COLL_FUNC_EXIT(MPID_STATE_MPI_ALLTOALLW); MPIU_THREAD_CS_EXIT(ALLFUNC,); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_alltoallw", "**mpi_alltoallw %p %p %p %p %p %p %p %p %C", sendbuf, sendcounts, sdispls, sendtypes, recvbuf, recvcounts, rdispls, recvtypes, comm); } # endif mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Imrecv - Nonblocking receive of message matched by MPI_Mprobe or MPI_Improbe. Input/Output Parameters: . message - message (handle) Input Parameters: + count - number of elements in the receive buffer (non-negative integer) - datatype - datatype of each receive buffer element (handle) Output Parameters: + buf - initial address of the receive buffer (choice) - request - communication request (handle) .N ThreadSafe .N Fortran .N Errors @*/ int MPI_Imrecv(void *buf, int count, MPI_Datatype datatype, MPI_Message *message, MPI_Request *request) { int mpi_errno = MPI_SUCCESS; MPIR_Request *rreq = NULL; MPIR_Request *msgp = NULL; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_IMRECV); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_IMRECV); /* 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 */ MPIR_Request_get_ptr(*message, msgp); /* 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; MPID_Datatype_get_ptr(datatype, datatype_ptr); MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPID_Datatype_committed_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } /* MPI_MESSAGE_NO_PROC should yield a "proc null" status */ if (*message != MPI_MESSAGE_NO_PROC) { MPIR_Request_valid_ptr(msgp, mpi_errno); if (mpi_errno) MPIR_ERR_POP(mpi_errno); MPIR_ERR_CHKANDJUMP((msgp->kind != MPIR_REQUEST_KIND__MPROBE), mpi_errno, MPI_ERR_ARG, "**reqnotmsg"); } MPIR_ERRTEST_ARGNULL(request, "request", mpi_errno); /* TODO more checks may be appropriate (counts, in_place, buffer aliasing, etc) */ } MPID_END_ERROR_CHECKS } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPID_Imrecv(buf, count, datatype, msgp, &rreq); if (mpi_errno) MPIR_ERR_POP(mpi_errno); MPIR_Assert(rreq != NULL); *request = rreq->handle; *message = MPI_MESSAGE_NULL; /* ... end of body of routine ... */ fn_exit: MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_IMRECV); 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_imrecv", "**mpi_imrecv %p %d %D %p %p", buf, count, datatype, message, request); } # endif mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Ibsend - Starts a nonblocking buffered send Input Parameters: + buf - initial address of send buffer (choice) . count - number of elements in send buffer (integer) . datatype - datatype of each send buffer element (handle) . dest - rank of destination (integer) . tag - message tag (integer) - comm - communicator (handle) Output Parameters: . request - communication request (handle) .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_COMM .N MPI_ERR_COUNT .N MPI_ERR_TYPE .N MPI_ERR_TAG .N MPI_ERR_RANK .N MPI_ERR_BUFFER @*/ int MPI_Ibsend(const void *buf, int count, MPI_Datatype datatype, int dest, int tag, MPI_Comm comm, MPI_Request *request) { int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPID_MPI_STATE_DECL(MPID_STATE_MPI_IBSEND); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIU_THREAD_CS_ENTER(ALLFUNC,); MPID_MPI_PT2PT_FUNC_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 */ MPID_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 */ MPID_Comm_valid_ptr( comm_ptr, mpi_errno ); if (mpi_errno) goto fn_fail; /* If comm_ptr is not valid, it will be reset to null */ 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) { MPID_Datatype *datatype_ptr = NULL; MPID_Datatype_get_ptr(datatype, datatype_ptr); MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno) goto fn_fail; MPID_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: MPID_MPI_PT2PT_FUNC_EXIT(MPID_STATE_MPI_IBSEND); MPIU_THREAD_CS_EXIT(ALLFUNC,); 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_free - Frees the datatype Input Parameters: . datatype - datatype that is freed (handle) Predefined types: The MPI standard states that (in Opaque Objects) .Bqs MPI provides certain predefined opaque objects and predefined, static handles to these objects. Such objects may not be destroyed. .Bqe Thus, it is an error to free a predefined datatype. The same section makes it clear that it is an error to free a null datatype. .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_TYPE .N MPI_ERR_ARG @*/ int MPI_Type_free(MPI_Datatype *datatype) { int mpi_errno = MPI_SUCCESS; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_FREE); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TYPE_FREE); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_ARGNULL(datatype, "datatype", mpi_errno); MPIR_ERRTEST_DATATYPE(*datatype, "datatype", mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* Convert MPI object handles to object pointers */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_Datatype *datatype_ptr = NULL; /* Check for built-in type */ if (HANDLE_GET_KIND(*datatype) == HANDLE_KIND_BUILTIN) { mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_TYPE, "**dtypeperm", 0); goto fn_fail; } /* all but MPI_2INT of the pair types are not stored as builtins * but should be treated similarly. */ if (*datatype == MPI_FLOAT_INT || *datatype == MPI_DOUBLE_INT || *datatype == MPI_LONG_INT || *datatype == MPI_SHORT_INT || *datatype == MPI_LONG_DOUBLE_INT) { mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_TYPE, "**dtypeperm", 0); goto fn_fail; } /* Validate parameters, especially handles needing to be converted */ 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 ... */ MPIR_Type_free_impl(datatype); /* ... end of body of routine ... */ #ifdef HAVE_ERROR_CHECKING fn_exit: #endif MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_FREE); MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); return mpi_errno; /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING fn_fail: { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_type_free", "**mpi_type_free %p", datatype); } mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno ); goto fn_exit; # endif /* --END ERROR HANDLING-- */ }
/*@ MPI_Unpack - Unpack a buffer according to a datatype into contiguous memory Input Parameters: + inbuf - input buffer start (choice) . insize - size of input buffer, in bytes (integer) . outcount - number of items to be unpacked (integer) . datatype - datatype of each output data item (handle) - comm - communicator for packed message (handle) Output Parameters: . outbuf - output buffer start (choice) Inout/Output Parameters: . position - current position in bytes (integer) .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_COMM .N MPI_ERR_COUNT .N MPI_ERR_TYPE .N MPI_ERR_ARG .seealso: MPI_Pack, MPI_Pack_size @*/ int MPI_Unpack(const void *inbuf, int insize, int *position, void *outbuf, int outcount, MPI_Datatype datatype, MPI_Comm comm) { int mpi_errno = MPI_SUCCESS; MPI_Aint position_x; MPIR_Comm *comm_ptr = NULL; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_UNPACK); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_UNPACK); /* Validate parameters, especially handles needing to be converted */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_COMM(comm, mpi_errno); } MPID_END_ERROR_CHECKS; } #endif /* Convert MPI object handles to object pointers */ MPIR_Comm_get_ptr(comm, comm_ptr); /* Validate parameters and objects (post conversion) */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { if (insize > 0) { MPIR_ERRTEST_ARGNULL(inbuf, "input buffer", mpi_errno); } /* Note: outbuf could be MPI_BOTTOM; don't test for NULL */ MPIR_ERRTEST_COUNT(insize, mpi_errno); MPIR_ERRTEST_COUNT(outcount, mpi_errno); /* Validate comm_ptr */ MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, FALSE); if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* If comm_ptr is not valid, it will be reset to null */ MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno); if (datatype != MPI_DATATYPE_NULL && HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) { 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); } if (mpi_errno != MPI_SUCCESS) goto fn_fail; } MPID_END_ERROR_CHECKS; } #endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ position_x = *position; mpi_errno = MPIR_Unpack_impl(inbuf, insize, &position_x, outbuf, outcount, datatype); if (mpi_errno) goto fn_fail; MPIR_Assign_trunc(*position, position_x, int); /* ... end of body of routine ... */ fn_exit: MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_UNPACK); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ #ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_unpack", "**mpi_unpack %p %d %p %p %d %D %C", inbuf, insize, position, outbuf, outcount, datatype, comm); } #endif mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Type_delete_attr - Deletes an attribute value associated with a key on a datatype Input Parameters: + datatype - MPI datatype to which attribute is attached (handle) - type_keyval - The key value of the deleted attribute (integer) .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_OTHER .N MPI_ERR_KEYVAL @*/ int MPI_Type_delete_attr(MPI_Datatype datatype, int type_keyval) { static const char FCNAME[] = "MPI_Type_delete_attr"; int mpi_errno = MPI_SUCCESS; MPIR_Datatype *type_ptr = NULL; MPIR_Attribute *p, **old_p; MPII_Keyval *keyval_ptr = 0; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_DELETE_ATTR); MPIR_ERRTEST_INITIALIZED_ORDIE(); /* The thread lock prevents a valid attr delete on the same datatype but in a different thread from causing problems */ MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TYPE_DELETE_ATTR); /* 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_KEYVAL(type_keyval, MPIR_DATATYPE, "datatype", mpi_errno); MPIR_ERRTEST_KEYVAL_PERM(type_keyval, mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* Validate parameters and objects (post conversion) */ MPID_Datatype_get_ptr( datatype, type_ptr ); MPII_Keyval_get_ptr( type_keyval, keyval_ptr ); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { /* Validate type_ptr */ MPIR_Datatype_valid_ptr( type_ptr, mpi_errno ); /* If type_ptr is not valid, it will be reset to null */ /* Validate keyval_ptr */ if (mpi_errno) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ /* Look for attribute. They are ordered by keyval handle */ old_p = &type_ptr->attributes; p = type_ptr->attributes; while (p) { if (p->keyval->handle == keyval_ptr->handle) { break; } old_p = &p->next; p = p->next; } /* We can't unlock yet, because we must not free the attribute until we know whether the delete function has returned with a 0 status code */ if (p) { /* Run the delete function, if any, and then free the attribute storage */ mpi_errno = MPIR_Call_attr_delete( datatype, p ); /* --BEGIN ERROR HANDLING-- */ if (!mpi_errno) { int in_use; /* We found the attribute. Remove it from the list */ *old_p = p->next; /* Decrement the use of the keyval */ MPII_Keyval_release_ref( p->keyval, &in_use); if (!in_use) { MPIR_Handle_obj_free( &MPII_Keyval_mem, p->keyval ); } MPID_Attr_free(p); } /* --END ERROR HANDLING-- */ } if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* ... end of body of routine ... */ fn_exit: MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_DELETE_ATTR); MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_type_delete_attr", "**mpi_type_delete_attr %D %d", datatype, type_keyval); } # endif mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Rsend_init - Creates a persistent request for a ready send Input Parameters: + buf - initial address of send buffer (choice) . count - number of elements sent (integer) . datatype - type of each 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_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_Request_free, MPI_Send_init @*/ int MPI_Rsend_init(const void *buf, int count, MPI_Datatype datatype, int dest, int tag, MPI_Comm comm, MPI_Request *request) { static const char FCNAME[] = "MPI_Rsend_init"; int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPID_Request *request_ptr = NULL; MPID_MPI_STATE_DECL(MPID_STATE_MPI_RSEND_INIT); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIU_THREAD_CS_ENTER(ALLFUNC,); MPID_MPI_PT2PT_FUNC_ENTER(MPID_STATE_MPI_RSEND_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 */ MPID_Comm_get_ptr( comm, comm_ptr ); /* Validate parameters if error checking is enabled */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPID_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); 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) { MPID_Datatype *datatype_ptr = NULL; MPID_Datatype_get_ptr(datatype, datatype_ptr); MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno) goto fn_fail; MPID_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_Rsend_init(buf, count, datatype, dest, tag, comm_ptr, MPID_CONTEXT_INTRA_PT2PT, &request_ptr); if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* return the handle of the request to the user */ MPIU_OBJ_PUBLISH_HANDLE(*request, request_ptr->handle); /* ... end of body of routine ... */ fn_exit: MPID_MPI_PT2PT_FUNC_EXIT(MPID_STATE_MPI_RSEND_INIT); MPIU_THREAD_CS_EXIT(ALLFUNC,); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_rsend_init", "**mpi_rsend_init %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_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; MPID_MPI_STATE_DECL(MPID_STATE_MPI_GET_ELEMENTS_X); MPIU_THREAD_CS_ENTER(ALLFUNC,); MPID_MPI_FUNC_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) { MPID_Datatype *datatype_ptr = NULL; MPID_Datatype_get_ptr(datatype, datatype_ptr); MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno); MPID_Datatype_committed_ptr(datatype_ptr, mpi_errno); } /* 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_Get_elements_x_impl(status, datatype, count); if (mpi_errno) MPIU_ERR_POP(mpi_errno); /* ... end of body of routine ... */ fn_exit: MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_GET_ELEMENTS_X); MPIU_THREAD_CS_EXIT(ALLFUNC,); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_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-- */ }
/*@ MPI_Type_lb - Returns the lower-bound of a datatype Input Parameters: . datatype - datatype (handle) Output Parameters: . displacement - displacement of lower bound from origin, in bytes (address integer) .N Deprecated The replacement for this routine is 'MPI_Type_Get_extent'. .N SignalSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_TYPE .N MPI_ERR_ARG @*/ int MPI_Type_lb(MPI_Datatype datatype, MPI_Aint * displacement) { int mpi_errno = MPI_SUCCESS; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_LB); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TYPE_LB); /* 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(displacement, "displacement", mpi_errno); } MPID_END_ERROR_CHECKS; } #endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ MPIR_Type_lb_impl(datatype, displacement); /* ... end of body of routine ... */ #ifdef HAVE_ERROR_CHECKING fn_exit: #endif MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_LB); return mpi_errno; /* --BEGIN ERROR HANDLING-- */ #ifdef HAVE_ERROR_CHECKING fn_fail: { mpi_errno = MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_OTHER, "**mpi_type_lb", "**mpi_type_lb %D %p", datatype, displacement); } mpi_errno = MPIR_Err_return_comm(NULL, __func__, mpi_errno); goto fn_exit; #endif /* --END ERROR HANDLING-- */ }
/*@ MPI_Type_get_name - Get the print name for a datatype Input Parameters: . datatype - datatype whose name is to be returned (handle) Output Parameters: + type_name - the name previously stored on the datatype, or a empty string if no such name exists (string) - resultlen - length of returned name (integer) .N ThreadSafeNoUpdate .N NULL .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_TYPE .N MPI_ERR_ARG @*/ int MPI_Type_get_name(MPI_Datatype datatype, char *type_name, int *resultlen) { static const char FCNAME[] = "MPI_Type_get_name"; int mpi_errno = MPI_SUCCESS; MPID_Datatype *datatype_ptr = NULL; static int setup = 0; MPID_MPI_STATE_DECL(MPID_STATE_MPI_TYPE_GET_NAME); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_TYPE_GET_NAME); /* 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 /* Note that MPI_DATATYPE_NULL is invalid input to this routine; it must not return a string for MPI_DATATYPE_NULL. Instead, it must return an error indicating an invalid datatype argument */ /* Convert MPI object handles to object pointers */ MPID_Datatype_get_ptr(datatype, datatype_ptr); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { /* Validate datatype_ptr */ MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno) goto fn_fail; /* If datatype_ptr is not valid, it will be reset to null */ MPIR_ERRTEST_ARGNULL(type_name,"type_name", mpi_errno); MPIR_ERRTEST_ARGNULL(resultlen,"resultlen", mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ /* If this is the first call, initialize all of the predefined names */ if (!setup) { mpi_errno = MPIR_Datatype_init_names(); if (mpi_errno != MPI_SUCCESS) goto fn_fail; setup = 1; } /* Include the null in MPI_MAX_OBJECT_NAME */ MPIU_Strncpy(type_name, datatype_ptr->name, MPI_MAX_OBJECT_NAME); *resultlen = (int) strlen(type_name); /* ... end of body of routine ... */ fn_exit: MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TYPE_GET_NAME); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_type_get_name", "**mpi_type_get_name %D %p %p", datatype, type_name, resultlen); } # endif mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Iscan - Computes the scan (partial reductions) of data on a collection of processes in a nonblocking way Input Parameters: + sendbuf - starting address of the send buffer (choice) . count - number of elements in input buffer (non-negative integer) . datatype - data type of elements of input buffer (handle) . op - operation (handle) - comm - communicator (handle) Output Parameters: + recvbuf - starting address of the receive buffer (choice) - request - communication request (handle) .N ThreadSafe .N Fortran .N Errors @*/ int MPI_Iscan(const void *sendbuf, void *recvbuf, int count, MPI_Datatype datatype, MPI_Op op, MPI_Comm comm, MPI_Request * request) { int mpi_errno = MPI_SUCCESS; MPIR_Comm *comm_ptr = NULL; MPIR_Request *request_ptr = NULL; MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_ISCAN); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_ISCAN); /* Validate parameters, especially handles needing to be converted */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno); MPIR_ERRTEST_COUNT(count, mpi_errno); MPIR_ERRTEST_OP(op, mpi_errno); MPIR_ERRTEST_COMM(comm, mpi_errno); /* TODO more checks may be appropriate */ } MPID_END_ERROR_CHECKS; } #endif /* HAVE_ERROR_CHECKING */ /* Convert MPI object handles to object pointers */ MPIR_Comm_get_ptr(comm, comm_ptr); /* Validate parameters and objects (post conversion) */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, FALSE); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPIR_ERRTEST_COMM_INTRA(comm_ptr, mpi_errno); if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) { MPIR_Datatype *datatype_ptr = NULL; MPIR_Datatype_get_ptr(datatype, datatype_ptr); MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPIR_Datatype_committed_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } if (HANDLE_GET_KIND(op) != HANDLE_KIND_BUILTIN) { MPIR_Op *op_ptr = NULL; MPIR_Op_get_ptr(op, op_ptr); MPIR_Op_valid_ptr(op_ptr, mpi_errno); } else if (HANDLE_GET_KIND(op) == HANDLE_KIND_BUILTIN) { mpi_errno = (*MPIR_OP_HDL_TO_DTYPE_FN(op)) (datatype); } if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPIR_ERRTEST_ARGNULL(request, "request", mpi_errno); if (sendbuf != MPI_IN_PLACE && count != 0) MPIR_ERRTEST_ALIAS_COLL(sendbuf, recvbuf, mpi_errno); /* TODO more checks may be appropriate (counts, in_place, etc) */ } MPID_END_ERROR_CHECKS; } #endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Iscan(sendbuf, recvbuf, count, datatype, op, comm_ptr, &request_ptr); if (mpi_errno) MPIR_ERR_POP(mpi_errno); /* create a complete request, if needed */ if (!request_ptr) request_ptr = MPIR_Request_create_complete(MPIR_REQUEST_KIND__COLL); /* return the handle of the request to the user */ *request = request_ptr->handle; /* ... end of body of routine ... */ fn_exit: MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_ISCAN); MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ #ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_OTHER, "**mpi_iscan", "**mpi_iscan %p %p %d %D %O %C %p", sendbuf, recvbuf, count, datatype, op, comm, request); } #endif mpi_errno = MPIR_Err_return_comm(comm_ptr, __func__, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ 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) { 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, __func__, __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, __func__, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Iscatterv - Scatters a buffer in parts to all processes in a communicator in a nonblocking way Input Parameters: + sendbuf - address of send buffer (significant only at root) (choice) . sendcounts - non-negative integer array (of length group size) specifying the number of elements to send to each processor (significant only at root) . displs - integer array (of length group size). Entry i specifies the displacement (relative to sendbuf) from which to take the outgoing data to process i (significant only at root) . sendtype - data type of send buffer elements (significant only at root) (handle) . recvcount - number of elements in receive buffer (non-negative integer) . recvtype - data type of receive buffer elements (handle) . root - rank of sending process (integer) - 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_Iscatterv(const void *sendbuf, const int sendcounts[], const int displs[], 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_ISCATTERV); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_ISCATTERV); /* Validate parameters, especially handles needing to be converted */ #ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_DATATYPE(sendtype, "sendtype", mpi_errno); if (recvbuf != MPI_IN_PLACE) 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_Datatype *sendtype_ptr = NULL, *recvtype_ptr = NULL; int i, comm_size, 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); rank = comm_ptr->rank; comm_size = comm_ptr->local_size; if (rank == root) { for (i = 0; i < comm_size; i++) { MPIR_ERRTEST_COUNT(sendcounts[i], 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; } for (i = 0; i < comm_size; i++) { if (sendcounts[i] > 0) { MPIR_ERRTEST_USERBUFFER(sendbuf, sendcounts[i], sendtype, mpi_errno); break; } } for (i = 0; i < comm_size; i++) { if (sendcounts[i] > 0) { MPIR_ERRTEST_SENDBUF_INPLACE(sendbuf, sendcounts[i], mpi_errno); break; } } /* catch common aliasing cases */ if (recvbuf != MPI_IN_PLACE && sendtype == recvtype && sendcounts[comm_ptr->rank] != 0 && recvcount != 0) { int sendtype_size; MPIR_Datatype_get_size_macro(sendtype, sendtype_size); MPIR_ERRTEST_ALIAS_COLL(recvbuf, (char *) sendbuf + displs[comm_ptr->rank] * sendtype_size, mpi_errno); } } else MPIR_ERRTEST_RECVBUF_INPLACE(recvbuf, recvcount, mpi_errno); if (recvbuf != MPI_IN_PLACE) { 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_USERBUFFER(recvbuf, recvcount, recvtype, 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(sendcounts[i], 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; } for (i = 0; i < comm_size; i++) { if (sendcounts[i] > 0) { MPIR_ERRTEST_SENDBUF_INPLACE(sendbuf, sendcounts[i], mpi_errno); MPIR_ERRTEST_USERBUFFER(sendbuf, sendcounts[i], sendtype, mpi_errno); break; } } } else if (root != MPI_PROC_NULL) { 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); } } } MPID_END_ERROR_CHECKS; } #endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Iscatterv(sendbuf, sendcounts, displs, 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_ISCATTERV); 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_iscatterv", "**mpi_iscatterv %p %p %p %D %p %d %D %d %C %p", sendbuf, sendcounts, displs, sendtype, recvbuf, recvcount, recvtype, root, comm, request); } #endif mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Type_commit - Commits the datatype Input Parameters: . datatype - datatype (handle) .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_TYPE @*/ int MPI_Type_commit(MPI_Datatype *datatype) { int mpi_errno = MPI_SUCCESS; MPID_Datatype *datatype_ptr = NULL; MPID_MPI_STATE_DECL(MPID_STATE_MPI_TYPE_COMMIT); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIU_THREAD_CS_ENTER(ALLFUNC,); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_TYPE_COMMIT); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_ARGNULL(datatype, "datatype", mpi_errno); MPIR_ERRTEST_DATATYPE(*datatype, "datatype", mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* Convert MPI object handles to object pointers */ MPID_Datatype_get_ptr( *datatype, datatype_ptr ); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { /* Validate datatype_ptr */ MPID_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_commit_impl(datatype); if (mpi_errno) MPIU_ERR_POP(mpi_errno); /* ... end of body of routine ... */ fn_exit: MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TYPE_COMMIT); MPIU_THREAD_CS_EXIT(ALLFUNC,); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_type_commit", "**mpi_type_commit %p", datatype); } # endif mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Accumulate - Accumulate data into the target process using remote memory access Input Parameters: + origin_addr - initial address of buffer (choice) . origin_count - number of entries in buffer (nonnegative integer) . origin_datatype - datatype of each buffer entry (handle) . target_rank - rank of target (nonnegative integer) . target_disp - displacement from start of window to beginning of target buffer (nonnegative integer) . target_count - number of entries in target buffer (nonnegative integer) . target_datatype - datatype of each entry in target buffer (handle) . op - predefined reduce operation (handle) - win - window object (handle) Notes: The basic components of both the origin and target datatype must be the same predefined datatype (e.g., all 'MPI_INT' or all 'MPI_DOUBLE_PRECISION'). .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_Raccumulate @*/ int MPI_Accumulate(const 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_Op op, MPI_Win win) { static const char FCNAME[] = "MPI_Accumulate"; int mpi_errno = MPI_SUCCESS; MPID_Win *win_ptr = NULL; MPID_MPI_STATE_DECL(MPID_STATE_MPI_ACCUMULATE); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPID_MPI_RMA_FUNC_ENTER(MPID_STATE_MPI_ACCUMULATE); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_WIN(win, mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* Convert MPI object handles to object pointers */ MPID_Win_get_ptr( win, win_ptr ); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPID_Comm * comm_ptr; /* Validate win_ptr */ MPID_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) { MPID_Datatype *datatype_ptr = NULL; MPID_Datatype_get_ptr(origin_datatype, datatype_ptr); MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPID_Datatype_committed_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } if (HANDLE_GET_KIND(target_datatype) != HANDLE_KIND_BUILTIN) { MPID_Datatype *datatype_ptr = NULL; MPID_Datatype_get_ptr(target_datatype, datatype_ptr); MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPID_Datatype_committed_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } comm_ptr = win_ptr->comm_ptr; MPIR_ERRTEST_SEND_RANK(comm_ptr, target_rank, mpi_errno); MPIR_ERRTEST_OP_ACC(op, mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPID_Accumulate(origin_addr, origin_count, origin_datatype, target_rank, target_disp, target_count, target_datatype, op, win_ptr); if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* ... end of body of routine ... */ fn_exit: MPID_MPI_RMA_FUNC_EXIT(MPID_STATE_MPI_ACCUMULATE); 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_accumulate", "**mpi_accumulate %p %d %D %d %d %d %D %O %W", origin_addr, origin_count, origin_datatype, target_rank, target_disp, target_count, target_datatype, op, win); } # endif mpi_errno = MPIR_Err_return_win( win_ptr, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Type_indexed - Creates an indexed datatype Input Parameters: + count - number of blocks -- also number of entries in array_of_displacements and array_of_blocklengths . array_of_blocklengths - number of elements in each block (array of nonnegative integers) . array_of_displacements - displacement of each block in multiples of oldtype (array of integers) - oldtype - old datatype (handle) Output Parameters: . newtype - new datatype (handle) .N ThreadSafe .N Fortran The array_of_displacements are displacements, and are based on a zero origin. A common error is to do something like to following .vb integer a(100) integer array_of_blocklengths(10), array_of_displacements(10) do i=1,10 array_of_blocklengths(i) = 1 10 array_of_displacements(i) = 1 + (i-1)*10 call MPI_TYPE_INDEXED(10,array_of_blocklengths,array_of_displacements,MPI_INTEGER,newtype,ierr) call MPI_TYPE_COMMIT(newtype,ierr) call MPI_SEND(a,1,newtype,...) .ve expecting this to send "a(1),a(11),..." because the array_of_displacements have values "1,11,...". Because these are `displacements` from the beginning of "a", it actually sends "a(1+1),a(1+11),...". If you wish to consider the displacements as array_of_displacements into a Fortran array, consider declaring the Fortran array with a zero origin .vb integer a(0:99) .ve .N Errors .N MPI_ERR_COUNT .N MPI_ERR_TYPE .N MPI_ERR_ARG .N MPI_ERR_EXHAUSTED @*/ int MPI_Type_indexed(int count, const int *array_of_blocklengths, const int *array_of_displacements, MPI_Datatype oldtype, MPI_Datatype *newtype) { int mpi_errno = MPI_SUCCESS; MPID_MPI_STATE_DECL(MPID_STATE_MPI_TYPE_INDEXED); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIU_THREAD_CS_ENTER(ALLFUNC,); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_TYPE_INDEXED); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { int j; MPID_Datatype *datatype_ptr = NULL; MPIR_ERRTEST_COUNT(count,mpi_errno); if (count > 0) { MPIR_ERRTEST_ARGNULL(array_of_blocklengths, "array_of_blocklengths", mpi_errno); MPIR_ERRTEST_ARGNULL(array_of_displacements, "array_of_displacements", mpi_errno); } MPIR_ERRTEST_DATATYPE(oldtype, "datatype", mpi_errno); if (HANDLE_GET_KIND(oldtype) != HANDLE_KIND_BUILTIN) { MPID_Datatype_get_ptr( oldtype, datatype_ptr ); MPID_Datatype_valid_ptr( datatype_ptr, mpi_errno ); } /* verify that all blocklengths are >= 0 */ for (j=0; j < count; j++) { MPIR_ERRTEST_ARGNEG(array_of_blocklengths[j], "blocklength", mpi_errno); } MPIR_ERRTEST_ARGNULL(newtype, "newtype", mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Type_indexed_impl(count, array_of_blocklengths, array_of_displacements, oldtype, newtype); if (mpi_errno) goto fn_fail; /* ... end of body of routine ... */ fn_exit: MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TYPE_INDEXED); MPIU_THREAD_CS_EXIT(ALLFUNC,); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_type_indexed", "**mpi_type_indexed %d %p %p %D %p", count,array_of_blocklengths, array_of_displacements, oldtype, newtype); } # endif mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Type_ub - Returns the upper bound of a datatype Input Parameters: . datatype - datatype (handle) Output Parameter: . displacement - displacement of upper bound from origin, in bytes (address integer) .N Deprecated The replacement for this routine is 'MPI_Type_get_extent' .N SignalSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_TYPE .N MPI_ERR_ARG @*/ int MPI_Type_ub(MPI_Datatype datatype, MPI_Aint *displacement) { int mpi_errno = MPI_SUCCESS; MPID_Datatype *datatype_ptr = NULL; MPID_MPI_STATE_DECL(MPID_STATE_MPI_TYPE_UB); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_TYPE_UB); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* Convert MPI object handles to object pointers */ MPID_Datatype_get_ptr(datatype, datatype_ptr); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { /* Validate datatype_ptr */ MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ if (HANDLE_GET_KIND(datatype) == HANDLE_KIND_BUILTIN) *displacement = MPID_Datatype_get_basic_size(datatype); else *displacement = datatype_ptr->ub; /* ... end of body of routine ... */ #ifdef HAVE_ERROR_CHECKING fn_exit: #endif MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TYPE_UB); 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_ub", "**mpi_type_ub %D %p", datatype, displacement); } mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno); goto fn_exit; # endif /* --END ERROR HANDLING-- */ }
/*@ MPI_Type_struct - Creates a struct datatype Input Parameters: + count - number of blocks (integer) -- also number of entries in arrays array_of_types , array_of_displacements and array_of_blocklengths . array_of_blocklengths - number of elements in each block (array) . array_of_displacements - byte displacement of each block (array) - array_of_types - type of elements in each block (array of handles to datatype objects) Output Parameters: . newtype - new datatype (handle) .N Deprecated The replacement for this routine is 'MPI_Type_create_struct' Notes: If an upperbound is set explicitly by using the MPI datatype 'MPI_UB', the corresponding index must be positive. The MPI standard originally made vague statements about padding and alignment; this was intended to allow the simple definition of structures that could be sent with a count greater than one. For example, .vb struct { int a; char b; } foo; .ve may have 'sizeof(foo) > sizeof(int) + sizeof(char)'; for example, 'sizeof(foo) == 2*sizeof(int)'. The initial version of the MPI standard defined the extent of a datatype as including an `epsilon` that would have allowed an implementation to make the extent an MPI datatype for this structure equal to '2*sizeof(int)'. However, since different systems might define different paddings, there was much discussion by the MPI Forum about what was the correct value of epsilon, and one suggestion was to define epsilon as zero. This would have been the best thing to do in MPI 1.0, particularly since the 'MPI_UB' type allows the user to easily set the end of the structure. Unfortunately, this change did not make it into the final document. Currently, this routine does not add any padding, since the amount of padding needed is determined by the compiler that the user is using to build their code, not the compiler used to construct the MPI library. A later version of MPICH may provide for some natural choices of padding (e.g., multiple of the size of the largest basic member), but users are advised to never depend on this, even with vendor MPI implementations. Instead, if you define a structure datatype and wish to send or receive multiple items, you should explicitly include an 'MPI_UB' entry as the last member of the structure. For example, the following code can be used for the structure foo .vb blen[0] = 1; array_of_displacements[0] = 0; oldtypes[0] = MPI_INT; blen[1] = 1; array_of_displacements[1] = &foo.b - &foo; oldtypes[1] = MPI_CHAR; blen[2] = 1; array_of_displacements[2] = sizeof(foo); oldtypes[2] = MPI_UB; MPI_Type_struct( 3, blen, array_of_displacements, oldtypes, &newtype ); .ve .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_TYPE .N MPI_ERR_COUNT .N MPI_ERR_EXHAUSTED @*/ int MPI_Type_struct(int count, const int *array_of_blocklengths, const MPI_Aint *array_of_displacements, const MPI_Datatype *array_of_types, MPI_Datatype *newtype) { int mpi_errno = MPI_SUCCESS; MPID_MPI_STATE_DECL(MPID_STATE_MPI_TYPE_STRUCT); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_TYPE_STRUCT); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { int i; MPID_Datatype *datatype_ptr; 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_ARGNULL(array_of_types, "array_of_types", mpi_errno); } for (i=0; i < count; i++) { MPIR_ERRTEST_ARGNEG(array_of_blocklengths[i], "blocklength", mpi_errno); MPIR_ERRTEST_DATATYPE(array_of_types[i], "datatype[i]", mpi_errno); if (array_of_types[i] != MPI_DATATYPE_NULL && HANDLE_GET_KIND(array_of_types[i]) != HANDLE_KIND_BUILTIN) { MPID_Datatype_get_ptr(array_of_types[i], datatype_ptr); MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno); } } if (mpi_errno != MPI_SUCCESS) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Type_struct_impl(count, array_of_blocklengths, array_of_displacements, array_of_types, newtype); if (mpi_errno) goto fn_fail; /* ... end of body of routine ... */ fn_exit: MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TYPE_STRUCT); 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_struct", "**mpi_type_struct %d %p %p %p %p", count, array_of_blocklengths, array_of_displacements, array_of_types, newtype); } # endif mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }