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