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