Date: 2026-03-31T13:23:01+00:00

Actual source code: zpepf.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 <slepcpep.h>

     14: #if defined(PETSC_HAVE_FORTRAN_CAPS)
     15: #define pepmonitorset_                    PEPMONITORSET
     16: #define pepmonitorall_                    PEPMONITORALL
     17: #define pepmonitorfirst_                  PEPMONITORFIRST
     18: #define pepmonitorconverged_              PEPMONITORCONVERGED
     19: #define pepmonitorconvergedcreate_        PEPMONITORCONVERGEDCREATE
     20: #define pepconvergedabsolute_             PEPCONVERGEDABSOLUTE
     21: #define pepconvergedrelative_             PEPCONVERGEDRELATIVE
     22: #define pepsetconvergencetestfunction_    PEPSETCONVERGENCETESTFUNCTION
     23: #define pepsetstoppingtestfunction_       PEPSETSTOPPINGTESTFUNCTION
     24: #define pepseteigenvaluecomparison_       PEPSETEIGENVALUECOMPARISON
     25: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
     26: #define pepmonitorset_                    pepmonitorset
     27: #define pepmonitorall_                    pepmonitorall
     28: #define pepmonitorfirst_                  pepmonitorfirst
     29: #define pepmonitorconverged_              pepmonitorconverged
     30: #define pepmonitorconvergedcreate_        pepmonitorconvergedcreate
     31: #define pepconvergedabsolute_             pepconvergedabsolute
     32: #define pepconvergedrelative_             pepconvergedrelative
     33: #define pepsetconvergencetestfunction_    pepsetconvergencetestfunction
     34: #define pepsetstoppingtestfunction_       pepsetstoppingtestfunction
     35: #define pepseteigenvaluecomparison_       pepseteigenvaluecomparison
     36: #endif

     38: /*
     39:    These cannot be called from Fortran but allow Fortran users
     40:    to transparently set these monitors from .F code
     41: */
     42: SLEPC_EXTERN void pepmonitorall_(PEP*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
     43: SLEPC_EXTERN void pepmonitorfirst_(PEP*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
     44: SLEPC_EXTERN void pepmonitorconverged_(PEP*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);

     46: SLEPC_EXTERN void pepmonitorconvergedcreate_(PetscViewer *vin,PetscViewerFormat *format,void *ctx,PetscViewerAndFormat **vf,PetscErrorCode *ierr)
     47: {
     48:   PetscViewer v;
     49:   PetscPatchDefaultViewers_Fortran(vin,v);
     50:   CHKFORTRANNULLOBJECT(ctx);
     51:   *ierr = PEPMonitorConvergedCreate(v,*format,ctx,vf);
     52: }

     54: static struct {
     55:   PetscFortranCallbackId monitor;
     56:   PetscFortranCallbackId monitordestroy;
     57:   PetscFortranCallbackId convergence;
     58:   PetscFortranCallbackId convdestroy;
     59:   PetscFortranCallbackId stopping;
     60:   PetscFortranCallbackId stopdestroy;
     61:   PetscFortranCallbackId comparison;
     62: } _cb;

     64: /* These are not extern C because they are passed into non-extern C user level functions */
     65: static PetscErrorCode ourmonitor(PEP pep,PetscInt i,PetscInt nc,PetscScalar *er,PetscScalar *ei,PetscReal *d,PetscInt l,void *ctx)
     66: {
     67:   PetscObjectUseFortranCallback(pep,_cb.monitor,(PEP*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,void*,PetscErrorCode*),(&pep,&i,&nc,er,ei,d,&l,_ctx,&ierr));
     68: }

     70: static PetscErrorCode ourdestroy(PetscCtxRt ctx)
     71: {
     72:   PEP pep = *(PEP*)ctx;
     73:   PetscObjectUseFortranCallback(pep,_cb.monitordestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
     74: }

     76: static PetscErrorCode ourconvergence(PEP pep,PetscScalar eigr,PetscScalar eigi,PetscReal res,PetscReal *errest,void *ctx)
     77: {
     78:   PetscObjectUseFortranCallback(pep,_cb.convergence,(PEP*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*),(&pep,&eigr,&eigi,&res,errest,_ctx,&ierr));
     79: }

     81: static PetscErrorCode ourconvdestroy(PetscCtxRt ctx)
     82: {
     83:   PEP pep = *(PEP*)ctx;
     84:   PetscObjectUseFortranCallback(pep,_cb.convdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
     85: }

     87: static PetscErrorCode ourstopping(PEP pep,PetscInt its,PetscInt max_it,PetscInt nconv,PetscInt nev,PEPConvergedReason *reason,void *ctx)
     88: {
     89:   PetscObjectUseFortranCallback(pep,_cb.stopping,(PEP*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,PEPConvergedReason*,void*,PetscErrorCode*),(&pep,&its,&max_it,&nconv,&nev,reason,_ctx,&ierr));
     90: }

     92: static PetscErrorCode ourstopdestroy(PetscCtxRt ctx)
     93: {
     94:   PEP pep = *(PEP*)ctx;
     95:   PetscObjectUseFortranCallback(pep,_cb.stopdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
     96: }

     98: static PetscErrorCode oureigenvaluecomparison(PetscScalar ar,PetscScalar ai,PetscScalar br,PetscScalar bi,PetscInt *r,void *ctx)
     99: {
    100:   PEP pep = (PEP)ctx;
    101:   PetscObjectUseFortranCallback(pep,_cb.comparison,(PetscScalar*,PetscScalar*,PetscScalar*,PetscScalar*,PetscInt*,void*,PetscErrorCode*),(&ar,&ai,&br,&bi,r,_ctx,&ierr));
    102: }

    104: SLEPC_EXTERN void pepmonitorset_(PEP *pep,void (*monitor)(PEP*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,void*,PetscErrorCode*),void *mctx,void (*monitordestroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
    105: {
    106:   CHKFORTRANNULLOBJECT(mctx);
    107:   CHKFORTRANNULLFUNCTION(monitordestroy);
    108:   if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)pepmonitorall_) {
    109:     *ierr = PEPMonitorSet(*pep,(PEPMonitorFn*)PEPMonitorAll,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
    110:   } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)pepmonitorconverged_) {
    111:     *ierr = PEPMonitorSet(*pep,(PEPMonitorFn*)PEPMonitorConverged,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
    112:   } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)pepmonitorfirst_) {
    113:     *ierr = PEPMonitorSet(*pep,(PEPMonitorFn*)PEPMonitorFirst,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
    114:   } else {
    115:     *ierr = PetscObjectSetFortranCallback((PetscObject)*pep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitor,(PetscFortranCallbackFn*)monitor,mctx); if (*ierr) return;
    116:     *ierr = PetscObjectSetFortranCallback((PetscObject)*pep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitordestroy,(PetscFortranCallbackFn*)monitordestroy,mctx); if (*ierr) return;
    117:     *ierr = PEPMonitorSet(*pep,ourmonitor,*pep,ourdestroy);
    118:   }
    119: }

    121: SLEPC_EXTERN void pepconvergedabsolute_(PEP*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
    122: SLEPC_EXTERN void pepconvergedrelative_(PEP*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*);

    124: SLEPC_EXTERN void pepsetconvergencetestfunction_(PEP *pep,void (*func)(PEP*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*),void *ctx,void (*destroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
    125: {
    126:   CHKFORTRANNULLOBJECT(ctx);
    127:   CHKFORTRANNULLFUNCTION(destroy);
    128:   if (func == pepconvergedabsolute_) {
    129:     *ierr = PEPSetConvergenceTest(*pep,PEP_CONV_ABS);
    130:   } else if (func == pepconvergedrelative_) {
    131:     *ierr = PEPSetConvergenceTest(*pep,PEP_CONV_REL);
    132:   } else {
    133:     *ierr = PetscObjectSetFortranCallback((PetscObject)*pep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.convergence,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
    134:     *ierr = PetscObjectSetFortranCallback((PetscObject)*pep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.convdestroy,(PetscFortranCallbackFn*)destroy,ctx); if (*ierr) return;
    135:     *ierr = PEPSetConvergenceTestFunction(*pep,ourconvergence,*pep,ourconvdestroy);
    136:   }
    137: }

    139: SLEPC_EXTERN void pepstoppingbasic_(PEP*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,PEPConvergedReason*,void*,PetscErrorCode*);

    141: SLEPC_EXTERN void pepsetstoppingtestfunction_(PEP *pep,void (*func)(PEP*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,PEPConvergedReason*,void*,PetscErrorCode*),void *ctx,void (*destroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
    142: {
    143:   CHKFORTRANNULLOBJECT(ctx);
    144:   CHKFORTRANNULLFUNCTION(destroy);
    145:   if (func == pepstoppingbasic_) {
    146:     *ierr = PEPSetStoppingTest(*pep,PEP_STOP_BASIC);
    147:   } else {
    148:     *ierr = PetscObjectSetFortranCallback((PetscObject)*pep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.stopping,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
    149:     *ierr = PetscObjectSetFortranCallback((PetscObject)*pep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.stopdestroy,(PetscFortranCallbackFn*)destroy,ctx); if (*ierr) return;
    150:     *ierr = PEPSetStoppingTestFunction(*pep,ourstopping,*pep,ourstopdestroy);
    151:   }
    152: }

    154: SLEPC_EXTERN void pepseteigenvaluecomparison_(PEP *pep,void (*func)(PetscScalar*,PetscScalar*,PetscScalar*,PetscScalar*,PetscInt*,void*),void *ctx,PetscErrorCode *ierr)
    155: {
    156:   CHKFORTRANNULLOBJECT(ctx);
    157:   *ierr = PetscObjectSetFortranCallback((PetscObject)*pep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.comparison,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
    158:   *ierr = PEPSetEigenvalueComparison(*pep,oureigenvaluecomparison,*pep);
    159: }