1: #include <petsc/private/ftnimpl.h>
  2: #include <petscpc.h>
  3: #include <petsc/private/pcmgimpl.h>

  5: #if PetscDefined(HAVE_FORTRAN_CAPS)
  6:   #define pcmgsetresidual_              PCMGSETRESIDUAL
  7:   #define pcmgresidualdefault_          PCMGRESIDUALDEFAULT
  8:   #define pcmgsetresidualtranspose_     PCMGSETRESIDUALTRANSPOSE
  9:   #define pcmgresidualtransposedefault_ PCMGRESIDUALTRANSPOSEDEFAULT
 10: #elif !PetscDefined(HAVE_FORTRAN_UNDERSCORE)
 11:   #define pcmgsetresidual_              pcmgsetresidual
 12:   #define pcmgresidualdefault_          pcmgresidualdefault
 13:   #define pcmgsetresidualtranspose_     pcmgsetresidualtranspose
 14:   #define pcmgresidualtransposedefault_ pcmgresidualtransposedefault
 15: #endif

 17: typedef PetscErrorCode (*MVVVV)(Mat, Vec, Vec, Vec);

 19: static struct {
 20:   PetscFortranCallbackId residual;
 21:   PetscFortranCallbackId residualtranspose;
 22: } _cb;

 24: static PetscErrorCode ourresidualfunction(Mat mat, Vec b, Vec x, Vec R)
 25: {
 26:   PetscObjectUseFortranCallback(mat, _cb.residual, (Mat *, Vec *, Vec *, Vec *, PetscErrorCode *), (&mat, &b, &x, &R, &ierr));
 27: }

 29: PETSC_EXTERN void pcmgresidualdefault_(Mat *, Vec *, Vec *, Vec *, PetscErrorCode *);

 31: PETSC_EXTERN void pcmgsetresidual_(PC *pc, PetscInt *l, void (*residual)(Mat *, Vec *, Vec *, Vec *, PetscErrorCode *), Mat *mat, PetscErrorCode *ierr)
 32: {
 33:   MVVVV rr;

 35:   CHKFORTRANNULLFUNCTION(residual);
 36:   if (!residual) rr = NULL;
 37:   else if (residual == pcmgresidualdefault_) rr = PCMGResidualDefault;
 38:   else {
 39:     /* The Mat is the only object passed to the residual computer. A keyed callback is used so that this does not collide with
 40:        the Fortran callbacks of a MATSHELL or MATMFFD, which are stored in fortran_func_pointers[] */
 41:     *ierr = PetscObjectSetFortranCallback((PetscObject)*mat, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.residual, (PetscFortranCallbackFn *)residual, NULL);
 42:     if (*ierr) return;
 43:     rr = ourresidualfunction;
 44:   }
 45:   *ierr = PCMGSetResidual(*pc, *l, rr, *mat);
 46: }

 48: static PetscErrorCode ourresidualtransposefunction(Mat mat, Vec b, Vec x, Vec R)
 49: {
 50:   PetscObjectUseFortranCallback(mat, _cb.residualtranspose, (Mat *, Vec *, Vec *, Vec *, PetscErrorCode *), (&mat, &b, &x, &R, &ierr));
 51: }

 53: PETSC_EXTERN void pcmgresidualtransposedefault_(Mat *, Vec *, Vec *, Vec *, PetscErrorCode *);

 55: PETSC_EXTERN void pcmgsetresidualtranspose_(PC *pc, PetscInt *l, void (*residualt)(Mat *, Vec *, Vec *, Vec *, PetscErrorCode *), Mat *mat, PetscErrorCode *ierr)
 56: {
 57:   MVVVV rr;

 59:   CHKFORTRANNULLFUNCTION(residualt);
 60:   if (!residualt) rr = NULL;
 61:   else if (residualt == pcmgresidualtransposedefault_) rr = PCMGResidualTransposeDefault;
 62:   else {
 63:     *ierr = PetscObjectSetFortranCallback((PetscObject)*mat, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.residualtranspose, (PetscFortranCallbackFn *)residualt, NULL);
 64:     if (*ierr) return;
 65:     rr = ourresidualtransposefunction;
 66:   }
 67:   *ierr = PCMGSetResidualTranspose(*pc, *l, rr, *mat);
 68: }