1 #include <petsc/private/fortranimpl.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 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, (PetscVoidFunction *)&func, &ctx)); 24 PetscCallFortranVoidFunction((*func)(&dm, &X, &J, &P, ctx, &ierr)); 25 PetscFunctionReturn(PETSC_SUCCESS); 26 } 27 28 PETSC_EXTERN void dmsnessetjacobianlocal_(DM *dm, void (*jac)(DM *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *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, (PetscVoidFunction)jac, ctx); 35 if (*ierr) return; 36 *ierr = DMSNESSetJacobianLocal(*dm, sourlj, NULL); 37 } 38 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, (PetscVoidFunction *)&func, &ctx)); 47 PetscCallFortranVoidFunction((*func)(&dm, &X, &F, ctx, &ierr)); 48 PetscFunctionReturn(PETSC_SUCCESS); 49 } 50 51 PETSC_EXTERN void dmsnessetfunctionlocal_(DM *dm, void (*func)(DM *, Vec *, Vec *, void *, PetscErrorCode *), void *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, (PetscVoidFunction)func, ctx); 58 if (*ierr) return; 59 *ierr = DMSNESSetFunctionLocal(*dm, sourlf, NULL); 60 } 61