Actual source code: zsys.c

  1: #include <petsc/private/ftnimpl.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 chkmemfortran_                     chkmemfortran
 10:   #define petscoffsetfortran_                petscoffsetfortran
 11:   #define petscobjectstateincrease_          petscobjectstateincrease
 12:   #define petsccienabledportableerroroutput_ petsccienabledportableerroroutput
 13: #endif

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

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

 25: PETSC_EXTERN void petscoffsetfortran_(PetscScalar *x, PetscScalar *y, size_t *shift, PetscErrorCode *ierr)
 26: {
 27:   *ierr  = PETSC_SUCCESS;
 28:   *shift = y - x;
 29: }

 31: /* ---------------------------------------------------------------------------------*/
 32: /*
 33:         This version does not do a malloc
 34: */
 35: static char FIXCHARSTRING[1024];

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

 51: PETSC_EXTERN void chkmemfortran_(int *line, char *file, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len)
 52: {
 53:   char *c1;

 55:   FIXCHARNOMALLOC(file, len, c1);
 56:   *ierr = PetscMallocValidate(*line, "Userfunction", c1);
 57: }