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