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
10
11 static struct {
12 PetscFortranCallbackId snesfunction;
13 PetscFortranCallbackId snesjacobian;
14 } _cb;
15
ourj(SNES snes,Vec X,Mat J,Mat P,void * ptr)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;
21
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 }
29
dmsnessetjacobian_(DM * dm,void (* jac)(DM *,Vec *,Mat *,Mat *,void *,PetscErrorCode *),PetscCtx ctx,PetscErrorCode * ierr)30 PETSC_EXTERN void dmsnessetjacobian_(DM *dm, void (*jac)(DM *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), PetscCtx ctx, PetscErrorCode *ierr)
31 {
32 DMSNES sdm;
33
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 }
40
ourf(SNES snes,Vec X,Vec F,void * ptr)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;
46
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 }
54
dmsnessetfunction_(DM * dm,void (* func)(SNES *,Vec *,Vec *,void *,PetscErrorCode *),PetscCtx ctx,PetscErrorCode * ierr)55 PETSC_EXTERN void dmsnessetfunction_(DM *dm, void (*func)(SNES *, Vec *, Vec *, void *, PetscErrorCode *), PetscCtx ctx, PetscErrorCode *ierr)
56 {
57 DMSNES sdm;
58
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 }
65