1 #include <petsc/private/ftnimpl.h>
2 #include <petsc/private/snesimpl.h>
3 #if defined(PETSC_HAVE_FORTRAN_CAPS)
4 #define dmsnessetjacobianlocal_ DMSNESSETJACOBIANLOCAL
5 #define dmsnessetfunctionlocal_ DMSNESSETFUNCTIONLOCAL
6 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
7 #define dmsnessetjacobianlocal_ dmsnessetjacobianlocal
8 #define dmsnessetfunctionlocal_ dmsnessetfunctionlocal
9 #endif
10
11 static struct {
12 PetscFortranCallbackId lf;
13 PetscFortranCallbackId lj;
14 } _cb;
15
sourlj(DM dm,Vec X,Mat J,Mat P,void * ptr)16 static PetscErrorCode sourlj(DM dm, Vec X, Mat J, Mat P, void *ptr)
17 {
18 void (*func)(DM *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), *ctx;
19 DMSNES sdm;
20
21 PetscFunctionBegin;
22 PetscCall(DMGetDMSNES(dm, &sdm));
23 PetscCall(PetscObjectGetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.lj, (PetscFortranCallbackFn **)&func, &ctx));
24 PetscCallFortranVoidFunction((*func)(&dm, &X, &J, &P, ctx, &ierr));
25 PetscFunctionReturn(PETSC_SUCCESS);
26 }
27
dmsnessetjacobianlocal_(DM * dm,void (* jac)(DM *,Vec *,Mat *,Mat *,void *,PetscErrorCode *),PetscCtx ctx,PetscErrorCode * ierr)28 PETSC_EXTERN void dmsnessetjacobianlocal_(DM *dm, void (*jac)(DM *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), PetscCtx ctx, PetscErrorCode *ierr)
29 {
30 DMSNES sdm;
31
32 *ierr = DMGetDMSNESWrite(*dm, &sdm);
33 if (*ierr) return;
34 *ierr = PetscObjectSetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, &_cb.lj, (PetscFortranCallbackFn *)jac, ctx);
35 if (*ierr) return;
36 *ierr = DMSNESSetJacobianLocal(*dm, sourlj, NULL);
37 }
38
sourlf(DM dm,Vec X,Vec F,void * ptr)39 static PetscErrorCode sourlf(DM dm, Vec X, Vec F, void *ptr)
40 {
41 void (*func)(DM *, Vec *, Vec *, void *, PetscErrorCode *), *ctx;
42 DMSNES sdm;
43
44 PetscFunctionBegin;
45 PetscCall(DMGetDMSNES(dm, &sdm));
46 PetscCall(PetscObjectGetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.lf, (PetscFortranCallbackFn **)&func, &ctx));
47 PetscCallFortranVoidFunction((*func)(&dm, &X, &F, ctx, &ierr));
48 PetscFunctionReturn(PETSC_SUCCESS);
49 }
50
dmsnessetfunctionlocal_(DM * dm,void (* func)(DM *,Vec *,Vec *,void *,PetscErrorCode *),PetscCtx ctx,PetscErrorCode * ierr)51 PETSC_EXTERN void dmsnessetfunctionlocal_(DM *dm, void (*func)(DM *, Vec *, Vec *, void *, PetscErrorCode *), PetscCtx ctx, PetscErrorCode *ierr)
52 {
53 DMSNES sdm;
54
55 *ierr = DMGetDMSNESWrite(*dm, &sdm);
56 if (*ierr) return;
57 *ierr = PetscObjectSetFortranCallback((PetscObject)sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, &_cb.lf, (PetscFortranCallbackFn *)func, ctx);
58 if (*ierr) return;
59 *ierr = DMSNESSetFunctionLocal(*dm, sourlf, NULL);
60 }
61