1: #include <petsc/private/ftnimpl.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 petscreturnerrorhandler_         PETSCRETURNERRORHANDLER
 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 petscreturnerrorhandler_         petscreturnerrorhandler
 20:   #define petscemacsclienterrorhandler_    petscemacsclienterrorhandler
 21:   #define petscattachdebuggererrorhandler_ petscattachdebuggererrorhandler
 22:   #define petscerror_                      petscerror
 23:   #define petscerrorf_                     petscerrorf
 24:   #define petscerrormpi_                   petscerrormpi
 25: #endif

 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);

 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, PetscCtx ctx)
 31: {
 32:   PetscErrorCode ierr = PETSC_SUCCESS;
 33:   size_t         len1, len2, len3;

 35:   ierr = PetscStrlen(fun, &len1);
 36:   ierr = PetscStrlen(file, &len2);
 37:   ierr = PetscStrlen(mess, &len3);

 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: }

 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, PetscCtx ctx, PetscErrorCode *ierr);
 49: 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);
 50: 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);
 51: 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);
 52: PETSC_EXTERN void petscreturnerrorhandler_(MPI_Comm *comm, int *line, const char *fun, const char *file, PetscErrorCode *n, PetscErrorType *p, const char *mess, PetscCtx ctx, PetscErrorCode *ierr);

 54: 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)
 55: {
 56:   if ((PetscFortranCallbackFn *)handler == (PetscFortranCallbackFn *)petsctracebackerrorhandler_) *ierr = PetscPushErrorHandler(PetscTraceBackErrorHandler, NULL);
 57:   else {
 58:     f2    = handler;
 59:     *ierr = PetscPushErrorHandler(ourerrorhandler, ctx);
 60:   }
 61: }

 63: PETSC_EXTERN void petscerror_(MPI_Fint *comm, PetscErrorCode *number, PetscErrorType *p, char *message, PETSC_FORTRAN_CHARLEN_T len)
 64: {
 65:   PetscErrorCode nierr, *ierr = &nierr;
 66:   char          *t1;
 67:   FIXCHAR(message, len, t1);
 68:   nierr = PetscError(MPI_Comm_f2c(*(comm)), 0, NULL, NULL, *number, *p, "%s", t1);
 69:   FREECHAR(message, t1);
 70: }

 72: #if defined(PETSC_HAVE_FORTRAN_FREE_LINE_LENGTH_NONE)
 73: PETSC_EXTERN void petscerrorf_(PetscErrorCode *err, int *line, char *file, PETSC_FORTRAN_CHARLEN_T len)
 74: {
 75:   char          *tfile;
 76:   PetscErrorCode ierr[] = {PETSC_SUCCESS}; /* needed by FIXCHAR */

 78:   FIXCHAR(file, len, tfile);
 79:   *err = PetscError(PETSC_COMM_SELF, *line, NULL, tfile, *err, PETSC_ERROR_REPEAT, NULL);
 80:   FREECHAR(file, tfile);
 81: }

 83: PETSC_EXTERN void petscerrormpi_(PetscErrorCode *err, int *line, char *file, PETSC_FORTRAN_CHARLEN_T len)
 84: {
 85:   char           errorstring[2 * MPI_MAX_ERROR_STRING];
 86:   char          *tfile;
 87:   PetscErrorCode ierr[] = {PETSC_SUCCESS}; /* needed by FIXCHAR */

 89:   FIXCHAR(file, len, tfile);
 90:   PetscMPIErrorString(*err, 2 * MPI_MAX_ERROR_STRING, errorstring);
 91:   *err = PetscError(PETSC_COMM_SELF, *line, NULL, file, PETSC_ERR_MPI, PETSC_ERROR_INITIAL, "MPI error %d %s", *err, errorstring);
 92:   FREECHAR(file, tfile);
 93:   *err = PETSC_ERR_MPI;
 94: }
 95: #else
 96: PETSC_EXTERN void petscerrorf_(PetscErrorCode *err)
 97: {
 98:   *err = PetscError(PETSC_COMM_SELF, 0, NULL, NULL, *err, PETSC_ERROR_REPEAT, NULL);
 99: }

101: PETSC_EXTERN void petscerrormpi_(PetscErrorCode *err)
102: {
103:   char errorstring[2 * MPI_MAX_ERROR_STRING];

105:   PetscMPIErrorString(*err, 2 * MPI_MAX_ERROR_STRING, errorstring);
106:   *err = PetscError(PETSC_COMM_SELF, 0, NULL, NULL, PETSC_ERR_MPI, PETSC_ERROR_INITIAL, "MPI error %d %s", *err, errorstring);
107:   *err = PETSC_ERR_MPI;
108: }
109: #endif