Actual source code: zerrf.c
1: #include <petsc/private/fortranimpl.h>
2: #include <petscsys.h>
3: #include <petscviewer.h>
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
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);
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;
39: ierr = PetscStrlen(fun, &len1);
40: ierr = PetscStrlen(file, &len2);
41: ierr = PetscStrlen(mess, &len3);
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: }
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: }
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: }
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: }
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: }
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: }
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, NULL);
80: else {
81: f2 = handler;
82: *ierr = PetscPushErrorHandler(ourerrorhandler, ctx);
83: }
84: }
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: }
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 */
101: FIXCHAR(file, len, tfile);
102: *err = PetscError(PETSC_COMM_SELF, *line, NULL, tfile, *err, PETSC_ERROR_REPEAT, NULL);
103: FREECHAR(file, tfile);
104: }
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 */
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: }
124: PETSC_EXTERN void petscerrormpi_(PetscErrorCode *err)
125: {
126: char errorstring[2 * MPI_MAX_ERROR_STRING];
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
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: }
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: }
148: #if defined(PETSC_HAVE_FORTRAN_CAPS)
149: #define petscscalarview_ PETSCSCALARVIEW
150: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
151: #define petscscalarview_ petscscalarview
152: #endif
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: }