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 #undef __FUNCT__ 17 #define __FUNCT__ "ourj" 18 static PetscErrorCode ourj(SNES snes, Vec X, Mat J, Mat P, void *ptr) 19 { 20 PetscErrorCode ierr; 21 void (PETSC_STDCALL *func)(SNES*,Vec*,Mat*,Mat*,void*,PetscErrorCode*),*ctx; 22 DM dm; 23 DMSNES sdm; 24 25 PetscFunctionBegin; 26 ierr = SNESGetDM(snes,&dm);CHKERRQ(ierr); 27 ierr = DMGetDMSNES(dm, &sdm);CHKERRQ(ierr); 28 ierr = PetscObjectGetFortranCallback((PetscObject) sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.snesjacobian, (PetscVoidFunction *) &func, &ctx);CHKERRQ(ierr); 29 (*func)(&snes, &X, &J, &P, ctx, &ierr);CHKERRQ(ierr); 30 PetscFunctionReturn(0); 31 } 32 33 PETSC_EXTERN void PETSC_STDCALL dmsnessetjacobian_(DM *dm, void (PETSC_STDCALL *jac)(DM*,Vec*,Mat*,Mat*,void*,PetscErrorCode*), void *ctx, PetscErrorCode *ierr) 34 { 35 DMSNES sdm; 36 37 *ierr = DMGetDMSNESWrite(*dm, &sdm); if (*ierr) return; 38 *ierr = PetscObjectSetFortranCallback((PetscObject) sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, &_cb.snesjacobian, (PetscVoidFunction) jac, ctx); if (*ierr) return; 39 *ierr = DMSNESSetJacobian(*dm, ourj, NULL); 40 } 41 42 #undef __FUNCT__ 43 #define __FUNCT__ "ourf" 44 static PetscErrorCode ourf(SNES snes, Vec X, Vec F, void *ptr) 45 { 46 PetscErrorCode ierr; 47 void (PETSC_STDCALL *func)(SNES*,Vec*,Vec*,void*,PetscErrorCode*), *ctx; 48 DM dm; 49 DMSNES sdm; 50 51 PetscFunctionBegin; 52 ierr = SNESGetDM(snes,&dm);CHKERRQ(ierr); 53 ierr = DMGetDMSNES(dm, &sdm);CHKERRQ(ierr); 54 ierr = PetscObjectGetFortranCallback((PetscObject) sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, _cb.snesfunction, (PetscVoidFunction *) &func, &ctx);CHKERRQ(ierr); 55 (*func)(&snes, &X, &F, ctx, &ierr);CHKERRQ(ierr); 56 PetscFunctionReturn(0); 57 } 58 59 PETSC_EXTERN void PETSC_STDCALL dmsnessetfunction_(DM *dm, void (PETSC_STDCALL *func)(SNES*,Vec*,Vec*,void*,PetscErrorCode*), void *ctx, PetscErrorCode *ierr) 60 { 61 DMSNES sdm; 62 63 *ierr = DMGetDMSNESWrite(*dm, &sdm); if (*ierr) return; 64 *ierr = PetscObjectSetFortranCallback((PetscObject) sdm, PETSC_FORTRAN_CALLBACK_SUBTYPE, &_cb.snesfunction, (PetscVoidFunction) func, ctx); if (*ierr) return; 65 *ierr = DMSNESSetFunction(*dm, ourf, NULL); 66 } 67