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