Date: 2026-01-20T11:35:16+00:00

Actual source code: zsvdf.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 <slepcsvd.h>

     14: #if defined(PETSC_HAVE_FORTRAN_CAPS)
     15: #define svdmonitorset_                    SVDMONITORSET
     16: #define svdmonitorall_                    SVDMONITORALL
     17: #define svdmonitorfirst_                  SVDMONITORFIRST
     18: #define svdmonitorconditioning_           SVDMONITORCONDITIONING
     19: #define svdmonitorconverged_              SVDMONITORCONVERGED
     20: #define svdmonitorconvergedcreate_        SVDMONITORCONVERGEDCREATE
     21: #define svdmonitorconvergeddestroy_       SVDMONITORCONVERGEDDESTROY
     22: #define svdconvergedabsolute_             SVDCONVERGEDABSOLUTE
     23: #define svdconvergedrelative_             SVDCONVERGEDRELATIVE
     24: #define svdconvergednorm_                 SVDCONVERGEDNORM
     25: #define svdconvergedmaxit_                SVDCONVERGEDMAXIT
     26: #define svdsetconvergencetestfunction_    SVDSETCONVERGENCETESTFUNCTION
     27: #define svdstoppingbasic_                 SVDSTOPPINGBASIC
     28: #define svdstoppingthreshold_             SVDSTOPPINGTHRESHOLD
     29: #define svdsetstoppingtestfunction_       SVDSETSTOPPINGTESTFUNCTION
     30: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
     31: #define svdmonitorset_                    svdmonitorset
     32: #define svdmonitorall_                    svdmonitorall
     33: #define svdmonitorfirst_                  svdmonitorfirst
     34: #define svdmonitorconditioning_           svdmonitorconditioning
     35: #define svdmonitorconverged_              svdmonitorconverged
     36: #define svdmonitorconvergedcreate_        svdmonitorconvergedcreate
     37: #define svdmonitorconvergeddestroy_       svdmonitorconvergeddestroy
     38: #define svdconvergedabsolute_             svdconvergedabsolute
     39: #define svdconvergedrelative_             svdconvergedrelative
     40: #define svdconvergednorm_                 svdconvergednorm
     41: #define svdconvergedmaxit_                svdconvergedmaxit
     42: #define svdsetconvergencetestfunction_    svdsetconvergencetestfunction
     43: #define svdstoppingbasic_                 svdstoppingbasic
     44: #define svdstoppingthreshold_             svdstoppingthreshold
     45: #define svdsetstoppingtestfunction_       svdsetstoppingtestfunction
     46: #endif

     48: /*
     49:    These cannot be called from Fortran but allow Fortran users
     50:    to transparently set these monitors from .F code
     51: */
     52: SLEPC_EXTERN void svdmonitorall_(SVD*,PetscInt*,PetscInt*,PetscReal*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
     53: SLEPC_EXTERN void svdmonitorfirst_(SVD*,PetscInt*,PetscInt*,PetscReal*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
     54: SLEPC_EXTERN void svdmonitorconditioning_(SVD*,PetscInt*,PetscInt*,PetscReal*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
     55: SLEPC_EXTERN void svdmonitorconverged_(SVD*,PetscInt*,PetscInt*,PetscReal*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);

     57: SLEPC_EXTERN void svdmonitorconvergedcreate_(PetscViewer *vin,PetscViewerFormat *format,void *ctx,PetscViewerAndFormat **vf,PetscErrorCode *ierr)
     58: {
     59:   PetscViewer v;
     60:   PetscPatchDefaultViewers_Fortran(vin,v);
     61:   CHKFORTRANNULLOBJECT(ctx);
     62:   *ierr = SVDMonitorConvergedCreate(v,*format,ctx,vf);
     63: }

     65: SLEPC_EXTERN void svdmonitorconvergeddestroy_(PetscViewerAndFormat **vf,PetscErrorCode *ierr)
     66: {
     67:   *ierr = SVDMonitorConvergedDestroy(vf);
     68: }

     70: static struct {
     71:   PetscFortranCallbackId monitor;
     72:   PetscFortranCallbackId monitordestroy;
     73:   PetscFortranCallbackId convergence;
     74:   PetscFortranCallbackId convdestroy;
     75:   PetscFortranCallbackId stopping;
     76:   PetscFortranCallbackId stopdestroy;
     77: } _cb;

     79: /* These are not extern C because they are passed into non-extern C user level functions */
     80: static PetscErrorCode ourmonitor(SVD svd,PetscInt i,PetscInt nc,PetscReal *sigma,PetscReal *d,PetscInt l,void *ctx)
     81: {
     82:   PetscObjectUseFortranCallback(svd,_cb.monitor,(SVD*,PetscInt*,PetscInt*,PetscReal*,PetscReal*,PetscInt*,void*,PetscErrorCode*),(&svd,&i,&nc,sigma,d,&l,_ctx,&ierr));
     83: }

     85: static PetscErrorCode ourdestroy(void **ctx)
     86: {
     87:   SVD svd = (SVD)*ctx;
     88:   PetscObjectUseFortranCallback(svd,_cb.monitordestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
     89: }

     91: static PetscErrorCode ourconvergence(SVD svd,PetscReal sigma,PetscReal res,PetscReal *errest,void *ctx)
     92: {
     93:   PetscObjectUseFortranCallback(svd,_cb.convergence,(SVD*,PetscReal*,PetscReal*,PetscReal*,void*,PetscErrorCode*),(&svd,&sigma,&res,errest,_ctx,&ierr));
     94: }

     96: static PetscErrorCode ourconvdestroy(void **ctx)
     97: {
     98:   SVD svd = (SVD)*ctx;
     99:   PetscObjectUseFortranCallback(svd,_cb.convdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
    100: }

    102: static PetscErrorCode ourstopping(SVD svd,PetscInt its,PetscInt max_it,PetscInt nconv,PetscInt nsv,SVDConvergedReason *reason,void *ctx)
    103: {
    104:   PetscObjectUseFortranCallback(svd,_cb.stopping,(SVD*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,SVDConvergedReason*,void*,PetscErrorCode*),(&svd,&its,&max_it,&nconv,&nsv,reason,_ctx,&ierr));
    105: }

    107: static PetscErrorCode ourstopdestroy(void **ctx)
    108: {
    109:   SVD svd = (SVD)*ctx;
    110:   PetscObjectUseFortranCallback(svd,_cb.stopdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
    111: }

    113: SLEPC_EXTERN void svdmonitorset_(SVD *svd,void (*monitor)(SVD*,PetscInt*,PetscInt*,PetscReal*,PetscReal*,PetscInt*,void*,PetscErrorCode*),void *mctx,PetscCtxDestroyFn monitordestroy,PetscErrorCode *ierr)
    114: {
    115:   CHKFORTRANNULLOBJECT(mctx);
    116:   CHKFORTRANNULLFUNCTION(monitordestroy);
    117:   if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)svdmonitorall_) {
    118:     *ierr = SVDMonitorSet(*svd,(SVDMonitorFn*)SVDMonitorAll,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
    119:   } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)svdmonitorconverged_) {
    120:     *ierr = SVDMonitorSet(*svd,(SVDMonitorFn*)SVDMonitorConverged,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)SVDMonitorConvergedDestroy);
    121:   } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)svdmonitorfirst_) {
    122:     *ierr = SVDMonitorSet(*svd,(SVDMonitorFn*)SVDMonitorFirst,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
    123:   } else {
    124:     *ierr = PetscObjectSetFortranCallback((PetscObject)*svd,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitor,(PetscFortranCallbackFn*)monitor,mctx); if (*ierr) return;
    125:     *ierr = PetscObjectSetFortranCallback((PetscObject)*svd,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitordestroy,(PetscFortranCallbackFn*)monitordestroy,mctx); if (*ierr) return;
    126:     *ierr = SVDMonitorSet(*svd,ourmonitor,*svd,ourdestroy);
    127:   }
    128: }

    130: SLEPC_EXTERN void svdconvergedabsolute_(SVD*,PetscReal*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
    131: SLEPC_EXTERN void svdconvergedrelative_(SVD*,PetscReal*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
    132: SLEPC_EXTERN void svdconvergednorm_(SVD*,PetscReal*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
    133: SLEPC_EXTERN void svdconvergedmaxit_(SVD*,PetscReal*,PetscReal*,PetscReal*,void*,PetscErrorCode*);

    135: SLEPC_EXTERN void svdsetconvergencetestfunction_(SVD *svd,void (*func)(SVD*,PetscReal*,PetscReal*,PetscReal*,void*,PetscErrorCode*),void *ctx,PetscCtxDestroyFn destroy,PetscErrorCode *ierr)
    136: {
    137:   CHKFORTRANNULLOBJECT(ctx);
    138:   CHKFORTRANNULLFUNCTION(destroy);
    139:   if (func == svdconvergedabsolute_) {
    140:     *ierr = SVDSetConvergenceTest(*svd,SVD_CONV_ABS);
    141:   } else if (func == svdconvergedrelative_) {
    142:     *ierr = SVDSetConvergenceTest(*svd,SVD_CONV_REL);
    143:   } else if (func == svdconvergednorm_) {
    144:     *ierr = SVDSetConvergenceTest(*svd,SVD_CONV_NORM);
    145:   } else if (func == svdconvergedmaxit_) {
    146:     *ierr = SVDSetConvergenceTest(*svd,SVD_CONV_MAXIT);
    147:   } else {
    148:     *ierr = PetscObjectSetFortranCallback((PetscObject)*svd,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.convergence,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
    149:     *ierr = PetscObjectSetFortranCallback((PetscObject)*svd,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.convdestroy,(PetscFortranCallbackFn*)destroy,ctx); if (*ierr) return;
    150:     *ierr = SVDSetConvergenceTestFunction(*svd,ourconvergence,*svd,ourconvdestroy);
    151:   }
    152: }

    154: SLEPC_EXTERN void svdstoppingbasic_(SVD*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,SVDConvergedReason*,void*,PetscErrorCode*);
    155: SLEPC_EXTERN void svdstoppingthreshold_(SVD*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,SVDConvergedReason*,void*,PetscErrorCode*);

    157: SLEPC_EXTERN void svdsetstoppingtestfunction_(SVD *svd,void (*func)(SVD*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,SVDConvergedReason*,void*,PetscErrorCode*),void *ctx,PetscCtxDestroyFn destroy,PetscErrorCode *ierr)
    158: {
    159:   CHKFORTRANNULLOBJECT(ctx);
    160:   CHKFORTRANNULLFUNCTION(destroy);
    161:   if (func == svdstoppingbasic_) {
    162:     *ierr = SVDSetStoppingTest(*svd,SVD_STOP_BASIC);
    163:   } else if (func == svdstoppingthreshold_) {
    164:     *ierr = SVDSetStoppingTest(*svd,SVD_STOP_THRESHOLD);
    165:   } else {
    166:     *ierr = PetscObjectSetFortranCallback((PetscObject)*svd,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.stopping,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
    167:     *ierr = PetscObjectSetFortranCallback((PetscObject)*svd,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.stopdestroy,(PetscFortranCallbackFn*)destroy,ctx); if (*ierr) return;
    168:     *ierr = SVDSetStoppingTestFunction(*svd,ourstopping,*svd,ourstopdestroy);
    169:   }
    170: }