Actual source code: zsys.c

  1: #include <petsc/private/fortranimpl.h>

  3: #if defined(PETSC_HAVE_FORTRAN_CAPS)
  4:   #define chkmemfortran_                     CHKMEMFORTRAN
  5:   #define petscoffsetfortran_                PETSCOFFSETFORTRAN
  6:   #define petscobjectstateincrease_          PETSCOBJECTSTATEINCREASE
  7:   #define petsccienabledportableerroroutput_ PETSCCIENABLEDPORTABLEERROROUTPUT
  8: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
  9:   #define petscoffsetfortran_                petscoffsetfortran
 10:   #define chkmemfortran_                     chkmemfortran
 11:   #define flush__                            flush_
 12:   #define petscobjectstateincrease_          petscobjectstateincrease
 13:   #define petsccienabledportableerroroutput_ petsccienabledportableerroroutput
 14: #endif

 16: PETSC_EXTERN void petsccienabledportableerroroutput_(PetscMPIInt *cienabled)
 17: {
 18:   *cienabled = PetscCIEnabledPortableErrorOutput ? 1 : 0;
 19: }

 21: PETSC_EXTERN void petscobjectstateincrease_(PetscObject *obj, PetscErrorCode *ierr)
 22: {
 23:   *ierr = PetscObjectStateIncrease(*obj);
 24: }

 26: #if defined(PETSC_MISSING_FORTRAN_FLUSH_)
 27: void flush__(int unit) { }
 28: #endif

 30: PETSC_EXTERN void petscoffsetfortran_(PetscScalar *x, PetscScalar *y, size_t *shift, PetscErrorCode *ierr)
 31: {
 32:   *ierr  = PETSC_SUCCESS;
 33:   *shift = y - x;
 34: }

 36: /* ---------------------------------------------------------------------------------*/
 37: /*
 38:         This version does not do a malloc
 39: */
 40: static char FIXCHARSTRING[1024];

 42: #define FIXCHARNOMALLOC(a, n, b) \
 43:   do { \
 44:     if (a == PETSC_NULL_CHARACTER_Fortran) { \
 45:       b = a = NULL; \
 46:     } else { \
 47:       while ((n > 0) && (a[n - 1] == ' ')) n--; \
 48:       if (a[n] != 0) { \
 49:         b     = FIXCHARSTRING; \
 50:         *ierr = PetscStrncpy(b, a, n + 1); \
 51:         if (*ierr) return; \
 52:       } else b = a; \
 53:     } \
 54:   } while (0)

 56: PETSC_EXTERN void chkmemfortran_(int *line, char *file, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len)
 57: {
 58:   char *c1;

 60:   FIXCHARNOMALLOC(file, len, c1);
 61:   *ierr = PetscMallocValidate(*line, "Userfunction", c1);
 62: }