1 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 */ 6 7 #include <petscsys.h> /*I "petscsys.h" I*/ 8 9 #if defined(PETSC_USE_LOG) && !defined(PETSC_HAVE_MPIUNI) 10 11 /*@C 12 PetscMPIDump - Dumps a listing of incomplete MPI operations, such as sends that 13 have never been received, etc. 14 15 Collective on PETSC_COMM_WORLD 16 17 Input Parameter: 18 . fp - file pointer. If fp is NULL, stdout is assumed. 19 20 Options Database Key: 21 . -mpidump - Dumps MPI incompleteness during call to PetscFinalize() 22 23 Level: developer 24 25 .seealso: `PetscMallocDump()` 26 @*/ 27 PetscErrorCode PetscMPIDump(FILE *fd) { 28 PetscMPIInt rank; 29 double tsends, trecvs, work; 30 int err; 31 32 PetscFunctionBegin; 33 PetscCallMPI(MPI_Comm_rank(PETSC_COMM_WORLD, &rank)); 34 if (!fd) fd = PETSC_STDOUT; 35 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 err = fflush(fd); 42 PetscCheck(!err, PETSC_COMM_SELF, PETSC_ERR_SYS, "fflush() failed on file"); 43 } 44 PetscCall(PetscSequentialPhaseEnd(PETSC_COMM_WORLD, 1)); 45 /* Did we receive all the messages that we sent? */ 46 work = petsc_irecv_ct + petsc_recv_ct; 47 PetscCallMPI(MPI_Reduce(&work, &trecvs, 1, MPI_DOUBLE, MPI_SUM, 0, PETSC_COMM_WORLD)); 48 work = petsc_isend_ct + petsc_send_ct; 49 PetscCallMPI(MPI_Reduce(&work, &tsends, 1, MPI_DOUBLE, MPI_SUM, 0, PETSC_COMM_WORLD)); 50 if (rank == 0 && tsends != trecvs) { 51 PetscCall(PetscFPrintf(PETSC_COMM_SELF, fd, "Total number sends %g not equal receives %g\n", tsends, trecvs)); 52 err = fflush(fd); 53 PetscCheck(!err, PETSC_COMM_SELF, PETSC_ERR_SYS, "fflush() failed on file"); 54 } 55 PetscFunctionReturn(0); 56 } 57 58 #else 59 60 PetscErrorCode PetscMPIDump(FILE *fd) { 61 PetscFunctionBegin; 62 PetscFunctionReturn(0); 63 } 64 65 #endif 66 67 #if defined(PETSC_HAVE_MPI_PROCESS_SHARED_MEMORY) 68 /* 69 OpenMPI version of MPI_Win_allocate_shared() does not provide __float128 alignment so we provide 70 a utility that insures alignment up to data item size. 71 */ 72 PetscErrorCode MPIU_Win_allocate_shared(MPI_Aint sz, PetscMPIInt szind, MPI_Info info, MPI_Comm comm, void *ptr, MPI_Win *win) { 73 float *tmp; 74 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(0); 80 } 81 82 PETSC_EXTERN PetscErrorCode MPIU_Win_shared_query(MPI_Win win, PetscMPIInt rank, MPI_Aint *sz, PetscMPIInt *szind, void *ptr) { 83 float *tmp; 84 85 PetscFunctionBegin; 86 PetscCallMPI(MPI_Win_shared_query(win, rank, sz, szind, &tmp)); 87 PetscCheck(*szind > 0, PETSC_COMM_SELF, PETSC_ERR_LIB, "szkind %d must be positive", *szind); 88 tmp += ((size_t)tmp) % *szind ? *szind / 4 - ((((size_t)tmp) % *szind) / 4) : 0; 89 *(void **)ptr = (void *)tmp; 90 PetscFunctionReturn(0); 91 } 92 93 #endif 94