Actual source code: zitfuncf.c

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

  4: #if defined(PETSC_HAVE_FORTRAN_CAPS)
  5:   #define kspmonitorset_               KSPMONITORSET
  6:   #define kspconvergeddefaultcreate_   KSPCONVERGEDDEFAULTCREATE
  7:   #define kspconvergeddefaultdestroy_  KSPCONVERGEDDEFAULTDESTROY
  8:   #define kspsetconvergencetest_       KSPSETCONVERGENCETEST
  9:   #define kspconvergeddefault_         KSPCONVERGEDDEFAULT
 10:   #define kspconvergedskip_            KSPCONVERGEDSKIP
 11:   #define kspgmresmonitorkrylov_       KSPGMRESMONITORKRYLOV
 12:   #define kspmonitorresidual_          KSPMONITORRESIDUAL
 13:   #define kspmonitortrueresidual_      KSPMONITORTRUERESIDUAL
 14:   #define kspmonitorsolution_          KSPMONITORSOLUTION
 15:   #define kspmonitorsingularvalue_     KSPMONITORSINGULARVALUE
 16:   #define kspsetcomputerhs_            KSPSETCOMPUTERHS
 17:   #define kspsetcomputeinitialguess_   KSPSETCOMPUTEINITIALGUESS
 18:   #define kspsetcomputeoperators_      KSPSETCOMPUTEOPERATORS
 19:   #define dmkspsetcomputerhs_          DMKSPSETCOMPUTERHS
 20:   #define dmkspsetcomputeinitialguess_ DMKSPSETCOMPUTEINITIALGUESS
 21:   #define dmkspsetcomputeoperators_    DMKSPSETCOMPUTEOPERATORS
 22: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
 23:   #define kspmonitorset_               kspmonitorset
 24:   #define kspconvergeddefaultcreate_   kspconvergeddefaultcreate
 25:   #define kspconvergeddefaultdestroy_  kspconvergeddefaultdestroy
 26:   #define kspsetconvergencetest_       kspsetconvergencetest
 27:   #define kspconvergeddefault_         kspconvergeddefault
 28:   #define kspconvergedskip_            kspconvergedskip
 29:   #define kspgmresmonitorkrylov_       kspgmresmonitorkrylov
 30:   #define kspmonitorresidual_          kspmonitorresidual
 31:   #define kspmonitortrueresidual_      kspmonitortrueresidual
 32:   #define kspmonitorsolution_          kspmonitorsolution
 33:   #define kspmonitorsingularvalue_     kspmonitorsingularvalue
 34:   #define kspsetcomputerhs_            kspsetcomputerhs
 35:   #define kspsetcomputeinitialguess_   kspsetcomputeinitialguess
 36:   #define kspsetcomputeoperators_      kspsetcomputeoperators
 37:   #define dmkspsetcomputerhs_          dmkspsetcomputerhs
 38:   #define dmkspsetcomputeinitialguess_ dmkspsetcomputeinitialguess
 39:   #define dmkspsetcomputeoperators_    dmkspsetcomputeoperators
 40: #endif

 42: /* These are defined in zdmkspf.c */
 43: PETSC_EXTERN void dmkspsetcomputerhs_(DM *dm, void (*func)(KSP *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr);
 44: PETSC_EXTERN void dmkspsetcomputeinitialguess_(DM *dm, void (*func)(KSP *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr);
 45: PETSC_EXTERN void dmkspsetcomputeoperators_(DM *dm, void (*func)(KSP *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr);

 47: /*
 48:         These cannot be called from Fortran but allow Fortran users to transparently set these monitors from .F code
 49: */

 51: PETSC_EXTERN void kspconvergeddefault_(KSP *, PetscInt *, PetscReal *, KSPConvergedReason *, void *, PetscErrorCode *);
 52: PETSC_EXTERN void kspconvergedskip_(KSP *, PetscInt *, PetscReal *, KSPConvergedReason *, void *, PetscErrorCode *);
 53: PETSC_EXTERN void kspgmresmonitorkrylov_(KSP *, PetscInt *, PetscReal *, PetscViewerAndFormat *, PetscErrorCode *);
 54: PETSC_EXTERN void kspmonitorresidual_(KSP *, PetscInt *, PetscReal *, PetscViewerAndFormat *, PetscErrorCode *);
 55: PETSC_EXTERN void kspmonitorsingularvalue_(KSP *, PetscInt *, PetscReal *, PetscViewerAndFormat *, PetscErrorCode *);
 56: PETSC_EXTERN void kspmonitortrueresidual_(KSP *, PetscInt *, PetscReal *, PetscViewerAndFormat *, PetscErrorCode *);
 57: PETSC_EXTERN void kspmonitorsolution_(KSP *, PetscInt *, PetscReal *, PetscViewerAndFormat *, PetscErrorCode *);

 59: static struct {
 60:   PetscFortranCallbackId monitor;
 61:   PetscFortranCallbackId monitordestroy;
 62:   PetscFortranCallbackId test;
 63:   PetscFortranCallbackId testdestroy;
 64: } _cb;

 66: static PetscErrorCode ourmonitor(KSP ksp, PetscInt i, PetscReal d, void *ctx)
 67: {
 68:   PetscObjectUseFortranCallback(ksp, _cb.monitor, (KSP *, PetscInt *, PetscReal *, void *, PetscErrorCode *), (&ksp, &i, &d, _ctx, &ierr));
 69: }

 71: static PetscErrorCode ourdestroy(void **ctx)
 72: {
 73:   KSP ksp = (KSP)*ctx;
 74:   PetscObjectUseFortranCallback(ksp, _cb.monitordestroy, (void *, PetscErrorCode *), (_ctx, &ierr));
 75: }

 77: /* These are not extern C because they are passed into non-extern C user level functions */
 78: static PetscErrorCode ourtest(KSP ksp, PetscInt i, PetscReal d, KSPConvergedReason *reason, void *ctx)
 79: {
 80:   PetscObjectUseFortranCallback(ksp, _cb.test, (KSP *, PetscInt *, PetscReal *, KSPConvergedReason *, void *, PetscErrorCode *), (&ksp, &i, &d, reason, _ctx, &ierr));
 81: }

 83: static PetscErrorCode ourtestdestroy(void **ctx)
 84: {
 85:   KSP ksp = (KSP)*ctx;
 86:   PetscObjectUseFortranCallback(ksp, _cb.testdestroy, (void **, PetscErrorCode *), (&_ctx, &ierr));
 87: }

 89: /*
 90:    For the built in monitors we ignore the monitordestroy that is passed in and use PetscViewerAndFormatDestroy()
 91: */
 92: PETSC_EXTERN void kspmonitorset_(KSP *ksp, void (*monitor)(KSP *, PetscInt *, PetscReal *, void *, PetscErrorCode *), void *mctx, void (*monitordestroy)(void *, PetscErrorCode *), PetscErrorCode *ierr)
 93: {
 94:   CHKFORTRANNULLFUNCTION(monitordestroy);

 96:   if ((PetscFortranCallbackFn *)monitor == (PetscFortranCallbackFn *)kspmonitorresidual_) {
 97:     *ierr = KSPMonitorSet(*ksp, (KSPMonitorFn *)KSPMonitorResidual, *(PetscViewerAndFormat **)mctx, (PetscCtxDestroyFn *)PetscViewerAndFormatDestroy);
 98:   } else if ((PetscFortranCallbackFn *)monitor == (PetscFortranCallbackFn *)kspmonitorsolution_) {
 99:     *ierr = KSPMonitorSet(*ksp, (KSPMonitorFn *)KSPMonitorSolution, *(PetscViewerAndFormat **)mctx, (PetscCtxDestroyFn *)PetscViewerAndFormatDestroy);
100:   } else if ((PetscFortranCallbackFn *)monitor == (PetscFortranCallbackFn *)kspmonitortrueresidual_) {
101:     *ierr = KSPMonitorSet(*ksp, (KSPMonitorFn *)KSPMonitorTrueResidual, *(PetscViewerAndFormat **)mctx, (PetscCtxDestroyFn *)PetscViewerAndFormatDestroy);
102:   } else if ((PetscFortranCallbackFn *)monitor == (PetscFortranCallbackFn *)kspmonitorsingularvalue_) {
103:     *ierr = KSPMonitorSet(*ksp, (KSPMonitorFn *)KSPMonitorSingularValue, *(PetscViewerAndFormat **)mctx, (PetscCtxDestroyFn *)PetscViewerAndFormatDestroy);
104:   } else if ((PetscFortranCallbackFn *)monitor == (PetscFortranCallbackFn *)kspgmresmonitorkrylov_) {
105:     *ierr = KSPMonitorSet(*ksp, (KSPMonitorFn *)KSPGMRESMonitorKrylov, *(PetscViewerAndFormat **)mctx, (PetscCtxDestroyFn *)PetscViewerAndFormatDestroy);
106:   } else {
107:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ksp, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.monitor, (PetscFortranCallbackFn *)monitor, mctx);
108:     if (*ierr) return;
109:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ksp, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.monitordestroy, (PetscFortranCallbackFn *)monitordestroy, mctx);
110:     if (*ierr) return;
111:     *ierr = KSPMonitorSet(*ksp, ourmonitor, *ksp, ourdestroy);
112:   }
113: }

115: PETSC_EXTERN void kspconvergeddefaultdestroy_(void **ctx, PetscErrorCode *ierr)
116: {
117:   *ierr = KSPConvergedDefaultDestroy(ctx);
118: }

120: PETSC_EXTERN void kspsetconvergencetest_(KSP *ksp, void (*converge)(KSP *, PetscInt *, PetscReal *, KSPConvergedReason *, void *, PetscErrorCode *), void **cctx, void (*destroy)(void **, PetscErrorCode *), PetscErrorCode *ierr)
121: {
122:   CHKFORTRANNULLFUNCTION(destroy);

124:   if (converge == kspconvergeddefault_) {
125:     *ierr = KSPSetConvergenceTest(*ksp, KSPConvergedDefault, &cctx, KSPConvergedDefaultDestroy);
126:   } else if (converge == kspconvergedskip_) {
127:     *ierr = KSPSetConvergenceTest(*ksp, KSPConvergedSkip, NULL, NULL);
128:   } else {
129:     if (destroy == kspconvergeddefaultdestroy_) cctx = *(void ***)cctx;
130:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ksp, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.test, (PetscFortranCallbackFn *)converge, cctx);
131:     if (*ierr) return;
132:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ksp, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.testdestroy, (PetscFortranCallbackFn *)destroy, cctx);
133:     if (*ierr) return;
134:     *ierr = KSPSetConvergenceTest(*ksp, ourtest, *ksp, ourtestdestroy);
135:   }
136: }

138: PETSC_EXTERN void kspsetcomputerhs_(KSP *ksp, void (*func)(KSP *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
139: {
140:   DM dm;
141:   *ierr = KSPGetDM(*ksp, &dm);
142:   if (!*ierr) dmkspsetcomputerhs_(&dm, func, ctx, ierr);
143: }

145: PETSC_EXTERN void kspsetcomputeinitialguess_(KSP *ksp, void (*func)(KSP *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
146: {
147:   DM dm;
148:   *ierr = KSPGetDM(*ksp, &dm);
149:   if (!*ierr) dmkspsetcomputeinitialguess_(&dm, func, ctx, ierr);
150: }

152: PETSC_EXTERN void kspsetcomputeoperators_(KSP *ksp, void (*func)(KSP *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
153: {
154:   DM dm;
155:   *ierr = KSPGetDM(*ksp, &dm);
156:   if (!*ierr) dmkspsetcomputeoperators_(&dm, func, ctx, ierr);
157: }

159: PETSC_EXTERN void kspconvergeddefaultcreate_(PetscFortranAddr *ctx, PetscErrorCode *ierr)
160: {
161:   *ierr = KSPConvergedDefaultCreate((void **)ctx);
162: }