1 #include <petsc/private/fortranimpl.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 #define petscrealview_ PETSCREALVIEW 16 #define petscintview_ PETSCINTVIEW 17 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 18 #define petscpusherrorhandler_ petscpusherrorhandler 19 #define petsctracebackerrorhandler_ petsctracebackerrorhandler 20 #define petscaborterrorhandler_ petscaborterrorhandler 21 #define petscignoreerrorhandler_ petscignoreerrorhandler 22 #define petscemacsclienterrorhandler_ petscemacsclienterrorhandler 23 #define petscattachdebuggererrorhandler_ petscattachdebuggererrorhandler 24 #define petscerror_ petscerror 25 #define petscerrorf_ petscerrorf 26 #define petscerrormpi_ petscerrormpi 27 #define petscrealview_ petscrealview 28 #define petscintview_ petscintview 29 #endif 30 31 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); 32 33 /* These are not extern C because they are passed into non-extern C user level functions */ 34 static PetscErrorCode ourerrorhandler(MPI_Comm comm, int line, const char *fun, const char *file, PetscErrorCode n, PetscErrorType p, const char *mess, void *ctx) 35 { 36 PetscErrorCode ierr = PETSC_SUCCESS; 37 size_t len1, len2, len3; 38 39 ierr = PetscStrlen(fun, &len1); 40 ierr = PetscStrlen(file, &len2); 41 ierr = PetscStrlen(mess, &len3); 42 43 ierr = PETSC_SUCCESS; 44 (*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))); 45 return ierr; 46 } 47 48 /* 49 These are not usually called from Fortran but allow Fortran users 50 to transparently set these monitors from .F code 51 */ 52 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) 53 { 54 *ierr = PetscTraceBackErrorHandler(*comm, *line, fun, file, *n, *p, mess, ctx); 55 } 56 57 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) 58 { 59 *ierr = PetscAbortErrorHandler(*comm, *line, fun, file, *n, *p, mess, ctx); 60 } 61 62 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) 63 { 64 *ierr = PetscAttachDebuggerErrorHandler(*comm, *line, fun, file, *n, *p, mess, ctx); 65 } 66 67 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) 68 { 69 *ierr = PetscEmacsClientErrorHandler(*comm, *line, fun, file, *n, *p, mess, ctx); 70 } 71 72 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) 73 { 74 *ierr = PetscIgnoreErrorHandler(*comm, *line, fun, file, *n, *p, mess, ctx); 75 } 76 77 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) 78 { 79 if ((void (*)(void))handler == (void (*)(void))petsctracebackerrorhandler_) *ierr = PetscPushErrorHandler(PetscTraceBackErrorHandler, 0); 80 else { 81 f2 = handler; 82 *ierr = PetscPushErrorHandler(ourerrorhandler, ctx); 83 } 84 } 85 86 PETSC_EXTERN void petscerror_(MPI_Fint *comm, PetscErrorCode *number, PetscErrorType *p, char *message, PETSC_FORTRAN_CHARLEN_T len) 87 { 88 PetscErrorCode nierr, *ierr = &nierr; 89 char *t1; 90 FIXCHAR(message, len, t1); 91 nierr = PetscError(MPI_Comm_f2c(*(comm)), 0, NULL, NULL, *number, *p, "%s", t1); 92 FREECHAR(message, t1); 93 } 94 95 #if defined(PETSC_HAVE_FORTRAN_FREE_LINE_LENGTH_NONE) 96 PETSC_EXTERN void petscerrorf_(PetscErrorCode *err, int *line, char *file, PETSC_FORTRAN_CHARLEN_T len) 97 { 98 char *tfile; 99 PetscErrorCode ierr[] = {PETSC_SUCCESS}; /* needed by FIXCHAR */ 100 101 FIXCHAR(file, len, tfile); 102 *err = PetscError(PETSC_COMM_SELF, *line, NULL, tfile, *err, PETSC_ERROR_REPEAT, NULL); 103 FREECHAR(file, tfile); 104 } 105 106 PETSC_EXTERN void petscerrormpi_(PetscErrorCode *err, int *line, char *file, PETSC_FORTRAN_CHARLEN_T len) 107 { 108 char errorstring[2 * MPI_MAX_ERROR_STRING]; 109 char *tfile; 110 PetscErrorCode ierr[] = {PETSC_SUCCESS}; /* needed by FIXCHAR */ 111 112 FIXCHAR(file, len, tfile); 113 PetscMPIErrorString(*err, errorstring); 114 *err = PetscError(PETSC_COMM_SELF, *line, NULL, file, PETSC_ERR_MPI, PETSC_ERROR_INITIAL, "MPI error %d %s", *err, errorstring); 115 FREECHAR(file, tfile); 116 *err = PETSC_ERR_MPI; 117 } 118 #else 119 PETSC_EXTERN void petscerrorf_(PetscErrorCode *err) 120 { 121 *err = PetscError(PETSC_COMM_SELF, 0, NULL, NULL, *err, PETSC_ERROR_REPEAT, NULL); 122 } 123 124 PETSC_EXTERN void petscerrormpi_(PetscErrorCode *err) 125 { 126 char errorstring[2 * MPI_MAX_ERROR_STRING]; 127 128 PetscMPIErrorString(*err, errorstring); 129 *err = PetscError(PETSC_COMM_SELF, 0, NULL, NULL, PETSC_ERR_MPI, PETSC_ERROR_INITIAL, "MPI error %d %s", *err, errorstring); 130 *err = PETSC_ERR_MPI; 131 } 132 #endif 133 134 PETSC_EXTERN void petscrealview_(PetscInt *n, PetscReal *d, PetscViewer *viewer, PetscErrorCode *ierr) 135 { 136 PetscViewer v; 137 PetscPatchDefaultViewers_Fortran(viewer, v); 138 *ierr = PetscRealView(*n, d, v); 139 } 140 141 PETSC_EXTERN void petscintview_(PetscInt *n, PetscInt *d, PetscViewer *viewer, PetscErrorCode *ierr) 142 { 143 PetscViewer v; 144 PetscPatchDefaultViewers_Fortran(viewer, v); 145 *ierr = PetscIntView(*n, d, v); 146 } 147 148 #if defined(PETSC_HAVE_FORTRAN_CAPS) 149 #define petscscalarview_ PETSCSCALARVIEW 150 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 151 #define petscscalarview_ petscscalarview 152 #endif 153 154 PETSC_EXTERN void petscscalarview_(PetscInt *n, PetscScalar *d, PetscViewer *viewer, PetscErrorCode *ierr) 155 { 156 PetscViewer v; 157 PetscPatchDefaultViewers_Fortran(viewer, v); 158 *ierr = PetscScalarView(*n, d, v); 159 } 160