Date: 2026-05-01T06:11:51+00:00

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 kspconvergeddefaultdestroycptr_ KSPCONVERGEDDEFAULTDESTROYCPTR
      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 kspconvergeddefaultdestroycptr_ kspconvergeddefaultdestroycptr
     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 *), PetscCtx ctx, PetscErrorCode *ierr);
     44: PETSC_EXTERN void dmkspsetcomputeinitialguess_(DM *dm, void (*func)(KSP *, Vec *, void *, PetscErrorCode *), PetscCtx ctx, PetscErrorCode *ierr);
     45: PETSC_EXTERN void dmkspsetcomputeoperators_(DM *dm, void (*func)(KSP *, Vec *, void *, PetscErrorCode *), PetscCtx 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, PetscCtx ctx)
     67: {
     68:   PetscObjectUseFortranCallback(ksp, _cb.monitor, (KSP *, PetscInt *, PetscReal *, void *, PetscErrorCode *), (&ksp, &i, &d, _ctx, &ierr));
     69: }

     71: static PetscErrorCode ourdestroy(PetscCtxRt 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, PetscCtx ctx)
     79: {
     80:   PetscObjectUseFortranCallback(ksp, _cb.test, (KSP *, PetscInt *, PetscReal *, KSPConvergedReason *, void *, PetscErrorCode *), (&ksp, &i, &d, reason, _ctx, &ierr));
     81: }

     83: static PetscErrorCode ourtestdestroy(PetscCtxRt 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 kspconvergeddefaultdestroycptr_(PetscCtxRt, PetscErrorCode *);

    117: PETSC_EXTERN void kspsetconvergencetest_(KSP *ksp, void (*converge)(KSP *, PetscInt *, PetscReal *, KSPConvergedReason *, void *, PetscErrorCode *), void **cctx, void (*destroy)(PetscCtxRt, PetscErrorCode *), PetscErrorCode *ierr)
    118: {
    119:   CHKFORTRANNULLFUNCTION(destroy);

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

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

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

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

    156: PETSC_EXTERN void kspconvergeddefaultcreate_(PetscFortranAddr *ctx, PetscErrorCode *ierr)
    157: {
    158:   *ierr = KSPConvergedDefaultCreate((void **)ctx);
    159: }