GCC Code Coverage Report

Directory: ./
File: src/eps/interface/ftn-custom/zepsf.c
Date: 2026-05-04 03:58:11
Exec Total Coverage
Lines: 21 68 30.9%
Functions: 4 14 28.6%
Branches: 42 320 13.1%
Line Branch Exec Source
1 /*
2 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3 SLEPc - Scalable Library for Eigenvalue Problem Computations
4 Copyright (c) 2002-, Universitat Politecnica de Valencia, Spain
5
6 This file is part of SLEPc.
7 SLEPc is distributed under a 2-clause BSD license (see LICENSE).
8 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
9 */
10
11 #include <petsc/private/ftnimpl.h>
12 #include <slepceps.h>
13
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
45
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*);
53
54 6 SLEPC_EXTERN void epsmonitorconvergedcreate_(PetscViewer *vin,PetscViewerFormat *format,void *ctx,PetscViewerAndFormat **vf,PetscErrorCode *ierr)
55 {
56 6 PetscViewer v;
57
4/24
✗ Branch 0 not taken.
✓ Branch 1 taken 2 times.
✓ Branch 2 taken 4 times.
✓ Branch 3 taken 2 times.
✓ Branch 4 taken 1 times.
✗ Branch 5 not taken.
✗ Branch 6 not taken.
✗ Branch 7 not taken.
✗ Branch 8 not taken.
✗ Branch 9 not taken.
✗ Branch 10 not taken.
✗ Branch 11 not taken.
✗ Branch 12 not taken.
✗ Branch 13 not taken.
✗ Branch 14 not taken.
✗ Branch 15 not taken.
✗ Branch 16 not taken.
✗ Branch 17 not taken.
✗ Branch 18 not taken.
✗ Branch 19 not taken.
✗ Branch 20 not taken.
✗ Branch 21 not taken.
✗ Branch 22 not taken.
✗ Branch 23 not taken.
 6 PetscPatchDefaultViewers_Fortran(vin,v);
58
1/24
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
✗ Branch 4 not taken.
✗ Branch 5 not taken.
✗ Branch 6 not taken.
✗ Branch 7 not taken.
✗ Branch 8 not taken.
✗ Branch 9 not taken.
✗ Branch 10 not taken.
✗ Branch 11 not taken.
✗ Branch 12 not taken.
✗ Branch 13 not taken.
✗ Branch 14 not taken.
✗ Branch 15 not taken.
✗ Branch 16 not taken.
✗ Branch 17 not taken.
✗ Branch 18 not taken.
✗ Branch 19 not taken.
✗ Branch 20 not taken.
✗ Branch 21 not taken.
✗ Branch 22 not taken.
✗ Branch 23 not taken.
 6 CHKFORTRANNULLOBJECT(ctx);
59 6 *ierr = EPSMonitorConvergedCreate(v,*format,ctx,vf);
60 }
61
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;
72
73 /* These are not extern C because they are passed into non-extern C user level functions */
74 24 static PetscErrorCode ourmonitor(EPS eps,PetscInt i,PetscInt nc,PetscScalar *er,PetscScalar *ei,PetscReal *d,PetscInt l,void *ctx)
75 {
76
3/6
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
✓ Branch 2 taken 6 times.
✗ Branch 3 not taken.
✗ Branch 4 not taken.
✓ Branch 5 taken 6 times.
 24 PetscObjectUseFortranCallback(eps,_cb.monitor,(EPS*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,void*,PetscErrorCode*),(&eps,&i,&nc,er,ei,d,&l,_ctx,&ierr));
77 }
78
79 6 static PetscErrorCode ourdestroy(PetscCtxRt ctx)
80 {
81 6 EPS eps = *(EPS*)ctx;
82
2/6
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 6 times.
✗ Branch 4 not taken.
✗ Branch 5 not taken.
 6 PetscObjectUseFortranCallback(eps,_cb.monitordestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
83 }
84
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 }
89
90 ✗ static PetscErrorCode ourconvdestroy(PetscCtxRt ctx)
91 {
92 ✗ EPS eps = *(EPS*)ctx;
93 ✗ PetscObjectUseFortranCallback(eps,_cb.convdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
94 }
95
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 }
100
101 ✗ static PetscErrorCode ourstopdestroy(PetscCtxRt ctx)
102 {
103 ✗ EPS eps = *(EPS*)ctx;
104 ✗ PetscObjectUseFortranCallback(eps,_cb.stopdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
105 }
106
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 }
112
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 }
118
119 18 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
12/24
✓ Branch 0 taken 6 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 6 times.
✗ Branch 3 not taken.
✓ Branch 4 taken 6 times.
✗ Branch 5 not taken.
✓ Branch 6 taken 6 times.
✗ Branch 7 not taken.
✓ Branch 8 taken 6 times.
✗ Branch 9 not taken.
✓ Branch 10 taken 6 times.
✗ Branch 11 not taken.
✓ Branch 12 taken 6 times.
✗ Branch 13 not taken.
✓ Branch 14 taken 6 times.
✗ Branch 15 not taken.
✓ Branch 16 taken 6 times.
✗ Branch 17 not taken.
✓ Branch 18 taken 6 times.
✗ Branch 19 not taken.
✓ Branch 20 taken 6 times.
✗ Branch 21 not taken.
✗ Branch 22 not taken.
✓ Branch 23 taken 6 times.
 18 CHKFORTRANNULLOBJECT(mctx);
