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

 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, void *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, void *ctx, PetscErrorCode *ierr)
 49: {
 50:   *ierr = PetscTraceBackErrorHandler(*comm, *line, fun, file, *n, *p, mess, ctx);
 51: }

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

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

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

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

 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 ((void (*)(void))handler == (void (*)(void))petsctracebackerrorhandler_) *ierr = PetscPushErrorHandler(PetscTraceBackErrorHandler, NULL);
 76:   else {
 77:     f2    = handler;
 78:     *ierr = PetscPushErrorHandler(ourerrorhandler, ctx);
 79:   }
 80: }

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

 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 */

 97:   FIXCHAR(file, len, tfile);
 98:   *err = PetscError(PETSC_COMM_SELF, *line, NULL, tfile, *err, PETSC_ERROR_REPEAT, NULL);
 99:   FREECHAR(file, tfile);
100: }

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 */

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

120: PETSC_EXTERN void petscerrormpi_(PetscErrorCode *err)
121: {
122:   char errorstring[2 * MPI_MAX_ERROR_STRING];

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