Actual source code: zdmsnesf.c

  1: #include <petsc/private/fortranimpl.h>
  2: #include <petsc/private/snesimpl.h>
  3: #if defined(PETSC_HAVE_FORTRAN_CAPS)
  4:   #define dmsnessetjacobian_ DMSNESSETJACOBIAN
  5:   #define dmsnessetfunction_ DMSNESSETFUNCTION
  6: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
  7:   #define dmsnessetjacobian_ dmsnessetjacobian
  8:   #define dmsnessetfunction_ dmsnessetfunction
  9: #endif

 11: static struct {
 12:   PetscFortranCallbackId snesfunction;
 13:   PetscFortranCallbackId snesjacobian;
 14: } _cb;

 16: static PetscErrorCode ourj(SNES snes, Vec X, Mat J, Mat P, void *ptr)
 17: {
 18:   void (*func)(SNES *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), *ctx;
 19:   DM     dm;
 20:   DMSNES sdm;

 22:   PetscFunctionBegin;
 23:   PetscCall(SNESGetDM(snes, &dm));
 24:   PetscCall(DMGetDMSNES(dm, &sdm));
 25:   PetscCall(PetscObjectGetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.snesjacobian, (PetscVoidFn **)&func, &ctx));
 26:   PetscCallFortranVoidFunction((*func)(&snes, &X, &J, &P, ctx, &ierr));
 27:   PetscFunctionReturn(PETSC_SUCCESS);
 28: }

 30: PETSC_EXTERN void dmsnessetjacobian_(DM *dm, void (*jac)(DM *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
 31: {
 32:   DMSNES sdm;

 34:   *ierr = DMGetDMSNESWrite(*dm, &sdm);
 35:   if (*ierr) return;
 36:   *ierr = PetscObjectSetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, &_cb.snesjacobian, (PetscVoidFn *)jac, ctx);
 37:   if (*ierr) return;
 38:   *ierr = DMSNESSetJacobian(*dm, ourj, NULL);
 39: }

 41: static PetscErrorCode ourf(SNES snes, Vec X, Vec F, void *ptr)
 42: {
 43:   void (*func)(SNES *, Vec *, Vec *, void *, PetscErrorCode *), *ctx;
 44:   DM     dm;
 45:   DMSNES sdm;

 47:   PetscFunctionBegin;
 48:   PetscCall(SNESGetDM(snes, &dm));
 49:   PetscCall(DMGetDMSNES(dm, &sdm));
 50:   PetscCall(PetscObjectGetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.snesfunction, (PetscVoidFn **)&func, &ctx));
 51:   PetscCallFortranVoidFunction((*func)(&snes, &X, &F, ctx, &ierr));
 52:   PetscFunctionReturn(PETSC_SUCCESS);
 53: }

 55: PETSC_EXTERN void dmsnessetfunction_(DM *dm, void (*func)(SNES *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
 56: {
 57:   DMSNES sdm;

 59:   *ierr = DMGetDMSNESWrite(*dm, &sdm);
 60:   if (*ierr) return;
 61:   *ierr = PetscObjectSetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, &_cb.snesfunction, (PetscVoidFn *)func, ctx);
 62:   if (*ierr) return;
 63:   *ierr = DMSNESSetFunction(*dm, ourf, NULL);
 64: }