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: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
  8:   #define petscoffsetfortran_       petscoffsetfortran
  9:   #define chkmemfortran_            chkmemfortran
 10:   #define flush__                   flush_
 11:   #define petscobjectstateincrease_ petscobjectstateincrease
 12: #endif

 14: PETSC_EXTERN void petscobjectstateincrease_(PetscObject *obj, PetscErrorCode *ierr)
 15: {
 16:   *ierr = PetscObjectStateIncrease(*obj);
 17: }

 19: #if defined(PETSC_MISSING_FORTRAN_FLUSH_)
 20: void flush__(int unit) { }
 21: #endif

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

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

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

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

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