1382167b7SJed Brown #include <petsc-private/fortranimpl.h> 2382167b7SJed Brown #include <petsc-private/snesimpl.h> 3382167b7SJed Brown #if defined(PETSC_HAVE_FORTRAN_CAPS) 4382167b7SJed Brown #define dmsnessetjacobian_ DMSNESSETJACOBIAN 5382167b7SJed Brown #define dmsnessetfunction_ DMSNESSETFUNCTION 6382167b7SJed Brown #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 7382167b7SJed Brown #define dmsnessetjacobian_ dmsnessetjacobian 8382167b7SJed Brown #define dmsnessetfunction_ dmsnessetfunction 9382167b7SJed Brown #endif 10382167b7SJed Brown 11382167b7SJed Brown static struct { 12382167b7SJed Brown PetscFortranCallbackId snesfunction; 13382167b7SJed Brown PetscFortranCallbackId snesjacobian; 14382167b7SJed Brown } _cb; 15382167b7SJed Brown 16382167b7SJed Brown #undef __FUNCT__ 17382167b7SJed Brown #define __FUNCT__ "ourj" 18*d1e9a80fSBarry Smith static PetscErrorCode ourj(SNES snes, Vec X, Mat J, Mat P, void *ptr) 19382167b7SJed Brown { 20382167b7SJed Brown PetscErrorCode ierr; 21*d1e9a80fSBarry Smith void (PETSC_STDCALL *func)(SNES*,Vec*,Mat*,Mat*,void*,PetscErrorCode*),*ctx; 22382167b7SJed Brown DM dm; 23382167b7SJed Brown DMSNES sdm; 24382167b7SJed Brown 25382167b7SJed Brown PetscFunctionBegin; 26382167b7SJed Brown ierr = SNESGetDM(snes,&dm);CHKERRQ(ierr); 27382167b7SJed Brown ierr = DMGetDMSNES(dm, &sdm);CHKERRQ(ierr); 28382167b7SJed Brown ierr = PetscObjectGetFortranCallback((PetscObject) sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.snesjacobian, (PetscVoidFunction *) &func, &ctx);CHKERRQ(ierr); 29*d1e9a80fSBarry Smith (*func)(&snes, &X, &J, &P, ctx, &ierr);CHKERRQ(ierr); 30382167b7SJed Brown PetscFunctionReturn(0); 31382167b7SJed Brown } 32382167b7SJed Brown 33*d1e9a80fSBarry Smith PETSC_EXTERN void PETSC_STDCALL dmsnessetjacobian_(DM *dm, void (PETSC_STDCALL *jac)(DM*,Vec*,Mat*,Mat*,void*,PetscErrorCode*), void *ctx, PetscErrorCode *ierr) 34382167b7SJed Brown { 35382167b7SJed Brown DMSNES sdm; 36382167b7SJed Brown 37382167b7SJed Brown *ierr = DMGetDMSNESWrite(*dm, &sdm); if (*ierr) return; 38382167b7SJed Brown *ierr = PetscObjectSetFortranCallback((PetscObject) sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, &_cb.snesjacobian, (PetscVoidFunction) jac, ctx); if (*ierr) return; 39382167b7SJed Brown *ierr = DMSNESSetJacobian(*dm, ourj, NULL); 40382167b7SJed Brown } 41382167b7SJed Brown 42382167b7SJed Brown #undef __FUNCT__ 43382167b7SJed Brown #define __FUNCT__ "ourf" 44382167b7SJed Brown static PetscErrorCode ourf(SNES snes, Vec X, Vec F, void *ptr) 45382167b7SJed Brown { 46382167b7SJed Brown PetscErrorCode ierr; 47382167b7SJed Brown void (PETSC_STDCALL *func)(SNES*,Vec*,Vec*,void*,PetscErrorCode*), *ctx; 48382167b7SJed Brown DM dm; 49382167b7SJed Brown DMSNES sdm; 50382167b7SJed Brown 51382167b7SJed Brown PetscFunctionBegin; 52382167b7SJed Brown ierr = SNESGetDM(snes,&dm);CHKERRQ(ierr); 53382167b7SJed Brown ierr = DMGetDMSNES(dm, &sdm);CHKERRQ(ierr); 54382167b7SJed Brown ierr = PetscObjectGetFortranCallback((PetscObject) sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.snesfunction, (PetscVoidFunction *) &func, &ctx);CHKERRQ(ierr); 55382167b7SJed Brown (*func)(&snes, &X, &F, ctx, &ierr);CHKERRQ(ierr); 56382167b7SJed Brown PetscFunctionReturn(0); 57382167b7SJed Brown } 58382167b7SJed Brown 59382167b7SJed Brown PETSC_EXTERN void PETSC_STDCALL dmsnessetfunction_(DM *dm, void (PETSC_STDCALL *func)(SNES*,Vec*,Vec*,void*,PetscErrorCode*), void *ctx, PetscErrorCode *ierr) 60382167b7SJed Brown { 61382167b7SJed Brown DMSNES sdm; 62382167b7SJed Brown 63382167b7SJed Brown *ierr = DMGetDMSNESWrite(*dm, &sdm); if (*ierr) return; 64382167b7SJed Brown *ierr = PetscObjectSetFortranCallback((PetscObject) sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, &_cb.snesfunction, (PetscVoidFunction) func, ctx); if (*ierr) return; 65382167b7SJed Brown *ierr = DMSNESSetFunction(*dm, ourf, NULL); 66382167b7SJed Brown } 67