Date: 2025-03-29T05:58:27+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 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 *, PetscFortranAddr *, 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 ((PetscVoidFn *)monitor == (PetscVoidFn *)kspmonitorresidual_) {
     97:     *ierr = KSPMonitorSet(*ksp, (PetscErrorCode (*)(KSP, PetscInt, PetscReal, void *))KSPMonitorResidual, *(PetscViewerAndFormat **)mctx, (PetscCtxDestroyFn *)PetscViewerAndFormatDestroy);
     98:   } else if ((PetscVoidFn *)monitor == (PetscVoidFn *)kspmonitorsolution_) {
     99:     *ierr = KSPMonitorSet(*ksp, (PetscErrorCode (*)(KSP, PetscInt, PetscReal, void *))KSPMonitorSolution, *(PetscViewerAndFormat **)mctx, (PetscCtxDestroyFn *)PetscViewerAndFormatDestroy);
    100:   } else if ((PetscVoidFn *)monitor == (PetscVoidFn *)kspmonitortrueresidual_) {
    101:     *ierr = KSPMonitorSet(*ksp, (PetscErrorCode (*)(KSP, PetscInt, PetscReal, void *))KSPMonitorTrueResidual, *(PetscViewerAndFormat **)mctx, (PetscCtxDestroyFn *)PetscViewerAndFormatDestroy);
    102:   } else if ((PetscVoidFn *)monitor == (PetscVoidFn *)kspmonitorsingularvalue_) {
    103:     *ierr = KSPMonitorSet(*ksp, (PetscErrorCode (*)(KSP, PetscInt, PetscReal, void *))KSPMonitorSingularValue, *(PetscViewerAndFormat **)mctx, (PetscCtxDestroyFn *)PetscViewerAndFormatDestroy);
    104:   } else if ((PetscVoidFn *)monitor == (PetscVoidFn *)kspgmresmonitorkrylov_) {
    105:     *ierr = KSPMonitorSet(*ksp, (PetscErrorCode (*)(KSP, PetscInt, PetscReal, void *))KSPGMRESMonitorKrylov, *(PetscViewerAndFormat **)mctx, (PetscCtxDestroyFn *)PetscViewerAndFormatDestroy);
    106:   } else {
    107:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ksp, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.monitor, (PetscVoidFn *)monitor, mctx);
    108:     if (*ierr) return;
    109:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ksp, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.monitordestroy, (PetscVoidFn *)monitordestroy, mctx);
    110:     if (*ierr) return;
    111:     *ierr = KSPMonitorSet(*ksp, ourmonitor, *ksp, ourdestroy);
    112:   }
    113: }

    115: PETSC_EXTERN void kspconvergeddefaultdestroy_(void *);

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

    121:   if ((PetscVoidFn *)converge == (PetscVoidFn *)kspconvergeddefault_) {
    122:     *ierr = KSPSetConvergenceTest(*ksp, KSPConvergedDefault, *cctx, KSPConvergedDefaultDestroy);
    123:   } else if ((PetscVoidFn *)converge == (PetscVoidFn *)kspconvergedskip_) {
    124:     *ierr = KSPSetConvergenceTest(*ksp, KSPConvergedSkip, NULL, NULL);
    125:   } else {
    126:     if ((PetscVoidFn *)destroy == (PetscVoidFn *)kspconvergeddefaultdestroy_) cctx = *(void ***)cctx;
    127:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ksp, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.test, (PetscVoidFn *)converge, cctx);
    128:     if (*ierr) return;
    129:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ksp, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.testdestroy, (PetscVoidFn *)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 *), void *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 *), void *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 *), void *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: }