Actual source code: mpitr.c
2: /*
3: Code for tracing mistakes in MPI usage. For example, sends that are never received,
4: nonblocking messages that are not correctly waited for, etc.
5: */
7: #include <petscsys.h>
9: #if defined(PETSC_USE_LOG) && !defined(PETSC_HAVE_MPIUNI)
11: /*@C
12: PetscMPIDump - Dumps a listing of incomplete MPI operations, such as sends that
13: have never been received, etc.
15: Collective on `PETSC_COMM_WORLD`
17: Input Parameter:
18: . fp - file pointer. If fp is `NULL`, `stdout` is assumed.
20: Options Database Key:
21: . -mpidump - Dumps MPI incompleteness during call to PetscFinalize()
23: Level: developer
25: .seealso: `PetscMallocDump()`
26: @*/
27: PetscErrorCode PetscMPIDump(FILE *fd)
28: {
29: PetscMPIInt rank;
30: double tsends, trecvs, work;
32: PetscFunctionBegin;
33: PetscCallMPI(MPI_Comm_rank(PETSC_COMM_WORLD, &rank));
34: if (!fd) fd = PETSC_STDOUT;
36: /* Did we wait on all the non-blocking sends and receives? */
37: PetscCall(PetscSequentialPhaseBegin(PETSC_COMM_WORLD, 1));
38: if (petsc_irecv_ct + petsc_isend_ct != petsc_sum_of_waits_ct) {
39: PetscCall(PetscFPrintf(PETSC_COMM_SELF, fd, "[%d]You have not waited on all non-blocking sends and receives", rank));
40: PetscCall(PetscFPrintf(PETSC_COMM_SELF, fd, "[%d]Number non-blocking sends %g receives %g number of waits %g\n", rank, petsc_isend_ct, petsc_irecv_ct, petsc_sum_of_waits_ct));
41: PetscCall(PetscFFlush(fd));
42: }
43: PetscCall(PetscSequentialPhaseEnd(PETSC_COMM_WORLD, 1));
44: /* Did we receive all the messages that we sent? */
45: work = petsc_irecv_ct + petsc_recv_ct;
46: PetscCallMPI(MPI_Reduce(&work, &trecvs, 1, MPI_DOUBLE, MPI_SUM, 0, PETSC_COMM_WORLD));
47: work = petsc_isend_ct + petsc_send_ct;
48: PetscCallMPI(MPI_Reduce(&work, &tsends, 1, MPI_DOUBLE, MPI_SUM, 0, PETSC_COMM_WORLD));
49: if (rank == 0 && tsends != trecvs) {
50: PetscCall(PetscFPrintf(PETSC_COMM_SELF, fd, "Total number sends %g not equal receives %g\n", tsends, trecvs));
51: PetscCall(PetscFFlush(fd));
52: }
53: PetscFunctionReturn(PETSC_SUCCESS);
54: }
56: #else
58: PetscErrorCode PetscMPIDump(FILE *fd)
59: {
60: PetscFunctionBegin;
61: PetscFunctionReturn(PETSC_SUCCESS);
62: }
64: #endif
66: #if defined(PETSC_HAVE_MPI_PROCESS_SHARED_MEMORY)
67: /*
68: OpenMPI version of MPI_Win_allocate_shared() does not provide __float128 alignment so we provide
69: a utility that insures alignment up to data item size.
70: */
71: PetscErrorCode MPIU_Win_allocate_shared(MPI_Aint sz, PetscMPIInt szind, MPI_Info info, MPI_Comm comm, void *ptr, MPI_Win *win)
72: {
73: float *tmp;
75: PetscFunctionBegin;
76: PetscCallMPI(MPI_Win_allocate_shared(16 + sz, szind, info, comm, &tmp, win));
77: tmp += ((size_t)tmp) % szind ? szind / 4 - ((((size_t)tmp) % szind) / 4) : 0;
78: *(void **)ptr = (void *)tmp;
79: PetscFunctionReturn(PETSC_SUCCESS);
80: }
82: PETSC_EXTERN PetscErrorCode MPIU_Win_shared_query(MPI_Win win, PetscMPIInt rank, MPI_Aint *sz, PetscMPIInt *szind, void *ptr)
83: {
84: float *tmp;
86: PetscFunctionBegin;
87: PetscCallMPI(MPI_Win_shared_query(win, rank, sz, szind, &tmp));
88: PetscCheck(*szind > 0, PETSC_COMM_SELF, PETSC_ERR_LIB, "szkind %d must be positive", *szind);
89: tmp += ((size_t)tmp) % *szind ? *szind / 4 - ((((size_t)tmp) % *szind) / 4) : 0;
90: *(void **)ptr = (void *)tmp;
91: PetscFunctionReturn(PETSC_SUCCESS);
92: }
94: #endif