Date: 2025-03-28T21:11:11+00:00

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