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