122
13/24
✓ Branch 0 taken 6 times.
✓ Branch 1 taken 6 times.
✓ Branch 2 taken 6 times.
✗ Branch 3 not taken.
✓ Branch 4 taken 6 times.
✗ Branch 5 not taken.
✓ Branch 6 taken 6 times.
✗ Branch 7 not taken.
✓ Branch 8 taken 6 times.
✗ Branch 9 not taken.
✓ Branch 10 taken 6 times.
✗ Branch 11 not taken.
✓ Branch 12 taken 6 times.
✗ Branch 13 not taken.
✓ Branch 14 taken 6 times.
✗ Branch 15 not taken.
✓ Branch 16 taken 6 times.
✗ Branch 17 not taken.
✓ Branch 18 taken 6 times.
✗ Branch 19 not taken.
✓ Branch 20 taken 6 times.
✗ Branch 21 not taken.
✗ Branch 22 not taken.
✓ Branch 23 taken 6 times.
 18 CHKFORTRANNULLFUNCTION(monitordestroy);
123
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 18 if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)epsmonitorall_) {
124 ✗ *ierr = EPSMonitorSet(*eps,(EPSMonitorFn*)EPSMonitorAll,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
125
2/2
✓ Branch 0 taken 6 times.
✓ Branch 1 taken 6 times.
 18 } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)epsmonitorconverged_) {
126 6 *ierr = EPSMonitorSet(*eps,(EPSMonitorFn*)EPSMonitorConverged,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
127
2/2
✓ Branch 0 taken 6 times.
✓ Branch 1 taken 6 times.
 12 } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)epsmonitorfirst_) {
128 6 *ierr = EPSMonitorSet(*eps,(EPSMonitorFn*)EPSMonitorFirst,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
129 } else {
130
1/2
✓ Branch 0 taken 6 times.
✗ Branch 1 not taken.
 6 *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitor,(PetscFortranCallbackFn*)monitor,mctx); if (*ierr) return;
131
1/2
✓ Branch 0 taken 6 times.
✗ Branch 1 not taken.
 6 *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitordestroy,(PetscFortranCallbackFn*)monitordestroy,mctx); if (*ierr) return;
132 6 *ierr = EPSMonitorSet(*eps,ourmonitor,*eps,ourdestroy);
133 }
134 }
135
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*);
139
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 }
156
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*);
159
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 }
174
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 }
181
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 }
188