Actual source code: zgmres2f.c

      1: #include <petsc/private/ftnimpl.h>
      2: #include <petscksp.h>

      4: #if defined(PETSC_HAVE_FORTRAN_CAPS)
      5:   #define kspgmressetorthogonalization_                  KSPGMRESSETORTHOGONALIZATION
      6:   #define kspgmresmodifiedgramschmidtorthogonalization_  KSPGMRESMODIFIEDGRAMSCHMIDTORTHOGONALIZATION
      7:   #define kspgmresclassicalgramschmidtorthogonalization_ KSPGMRESCLASSICALGRAMSCHMIDTORTHOGONALIZATION
      8: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
      9:   #define kspgmressetorthogonalization_                  kspgmressetorthogonalization
     10:   #define kspgmresmodifiedgramschmidtorthogonalization_  kspgmresmodifiedgramschmidtorthogonalization
     11:   #define kspgmresclassicalgramschmidtorthogonalization_ kspgmresclassicalgramschmidtorthogonalization
     12: #endif

     14: static struct {
     15:   PetscFortranCallbackId orthog;
     16: } _cb;

     18: PETSC_EXTERN void kspgmresmodifiedgramschmidtorthogonalization_(KSP *, PetscInt *, PetscErrorCode *);
     19: PETSC_EXTERN void kspgmresclassicalgramschmidtorthogonalization_(KSP *, PetscInt *, PetscErrorCode *);

     21: static PetscErrorCode ourorthog(KSP ksp, PetscInt n)
     22: {
     23:   PetscObjectUseFortranCallback(ksp, _cb.orthog, (KSP *, PetscInt *, PetscErrorCode *), (&ksp, &n, &ierr));
     24: }

     26: PETSC_EXTERN void kspgmressetorthogonalization_(KSP *ksp, void (*orthog)(KSP *, PetscInt *, PetscErrorCode *), PetscErrorCode *ierr)
     27: {
     28:   if (orthog == kspgmresmodifiedgramschmidtorthogonalization_) {
     29:     *ierr = KSPGMRESSetOrthogonalization(*ksp, KSPGMRESModifiedGramSchmidtOrthogonalization);
     30:   } else if (orthog == kspgmresclassicalgramschmidtorthogonalization_) {
     31:     *ierr = KSPGMRESSetOrthogonalization(*ksp, KSPGMRESClassicalGramSchmidtOrthogonalization);
     32:   } else {
     33:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ksp, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.orthog, (PetscFortranCallbackFn *)orthog, NULL);
     34:     if (*ierr) return;
     35:     *ierr = KSPGMRESSetOrthogonalization(*ksp, ourorthog);
     36:   }
     37: }