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 */
ourerrorhandler(MPI_Comm comm,int line,const char * fun,const char * file,PetscErrorCode n,PetscErrorType p,const char * mess,PetscCtx ctx)30 static PetscErrorCode ourerrorhandler(MPI_Comm comm, int line, const char *fun, const char *file, PetscErrorCode n, PetscErrorType p, const char *mess, PetscCtx 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 */
petsctracebackerrorhandler_(MPI_Comm * comm,int * line,const char * fun,const char * file,PetscErrorCode * n,PetscErrorType * p,const char * mess,PetscCtx ctx,PetscErrorCode * ierr)48 PETSC_EXTERN void petsctracebackerrorhandler_(MPI_Comm *comm, int *line, const char *fun, const char *file, PetscErrorCode *n, PetscErrorType *p, const char *mess, PetscCtx ctx, PetscErrorCode *ierr)
49 {
50 *ierr = PetscTraceBackErrorHandler(*comm, *line, fun, file, *n, *p, mess, ctx);
51 }
52
petscaborterrorhandler_(MPI_Comm * comm,int * line,const char * fun,const char * file,PetscErrorCode * n,PetscErrorType * p,const char * mess,PetscCtx ctx,PetscErrorCode * ierr)53 PETSC_EXTERN void petscaborterrorhandler_(MPI_Comm *comm, int *line, const char *fun, const char *file, PetscErrorCode *n, PetscErrorType *p, const char *mess, PetscCtx ctx, PetscErrorCode *ierr)
54 {
55 *ierr = PetscAbortErrorHandler(*comm, *line, fun, file, *n, *p, mess, ctx);
56 }
57
petscattachdebuggererrorhandler_(MPI_Comm * comm,int * line,const char * fun,const char * file,PetscErrorCode * n,PetscErrorType * p,const char * mess,PetscCtx ctx,PetscErrorCode * ierr)58 PETSC_EXTERN void petscattachdebuggererrorhandler_(MPI_Comm *comm, int *line, const char *fun, const char *file, PetscErrorCode *n, PetscErrorType *p, const char *mess, PetscCtx ctx, PetscErrorCode *ierr)
59 {
60 *ierr = PetscAttachDebuggerErrorHandler(*comm, *line, fun, file, *n, *p, mess, ctx);
61 }
62
petscemacsclienterrorhandler_(MPI_Comm * comm,int * line,const char * fun,const char * file,PetscErrorCode * n,PetscErrorType * p,const char * mess,PetscCtx ctx,PetscErrorCode * ierr)63 PETSC_EXTERN void petscemacsclienterrorhandler_(MPI_Comm *comm, int *line, const char *fun, const char *file, PetscErrorCode *n, PetscErrorType *p, const char *mess, PetscCtx ctx, PetscErrorCode *ierr)
64 {
65 *ierr = PetscEmacsClientErrorHandler(*comm, *line, fun, file, *n, *p, mess, ctx);
66 }
67
petscignoreerrorhandler_(MPI_Comm * comm,int * line,const char * fun,const char * file,PetscErrorCode * n,PetscErrorType * p,const char * mess,PetscCtx ctx,PetscErrorCode * ierr)68 PETSC_EXTERN void petscignoreerrorhandler_(MPI_Comm *comm, int *line, const char *fun, const char *file, PetscErrorCode *n, PetscErrorType *p, const char *mess, PetscCtx ctx, PetscErrorCode *ierr)
69 {
70 *ierr = PetscIgnoreErrorHandler(*comm, *line, fun, file, *n, *p, mess, ctx);
71 }
72
petscpusherrorhandler_(void (* handler)(MPI_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),PetscCtx ctx,PetscErrorCode * ierr)73 PETSC_EXTERN void petscpusherrorhandler_(void (*handler)(MPI_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), PetscCtx ctx, PetscErrorCode *ierr)
74 {
75 if ((PetscFortranCallbackFn *)handler == (PetscFortranCallbackFn *)petsctracebackerrorhandler_) *ierr = PetscPushErrorHandler(PetscTraceBackErrorHandler, NULL);
76 else {
77 f2 = handler;
78 *ierr = PetscPushErrorHandler(ourerrorhandler, ctx);
79 }
80 }
81
petscerror_(MPI_Fint * comm,PetscErrorCode * number,PetscErrorType * p,char * message,PETSC_FORTRAN_CHARLEN_T len)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)
petscerrorf_(PetscErrorCode * err,int * line,char * file,PETSC_FORTRAN_CHARLEN_T len)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
petscerrormpi_(PetscErrorCode * err,int * line,char * file,PETSC_FORTRAN_CHARLEN_T len)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
petscerrorf_(PetscErrorCode * err)115 PETSC_EXTERN void petscerrorf_(PetscErrorCode *err)
116 {
117 *err = PetscError(PETSC_COMM_SELF, 0, NULL, NULL, *err, PETSC_ERROR_REPEAT, NULL);
118 }
119
petscerrormpi_(PetscErrorCode * err)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