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 10 11 static struct { 12 PetscFortranCallbackId snesfunction; 13 PetscFortranCallbackId snesjacobian; 14 } _cb; 15 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, (PetscVoidFn **)&func, &ctx)); 26 PetscCallFortranVoidFunction((*func)(&snes, &X, &J, &P, ctx, &ierr)); 27 PetscFunctionReturn(PETSC_SUCCESS); 28 } 29 30 PETSC_EXTERN void dmsnessetjacobian_(DM *dm, void (*jac)(DM *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *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, (PetscVoidFn *)jac, ctx); 37 if (*ierr) return; 38 *ierr = DMSNESSetJacobian(*dm, ourj, NULL); 39 } 40 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, (PetscVoidFn **)&func, &ctx)); 51 PetscCallFortranVoidFunction((*func)(&snes, &X, &F, ctx, &ierr)); 52 PetscFunctionReturn(PETSC_SUCCESS); 53 } 54 55 PETSC_EXTERN void dmsnessetfunction_(DM *dm, void (*func)(SNES *, Vec *, Vec *, void *, PetscErrorCode *), void *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, (PetscVoidFn *)func, ctx); 62 if (*ierr) return; 63 *ierr = DMSNESSetFunction(*dm, ourf, NULL); 64 } 65