Actual source code: zerrf.c

      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