Actual source code: zdmsnesf.c

      1: #include <petsc/private/ftnimpl.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, (PetscFortranCallbackFn **)&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 *), PetscCtx 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, (PetscFortranCallbackFn *)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, (PetscFortranCallbackFn **)&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 *), PetscCtx 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, (PetscFortranCallbackFn *)func, ctx);
     62:   if (*ierr) return;
     63:   *ierr = DMSNESSetFunction(*dm, ourf, NULL);
     64: }