xref: /petsc/src/sys/ftn-custom/zsys.c (revision 3920c838bce877c9bfcf827e2585c2b5af2c7263)

#include <petsc/private/fortranimpl.h>

#if defined(PETSC_HAVE_FORTRAN_CAPS)
#define chkmemfortran_              CHKMEMFORTRAN
#define petscoffsetfortran_         PETSCOFFSETFORTRAN
#define petscobjectstateincrease_   PETSCOBJECTSTATEINCREASE
#define petscobjectcomposefunction_ PETSCOBJECTCOMPOSEFUNCTION
#define petscobjectqueryfunction_   PETSCOBJECTQUERYFUNCTION
#elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
#define petscoffsetfortran_         petscoffsetfortran
#define chkmemfortran_              chkmemfortran
#define flush__                     flush_
#define petscobjectstateincrease_   petscobjectstateincrease
#define petscobjectcomposefunction_ petscobjectcomposefunction
#define petscobjectqueryfunction_   petscobjectqueryfunction
#endif

PETSC_EXTERN void PETSC_STDCALL petscobjectstateincrease_(PetscObject *obj, PetscErrorCode *ierr)
{
  *ierr = PetscObjectStateIncrease(*obj);
}

#if defined(PETSC_MISSING_FORTRAN_FLUSH_)
void flush__(int unit)
{
}
#endif


PETSC_EXTERN void PETSC_STDCALL petscoffsetfortran_(PetscScalar *x,PetscScalar *y,size_t *shift,PetscErrorCode *ierr)
{
  *ierr  = 0;
  *shift = y - x;
}

/* ---------------------------------------------------------------------------------*/
/*
        This version does not do a malloc
*/
static char FIXCHARSTRING[1024];

#define FIXCHARNOMALLOC(a,n,b) \
{\
  if (a == PETSC_NULL_CHARACTER_Fortran) { \
    b = a = 0; \
  } else { \
    while ((n > 0) && (a[n-1] == ' ')) n--; \
    if (a[n] != 0) { \
      b = FIXCHARSTRING; \
      *ierr = PetscStrncpy(b,a,n+1); \
      if (*ierr) return; \
    } else b = a;\
  } \
}

PETSC_EXTERN void PETSC_STDCALL chkmemfortran_(int *line,char* file PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
{
  char *c1;

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

PETSC_EXTERN void PETSC_STDCALL petscobjectcomposefunction_(PetscObject *obj, char* name PETSC_MIXED_LEN(len), void (*fptr)(void), PetscErrorCode *ierr PETSC_END_LEN(len))
{
  char *c1;

  FIXCHARNOMALLOC(name,len,c1);
  *ierr = PetscObjectComposeFunction(*obj,name,**fptr);
}

PETSC_EXTERN void PETSC_STDCALL petscobjectqueryfunction_(PetscObject *obj, char* name PETSC_MIXED_LEN(len), void (**fptr)(void), PetscErrorCode *ierr PETSC_END_LEN(len))
{
  char *c1;

  FIXCHARNOMALLOC(name,len,c1);
  *ierr = PetscObjectQueryFunction(*obj,name,fptr);
}