1 #include <petsc/private/ftnimpl.h> 2 #include <petscsys.h> 3 #include <petscviewer.h> 4 5 #if defined(PETSC_HAVE_FORTRAN_CAPS) 6 #define petscpusherrorhandler_ PETSCPUSHERRORHANDLER 7 #define petsctracebackerrorhandler_ PETSCTRACEBACKERRORHANDLER 8 #define petscaborterrorhandler_ PETSCABORTERRORHANDLER 9 #define petscignoreerrorhandler_ PETSCIGNOREERRORHANDLER 10 #define petscemacsclienterrorhandler_ PETSCEMACSCLIENTERRORHANDLER 11 #define petscattachdebuggererrorhandler_ PETSCATTACHDEBUGGERERRORHANDLER 12 #define petscerror_ PETSCERROR 13 #define petscerrorf_ PETSCERRORF 14 #define petscerrormpi_ PETSCERRORMPI 15 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 16 #define petscpusherrorhandler_ petscpusherrorhandler 17 #define petsctracebackerrorhandler_ petsctracebackerrorhandler 18 #define petscaborterrorhandler_ petscaborterrorhandler 19 #define petscignoreerrorhandler_ petscignoreerrorhandler 20 #define petscemacsclienterrorhandler_ petscemacsclienterrorhandler 21 #define petscattachdebuggererrorhandler_ petscattachdebuggererrorhandler 22 #define petscerror_ petscerror 23 #define petscerrorf_ petscerrorf 24 #define petscerrormpi_ petscerrormpi 25 #endif 26 27 static void (*f2)(MPI_Comm *comm, int *, const char *, const char *, PetscErrorCode *, PetscErrorType *, const char *, void *, PetscErrorCode *, PETSC_FORTRAN_CHARLEN_T len1, PETSC_FORTRAN_CHARLEN_T len2, PETSC_FORTRAN_CHARLEN_T len3); 28 29 /* These are not extern C because they are passed into non-extern C user level functions */ 30 static PetscErrorCode ourerrorhandler(MPI_Comm comm, int line, const char *fun, const char *file, PetscErrorCode n, PetscErrorType p, const char *mess, void *ctx) 31 { 32 PetscErrorCode ierr = PETSC_SUCCESS; 33 size_t len1, len2, len3; 34 35 ierr = PetscStrlen(fun, &len1); 36 ierr = PetscStrlen(file, &len2); 37 ierr = PetscStrlen(mess, &len3); 38 39 ierr = PETSC_SUCCESS; 40 (*f2)(&comm, &line, fun, file, &n, &p, mess, ctx, &ierr, (PETSC_FORTRAN_CHARLEN_T)len1, (PETSC_FORTRAN_CHARLEN_T)len2, (PETSC_FORTRAN_CHARLEN_T)len3); 41 return ierr; 42 } 43 44 /* 45 These are not usually called from Fortran but allow Fortran users 46 to transparently set these monitors from .F code 47 */ 48 PETSC_EXTERN void petsctracebackerrorhandler_(MPI_Comm *comm, int *line, const char *fun, const char *file, PetscErrorCode *n, PetscErrorType *p, const char *mess, void *ctx, PetscErrorCode *ierr) 49 { 50 *ierr = PetscTraceBackErrorHandler(*comm, *line, fun, file, *n, *p, mess, ctx); 51 } 52 53 PETSC_EXTERN void petscaborterrorhandler_(MPI_Comm *comm, int *line, const char *fun, const char *file, PetscErrorCode *n, PetscErrorType *p, const char *mess, void *ctx, PetscErrorCode *ierr) 54 { 55 *ierr = PetscAbortErrorHandler(*comm, *line, fun, file, *n, *p, mess, ctx); 56 } 57 58 PETSC_EXTERN void petscattachdebuggererrorhandler_(MPI_Comm *comm, int *line, const char *fun, const char *file, PetscErrorCode *n, PetscErrorType *p, const char *mess, void *ctx, PetscErrorCode *ierr) 59 { 60 *ierr = PetscAttachDebuggerErrorHandler(*comm, *line, fun, file, *n, *p, mess, ctx); 61 } 62 63 PETSC_EXTERN void petscemacsclienterrorhandler_(MPI_Comm *comm, int *line, const char *fun, const char *file, PetscErrorCode *n, PetscErrorType *p, const char *mess, void *ctx, PetscErrorCode *ierr) 64 { 65 *ierr = PetscEmacsClientErrorHandler(*comm, *line, fun, file, *n, *p, mess, ctx); 66 } 67 68 PETSC_EXTERN void petscignoreerrorhandler_(MPI_Comm *comm, int *line, const char *fun, const char *file, PetscErrorCode *n, PetscErrorType *p, const char *mess, void *ctx, PetscErrorCode *ierr) 69 { 70 *ierr = PetscIgnoreErrorHandler(*comm, *line, fun, file, *n, *p, mess, ctx); 71 } 72 73 PETSC_EXTERN void petscpusherrorhandler_(void (*handler)(MPI_Comm *comm, int *, const char *, const char *, PetscErrorCode *, PetscErrorType *, const char *, void *, PetscErrorCode *, PETSC_FORTRAN_CHARLEN_T len1, PETSC_FORTRAN_CHARLEN_T len2, PETSC_FORTRAN_CHARLEN_T len3), void *ctx, PetscErrorCode *ierr) 74 { 75 if ((PetscVoidFn *)handler == (PetscVoidFn *)petsctracebackerrorhandler_) *ierr = PetscPushErrorHandler(PetscTraceBackErrorHandler, NULL); 76 else { 77 f2 = handler; 78 *ierr = PetscPushErrorHandler(ourerrorhandler, ctx); 79 } 80 } 81 82 PETSC_EXTERN void petscerror_(MPI_Fint *comm, PetscErrorCode *number, PetscErrorType *p, char *message, PETSC_FORTRAN_CHARLEN_T len) 83 { 84 PetscErrorCode nierr, *ierr = &nierr; 85 char *t1; 86 FIXCHAR(message, len, t1); 87 nierr = PetscError(MPI_Comm_f2c(*(comm)), 0, NULL, NULL, *number, *p, "%s", t1); 88 FREECHAR(message, t1); 89 } 90 91 #if defined(PETSC_HAVE_FORTRAN_FREE_LINE_LENGTH_NONE) 92 PETSC_EXTERN void petscerrorf_(PetscErrorCode *err, int *line, char *file, PETSC_FORTRAN_CHARLEN_T len) 93 { 94 char *tfile; 95 PetscErrorCode ierr[] = {PETSC_SUCCESS}; /* needed by FIXCHAR */ 96 97 FIXCHAR(file, len, tfile); 98 *err = PetscError(PETSC_COMM_SELF, *line, NULL, tfile, *err, PETSC_ERROR_REPEAT, NULL); 99 FREECHAR(file, tfile); 100 } 101 102 PETSC_EXTERN void petscerrormpi_(PetscErrorCode *err, int *line, char *file, PETSC_FORTRAN_CHARLEN_T len) 103 { 104 char errorstring[2 * MPI_MAX_ERROR_STRING]; 105 char *tfile; 106 PetscErrorCode ierr[] = {PETSC_SUCCESS}; /* needed by FIXCHAR */ 107 108 FIXCHAR(file, len, tfile); 109 PetscMPIErrorString(*err, 2 * MPI_MAX_ERROR_STRING, errorstring); 110 *err = PetscError(PETSC_COMM_SELF, *line, NULL, file, PETSC_ERR_MPI, PETSC_ERROR_INITIAL, "MPI error %d %s", *err, errorstring); 111 FREECHAR(file, tfile); 112 *err = PETSC_ERR_MPI; 113 } 114 #else 115 PETSC_EXTERN void petscerrorf_(PetscErrorCode *err) 116 { 117 *err = PetscError(PETSC_COMM_SELF, 0, NULL, NULL, *err, PETSC_ERROR_REPEAT, NULL); 118 } 119 120 PETSC_EXTERN void petscerrormpi_(PetscErrorCode *err) 121 { 122 char errorstring[2 * MPI_MAX_ERROR_STRING]; 123 124 PetscMPIErrorString(*err, 2 * MPI_MAX_ERROR_STRING, errorstring); 125 *err = PetscError(PETSC_COMM_SELF, 0, NULL, NULL, PETSC_ERR_MPI, PETSC_ERROR_INITIAL, "MPI error %d %s", *err, errorstring); 126 *err = PETSC_ERR_MPI; 127 } 128 #endif 129