Actual source code: zitfuncf.c

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

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

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

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

     53: PETSC_EXTERN void kspconvergeddefault_(KSP *ksp, PetscInt *n, PetscReal *rnorm, KSPConvergedReason *flag, PetscFortranAddr *dummy, PetscErrorCode *ierr)
     54: {
     55:   *ierr = KSPConvergedDefault(*ksp, *n, *rnorm, flag, (void *)*dummy);
     56: }

     58: PETSC_EXTERN void kspconvergedskip_(KSP *ksp, PetscInt *n, PetscReal *rnorm, KSPConvergedReason *flag, void *dummy, PetscErrorCode *ierr)
     59: {
     60:   *ierr = KSPConvergedSkip(*ksp, *n, *rnorm, flag, dummy);
     61: }

     63: PETSC_EXTERN void kspgmresmonitorkrylov_(KSP *ksp, PetscInt *it, PetscReal *norm, PetscViewerAndFormat **ctx, PetscErrorCode *ierr)
     64: {
     65:   *ierr = KSPGMRESMonitorKrylov(*ksp, *it, *norm, *ctx);
     66: }

     68: PETSC_EXTERN void kspmonitorresidual_(KSP *ksp, PetscInt *it, PetscReal *norm, PetscViewerAndFormat **ctx, PetscErrorCode *ierr)
     69: {
     70:   *ierr = KSPMonitorResidual(*ksp, *it, *norm, *ctx);
     71: }

     73: PETSC_EXTERN void kspmonitorsingularvalue_(KSP *ksp, PetscInt *it, PetscReal *norm, PetscViewerAndFormat **ctx, PetscErrorCode *ierr)
     74: {
     75:   *ierr = KSPMonitorSingularValue(*ksp, *it, *norm, *ctx);
     76: }

     78: PETSC_EXTERN void kspmonitortrueresidual_(KSP *ksp, PetscInt *it, PetscReal *norm, PetscViewerAndFormat **ctx, PetscErrorCode *ierr)
     79: {
     80:   *ierr = KSPMonitorTrueResidual(*ksp, *it, *norm, *ctx);
     81: }

     83: PETSC_EXTERN void kspmonitorsolution_(KSP *ksp, PetscInt *it, PetscReal *norm, PetscViewerAndFormat **ctx, PetscErrorCode *ierr)
     84: {
     85:   *ierr = KSPMonitorSolution(*ksp, *it, *norm, *ctx);
     86: }

     88: static struct {
     89:   PetscFortranCallbackId monitor;
     90:   PetscFortranCallbackId monitordestroy;
     91:   PetscFortranCallbackId test;
     92:   PetscFortranCallbackId testdestroy;
     93: } _cb;

     95: static PetscErrorCode ourmonitor(KSP ksp, PetscInt i, PetscReal d, void *ctx)
     96: {
     97:   PetscObjectUseFortranCallback(ksp, _cb.monitor, (KSP *, PetscInt *, PetscReal *, void *, PetscErrorCode *), (&ksp, &i, &d, _ctx, &ierr));
     98: }

    100: static PetscErrorCode ourdestroy(void **ctx)
    101: {
    102:   KSP ksp = (KSP)*ctx;
    103:   PetscObjectUseFortranCallback(ksp, _cb.monitordestroy, (void *, PetscErrorCode *), (_ctx, &ierr));
    104: }

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

    112: static PetscErrorCode ourtestdestroy(void *ctx)
    113: {
    114:   KSP ksp = (KSP)ctx;
    115:   PetscObjectUseFortranCallback(ksp, _cb.testdestroy, (void *, PetscErrorCode *), (_ctx, &ierr));
    116: }

    118: /*
    119:    For the built in monitors we ignore the monitordestroy that is passed in and use PetscViewerAndFormatDestroy()
    120: */
    121: PETSC_EXTERN void kspmonitorset_(KSP *ksp, void (*monitor)(KSP *, PetscInt *, PetscReal *, void *, PetscErrorCode *), void *mctx, void (*monitordestroy)(void *, PetscErrorCode *), PetscErrorCode *ierr)
    122: {
    123:   CHKFORTRANNULLFUNCTION(monitordestroy);

    125:   if ((PetscVoidFn *)monitor == (PetscVoidFn *)kspmonitorresidual_) {
    126:     *ierr = KSPMonitorSet(*ksp, (PetscErrorCode (*)(KSP, PetscInt, PetscReal, void *))KSPMonitorResidual, *(PetscViewerAndFormat **)mctx, (PetscErrorCode (*)(void **))PetscViewerAndFormatDestroy);
    127:   } else if ((PetscVoidFn *)monitor == (PetscVoidFn *)kspmonitorsolution_) {
    128:     *ierr = KSPMonitorSet(*ksp, (PetscErrorCode (*)(KSP, PetscInt, PetscReal, void *))KSPMonitorSolution, *(PetscViewerAndFormat **)mctx, (PetscErrorCode (*)(void **))PetscViewerAndFormatDestroy);
    129:   } else if ((PetscVoidFn *)monitor == (PetscVoidFn *)kspmonitortrueresidual_) {
    130:     *ierr = KSPMonitorSet(*ksp, (PetscErrorCode (*)(KSP, PetscInt, PetscReal, void *))KSPMonitorTrueResidual, *(PetscViewerAndFormat **)mctx, (PetscErrorCode (*)(void **))PetscViewerAndFormatDestroy);
    131:   } else if ((PetscVoidFn *)monitor == (PetscVoidFn *)kspmonitorsingularvalue_) {
    132:     *ierr = KSPMonitorSet(*ksp, (PetscErrorCode (*)(KSP, PetscInt, PetscReal, void *))KSPMonitorSingularValue, *(PetscViewerAndFormat **)mctx, (PetscErrorCode (*)(void **))PetscViewerAndFormatDestroy);
    133:   } else if ((PetscVoidFn *)monitor == (PetscVoidFn *)kspgmresmonitorkrylov_) {
    134:     *ierr = KSPMonitorSet(*ksp, (PetscErrorCode (*)(KSP, PetscInt, PetscReal, void *))KSPGMRESMonitorKrylov, *(PetscViewerAndFormat **)mctx, (PetscErrorCode (*)(void **))PetscViewerAndFormatDestroy);
    135:   } else {
    136:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ksp, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.monitor, (PetscVoidFn *)monitor, mctx);
    137:     if (*ierr) return;
    138:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ksp, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.monitordestroy, (PetscVoidFn *)monitordestroy, mctx);
    139:     if (*ierr) return;
    140:     *ierr = KSPMonitorSet(*ksp, ourmonitor, *ksp, ourdestroy);
    141:   }
    142: }

    144: PETSC_EXTERN void kspsetconvergencetest_(KSP *ksp, void (*converge)(KSP *, PetscInt *, PetscReal *, KSPConvergedReason *, void *, PetscErrorCode *), void **cctx, void (*destroy)(void *, PetscErrorCode *), PetscErrorCode *ierr)
    145: {
    146:   CHKFORTRANNULLFUNCTION(destroy);

    148:   if ((PetscVoidFn *)converge == (PetscVoidFn *)kspconvergeddefault_) {
    149:     *ierr = KSPSetConvergenceTest(*ksp, KSPConvergedDefault, *cctx, KSPConvergedDefaultDestroy);
    150:   } else if ((PetscVoidFn *)converge == (PetscVoidFn *)kspconvergedskip_) {
    151:     *ierr = KSPSetConvergenceTest(*ksp, KSPConvergedSkip, NULL, NULL);
    152:   } else {
    153:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ksp, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.test, (PetscVoidFn *)converge, cctx);
    154:     if (*ierr) return;
    155:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ksp, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.testdestroy, (PetscVoidFn *)destroy, cctx);
    156:     if (*ierr) return;
    157:     *ierr = KSPSetConvergenceTest(*ksp, ourtest, *ksp, ourtestdestroy);
    158:   }
    159: }

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

    166: PETSC_EXTERN void kspconvergeddefaultdestroy_(PetscFortranAddr *ctx, PetscErrorCode *ierr)
    167: {
    168:   *ierr = KSPConvergedDefaultDestroy(*(void **)ctx);
    169: }

    171: PETSC_EXTERN void kspgetresidualhistory_(KSP *ksp, PetscInt *na, PetscErrorCode *ierr)
    172: {
    173:   *ierr = KSPGetResidualHistory(*ksp, NULL, na);
    174: }

    176: PETSC_EXTERN void kspsetcomputerhs_(KSP *ksp, void (*func)(KSP *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    177: {
    178:   DM dm;
    179:   *ierr = KSPGetDM(*ksp, &dm);
    180:   if (!*ierr) dmkspsetcomputerhs_(&dm, func, ctx, ierr);
    181: }

    183: PETSC_EXTERN void kspsetcomputeinitialguess_(KSP *ksp, void (*func)(KSP *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    184: {
    185:   DM dm;
    186:   *ierr = KSPGetDM(*ksp, &dm);
    187:   if (!*ierr) dmkspsetcomputeinitialguess_(&dm, func, ctx, ierr);
    188: }

    190: PETSC_EXTERN void kspsetcomputeoperators_(KSP *ksp, void (*func)(KSP *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    191: {
    192:   DM dm;
    193:   *ierr = KSPGetDM(*ksp, &dm);
    194:   if (!*ierr) dmkspsetcomputeoperators_(&dm, func, ctx, ierr);
    195: }