Date: 2026-05-01T10:02:29+00:00

Actual source code: zepsf.c

      1: /*
      2:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      3:    SLEPc - Scalable Library for Eigenvalue Problem Computations
      4:    Copyright (c) 2002-, Universitat Politecnica de Valencia, Spain

      6:    This file is part of SLEPc.
      7:    SLEPc is distributed under a 2-clause BSD license (see LICENSE).
      8:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      9: */

     11: #include <petsc/private/ftnimpl.h>
     12: #include <slepceps.h>

     14: #if defined(PETSC_HAVE_FORTRAN_CAPS)
     15: #define epsmonitorset_                    EPSMONITORSET
     16: #define epsmonitorall_                    EPSMONITORALL
     17: #define epsmonitorfirst_                  EPSMONITORFIRST
     18: #define epsmonitorconverged_              EPSMONITORCONVERGED
     19: #define epsmonitorconvergedcreate_        EPSMONITORCONVERGEDCREATE
     20: #define epsconvergedabsolute_             EPSCONVERGEDABSOLUTE
     21: #define epsconvergedrelative_             EPSCONVERGEDRELATIVE
     22: #define epsconvergednorm_                 EPSCONVERGEDNORM
     23: #define epssetconvergencetestfunction_    EPSSETCONVERGENCETESTFUNCTION
     24: #define epsstoppingbasic_                 EPSSTOPPINGBASIC
     25: #define epsstoppingthreshold_             EPSSTOPPINGTHRESHOLD
     26: #define epssetstoppingtestfunction_       EPSSETSTOPPINGTESTFUNCTION
     27: #define epsseteigenvaluecomparison_       EPSSETEIGENVALUECOMPARISON
     28: #define epssetarbitraryselection_         EPSSETARBITRARYSELECTION
     29: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
     30: #define epsmonitorset_                    epsmonitorset
     31: #define epsmonitorall_                    epsmonitorall
     32: #define epsmonitorfirst_                  epsmonitorfirst
     33: #define epsmonitorconverged_              epsmonitorconverged
     34: #define epsmonitorconvergedcreate_        epsmonitorconvergedcreate
     35: #define epsconvergedabsolute_             epsconvergedabsolute
     36: #define epsconvergedrelative_             epsconvergedrelative
     37: #define epsconvergednorm_                 epsconvergednorm
     38: #define epssetconvergencetestfunction_    epssetconvergencetestfunction
     39: #define epsstoppingbasic_                 epsstoppingbasic
     40: #define epsstoppingthreshold_             epsstoppingthreshold
     41: #define epssetstoppingtestfunction_       epssetstoppingtestfunction
     42: #define epsseteigenvaluecomparison_       epsseteigenvaluecomparison
     43: #define epssetarbitraryselection_         epssetarbitraryselection
     44: #endif

     46: /*
     47:    These cannot be called from Fortran but allow Fortran users
     48:    to transparently set these monitors from .F code
     49: */
     50: SLEPC_EXTERN void epsmonitorall_(EPS*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
     51: SLEPC_EXTERN void epsmonitorfirst_(EPS*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
     52: SLEPC_EXTERN void epsmonitorconverged_(EPS*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);

     54: SLEPC_EXTERN void epsmonitorconvergedcreate_(PetscViewer *vin,PetscViewerFormat *format,void *ctx,PetscViewerAndFormat **vf,PetscErrorCode *ierr)
     55: {
     56:   PetscViewer v;
     57:   PetscPatchDefaultViewers_Fortran(vin,v);
     58:   CHKFORTRANNULLOBJECT(ctx);
     59:   *ierr = EPSMonitorConvergedCreate(v,*format,ctx,vf);
     60: }

     62: static struct {
     63:   PetscFortranCallbackId monitor;
     64:   PetscFortranCallbackId monitordestroy;
     65:   PetscFortranCallbackId convergence;
     66:   PetscFortranCallbackId convdestroy;
     67:   PetscFortranCallbackId stopping;
     68:   PetscFortranCallbackId stopdestroy;
     69:   PetscFortranCallbackId comparison;
     70:   PetscFortranCallbackId arbitrary;
     71: } _cb;

     73: /* These are not extern C because they are passed into non-extern C user level functions */
     74: static PetscErrorCode ourmonitor(EPS eps,PetscInt i,PetscInt nc,PetscScalar *er,PetscScalar *ei,PetscReal *d,PetscInt l,void *ctx)
     75: {
     76:   PetscObjectUseFortranCallback(eps,_cb.monitor,(EPS*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,void*,PetscErrorCode*),(&eps,&i,&nc,er,ei,d,&l,_ctx,&ierr));
     77: }

     79: static PetscErrorCode ourdestroy(PetscCtxRt ctx)
     80: {
     81:   EPS eps = *(EPS*)ctx;
     82:   PetscObjectUseFortranCallback(eps,_cb.monitordestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
     83: }

     85: static PetscErrorCode ourconvergence(EPS eps,PetscScalar eigr,PetscScalar eigi,PetscReal res,PetscReal *errest,void *ctx)
     86: {
     87:   PetscObjectUseFortranCallback(eps,_cb.convergence,(EPS*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*),(&eps,&eigr,&eigi,&res,errest,_ctx,&ierr));
     88: }

     90: static PetscErrorCode ourconvdestroy(PetscCtxRt ctx)
     91: {
     92:   EPS eps = *(EPS*)ctx;
     93:   PetscObjectUseFortranCallback(eps,_cb.convdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
     94: }

     96: static PetscErrorCode ourstopping(EPS eps,PetscInt its,PetscInt max_it,PetscInt nconv,PetscInt nev,EPSConvergedReason *reason,void *ctx)
     97: {
     98:   PetscObjectUseFortranCallback(eps,_cb.stopping,(EPS*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,EPSConvergedReason*,void*,PetscErrorCode*),(&eps,&its,&max_it,&nconv,&nev,reason,_ctx,&ierr));
     99: }

    101: static PetscErrorCode ourstopdestroy(PetscCtxRt ctx)
    102: {
    103:   EPS eps = *(EPS*)ctx;
    104:   PetscObjectUseFortranCallback(eps,_cb.stopdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
    105: }

    107: static PetscErrorCode oureigenvaluecomparison(PetscScalar ar,PetscScalar ai,PetscScalar br,PetscScalar bi,PetscInt *r,void *ctx)
    108: {
    109:   EPS eps = (EPS)ctx;
    110:   PetscObjectUseFortranCallback(eps,_cb.comparison,(PetscScalar*,PetscScalar*,PetscScalar*,PetscScalar*,PetscInt*,void*,PetscErrorCode*),(&ar,&ai,&br,&bi,r,_ctx,&ierr));
    111: }

    113: static PetscErrorCode ourarbitraryfunc(PetscScalar er,PetscScalar ei,Vec xr,Vec xi,PetscScalar *rr,PetscScalar *ri,void *ctx)
    114: {
    115:   EPS eps = (EPS)ctx;
    116:   PetscObjectUseFortranCallback(eps,_cb.arbitrary,(PetscScalar*,PetscScalar*,Vec*,Vec*,PetscScalar*,PetscScalar*,void*,PetscErrorCode*),(&er,&ei,&xr,&xi,rr,ri,_ctx,&ierr));
    117: }

    119: SLEPC_EXTERN void epsmonitorset_(EPS *eps,void (*monitor)(EPS*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,void*,PetscErrorCode*),void *mctx,void (*monitordestroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
    120: {
    121:   CHKFORTRANNULLOBJECT(mctx);
    122:   CHKFORTRANNULLFUNCTION(monitordestroy);
    123:   if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)epsmonitorall_) {
    124:     *ierr = EPSMonitorSet(*eps,(EPSMonitorFn*)EPSMonitorAll,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
    125:   } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)epsmonitorconverged_) {
    126:     *ierr = EPSMonitorSet(*eps,(EPSMonitorFn*)EPSMonitorConverged,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
    127:   } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)epsmonitorfirst_) {
    128:     *ierr = EPSMonitorSet(*eps,(EPSMonitorFn*)EPSMonitorFirst,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
    129:   } else {
    130:     *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitor,(PetscFortranCallbackFn*)monitor,mctx); if (*ierr) return;
    131:     *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitordestroy,(PetscFortranCallbackFn*)monitordestroy,mctx); if (*ierr) return;
    132:     *ierr = EPSMonitorSet(*eps,ourmonitor,*eps,ourdestroy);
    133:   }
    134: }

    136: SLEPC_EXTERN void epsconvergedabsolute_(EPS*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
    137: SLEPC_EXTERN void epsconvergedrelative_(EPS*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
    138: SLEPC_EXTERN void epsconvergednorm_(EPS*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*);

    140: SLEPC_EXTERN void epssetconvergencetestfunction_(EPS *eps,void (*func)(EPS*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*),void *ctx,void (*destroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
    141: {
    142:   CHKFORTRANNULLOBJECT(ctx);
    143:   CHKFORTRANNULLFUNCTION(destroy);
    144:   if (func == epsconvergedabsolute_) {
    145:     *ierr = EPSSetConvergenceTest(*eps,EPS_CONV_ABS);
    146:   } else if (func == epsconvergedrelative_) {
    147:     *ierr = EPSSetConvergenceTest(*eps,EPS_CONV_REL);
    148:   } else if (func == epsconvergednorm_) {
    149:     *ierr = EPSSetConvergenceTest(*eps,EPS_CONV_NORM);
    150:   } else {
    151:     *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.convergence,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
    152:     *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.convdestroy,(PetscFortranCallbackFn*)destroy,ctx); if (*ierr) return;
    153:     *ierr = EPSSetConvergenceTestFunction(*eps,ourconvergence,*eps,ourconvdestroy);
    154:   }
    155: }

    157: SLEPC_EXTERN void epsstoppingbasic_(EPS*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,EPSConvergedReason*,void*,PetscErrorCode*);
    158: SLEPC_EXTERN void epsstoppingthreshold_(EPS*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,EPSConvergedReason*,void*,PetscErrorCode*);

    160: SLEPC_EXTERN void epssetstoppingtestfunction_(EPS *eps,void (*func)(EPS*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,EPSConvergedReason*,void*,PetscErrorCode*),void *ctx,void (*destroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
    161: {
    162:   CHKFORTRANNULLOBJECT(ctx);
    163:   CHKFORTRANNULLFUNCTION(destroy);
    164:   if (func == epsstoppingbasic_) {
    165:     *ierr = EPSSetStoppingTest(*eps,EPS_STOP_BASIC);
    166:   } else if (func == epsstoppingthreshold_) {
    167:     *ierr = EPSSetStoppingTest(*eps,EPS_STOP_THRESHOLD);
    168:   } else {
    169:     *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.stopping,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
    170:     *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.stopdestroy,(PetscFortranCallbackFn*)destroy,ctx); if (*ierr) return;
    171:     *ierr = EPSSetStoppingTestFunction(*eps,ourstopping,*eps,ourstopdestroy);
    172:   }
    173: }

    175: SLEPC_EXTERN void epsseteigenvaluecomparison_(EPS *eps,void (*func)(PetscScalar*,PetscScalar*,PetscScalar*,PetscScalar*,PetscInt*,void*),void *ctx,PetscErrorCode *ierr)
    176: {
    177:   CHKFORTRANNULLOBJECT(ctx);
    178:   *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.comparison,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
    179:   *ierr = EPSSetEigenvalueComparison(*eps,oureigenvaluecomparison,*eps);
    180: }

    182: SLEPC_EXTERN void epssetarbitraryselection_(EPS *eps,void (*func)(PetscScalar*,PetscScalar*,Vec*,Vec*,PetscScalar*,PetscScalar*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr)
    183: {
    184:   CHKFORTRANNULLOBJECT(ctx);
    185:   *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.arbitrary,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
    186:   *ierr = EPSSetArbitrarySelection(*eps,ourarbitraryfunc,*eps);
    187: }