int free_2level_comm (MPID_Comm* comm_ptr) { MPID_Comm *shmem_comm_ptr=NULL; MPID_Comm *leader_comm_ptr=NULL; MPID_Comm *allgather_comm_ptr=NULL; int local_rank=0; int mpi_errno=MPI_SUCCESS; if (comm_ptr->ch.leader_map != NULL) { MPIU_Free(comm_ptr->ch.leader_map); } if (comm_ptr->ch.leader_rank != NULL) { MPIU_Free(comm_ptr->ch.leader_rank); } MPID_Comm_get_ptr((comm_ptr->ch.shmem_comm), shmem_comm_ptr ); MPID_Comm_get_ptr((comm_ptr->ch.leader_comm), leader_comm_ptr ); if(comm_ptr->ch.allgather_comm_ok == 1) { MPID_Comm_get_ptr((comm_ptr->ch.allgather_comm), allgather_comm_ptr ); MPIU_Free(comm_ptr->ch.allgather_new_ranks); } local_rank = shmem_comm_ptr->rank; if(local_rank == 0) { if(comm_ptr->ch.node_sizes != NULL) { MPIU_Free(comm_ptr->ch.node_sizes); } } if (local_rank == 0 && leader_comm_ptr != NULL) { mpi_errno = MPIR_Comm_release(leader_comm_ptr, 0); if (mpi_errno != MPI_SUCCESS) { goto fn_fail; } } if (shmem_comm_ptr != NULL) { mpi_errno = MPIR_Comm_release(shmem_comm_ptr, 0); if (mpi_errno != MPI_SUCCESS) { goto fn_fail; } } if (allgather_comm_ptr != NULL) { mpi_errno = MPIR_Comm_release(allgather_comm_ptr, 0); if (mpi_errno != MPI_SUCCESS) { goto fn_fail; } } clear_2level_comm(comm_ptr); fn_exit: return mpi_errno; fn_fail: goto fn_exit; }
int MPIDO_Barrier_gi(MPID_Comm * comm) { int rc; MPID_Comm * comm_world; MPID_Comm_get_ptr(MPI_COMM_WORLD, comm_world); DCMF_Callback_t callback = { barrier_cb_done, (void *) &mpid_globalbarrier_active }; /* initialize global active field */ mpid_globalbarrier_active = 1; if (mpid_globalbarrier_restart) rc = DCMF_Restart (&mpid_globalbarrier_request); else { mpid_globalbarrier_restart = 1; rc = DCMF_GlobalBarrier(&MPIDI_Protocols.globalbarrier, &mpid_globalbarrier_request, callback); } if (rc == DCMF_SUCCESS) MPID_PROGRESS_WAIT_WHILE(* (int *) callback.clientdata); return rc; }
int MPIC_Send(void *buf, int count, MPI_Datatype datatype, int dest, int tag, MPI_Comm comm) { int mpi_errno, context_id; MPID_Request *request_ptr=NULL; MPID_Comm *comm_ptr=NULL; MPIDI_STATE_DECL(MPID_STATE_MPIC_SEND); MPIDI_PT2PT_FUNC_ENTER_FRONT(MPID_STATE_MPIC_SEND); MPID_Comm_get_ptr( comm, comm_ptr ); context_id = (comm_ptr->comm_kind == MPID_INTRACOMM) ? MPID_CONTEXT_INTRA_COLL : MPID_CONTEXT_INTER_COLL; mpi_errno = MPID_Send(buf, count, datatype, dest, tag, comm_ptr, context_id, &request_ptr); if (mpi_errno) { MPIU_ERR_POP(mpi_errno); } if (request_ptr) { mpi_errno = MPIC_Wait(request_ptr); if (mpi_errno) { MPIU_ERR_POP(mpi_errno); } MPID_Request_release(request_ptr); } fn_exit: MPIDI_PT2PT_FUNC_EXIT(MPID_STATE_MPIC_SEND); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ if (request_ptr) { MPID_Request_release(request_ptr); } goto fn_exit; /* --END ERROR HANDLING-- */ }
int MPIC_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_Context_id_t context_id_offset; MPID_Request *sreq; MPID_Request *rreq; void *tmpbuf = NULL; int tmpbuf_size = 0; int tmpbuf_count = 0; MPID_Comm *comm_ptr; MPIU_CHKLMEM_DECL(1); MPIDI_STATE_DECL(MPID_STATE_MPIC_SENDRECV_REPLACE); #ifdef MPID_LOG_ARROWS /* The logging macros log sendcount and recvcount */ int sendcount = count, recvcount = count; #endif MPIDI_PT2PT_FUNC_ENTER_BOTH(MPID_STATE_MPIC_SENDRECV_REPLACE); MPID_Comm_get_ptr( comm, comm_ptr ); context_id_offset = (comm_ptr->comm_kind == MPID_INTRACOMM) ? MPID_CONTEXT_INTRA_COLL : MPID_CONTEXT_INTER_COLL; if (count > 0 && dest != MPI_PROC_NULL) { MPIR_Pack_size_impl(count, datatype, &tmpbuf_size); MPIU_CHKLMEM_MALLOC(tmpbuf, void *, tmpbuf_size, mpi_errno, "temporary send buffer"); mpi_errno = MPIR_Pack_impl(buf, count, datatype, tmpbuf, tmpbuf_size, &tmpbuf_count); if (mpi_errno) MPIU_ERR_POP(mpi_errno); }
int MPIDI_CH3U_Win_allocate_shared(MPI_Aint size, int disp_unit, MPID_Info *info, MPID_Comm *comm_ptr, void **base_ptr, MPID_Win **win_ptr) { int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_self_ptr = NULL; MPID_Group *group_comm, *group_self; int result; MPIU_CHKPMEM_DECL(1); MPIDI_STATE_DECL(MPID_STATE_MPIDI_CH3U_WIN_ALLOCATE_SHARED); MPIDI_RMA_FUNC_ENTER(MPID_STATE_MPIDI_CH3U_WIN_ALLOCATE_SHARED); #ifdef HAVE_ERROR_CHECKING /* The baseline CH3 implementation only works with MPI_COMM_SELF */ MPID_Comm_get_ptr( MPI_COMM_SELF, comm_self_ptr ); mpi_errno = MPIR_Comm_group_impl(comm_ptr, &group_comm); if (mpi_errno) MPIU_ERR_POP(mpi_errno); mpi_errno = MPIR_Comm_group_impl(comm_self_ptr, &group_self); if (mpi_errno) MPIU_ERR_POP(mpi_errno); mpi_errno = MPIR_Group_compare_impl(group_comm, group_self, &result); if (mpi_errno) MPIU_ERR_POP(mpi_errno); mpi_errno = MPIR_Group_free_impl(group_comm); if (mpi_errno) MPIU_ERR_POP(mpi_errno); mpi_errno = MPIR_Group_free_impl(group_self); if (mpi_errno) MPIU_ERR_POP(mpi_errno); if (result != MPI_IDENT) { MPIU_ERR_SETANDJUMP(mpi_errno, MPI_ERR_RMA_SHARED, "**ch3|win_shared_comm"); } #endif mpi_errno = MPIDI_CH3U_Win_allocate(size, disp_unit, info, comm_ptr, base_ptr, win_ptr); if (mpi_errno) MPIU_ERR_POP(mpi_errno); MPIU_CHKPMEM_MALLOC((*win_ptr)->shm_base_addrs, void **, 1 /* comm_size */ * sizeof(void *), mpi_errno, "(*win_ptr)->shm_base_addrs"); (*win_ptr)->shm_base_addrs[0] = *base_ptr; /* Register the shared memory window free function, which will free the memory allocated here. */ (*win_ptr)->RMAFns.Win_free = MPIDI_SHM_Win_free; fn_exit: MPIDI_RMA_FUNC_EXIT(MPID_STATE_MPIDI_CH3U_WIN_ALLOCATE_SHARED); return mpi_errno; /* --BEGIN ERROR HANDLING-- */ fn_fail: MPIU_CHKPMEM_REAP(); goto fn_exit; /* --END ERROR HANDLING-- */ }
int MPIC_Probe(int source, int tag, MPI_Comm comm, MPI_Status *status) { int mpi_errno = MPI_SUCCESS; int context_id; MPID_Comm *comm_ptr; MPID_Comm_get_ptr( comm, comm_ptr ); context_id = (comm_ptr->comm_kind == MPID_INTRACOMM) ? MPID_CONTEXT_INTRA_COLL : MPID_CONTEXT_INTER_COLL; mpi_errno = MPID_Probe(source, tag, comm_ptr, context_id, status); if (mpi_errno != MPI_SUCCESS) goto fn_fail; fn_exit: return mpi_errno; fn_fail: goto fn_exit; }
int check_comm_registry(MPI_Comm comm) { MPID_Comm* comm_ptr; MPIU_THREADPRIV_DECL; MPIU_THREADPRIV_GET; MPID_Comm_get_ptr( comm, comm_ptr ); int context_id = 0, i =0, my_rank, size; context_id = comm_ptr->context_id; PMPI_Comm_rank(comm, &my_rank); PMPI_Comm_size(comm, &size); for (i = 0; i < comm_registered; i++){ if (comm_registry[i] == context_id){ return 1; } } return 0; }
int MPIC_Recv(void *buf, int count, MPI_Datatype datatype, int source, int tag, MPI_Comm comm, MPI_Status *status) { int mpi_errno, context_id; MPID_Request *request_ptr=NULL; MPID_Comm *comm_ptr = NULL; MPIDI_STATE_DECL(MPID_STATE_MPIC_RECV); MPIDI_PT2PT_FUNC_ENTER_BACK(MPID_STATE_MPIC_RECV); MPID_Comm_get_ptr( comm, comm_ptr ); context_id = (comm_ptr->comm_kind == MPID_INTRACOMM) ? MPID_CONTEXT_INTRA_COLL : MPID_CONTEXT_INTER_COLL; mpi_errno = MPID_Recv(buf, count, datatype, source, tag, comm_ptr, context_id, status, &request_ptr); if (mpi_errno) { MPIU_ERR_POP(mpi_errno); } if (request_ptr) { mpi_errno = MPIC_Wait(request_ptr); if (mpi_errno == MPI_SUCCESS) { if (status != MPI_STATUS_IGNORE) { *status = request_ptr->status; } mpi_errno = request_ptr->status.MPI_ERROR; } else { MPIU_ERR_POP(mpi_errno); } MPID_Request_release(request_ptr); } fn_exit: MPIDI_PT2PT_FUNC_EXIT_BACK(MPID_STATE_MPIC_RECV); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ if (request_ptr) { MPID_Request_release(request_ptr); } goto fn_exit; /* --END ERROR HANDLING-- */ }
int MPIC_Sendrecv(void *sendbuf, int sendcount, MPI_Datatype sendtype, int dest, int sendtag, void *recvbuf, int recvcount, MPI_Datatype recvtype, int source, int recvtag, MPI_Comm comm, MPI_Status *status) { MPID_Request *recv_req_ptr=NULL, *send_req_ptr=NULL; int mpi_errno, context_id; MPID_Comm *comm_ptr = NULL; MPIDI_STATE_DECL(MPID_STATE_MPIC_SENDRECV); MPIDI_PT2PT_FUNC_ENTER_BOTH(MPID_STATE_MPIC_SENDRECV); MPID_Comm_get_ptr( comm, comm_ptr ); context_id = (comm_ptr->comm_kind == MPID_INTRACOMM) ? MPID_CONTEXT_INTRA_COLL : MPID_CONTEXT_INTER_COLL; mpi_errno = MPID_Irecv(recvbuf, recvcount, recvtype, source, recvtag, comm_ptr, context_id, &recv_req_ptr); if (mpi_errno) { MPIU_ERR_POP(mpi_errno); } mpi_errno = MPID_Isend(sendbuf, sendcount, sendtype, dest, sendtag, comm_ptr, context_id, &send_req_ptr); if (mpi_errno) { MPIU_ERR_POP(mpi_errno); } mpi_errno = MPIC_Wait(send_req_ptr); if (mpi_errno) { MPIU_ERR_POP(mpi_errno); } mpi_errno = MPIC_Wait(recv_req_ptr); if (mpi_errno) { MPIU_ERR_POPFATAL(mpi_errno); } if (status != MPI_STATUS_IGNORE) *status = recv_req_ptr->status; mpi_errno = recv_req_ptr->status.MPI_ERROR; MPID_Request_release(send_req_ptr); MPID_Request_release(recv_req_ptr); fn_fail: /* --BEGIN ERROR HANDLING-- */ MPIDI_PT2PT_FUNC_EXIT_BOTH(MPID_STATE_MPIC_SENDRECV); return mpi_errno; /* --END ERROR HANDLING-- */ }
pami_result_t MPIDI_Comm_create_from_pami_geom(pami_geometry_range_t *task_slices, size_t slice_count, pami_geometry_t *geometry, void **cookie) { int mpi_errno = MPI_SUCCESS; int num_tasks = 0; int *ranks = NULL; MPID_Comm *comm_ptr = NULL, *new_comm_ptr = NULL; MPID_Group *group_ptr = NULL, *new_group_ptr = NULL; int i = 0, j = 0; /* Get comm_ptr for MPI_COMM_WORLD and get the group_ptr for it */ MPID_Comm_get_ptr( MPI_COMM_WORLD, comm_ptr ); mpi_errno = MPIR_Comm_group_impl(comm_ptr, &group_ptr); if (mpi_errno) { TRACE_ERR("Error while creating group_ptr from MPI_COMM_WORLD in MPIDI_Comm_create_from_pami_geom\n"); return PAMI_ERROR; } /* Create the ranks list from the pami_geometry_range_t array */ for(i = 0; i < slice_count; i++) { num_tasks += (task_slices[i].hi - task_slices[i].lo) + 1; } ranks = MPIU_Calloc0(num_tasks, int); for(i = 0; i < slice_count; i++) { int slice_sz = (task_slices[i].hi - task_slices[i].lo) + 1; int k = 0; for(k = 0; k < slice_sz; k++) { ranks[j] = task_slices[i].lo + k; j++; } } /* Now we have all we need to create the new group. Create it */ mpi_errno = MPIR_Group_incl_impl(group_ptr, num_tasks, ranks, &new_group_ptr); if (mpi_errno) { TRACE_ERR("Error while creating new_group_ptr from group_ptr in MPIDI_Comm_create_from_pami_geom\n"); return PAMI_ERROR; } /* Now create the communicator using the new_group_ptr */ mpi_errno = MPIR_Comm_create_intra(comm_ptr, new_group_ptr, &new_comm_ptr); if (mpi_errno) { TRACE_ERR("Error while creating new_comm_ptr from group_ptr in MPIDI_Comm_create_from_pami_geom\n"); return PAMI_ERROR; } if(new_comm_ptr) { /* Get the geometry from the communicator and set the out parameters */ *geometry = new_comm_ptr->mpid.geometry; *cookie = new_comm_ptr; } else { *geometry = PAMI_GEOMETRY_NULL; *cookie = NULL; } /* Cleanup */ MPIU_TestFree(&ranks); return PAMI_SUCCESS; }
/*@ MPI_Iprobe - Nonblocking test for a message Input Parameters: + source - source rank, or 'MPI_ANY_SOURCE' (integer) . tag - tag value or 'MPI_ANY_TAG' (integer) - comm - communicator (handle) Output Parameters: + flag - True if a message with the specified source, tag, and communicator is available (logical) - status - status object (Status) .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_COMM .N MPI_ERR_TAG .N MPI_ERR_RANK @*/ int MPI_Iprobe(int source, int tag, MPI_Comm comm, int *flag, MPI_Status *status) { static const char FCNAME[] = "MPI_Iprobe"; int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPID_MPI_STATE_DECL(MPID_STATE_MPI_IPROBE); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIU_THREAD_CS_ENTER(ALLFUNC,); MPID_MPI_PT2PT_FUNC_ENTER(MPID_STATE_MPI_IPROBE); /* 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; { /* Validate communicator */ MPID_Comm_valid_ptr( comm_ptr, mpi_errno ); if (mpi_errno) goto fn_fail; MPIR_ERRTEST_ARGNULL( flag, "flag", mpi_errno ); MPIR_ERRTEST_RECV_TAG(tag,mpi_errno); if (comm_ptr) { MPIR_ERRTEST_RECV_RANK(comm_ptr, source, mpi_errno); } } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ /* FIXME: Is this correct for intercomms? */ mpi_errno = MPID_Iprobe(source, tag, comm_ptr, MPID_CONTEXT_INTRA_PT2PT, flag, status); if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* ... end of body of routine ... */ fn_exit: MPID_MPI_PT2PT_FUNC_EXIT(MPID_STATE_MPI_IPROBE); 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_iprobe", "**mpi_iprobe %i %t %C %p %p", source, tag, comm, flag, status); } # endif mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Igatherv - XXX description here Input Parameters: + sendbuf - starting address of the send buffer (choice) . sendcount - number of elements in send buffer (non-negative integer) . sendtype - data type of send buffer elements (handle) . recvcounts - non-negative integer array (of length group size) containing the number of elements that are received from each process (significant only at root) . displs - integer array (of length group size). Entry i specifies the displacement relative to recvbuf at which to place the incoming data from process i (significant only at root) . recvtype - data type of receive buffer elements (significant only at root) (handle) . root - rank of receiving process (integer) - comm - communicator (handle) Output Parameters: + recvbuf - starting address of the receive buffer (significant only at root) (choice) - request - communication request (handle) .N ThreadSafe .N Fortran .N Errors @*/ int MPI_Igatherv(const void *sendbuf, int sendcount, MPI_Datatype sendtype, void *recvbuf, const int recvcounts[], const int displs[], MPI_Datatype recvtype, int root, MPI_Comm comm, MPI_Request *request) { int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPID_MPI_STATE_DECL(MPID_STATE_MPI_IGATHERV); MPIU_THREAD_CS_ENTER(ALLFUNC,); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_IGATHERV); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS { MPIR_ERRTEST_COMM(comm, mpi_errno); /* TODO more checks may be appropriate */ } MPID_END_ERROR_CHECKS } # endif /* HAVE_ERROR_CHECKING */ /* Convert MPI object handles to object pointers */ 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, rank, comm_size; MPID_Comm_valid_ptr( comm_ptr, mpi_errno ); if (mpi_errno != MPI_SUCCESS) goto fn_fail; if (comm_ptr->comm_kind == MPID_INTRACOMM) { MPIR_ERRTEST_INTRA_ROOT(comm_ptr, root, mpi_errno); if (sendbuf != MPI_IN_PLACE) { MPIR_ERRTEST_COUNT(sendcount, mpi_errno); MPIR_ERRTEST_DATATYPE(sendtype, "sendtype", mpi_errno); if (HANDLE_GET_KIND(sendtype) != HANDLE_KIND_BUILTIN) { MPID_Datatype_get_ptr(sendtype, 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_USERBUFFER(sendbuf,sendcount,sendtype,mpi_errno); } rank = comm_ptr->rank; if (rank == root) { comm_size = comm_ptr->local_size; for (i=0; i<comm_size; i++) { MPIR_ERRTEST_COUNT(recvcounts[i], mpi_errno); MPIR_ERRTEST_DATATYPE(recvtype, "recvtype", mpi_errno); } if (HANDLE_GET_KIND(recvtype) != HANDLE_KIND_BUILTIN) { MPID_Datatype_get_ptr(recvtype, 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; i++) { if (recvcounts[i] > 0) { MPIR_ERRTEST_RECVBUF_INPLACE(recvbuf, recvcounts[i], mpi_errno); MPIR_ERRTEST_USERBUFFER(recvbuf,recvcounts[i],recvtype,mpi_errno); break; } } } else MPIR_ERRTEST_SENDBUF_INPLACE(sendbuf, sendcount, mpi_errno); } if (comm_ptr->comm_kind == MPID_INTERCOMM) { MPIR_ERRTEST_INTER_ROOT(comm_ptr, root, mpi_errno); if (root == MPI_ROOT) { comm_size = comm_ptr->remote_size; for (i=0; i<comm_size; i++) { MPIR_ERRTEST_COUNT(recvcounts[i], mpi_errno); MPIR_ERRTEST_DATATYPE(recvtype, "recvtype", mpi_errno); } if (HANDLE_GET_KIND(recvtype) != HANDLE_KIND_BUILTIN) { MPID_Datatype_get_ptr(recvtype, 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; i++) { if (recvcounts[i] > 0) { MPIR_ERRTEST_RECVBUF_INPLACE(recvbuf, recvcounts[i], mpi_errno); MPIR_ERRTEST_USERBUFFER(recvbuf,recvcounts[i],recvtype,mpi_errno); break; } } } else if (root != MPI_PROC_NULL) { MPIR_ERRTEST_COUNT(sendcount, mpi_errno); MPIR_ERRTEST_DATATYPE(sendtype, "sendtype", mpi_errno); if (HANDLE_GET_KIND(sendtype) != HANDLE_KIND_BUILTIN) { MPID_Datatype_get_ptr(sendtype, 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_SENDBUF_INPLACE(sendbuf, sendcount, mpi_errno); MPIR_ERRTEST_USERBUFFER(sendbuf,sendcount,sendtype,mpi_errno); } } } MPID_END_ERROR_CHECKS } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Igatherv_impl(sendbuf, sendcount, sendtype, recvbuf, recvcounts, displs, recvtype, root, comm_ptr, request); if (mpi_errno) MPIU_ERR_POP(mpi_errno); /* ... end of body of routine ... */ fn_exit: MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_IGATHERV); 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_igatherv", "**mpi_igatherv %p %d %D %p %p %p %D %d %C %p", sendbuf, sendcount, sendtype, recvbuf, recvcounts, displs, recvtype, root, comm, request); } # endif mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ goto fn_exit; }
/*@ MPI_Comm_idup - nonblocking communicator duplication Input Parameters: . comm - communicator (handle) Output Parameters: + newcomm - copy of comm (handle) - request - communication request (handle) .N ThreadSafe .N Fortran .N Errors @*/ int MPI_Comm_idup(MPI_Comm comm, MPI_Comm *newcomm, MPI_Request *request) { int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPID_Comm *newcomm_ptr = NULL; MPID_Request *dreq = NULL; MPID_MPI_STATE_DECL(MPID_STATE_MPI_COMM_IDUP); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_COMM_IDUP); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS { MPIR_ERRTEST_COMM(comm, mpi_errno); /* TODO more checks may be appropriate */ } MPID_END_ERROR_CHECKS } # endif /* HAVE_ERROR_CHECKING */ /* Convert MPI object handles to object pointers */ MPID_Comm_get_ptr(comm, comm_ptr); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS { MPID_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE ); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPIR_ERRTEST_ARGNULL(request, "request", mpi_errno); /* TODO more checks may be appropriate (counts, in_place, buffer aliasing, etc) */ } MPID_END_ERROR_CHECKS } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ *request = MPI_REQUEST_NULL; *newcomm = MPI_COMM_NULL; mpi_errno = MPIR_Comm_idup_impl(comm_ptr, &newcomm_ptr, &dreq); if (mpi_errno) MPIR_ERR_POP(mpi_errno); /* NOTE: this is a publication for most of the comm, but the context ID * won't be valid yet, so we must "republish" relative to the request * handle at request completion time. */ MPIR_OBJ_PUBLISH_HANDLE(*newcomm, newcomm_ptr->handle); *request = dreq->handle; /* ... end of body of routine ... */ fn_exit: MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_COMM_IDUP); MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_comm_idup", "**mpi_comm_idup %C %p %p", comm, newcomm, request); } # endif mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Alltoallv - Sends data from all to all processes; each process may send a different amount of data and provide displacements for the input and output data. 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 . sdispls - integer array (of length group size). Entry 'j' specifies the displacement (relative to sendbuf from which to take the outgoing data destined for process 'j' . sendtype - data type of send buffer elements (handle) . recvcounts - integer array equal to the group size specifying the maximum number of elements that can be received from each processor . rdispls - integer array (of length group size). Entry 'i' specifies the displacement (relative to recvbuf at which to place the incoming data from process 'i' . recvtype - data type of receive buffer elements (handle) - comm - communicator (handle) Output Parameters: . recvbuf - address of receive buffer (choice) .N ThreadSafe .N Fortran .N Errors .N MPI_ERR_COMM .N MPI_ERR_COUNT .N MPI_ERR_TYPE .N MPI_ERR_BUFFER @*/ int MPI_Alltoallv(const void *sendbuf, const int *sendcounts, const int *sdispls, MPI_Datatype sendtype, void *recvbuf, const int *recvcounts, const int *rdispls, MPI_Datatype recvtype, MPI_Comm comm) { int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPIR_Errflag_t errflag = MPIR_ERR_NONE; MPID_MPI_STATE_DECL(MPID_STATE_MPI_ALLTOALLV); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPID_MPI_COLL_FUNC_ENTER(MPID_STATE_MPI_ALLTOALLV); /* 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 = (comm_ptr->comm_kind == MPID_INTRACOMM && sendbuf != MPI_IN_PLACE); MPID_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE ); if (mpi_errno != MPI_SUCCESS) goto fn_fail; if (comm_ptr->comm_kind == MPID_INTRACOMM) { comm_size = comm_ptr->local_size; if (sendbuf != MPI_IN_PLACE && sendtype == recvtype && sendcounts == recvcounts) MPIR_ERRTEST_ALIAS_COLL(sendbuf, recvbuf, mpi_errno); } else comm_size = comm_ptr->remote_size; if (comm_ptr->comm_kind == MPID_INTERCOMM && sendbuf == MPI_IN_PLACE) { MPIR_ERR_SETANDJUMP(mpi_errno, MPI_ERR_OTHER, "**sendbuf_inplace"); } for (i=0; i<comm_size; i++) { if (check_send) { MPIR_ERRTEST_COUNT(sendcounts[i], mpi_errno); MPIR_ERRTEST_DATATYPE(sendtype, "sendtype", mpi_errno); } MPIR_ERRTEST_COUNT(recvcounts[i], mpi_errno); MPIR_ERRTEST_DATATYPE(recvtype, "recvtype", mpi_errno); } if (check_send && HANDLE_GET_KIND(sendtype) != HANDLE_KIND_BUILTIN) { MPID_Datatype_get_ptr(sendtype, 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; } if (HANDLE_GET_KIND(recvtype) != HANDLE_KIND_BUILTIN) { MPID_Datatype_get_ptr(recvtype, 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],sendtype,mpi_errno); } } for (i=0; i<comm_size; i++) { if (recvcounts[i] > 0) { MPIR_ERRTEST_RECVBUF_INPLACE(recvbuf, recvcounts[i], mpi_errno); MPIR_ERRTEST_USERBUFFER(recvbuf,recvcounts[i],recvtype,mpi_errno); break; } } } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Alltoallv_impl(sendbuf, sendcounts, sdispls, sendtype, recvbuf, recvcounts, rdispls, recvtype, comm_ptr, &errflag); if (mpi_errno) goto fn_fail; /* ... end of body of routine ... */ fn_exit: MPID_MPI_COLL_FUNC_EXIT(MPID_STATE_MPI_ALLTOALLV); 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_alltoallv", "**mpi_alltoallv %p %p %p %D %p %p %p %D %C", sendbuf, sendcounts, sdispls, sendtype, recvbuf, recvcounts, rdispls, recvtype, comm); } # endif mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Allreduce - Combines values from all processes and distributes the result back to all processes Input Parameters: + sendbuf - starting address of send buffer (choice) . count - number of elements in send buffer (integer) . datatype - data type of elements of send buffer (handle) . op - operation (handle) - comm - communicator (handle) Output Parameter: . recvbuf - starting address of receive buffer (choice) .N ThreadSafe .N Fortran .N collops .N Errors .N MPI_ERR_BUFFER .N MPI_ERR_COUNT .N MPI_ERR_TYPE .N MPI_ERR_OP .N MPI_ERR_COMM @*/ int MPI_Allreduce ( void *sendbuf, void *recvbuf, int count, MPI_Datatype datatype, MPI_Op op, MPI_Comm comm ) { static const char FCNAME[] = "MPI_Allreduce"; int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; int errflag = FALSE; MPID_MPI_STATE_DECL(MPID_STATE_MPI_ALLREDUCE); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIU_THREAD_CS_ENTER(ALLFUNC,); MPID_MPI_COLL_FUNC_ENTER(MPID_STATE_MPI_ALLREDUCE); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_COMM(comm, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* Convert MPI object handles to object pointers */ MPID_Comm_get_ptr( comm, comm_ptr ); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPID_Datatype *datatype_ptr = NULL; MPID_Op *op_ptr = NULL; MPID_Comm_valid_ptr( comm_ptr, mpi_errno ); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPIR_ERRTEST_COUNT(count, mpi_errno); MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno); MPIR_ERRTEST_OP(op, mpi_errno); if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) { MPID_Datatype_get_ptr(datatype, datatype_ptr); MPID_Datatype_valid_ptr( datatype_ptr, mpi_errno ); MPID_Datatype_committed_ptr( datatype_ptr, mpi_errno ); } if (comm_ptr->comm_kind == MPID_INTERCOMM) MPIR_ERRTEST_SENDBUF_INPLACE(sendbuf, count, mpi_errno); if (sendbuf != MPI_IN_PLACE) MPIR_ERRTEST_USERBUFFER(sendbuf,count,datatype,mpi_errno); MPIR_ERRTEST_RECVBUF_INPLACE(recvbuf, count, mpi_errno); MPIR_ERRTEST_USERBUFFER(recvbuf,count,datatype,mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; if (HANDLE_GET_KIND(op) != HANDLE_KIND_BUILTIN) { MPID_Op_get_ptr(op, op_ptr); MPID_Op_valid_ptr( op_ptr, mpi_errno ); } if (HANDLE_GET_KIND(op) == HANDLE_KIND_BUILTIN) { mpi_errno = ( * MPIR_Op_check_dtype_table[op%16 - 1] )(datatype); } if (count != 0) { MPIR_ERRTEST_ALIAS_COLL(sendbuf, recvbuf, mpi_errno); } if (mpi_errno != MPI_SUCCESS) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Allreduce_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_ALLREDUCE); 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_allreduce", "**mpi_allreduce %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_Comm_join - Create a communicator by joining two processes connected by a socket. Input Parameter: . fd - socket file descriptor Output Parameter: . intercomm - new intercommunicator (handle) Notes: The socket must be quiescent before 'MPI_COMM_JOIN' is called and after 'MPI_COMM_JOIN' returns. More specifically, on entry to 'MPI_COMM_JOIN', a read on the socket will not read any data that was written to the socket before the remote process called 'MPI_COMM_JOIN'. .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_ARG @*/ int MPI_Comm_join(int fd, MPI_Comm *intercomm) { static const char FCNAME[] = "MPI_Comm_join"; int mpi_errno = MPI_SUCCESS, err; MPID_Comm *intercomm_ptr; char *local_port, *remote_port; MPIU_CHKLMEM_DECL(2); MPID_MPI_STATE_DECL(MPID_STATE_MPI_COMM_JOIN); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIU_THREAD_CS_ENTER(ALLFUNC,); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_COMM_JOIN); /* ... body of routine ... */ MPIU_CHKLMEM_MALLOC(local_port, char *, MPI_MAX_PORT_NAME, mpi_errno, "local port name"); MPIU_CHKLMEM_MALLOC(remote_port, char *, MPI_MAX_PORT_NAME, mpi_errno, "remote port name"); mpi_errno = MPIR_Open_port_impl(NULL, local_port); MPIU_ERR_CHKANDJUMP((mpi_errno != MPI_SUCCESS), mpi_errno, MPI_ERR_OTHER, "**openportfailed"); err = MPIR_fd_send(fd, local_port, MPI_MAX_PORT_NAME); MPIU_ERR_CHKANDJUMP1((err != 0), mpi_errno, MPI_ERR_INTERN, "**join_send", "**join_send %d", err); err = MPIR_fd_recv(fd, remote_port, MPI_MAX_PORT_NAME); MPIU_ERR_CHKANDJUMP1((err != 0), mpi_errno, MPI_ERR_INTERN, "**join_recv", "**join_recv %d", err); MPIU_ERR_CHKANDJUMP2((strcmp(local_port, remote_port) == 0), mpi_errno, MPI_ERR_INTERN, "**join_portname", "**join_portname %s %s", local_port, remote_port); if (strcmp(local_port, remote_port) < 0) { MPID_Comm *comm_self_ptr; MPID_Comm_get_ptr( MPI_COMM_SELF, comm_self_ptr ); mpi_errno = MPIR_Comm_accept_impl(local_port, NULL, 0, comm_self_ptr, &intercomm_ptr); if (mpi_errno) MPIU_ERR_POP(mpi_errno); } else { MPID_Comm *comm_self_ptr; MPID_Comm_get_ptr( MPI_COMM_SELF, comm_self_ptr ); mpi_errno = MPIR_Comm_connect_impl(remote_port, NULL, 0, comm_self_ptr, &intercomm_ptr); if (mpi_errno) MPIU_ERR_POP(mpi_errno); } mpi_errno = MPIR_Close_port_impl(local_port); if (mpi_errno) MPIU_ERR_POP(mpi_errno); MPIU_OBJ_PUBLISH_HANDLE(*intercomm, intercomm_ptr->handle); /* ... end of body of routine ... */ fn_exit: MPIU_CHKLMEM_FREEALL(); MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_COMM_JOIN); 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_comm_join", "**mpi_comm_join %d %p", fd, intercomm); } # endif mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Bsend - Basic send with user-provided buffering 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) Notes: This send is provided as a convenience function; it allows the user to send messages without worring about where they are buffered (because the user `must` have provided buffer space with 'MPI_Buffer_attach'). In deciding how much buffer space to allocate, remember that the buffer space is not available for reuse by subsequent 'MPI_Bsend's unless you are certain that the message has been received (not just that it should have been received). For example, this code does not allocate enough buffer space .vb MPI_Buffer_attach( b, n*sizeof(double) + MPI_BSEND_OVERHEAD ); for (i=0; i<m; i++) { MPI_Bsend( buf, n, MPI_DOUBLE, ... ); } .ve because only enough buffer space is provided for a single send, and the loop may start a second 'MPI_Bsend' before the first is done making use of the buffer. In C, you can force the messages to be delivered by .vb MPI_Buffer_detach( &b, &n ); MPI_Buffer_attach( b, n ); .ve (The 'MPI_Buffer_detach' will not complete until all buffered messages are delivered.) .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_COMM .N MPI_ERR_COUNT .N MPI_ERR_TYPE .N MPI_ERR_RANK .N MPI_ERR_TAG .seealso: MPI_Buffer_attach, MPI_Ibsend, MPI_Bsend_init @*/ int MPI_Bsend(const void *buf, int count, MPI_Datatype datatype, int dest, int tag, MPI_Comm comm) { static const char FCNAME[] = "MPI_Bsend"; int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPID_Request *request_ptr = NULL; MPID_MPI_STATE_DECL(MPID_STATE_MPI_BSEND); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPID_MPI_PT2PT_FUNC_ENTER_FRONT(MPID_STATE_MPI_BSEND); /* 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 object pointers 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, FALSE ); if (mpi_errno) goto fn_fail; /* If comm_ptr is not valid, it will be reset to null */ if (comm_ptr) { MPIR_ERRTEST_SEND_TAG(tag,mpi_errno); MPIR_ERRTEST_SEND_RANK(comm_ptr,dest,mpi_errno) } /* Validate datatype handle */ MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno); /* Validate datatype object */ if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) { 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 ... */ # ifdef MPID_HAS_TBSEND { mpi_errno = MPID_tBsend( buf, count, datatype, dest, tag, comm_ptr, 0 ); if (mpi_errno == MPI_SUCCESS) { goto fn_exit; } /* FIXME: Check for MPID_WOULD_BLOCK? */ } # endif mpi_errno = MPIR_Bsend_isend( buf, count, datatype, dest, tag, comm_ptr, BSEND, &request_ptr ); /* Note that we can ignore the request_ptr because it is handled internally by the bsend util routines */ if (mpi_errno != MPI_SUCCESS) goto fn_fail; /* ... end of body of routine ... */ fn_exit: MPID_MPI_PT2PT_FUNC_EXIT(MPID_STATE_MPI_BSEND); 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_bsend", "**mpi_bsend %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_Barrier - Blocks until all processes in the communicator have reached this routine. Input Parameters: . comm - communicator (handle) Notes: Blocks the caller until all processes in the communicator have called it; that is, the call returns at any process only after all members of the communicator have entered the call. .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_COMM @*/ int MPI_Barrier( MPI_Comm comm ) { int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPIR_Errflag_t errflag = MPIR_ERR_NONE; MPID_MPI_STATE_DECL(MPID_STATE_MPI_BARRIER); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); MPID_MPI_COLL_FUNC_ENTER(MPID_STATE_MPI_BARRIER); /* 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; { /* Validate communicator */ MPID_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE ); if (mpi_errno) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Barrier_impl(comm_ptr, &errflag); if (mpi_errno) goto fn_fail; /* ... end of body of routine ... */ fn_exit: MPID_MPI_COLL_FUNC_EXIT(MPID_STATE_MPI_BARRIER); 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_barrier", "**mpi_barrier %C", comm); } # endif mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/* Find the requested attribute. If it exists, return either the attribute entry or the address of the entry, based on whether the request is for a pointer-valued attribute (C or C++) or an integer-valued attribute (Fortran, either 77 or 90). If the attribute has the same type as the request, it is returned as-is. Otherwise, the address of the attribute is returned. */ int MPIR_CommGetAttr( MPI_Comm comm, int comm_keyval, void *attribute_val, int *flag, MPIR_AttrType outAttrType ) { static const char FCNAME[] = "MPIR_CommGetAttr"; int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; static PreDefined_attrs attr_copy; /* Used to provide a copy of the predefined attributes */ MPID_MPI_STATE_DECL(MPID_STATE_MPIR_COMM_GET_ATTR); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_MPI_FUNC_ENTER(MPID_STATE_MPIR_COMM_GET_ATTR); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_COMM(comm, mpi_errno); MPIR_ERRTEST_KEYVAL(comm_keyval, MPID_COMM, "communicator", mpi_errno); # ifdef NEEDS_POINTER_ALIGNMENT_ADJUST /* A common user error is to pass the address of a 4-byte int when the address of a pointer (or an address-sized int) should have been used. We can test for this specific case. Note that this code assumes sizeof(MPIR_Pint) is a power of 2. */ if ((MPIR_Pint)attribute_val & (sizeof(MPIR_Pint)-1)) { MPIU_ERR_SET(mpi_errno,MPI_ERR_ARG,"**attrnotptr"); } # endif if (mpi_errno != MPI_SUCCESS) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* Convert MPI object handles to object pointers */ MPID_Comm_get_ptr( comm, comm_ptr ); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { /* Validate comm_ptr */ MPID_Comm_valid_ptr( comm_ptr, mpi_errno ); /* If comm_ptr is not valid, it will be reset to null */ MPIR_ERRTEST_ARGNULL(attribute_val, "attr_val", mpi_errno); MPIR_ERRTEST_ARGNULL(flag, "flag", mpi_errno); if (mpi_errno) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ /* Check for builtin attribute */ /* This code is ok for correct programs, but it would be better to copy the values from the per-process block and pass the user a pointer to a copy */ /* Note that if we are called from Fortran, we must return the values, not the addresses, of these attributes */ if (HANDLE_GET_KIND(comm_keyval) == HANDLE_KIND_BUILTIN) { int attr_idx = comm_keyval & 0x0000000f; void **attr_val_p = (void **)attribute_val; #ifdef HAVE_FORTRAN_BINDING /* This is an address-sized int instead of a Fortran (MPI_Fint) integer because, even for the Fortran keyvals, the C interface is used which stores the result in a pointer (hence we need a pointer-sized int). Thus we use MPIR_Pint instead of MPI_Fint. On some 64-bit plaforms, such as Solaris-SPARC, using an MPI_Fint will cause the value to placed into the high, rather than low, end of the output value. */ #endif *flag = 1; /* FIXME : We could initialize some of these here; only tag_ub is used in the error checking. */ /* * The C versions of the attributes return the address of a * *COPY* of the value (to prevent the user from changing it) * and the Fortran versions provide the actual value (as an Fint) */ attr_copy = MPIR_Process.attrs; switch (attr_idx) { case 1: /* TAG_UB */ case 2: *attr_val_p = &attr_copy.tag_ub; break; case 3: /* HOST */ case 4: *attr_val_p = &attr_copy.host; break; case 5: /* IO */ case 6: *attr_val_p = &attr_copy.io; break; case 7: /* WTIME */ case 8: *attr_val_p = &attr_copy.wtime_is_global; break; case 9: /* UNIVERSE_SIZE */ case 10: /* This is a special case. If universe is not set, then we attempt to get it from the device. If the device is doesn't supply a value, then we set the flag accordingly */ if (attr_copy.universe >= 0) { *attr_val_p = &attr_copy.universe; } else if (attr_copy.universe == MPIR_UNIVERSE_SIZE_NOT_AVAILABLE) { *flag = 0; } else { mpi_errno = MPID_Get_universe_size(&attr_copy.universe); /* --BEGIN ERROR HANDLING-- */ if (mpi_errno != MPI_SUCCESS) { attr_copy.universe = MPIR_UNIVERSE_SIZE_NOT_AVAILABLE; goto fn_fail; } /* --END ERROR HANDLING-- */ if (attr_copy.universe >= 0) { *attr_val_p = &attr_copy.universe; } else { attr_copy.universe = MPIR_UNIVERSE_SIZE_NOT_AVAILABLE; *flag = 0; } } break; case 11: /* LASTUSEDCODE */ case 12: *attr_val_p = &attr_copy.lastusedcode; break; case 13: /* APPNUM */ case 14: /* This is another special case. If appnum is negative, we take that as indicating no value of APPNUM, and set the flag accordingly */ if (attr_copy.appnum < 0) { *flag = 0; } else { *attr_val_p = &attr_copy.appnum; } break; } /* All of the predefined attributes are INTEGER; since we've set the output value as the pointer to these, we need to dereference it here. */ if (*flag) { /* Use the internal pointer-sized-int for systems (e.g., BG/P) that define MPI_Aint as a different size than MPIR_Pint. The casts must be as they are: On the right, the value is a pointer to an int, so to get the correct value, we need to extract the int. On the left, the output type is given by the argument outAttrType - and the cast must match the intended results */ if (outAttrType == MPIR_ATTR_AINT) *(MPIR_Pint*)attr_val_p = *(int*)*(void **)attr_val_p; else if (outAttrType == MPIR_ATTR_INT) *(int*)attr_val_p = *(int *)*(void **)attr_val_p; } } else { MPID_Attribute *p = comm_ptr->attributes; /* */ *flag = 0; while (p) { if (p->keyval->handle == comm_keyval) { *flag = 1; if (outAttrType == MPIR_ATTR_PTR) { if (p->attrType == MPIR_ATTR_INT) { /* This is the tricky case: if the system is bigendian, and we have to return a pointer to an int, then we may need to point to the correct location in the word. */ #if defined(WORDS_LITTLEENDIAN) || (SIZEOF_VOID_P == SIZEOF_INT) *(void**)attribute_val = &(p->value); #else int *p_loc = (int *)&(p->value); #if SIZEOF_VOID_P == 2 * SIZEOF_INT p_loc++; #else #error Expected sizeof(void*) to be either sizeof(int) or 2*sizeof(int) #endif *(void **)attribute_val = p_loc; #endif } else if (p->attrType == MPIR_ATTR_AINT) { *(void**)attribute_val = &(p->value); } else { *(void**)attribute_val = (void *)(MPIR_Pint)(p->value); } } else *(void**)attribute_val = (void *)(MPIR_Pint)(p->value); break; } p = p->next; } } /* ... end of body of routine ... */ fn_exit: MPID_MPI_FUNC_EXIT(MPID_STATE_MPIR_COMM_GET_ATTR); 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, "**mpir_comm_get_attr", "**mpir_comm_get_attr %C %d %p %p", comm, comm_keyval, attribute_val, flag); } # endif mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Cart_shift - Returns the shifted source and destination ranks, given a shift direction and amount Input Parameters: + comm - communicator with cartesian structure (handle) . direction - coordinate dimension of shift (integer) - disp - displacement (> 0: upwards shift, < 0: downwards shift) (integer) Output Parameters: + rank_source - rank of source process (integer) - rank_dest - rank of destination process (integer) Notes: The 'direction' argument is in the range '[0,n-1]' for an n-dimensional Cartesian mesh. .N SignalSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_TOPOLOGY .N MPI_ERR_COMM .N MPI_ERR_ARG @*/ int MPI_Cart_shift(MPI_Comm comm, int direction, int disp, int *rank_source, int *rank_dest) { int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPID_MPI_STATE_DECL(MPID_STATE_MPI_CART_SHIFT); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_CART_SHIFT); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_COMM(comm, mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* Convert MPI object handles to object pointers */ MPID_Comm_get_ptr( comm, comm_ptr ); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { /* Validate comm_ptr */ MPID_Comm_valid_ptr( comm_ptr, mpi_errno, TRUE ); if (mpi_errno) goto fn_fail; /* If comm_ptr is not valid, it will be reset to null */ MPIR_ERRTEST_ARGNULL( rank_source, "rank_source", mpi_errno ); MPIR_ERRTEST_ARGNULL( rank_dest, "rank_dest", mpi_errno ); MPIR_ERRTEST_ARGNEG( direction, "direction", mpi_errno ); /* Nothing in the standard indicates that a zero displacement is not valid, so we don't check for a zero shift */ } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Cart_shift_impl(comm_ptr, direction, disp, rank_source, rank_dest); if (mpi_errno) MPIU_ERR_POP(mpi_errno); /* ... end of body of routine ... */ fn_exit: MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_CART_SHIFT); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_cart_shift", "**mpi_cart_shift %C %d %d %p %p", comm, direction, disp, rank_source, rank_dest); } # endif mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Bsend_init - Builds a handle for a buffered 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_COMM .N MPI_ERR_COUNT .N MPI_ERR_TYPE .N MPI_ERR_RANK .N MPI_ERR_TAG .seealso: MPI_Buffer_attach @*/ int MPI_Bsend_init(const void *buf, int count, MPI_Datatype datatype, int dest, int tag, MPI_Comm comm, MPI_Request *request) { static const char FCNAME[] = "MPI_Bsend_init"; int mpi_errno = MPI_SUCCESS; MPID_Request *request_ptr = NULL; MPID_Comm *comm_ptr = NULL; MPID_MPI_STATE_DECL(MPID_STATE_MPI_BSEND_INIT); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIU_THREAD_CS_ENTER(ALLFUNC,); MPID_MPI_PT2PT_FUNC_ENTER(MPID_STATE_MPI_BSEND_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 ); if (mpi_errno) goto fn_fail; MPIR_ERRTEST_COUNT(count, mpi_errno); MPIR_ERRTEST_DATATYPE(datatype, "datatype", 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 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; } } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPID_Bsend_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_BSEND_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_bsend_init", "**mpi_bsend_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-- */ }
static int MPIDI_CH3I_Initialize_tmp_comm(MPID_Comm **comm_pptr, MPIDI_VC_t *vc_ptr, int is_low_group, int context_id_offset) { int mpi_errno = MPI_SUCCESS; MPID_Comm *tmp_comm, *commself_ptr; MPIDI_STATE_DECL(MPID_STATE_MPIDI_CH3I_INITIALIZE_TMP_COMM); MPIDI_FUNC_ENTER(MPID_STATE_MPIDI_CH3I_INITIALIZE_TMP_COMM); MPID_Comm_get_ptr( MPI_COMM_SELF, commself_ptr ); /* WDG-old code allocated a context id that was then discarded */ mpi_errno = MPIR_Comm_create(&tmp_comm); if (mpi_errno != MPI_SUCCESS) { MPIU_ERR_POP(mpi_errno); } /* fill in all the fields of tmp_comm. */ /* We use the second half of the context ID bits for dynamic * processes. This assumes that the context ID mask array is made * up of uint32_t's. */ /* FIXME: This code is still broken for the following case: * If the same process opens connections to the multiple * processes, this context ID might get out of sync. */ tmp_comm->context_id = MPID_CONTEXT_SET_FIELD(DYNAMIC_PROC, context_id_offset, 1); tmp_comm->recvcontext_id = tmp_comm->context_id; /* sanity: the INVALID context ID value could potentially conflict with the * dynamic proccess space */ MPIU_Assert(tmp_comm->context_id != MPIR_INVALID_CONTEXT_ID); MPIU_Assert(tmp_comm->recvcontext_id != MPIR_INVALID_CONTEXT_ID); /* FIXME - we probably need a unique context_id. */ tmp_comm->remote_size = 1; /* Fill in new intercomm */ tmp_comm->local_size = 1; tmp_comm->rank = 0; tmp_comm->comm_kind = MPID_INTERCOMM; tmp_comm->local_comm = NULL; tmp_comm->is_low_group = is_low_group; /* No pg structure needed since vc has already been set up (connection has been established). */ /* Point local vcr, vcrt at those of commself_ptr */ /* FIXME: Explain why */ tmp_comm->local_vcrt = commself_ptr->vcrt; MPID_VCRT_Add_ref(commself_ptr->vcrt); tmp_comm->local_vcr = commself_ptr->vcr; /* No pg needed since connection has already been formed. FIXME - ensure that the comm_release code does not try to free an unallocated pg */ /* Set up VC reference table */ mpi_errno = MPID_VCRT_Create(tmp_comm->remote_size, &tmp_comm->vcrt); if (mpi_errno != MPI_SUCCESS) { MPIU_ERR_SETANDJUMP(mpi_errno,MPI_ERR_OTHER, "**init_vcrt"); } mpi_errno = MPID_VCRT_Get_ptr(tmp_comm->vcrt, &tmp_comm->vcr); if (mpi_errno != MPI_SUCCESS) { MPIU_ERR_SETANDJUMP(mpi_errno,MPI_ERR_OTHER, "**init_getptr"); } /* FIXME: Why do we do a dup here? */ MPID_VCR_Dup(vc_ptr, tmp_comm->vcr); /* Even though this is a tmp comm and we don't call MPI_Comm_commit, we still need to call the creation hook because the destruction hook will be called in comm_release */ mpi_errno = MPID_Dev_comm_create_hook(tmp_comm); if (mpi_errno) MPIU_ERR_POP(mpi_errno); *comm_pptr = tmp_comm; fn_exit: MPIDI_FUNC_EXIT(MPID_STATE_MPIDI_CH3I_INITIALIZE_TMP_COMM); return mpi_errno; fn_fail: goto fn_exit; }
/*@ 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); } 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_RECV_RANK(comm_ptr, source, mpi_errno); MPIR_ERRTEST_RECV_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 ... */ /* 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-- */ } if (unlikely(MPIR_CVAR_ENABLE_FT && !MPID_Request_is_complete(request_ptr) && MPID_Request_is_anysource(request_ptr) && !MPID_Comm_AS_enabled(request_ptr->comm))) { /* --BEGIN ERROR HANDLING-- */ MPID_Cancel_recv(request_ptr); MPIR_STATUS_SET_CANCEL_BIT(request_ptr->status, FALSE); MPIU_ERR_SET(request_ptr->status.MPI_ERROR, MPIX_ERR_PROC_FAILED, "**proc_failed"); mpi_errno = request_ptr->status.MPI_ERROR; 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_Cart_coords - Determines process coords in cartesian topology given rank in group Input Parameters: + comm - communicator with cartesian structure (handle) . rank - rank of a process within group of 'comm' (integer) - maxdims - length of vector 'coords' in the calling program (integer) Output Parameter: . coords - integer array (of size 'ndims') containing the Cartesian coordinates of specified process (integer) .N SignalSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_TOPOLOGY .N MPI_ERR_RANK .N MPI_ERR_DIMS .N MPI_ERR_ARG @*/ int MPI_Cart_coords(MPI_Comm comm, int rank, int maxdims, int *coords) { static const char FCNAME[] = "MPI_Cart_coords"; int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPIR_Topology *cart_ptr; int i, nnodes; MPID_MPI_STATE_DECL(MPID_STATE_MPI_CART_COORDS); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_CART_COORDS); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_COMM(comm, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* Convert MPI object handles to object pointers */ MPID_Comm_get_ptr( comm, comm_ptr ); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { /* Validate comm_ptr */ MPID_Comm_valid_ptr( comm_ptr, mpi_errno ); /* If comm_ptr is not valid, it will be reset to null */ if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPIR_ERRTEST_RANK(comm_ptr, rank, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ cart_ptr = MPIR_Topology_get( comm_ptr ); # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIU_ERR_CHKANDJUMP((!cart_ptr || cart_ptr->kind != MPI_CART), mpi_errno, MPI_ERR_TOPOLOGY, "**notcarttopo"); MPIU_ERR_CHKANDJUMP2((cart_ptr->topo.cart.ndims > maxdims), mpi_errno, MPI_ERR_ARG, "**dimsmany", "**dimsmany %d %d", cart_ptr->topo.cart.ndims, maxdims); if (cart_ptr->topo.cart.ndims) { MPIR_ERRTEST_ARGNULL(coords,"coords",mpi_errno); if (mpi_errno) goto fn_fail; } } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ /* Calculate coords */ nnodes = cart_ptr->topo.cart.nnodes; for ( i=0; i < cart_ptr->topo.cart.ndims; i++ ) { nnodes = nnodes / cart_ptr->topo.cart.dims[i]; coords[i] = rank / nnodes; rank = rank % nnodes; } /* ... end of body of routine ... */ fn_exit: MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_CART_COORDS); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_cart_coords", "**mpi_cart_coords %C %d %d %p", comm, rank, maxdims, coords); } # endif mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Neighbor_allgather - In this function, each process i gathers data items from each process j if an edge (j,i) exists in the topology graph, and each process i sends the same data items to all processes j where an edge (i,j) exists. The send buffer is sent to each neighboring process and the l-th block in the receive buffer is received from the l-th neighbor. Input Parameters: + sendbuf - starting address of the send buffer (choice) . sendcount - number of elements sent to each neighbor (non-negative integer) . sendtype - data type of send buffer elements (handle) . recvcount - number of elements received from each neighbor (non-negative integer) . recvtype - data type of receive buffer elements (handle) - comm - communicator (handle) Output Parameters: . recvbuf - starting address of the receive buffer (choice) .N ThreadSafe .N Fortran .N Errors @*/ int MPI_Neighbor_allgather(const void *sendbuf, int sendcount, MPI_Datatype sendtype, void *recvbuf, int recvcount, MPI_Datatype recvtype, MPI_Comm comm) { int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPID_MPI_STATE_DECL(MPID_STATE_MPI_NEIGHBOR_ALLGATHER); MPIU_THREAD_CS_ENTER(ALLFUNC,); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_NEIGHBOR_ALLGATHER); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS { MPIR_ERRTEST_DATATYPE(sendtype, "sendtype", mpi_errno); MPIR_ERRTEST_DATATYPE(recvtype, "recvtype", mpi_errno); MPIR_ERRTEST_COMM(comm, mpi_errno); /* TODO more checks may be appropriate */ } MPID_END_ERROR_CHECKS } # endif /* HAVE_ERROR_CHECKING */ /* Convert MPI object handles to object pointers */ MPID_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) { MPID_Datatype *sendtype_ptr = NULL; MPID_Datatype_get_ptr(sendtype, sendtype_ptr); MPID_Datatype_valid_ptr(sendtype_ptr, mpi_errno); MPID_Datatype_committed_ptr(sendtype_ptr, mpi_errno); } if (HANDLE_GET_KIND(recvtype) != HANDLE_KIND_BUILTIN) { MPID_Datatype *recvtype_ptr = NULL; MPID_Datatype_get_ptr(recvtype, recvtype_ptr); MPID_Datatype_valid_ptr(recvtype_ptr, mpi_errno); MPID_Datatype_committed_ptr(recvtype_ptr, mpi_errno); } MPID_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE ); /* TODO more checks may be appropriate (counts, in_place, buffer aliasing, etc) */ if (mpi_errno != MPI_SUCCESS) goto fn_fail; } MPID_END_ERROR_CHECKS } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Neighbor_allgather_impl(sendbuf, sendcount, sendtype, recvbuf, recvcount, recvtype, comm_ptr); if (mpi_errno) MPIU_ERR_POP(mpi_errno); /* ... end of body of routine ... */ fn_exit: MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_NEIGHBOR_ALLGATHER); 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_neighbor_allgather", "**mpi_neighbor_allgather %p %d %D %p %d %D %C", sendbuf, sendcount, sendtype, recvbuf, recvcount, recvtype, comm); } # endif mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Topo_test - Determines the type of topology (if any) associated with a communicator Input Parameters: . comm - communicator (handle) Output Parameters: . status - topology type of communicator 'comm' (integer). If the communicator has no associated topology, returns 'MPI_UNDEFINED'. .N SignalSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_COMM .N MPI_ERR_ARG .seealso: MPI_Graph_create, MPI_Cart_create @*/ int MPI_Topo_test(MPI_Comm comm, int *status) { #ifdef HAVE_ERROR_CHECKING static const char FCNAME[] = "MPI_Topo_test"; #endif int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPIR_Topology *topo_ptr; MPID_MPI_STATE_DECL(MPID_STATE_MPI_TOPO_TEST); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_TOPO_TEST); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_COMM(comm, mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* Convert MPI object handles to object pointers */ MPID_Comm_get_ptr( comm, comm_ptr ); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { /* Validate comm_ptr */ MPID_Comm_valid_ptr( comm_ptr, mpi_errno, TRUE ); if (mpi_errno) goto fn_fail; /* If comm_ptr is not valid, it will be reset to null */ MPIR_ERRTEST_ARGNULL(status, "status", mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ topo_ptr = MPIR_Topology_get( comm_ptr ); if (topo_ptr) { *status = (int)(topo_ptr->kind); } else { *status = MPI_UNDEFINED; } /* ... end of body of routine ... */ #ifdef HAVE_ERROR_CHECKING fn_exit: #endif MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TOPO_TEST); return mpi_errno; /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING fn_fail: { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_topo_test", "**mpi_topo_test %C %p", comm, status); } mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno ); goto fn_exit; # endif /* --END ERROR HANDLING-- */ }
/*@ MPI_Comm_free - Marks the communicator object for deallocation Input Parameters: . comm - Communicator to be destroyed (handle) Notes: This routine `frees` a communicator. Because the communicator may still be in use by other MPI routines, the actual communicator storage will not be freed until all references to this communicator are removed. For most users, the effect of this routine is the same as if it was in fact freed at this time of this call. Null Handles: The MPI 1.1 specification, in the section on opaque objects, explicitly disallows freeing a null communicator. The text from the standard is: .vb A null handle argument is an erroneous IN argument in MPI calls, unless an exception is explicitly stated in the text that defines the function. Such exception is allowed for handles to request objects in Wait and Test calls (sections Communication Completion and Multiple Completions ). Otherwise, a null handle can only be passed to a function that allocates a new object and returns a reference to it in the handle. .ve .N ThreadSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_COMM .N MPI_ERR_ARG @*/ int MPI_Comm_free(MPI_Comm *comm) { int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPID_MPI_STATE_DECL(MPID_STATE_MPI_COMM_FREE); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPIU_THREAD_CS_ENTER(ALLFUNC,); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_COMM_FREE); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_COMM(*comm, mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* Get handles to MPI objects. */ MPID_Comm_get_ptr( *comm, comm_ptr ); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { /* Validate comm_ptr */ MPID_Comm_valid_ptr( comm_ptr, mpi_errno, TRUE ); /* If comm_ptr is not valid, it will be reset to null */ /* Cannot free the predefined communicators */ if (HANDLE_GET_KIND(*comm) == HANDLE_KIND_BUILTIN) { mpi_errno = MPIR_Err_create_code( MPI_SUCCESS, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_COMM, "**commperm", "**commperm %s", comm_ptr->name ); } if (mpi_errno) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ mpi_errno = MPIR_Comm_free_impl(comm_ptr); if (mpi_errno != MPI_SUCCESS) goto fn_fail; *comm = MPI_COMM_NULL; /* ... end of body of routine ... */ fn_exit: MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_COMM_FREE); 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_comm_free", "**mpi_comm_free %p", comm); } # endif mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Pack - Packs a datatype into contiguous memory Input Parameters: + inbuf - input buffer start (choice) . incount - number of input data items (non-negative integer) . datatype - datatype of each input data item (handle) . outsize - output buffer size, in bytes (non-negative integer) - comm - communicator for packed message (handle) Output Parameters: . outbuf - output buffer start (choice) Input/Output Parameters: . position - current position in buffer, in bytes (integer) Notes (from the specifications): The input value of position is the first location in the output buffer to be used for packing. position is incremented by the size of the packed message, and the output value of position is the first location in the output buffer following the locations occupied by the packed message. The comm argument is the communicator that will be subsequently used for sending the packed message. .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_ARG .N MPI_ERR_OTHER @*/ int MPI_Pack(const void *inbuf, int incount, MPI_Datatype datatype, void *outbuf, int outsize, int *position, MPI_Comm comm) { int mpi_errno = MPI_SUCCESS; MPI_Aint position_x; MPID_Comm *comm_ptr = NULL; MPID_MPI_STATE_DECL(MPID_STATE_MPI_PACK); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_PACK); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_COMM(comm, mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* Convert MPI object handles to object pointers */ MPID_Comm_get_ptr(comm, comm_ptr); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_COUNT(incount,mpi_errno); MPIR_ERRTEST_COUNT(outsize,mpi_errno); /* NOTE: inbuf could be null (MPI_BOTTOM) */ if (incount > 0) { MPIR_ERRTEST_ARGNULL(outbuf, "output buffer", mpi_errno); } MPIR_ERRTEST_ARGNULL(position, "position", mpi_errno); /* Validate comm_ptr */ /* If comm_ptr is not valid, it will be reset to null */ MPID_Comm_valid_ptr(comm_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno); if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) { MPID_Datatype *datatype_ptr = NULL; MPID_Datatype_get_ptr(datatype, datatype_ptr); MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; MPID_Datatype_committed_ptr(datatype_ptr, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ #ifdef HAVE_ERROR_CHECKING /* IMPLEMENTATION-SPECIFIC ERROR CHECKS */ { int tmp_sz; MPID_BEGIN_ERROR_CHECKS; /* Verify that there is space in the buffer to pack the type */ MPID_Datatype_get_size_macro(datatype, tmp_sz); if (tmp_sz * incount > outsize - *position) { if (*position < 0) { MPIU_ERR_SETANDJUMP1(mpi_errno,MPI_ERR_ARG, "**argposneg","**argposneg %d", *position); } else if (outsize < 0) { MPIU_ERR_SETANDJUMP2(mpi_errno,MPI_ERR_ARG,"**argneg", "**argneg %s %d","outsize",outsize); } else if (incount < 0) { MPIU_ERR_SETANDJUMP2(mpi_errno,MPI_ERR_ARG,"**argneg", "**argneg %s %d","incount",incount); } else { MPIU_ERR_SETANDJUMP2(mpi_errno,MPI_ERR_ARG,"**argpackbuf", "**argpackbuf %d %d", tmp_sz * incount, outsize - *position); } } MPID_END_ERROR_CHECKS; } #endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ position_x = *position; mpi_errno = MPIR_Pack_impl(inbuf, incount, datatype, outbuf, outsize, &position_x); MPIU_Assign_trunc(*position, position_x, int); if (mpi_errno) goto fn_fail; /* ... end of body of routine ... */ fn_exit: MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_PACK); 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_pack", "**mpi_pack %p %d %D %p %d %p %C", inbuf, incount, datatype, outbuf, outsize, position, comm); } # endif mpi_errno = MPIR_Err_return_comm(comm_ptr, FCNAME, mpi_errno); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Cart_shift - Returns the shifted source and destination ranks, given a shift direction and amount Input Parameters: + comm - communicator with cartesian structure (handle) . direction - coordinate dimension of shift (integer) - displ - displacement (> 0: upwards shift, < 0: downwards shift) (integer) Output Parameters: + source - rank of source process (integer) - dest - rank of destination process (integer) Notes: The 'direction' argument is in the range '[0,n-1]' for an n-dimensional Cartesian mesh. .N SignalSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_TOPOLOGY .N MPI_ERR_COMM .N MPI_ERR_ARG @*/ int MPI_Cart_shift(MPI_Comm comm, int direction, int displ, int *source, int *dest) { int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPIR_Topology *cart_ptr; int i; int pos[MAX_CART_DIM]; int rank; MPID_MPI_STATE_DECL(MPID_STATE_MPI_CART_SHIFT); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_CART_SHIFT); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_COMM(comm, mpi_errno); if (mpi_errno != MPI_SUCCESS) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* Convert MPI object handles to object pointers */ MPID_Comm_get_ptr( comm, comm_ptr ); /* Validate parameters and objects (post conversion) */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { /* Validate comm_ptr */ MPID_Comm_valid_ptr( comm_ptr, mpi_errno ); /* If comm_ptr is not valid, it will be reset to null */ MPIR_ERRTEST_ARGNULL( source, "source", mpi_errno ); MPIR_ERRTEST_ARGNULL( dest, "dest", mpi_errno ); MPIR_ERRTEST_ARGNEG( direction, "direction", mpi_errno ); /* Nothing in the standard indicates that a zero displacement is not valid, so we don't check for a zero shift */ if (mpi_errno) goto fn_fail; } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ cart_ptr = MPIR_Topology_get( comm_ptr ); MPIU_ERR_CHKANDJUMP((!cart_ptr || cart_ptr->kind != MPI_CART), mpi_errno, MPI_ERR_TOPOLOGY, "**notcarttopo"); MPIU_ERR_CHKANDJUMP((cart_ptr->topo.cart.ndims == 0), mpi_errno, MPI_ERR_TOPOLOGY, "**dimszero"); MPIU_ERR_CHKANDJUMP2((direction >= cart_ptr->topo.cart.ndims), mpi_errno, MPI_ERR_ARG, "**dimsmany", "**dimsmany %d %d", cart_ptr->topo.cart.ndims, direction); /* Check for the case of a 0 displacement */ rank = comm_ptr->rank; if (displ == 0) { *source = *dest = rank; } else { /* To support advanced implementations that support MPI_Cart_create, we compute the new position and call PMPI_Cart_rank to get the source and destination. We could bypass that step if we know that the mapping is trivial. Copy the current position. */ for (i=0; i<cart_ptr->topo.cart.ndims; i++) { pos[i] = cart_ptr->topo.cart.position[i]; } /* We must return MPI_PROC_NULL if shifted over the edge of a non-periodic mesh */ pos[direction] += displ; if (!cart_ptr->topo.cart.periodic[direction] && (pos[direction] >= cart_ptr->topo.cart.dims[direction] || pos[direction] < 0)) { *dest = MPI_PROC_NULL; } else { MPIR_Cart_rank_impl( cart_ptr, pos, dest ); } pos[direction] = cart_ptr->topo.cart.position[direction] - displ; if (!cart_ptr->topo.cart.periodic[direction] && (pos[direction] >= cart_ptr->topo.cart.dims[direction] || pos[direction] < 0)) { *source = MPI_PROC_NULL; } else { MPIR_Cart_rank_impl( cart_ptr, pos, source ); } } /* ... end of body of routine ... */ fn_exit: MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_CART_SHIFT); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_cart_shift", "**mpi_cart_shift %C %d %d %p %p", comm, direction, displ, source, dest); } # endif mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }
/*@ MPI_Cart_rank - Determines process rank in communicator given Cartesian location Input Parameters: + comm - communicator with cartesian structure (handle) - coords - integer array (of size 'ndims', the number of dimensions of the Cartesian topology associated with 'comm') specifying the cartesian coordinates of a process Output Parameters: . rank - rank of specified process (integer) Notes: Out-of-range coordinates are erroneous for non-periodic dimensions. Versions of MPICH before 1.2.2 returned 'MPI_PROC_NULL' for the rank in this case. .N SignalSafe .N Fortran .N Errors .N MPI_SUCCESS .N MPI_ERR_TOPOLOGY .N MPI_ERR_RANK .N MPI_ERR_ARG @*/ int MPI_Cart_rank(MPI_Comm comm, const int coords[], int *rank) { int mpi_errno = MPI_SUCCESS; MPID_Comm *comm_ptr = NULL; MPIR_Topology *cart_ptr; MPID_MPI_STATE_DECL(MPID_STATE_MPI_CART_RANK); MPIR_ERRTEST_INITIALIZED_ORDIE(); MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_CART_RANK); /* Validate parameters, especially handles needing to be converted */ # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { MPIR_ERRTEST_COMM(comm, mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* Convert MPI object handles to object pointers */ MPID_Comm_get_ptr( comm, comm_ptr ); # ifdef HAVE_ERROR_CHECKING { MPID_BEGIN_ERROR_CHECKS; { /* 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 */ MPIR_ERRTEST_ARGNULL(rank,"rank",mpi_errno); } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ cart_ptr = MPIR_Topology_get( comm_ptr ); MPIU_ERR_CHKANDJUMP((!cart_ptr || cart_ptr->kind != MPI_CART), mpi_errno, MPI_ERR_TOPOLOGY, "**notcarttopo"); /* Validate coordinates */ # ifdef HAVE_ERROR_CHECKING { int i, ndims, coord; MPID_BEGIN_ERROR_CHECKS; { ndims = cart_ptr->topo.cart.ndims; if (ndims != 0) { MPIR_ERRTEST_ARGNULL(coords,"coords",mpi_errno); } for (i=0; i<ndims; i++) { if (!cart_ptr->topo.cart.periodic[i]) { coord = coords[i]; MPIU_ERR_CHKANDJUMP3( (coord < 0 || coord >= cart_ptr->topo.cart.dims[i] ), mpi_errno, MPI_ERR_ARG, "**cartcoordinvalid", "**cartcoordinvalid %d %d %d",i, coords[i], cart_ptr->topo.cart.dims[i]-1 ); } } } MPID_END_ERROR_CHECKS; } # endif /* HAVE_ERROR_CHECKING */ /* ... body of routine ... */ MPIR_Cart_rank_impl(cart_ptr, coords, rank); /* ... end of body of routine ... */ fn_exit: MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_CART_RANK); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ # ifdef HAVE_ERROR_CHECKING { mpi_errno = MPIR_Err_create_code( mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_cart_rank", "**mpi_cart_rank %C %p %p", comm, coords, rank); } # endif mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno ); goto fn_exit; /* --END ERROR HANDLING-- */ }