1*382167b7SJed Brown #include <petsc-private/fortranimpl.h> 2*382167b7SJed Brown #include <petsc-private/snesimpl.h> 3*382167b7SJed Brown #if defined(PETSC_HAVE_FORTRAN_CAPS) 4*382167b7SJed Brown #define dmsnessetjacobian_ DMSNESSETJACOBIAN 5*382167b7SJed Brown #define dmsnessetfunction_ DMSNESSETFUNCTION 6*382167b7SJed Brown #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 7*382167b7SJed Brown #define dmsnessetjacobian_ dmsnessetjacobian 8*382167b7SJed Brown #define dmsnessetfunction_ dmsnessetfunction 9*382167b7SJed Brown #endif 10*382167b7SJed Brown 11*382167b7SJed Brown static struct { 12*382167b7SJed Brown PetscFortranCallbackId snesfunction; 13*382167b7SJed Brown PetscFortranCallbackId snesjacobian; 14*382167b7SJed Brown } _cb; 15*382167b7SJed Brown 16*382167b7SJed Brown #undef __FUNCT__ 17*382167b7SJed Brown #define __FUNCT__ "ourj" 18*382167b7SJed Brown static PetscErrorCode ourj(SNES snes, Vec X, Mat *J, Mat *P, MatStructure *str, void *ptr) 19*382167b7SJed Brown { 20*382167b7SJed Brown PetscErrorCode ierr; 21*382167b7SJed Brown void (PETSC_STDCALL *func)(SNES*,Vec*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*),*ctx; 22*382167b7SJed Brown DM dm; 23*382167b7SJed Brown DMSNES sdm; 24*382167b7SJed Brown 25*382167b7SJed Brown PetscFunctionBegin; 26*382167b7SJed Brown ierr = SNESGetDM(snes,&dm);CHKERRQ(ierr); 27*382167b7SJed Brown ierr = DMGetDMSNES(dm, &sdm);CHKERRQ(ierr); 28*382167b7SJed Brown ierr = PetscObjectGetFortranCallback((PetscObject) sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.snesjacobian, (PetscVoidFunction *) &func, &ctx);CHKERRQ(ierr); 29*382167b7SJed Brown (*func)(&snes, &X, J, P, str, ctx, &ierr);CHKERRQ(ierr); 30*382167b7SJed Brown PetscFunctionReturn(0); 31*382167b7SJed Brown } 32*382167b7SJed Brown 33*382167b7SJed Brown PETSC_EXTERN void PETSC_STDCALL dmsnessetjacobian_(DM *dm, void (PETSC_STDCALL *jac)(DM*,Vec*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*), void *ctx, PetscErrorCode *ierr) 34*382167b7SJed Brown { 35*382167b7SJed Brown DMSNES sdm; 36*382167b7SJed Brown 37*382167b7SJed Brown *ierr = DMGetDMSNESWrite(*dm, &sdm); if (*ierr) return; 38*382167b7SJed Brown *ierr = PetscObjectSetFortranCallback((PetscObject) sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, &_cb.snesjacobian, (PetscVoidFunction) jac, ctx); if (*ierr) return; 39*382167b7SJed Brown *ierr = DMSNESSetJacobian(*dm, ourj, NULL); 40*382167b7SJed Brown } 41*382167b7SJed Brown 42*382167b7SJed Brown #undef __FUNCT__ 43*382167b7SJed Brown #define __FUNCT__ "ourf" 44*382167b7SJed Brown static PetscErrorCode ourf(SNES snes, Vec X, Vec F, void *ptr) 45*382167b7SJed Brown { 46*382167b7SJed Brown PetscErrorCode ierr; 47*382167b7SJed Brown void (PETSC_STDCALL *func)(SNES*,Vec*,Vec*,void*,PetscErrorCode*), *ctx; 48*382167b7SJed Brown DM dm; 49*382167b7SJed Brown DMSNES sdm; 50*382167b7SJed Brown 51*382167b7SJed Brown PetscFunctionBegin; 52*382167b7SJed Brown ierr = SNESGetDM(snes,&dm);CHKERRQ(ierr); 53*382167b7SJed Brown ierr = DMGetDMSNES(dm, &sdm);CHKERRQ(ierr); 54*382167b7SJed Brown ierr = PetscObjectGetFortranCallback((PetscObject) sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.snesfunction, (PetscVoidFunction *) &func, &ctx);CHKERRQ(ierr); 55*382167b7SJed Brown (*func)(&snes, &X, &F, ctx, &ierr);CHKERRQ(ierr); 56*382167b7SJed Brown PetscFunctionReturn(0); 57*382167b7SJed Brown } 58*382167b7SJed Brown 59*382167b7SJed Brown PETSC_EXTERN void PETSC_STDCALL dmsnessetfunction_(DM *dm, void (PETSC_STDCALL *func)(SNES*,Vec*,Vec*,void*,PetscErrorCode*), void *ctx, PetscErrorCode *ierr) 60*382167b7SJed Brown { 61*382167b7SJed Brown DMSNES sdm; 62*382167b7SJed Brown 63*382167b7SJed Brown *ierr = DMGetDMSNESWrite(*dm, &sdm); if (*ierr) return; 64*382167b7SJed Brown *ierr = PetscObjectSetFortranCallback((PetscObject) sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, &_cb.snesfunction, (PetscVoidFunction) func, ctx); if (*ierr) return; 65*382167b7SJed Brown *ierr = DMSNESSetFunction(*dm, ourf, NULL); 66*382167b7SJed Brown } 67