GCC Code Coverage Report

Directory: ./
File: src/nep/interface/ftn-custom/znepf.c
Date: 2026-05-04 03:58:11
Exec Total Coverage
Lines: 29 84 34.5%
Functions: 6 18 33.3%
Branches: 45 436 10.3%
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 <slepcnep.h>
13
14 #if defined(PETSC_HAVE_FORTRAN_CAPS)
15 #define nepmonitorset_ NEPMONITORSET
16 #define nepmonitorall_ NEPMONITORALL
17 #define nepmonitorfirst_ NEPMONITORFIRST
18 #define nepmonitorconverged_ NEPMONITORCONVERGED
19 #define nepmonitorconvergedcreate_ NEPMONITORCONVERGEDCREATE
20 #define nepconvergedabsolute_ NEPCONVERGEDABSOLUTE
21 #define nepconvergedrelative_ NEPCONVERGEDRELATIVE
22 #define nepsetconvergencetestfunction_ NEPSETCONVERGENCETESTFUNCTION
23 #define nepsetstoppingtestfunction_ NEPSETSTOPPINGTESTFUNCTION
24 #define nepseteigenvaluecomparison_ NEPSETEIGENVALUECOMPARISON
25 #define nepsetfunction_ NEPSETFUNCTION
26 #define nepgetfunction_ NEPGETFUNCTION
27 #define nepsetjacobian_ NEPSETJACOBIAN
28 #define nepgetjacobian_ NEPGETJACOBIAN
29 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
30 #define nepmonitorset_ nepmonitorset
31 #define nepmonitorall_ nepmonitorall
32 #define nepmonitorfirst_ nepmonitorfirst
33 #define nepmonitorconverged_ nepmonitorconverged
34 #define nepmonitorconvergedcreate_ nepmonitorconvergedcreate
35 #define nepconvergedabsolute_ nepconvergedabsolute
36 #define nepconvergedrelative_ nepconvergedrelative
37 #define nepsetconvergencetestfunction_ nepsetconvergencetestfunction
38 #define nepsetstoppingtestfunction_ nepsetstoppingtestfunction
39 #define nepseteigenvaluecomparison_ nepseteigenvaluecomparison
40 #define nepsetfunction_ nepsetfunction
41 #define nepgetfunction_ nepgetfunction
42 #define nepsetjacobian_ nepsetjacobian
43 #define nepgetjacobian_ nepgetjacobian
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 nepmonitorall_(NEP*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
51 SLEPC_EXTERN void nepmonitorfirst_(NEP*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
52 SLEPC_EXTERN void nepmonitorconverged_(NEP*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
53
54 6 SLEPC_EXTERN void nepmonitorconvergedcreate_(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 = NEPMonitorConvergedCreate(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 function;
71 PetscFortranCallbackId jacobian;
72 #if defined(PETSC_HAVE_F90_2PTR_ARG)
73 PetscFortranCallbackId function_pgiptr;
74 PetscFortranCallbackId jacobian_pgiptr;
75 #endif
76 } _cb;
77
78 /* These are not extern C because they are passed into non-extern C user level functions */
79 ✗ static PetscErrorCode ourmonitor(NEP nep,PetscInt i,PetscInt nc,PetscScalar *er,PetscScalar *ei,PetscReal *d,PetscInt l,void *ctx)
80 {
81 ✗ PetscObjectUseFortranCallback(nep,_cb.monitor,(NEP*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,void*,PetscErrorCode*),(&nep,&i,&nc,er,ei,d,&l,_ctx,&ierr));
82 }
83
84 ✗ static PetscErrorCode ourdestroy(PetscCtxRt ctx)
85 {
86 ✗ NEP nep = *(NEP*)ctx;
87 ✗ PetscObjectUseFortranCallback(nep,_cb.monitordestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
88 }
89
90 ✗ static PetscErrorCode ourconvergence(NEP nep,PetscScalar eigr,PetscScalar eigi,PetscReal res,PetscReal *errest,void *ctx)
91 {
92 ✗ PetscObjectUseFortranCallback(nep,_cb.convergence,(NEP*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*),(&nep,&eigr,&eigi,&res,errest,_ctx,&ierr));
93 }
94
95 ✗ static PetscErrorCode ourconvdestroy(PetscCtxRt ctx)
96 {
97 ✗ NEP nep = *(NEP*)ctx;
98 ✗ PetscObjectUseFortranCallback(nep,_cb.convdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
99 }
100
101 ✗ static PetscErrorCode ourstopping(NEP nep,PetscInt its,PetscInt max_it,PetscInt nconv,PetscInt nev,NEPConvergedReason *reason,void *ctx)
102 {
103 ✗ PetscObjectUseFortranCallback(nep,_cb.stopping,(NEP*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,NEPConvergedReason*,void*,PetscErrorCode*),(&nep,&its,&max_it,&nconv,&nev,reason,_ctx,&ierr));
104 }
105
106 ✗ static PetscErrorCode ourstopdestroy(PetscCtxRt ctx)
107 {
108 ✗ NEP nep = *(NEP*)ctx;
109 ✗ PetscObjectUseFortranCallback(nep,_cb.stopdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
110 }
111
112 ✗ static PetscErrorCode oureigenvaluecomparison(PetscScalar ar,PetscScalar ai,PetscScalar br,PetscScalar bi,PetscInt *r,void *ctx)
113 {
114 ✗ NEP eps = (NEP)ctx;
115 ✗ PetscObjectUseFortranCallback(eps,_cb.comparison,(PetscScalar*,PetscScalar*,PetscScalar*,PetscScalar*,PetscInt*,void*,PetscErrorCode*),(&ar,&ai,&br,&bi,r,_ctx,&ierr));
116 }
117
118 944 static PetscErrorCode ournepfunction(NEP nep,PetscScalar lambda,Mat T,Mat P,void *ctx)
119 {
120 #if defined(PETSC_HAVE_F90_2PTR_ARG)
121 157 void *ptr;
122
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 1 times.
 157 PetscCall(PetscObjectGetFortranCallback((PetscObject)nep,PETSC_FORTRAN_CALLBACK_CLASS,_cb.function_pgiptr,NULL,&ptr));
123 #endif
124
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.
 944 PetscObjectUseFortranCallback(nep,_cb.function,(NEP*,PetscScalar*,Mat*,Mat*,void*,PetscErrorCode* PETSC_F90_2PTR_PROTO_NOVAR),(&nep,&lambda,&T,&P,_ctx,&ierr PETSC_F90_2PTR_PARAM(ptr)));
125 }
126
127 84 static PetscErrorCode ournepjacobian(NEP nep,PetscScalar lambda,Mat J,void *ctx)
128 {
129 #if defined(PETSC_HAVE_F90_2PTR_ARG)
130 14 void *ptr;
131
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 1 times.
 14 PetscCall(PetscObjectGetFortranCallback((PetscObject)nep,PETSC_FORTRAN_CALLBACK_CLASS,_cb.jacobian_pgiptr,NULL,&ptr));
132 #endif
133
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.
 84 PetscObjectUseFortranCallback(nep,_cb.jacobian,(NEP*,PetscScalar*,Mat*,void*,PetscErrorCode* PETSC_F90_2PTR_PROTO_NOVAR),(&nep,&lambda,&J,_ctx,&ierr PETSC_F90_2PTR_PARAM(ptr)));
134 }
135
136 12 SLEPC_EXTERN void nepmonitorset_(NEP *nep,void (*monitor)(NEP*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,void*,PetscErrorCode*),void *mctx,void (*monitordestroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
137 {
138
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.
 12 CHKFORTRANNULLOBJECT(mctx);
139
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.
 12 CHKFORTRANNULLFUNCTION(monitordestroy);
140
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)nepmonitorall_) {
141 ✗ *ierr = NEPMonitorSet(*nep,(NEPMonitorFn*)NEPMonitorAll,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
142
2/2
✓ Branch 0 taken 6 times.
✓ Branch 1 taken 6 times.
 12 } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)nepmonitorconverged_) {
143 6 *ierr = NEPMonitorSet(*nep,(NEPMonitorFn*)NEPMonitorConverged,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
144
1/2
✓ Branch 0 taken 6 times.
✗ Branch 1 not taken.
 6 } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)nepmonitorfirst_) {
145 6 *ierr = NEPMonitorSet(*nep,(NEPMonitorFn*)NEPMonitorFirst,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
146 } else {
147 ✗ *ierr = PetscObjectSetFortranCallback((PetscObject)*nep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitor,(PetscFortranCallbackFn*)monitor,mctx); if (*ierr) return;
148 ✗ *ierr = PetscObjectSetFortranCallback((PetscObject)*nep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitordestroy,(PetscFortranCallbackFn*)monitordestroy,mctx); if (*ierr) return;
149 ✗ *ierr = NEPMonitorSet(*nep,ourmonitor,*nep,ourdestroy);
150 }
151 }
152
153 SLEPC_EXTERN void nepconvergedabsolute_(NEP*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
154 SLEPC_EXTERN void nepconvergedrelative_(NEP*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
155
156 ✗ SLEPC_EXTERN void nepsetconvergencetestfunction_(NEP *nep,void (*func)(NEP*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*),void *ctx,void (*destroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
157 {
158 ✗ CHKFORTRANNULLOBJECT(ctx);
159 ✗ CHKFORTRANNULLFUNCTION(destroy);
160 ✗ if (func == nepconvergedabsolute_) {
161 ✗ *ierr = NEPSetConvergenceTest(*nep,NEP_CONV_ABS);
162 ✗ } else if (func == nepconvergedrelative_) {
163 ✗ *ierr = NEPSetConvergenceTest(*nep,NEP_CONV_REL);
164 } else {
165 ✗ *ierr = PetscObjectSetFortranCallback((PetscObject)*nep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.convergence,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
166 ✗ *ierr = PetscObjectSetFortranCallback((PetscObject)*nep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.convdestroy,(PetscFortranCallbackFn*)destroy,ctx); if (*ierr) return;
167 ✗ *ierr = NEPSetConvergenceTestFunction(*nep,ourconvergence,*nep,ourconvdestroy);
168 }
169 }
170
171 SLEPC_EXTERN void nepstoppingbasic_(NEP*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,NEPConvergedReason*,void*,PetscErrorCode*);
172
173 ✗ SLEPC_EXTERN void nepsetstoppingtestfunction_(NEP *nep,void (*func)(NEP*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,NEPConvergedReason*,void*,PetscErrorCode*),void *ctx,void (*destroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
174 {
175 ✗ CHKFORTRANNULLOBJECT(ctx);
176 ✗ CHKFORTRANNULLFUNCTION(destroy);
177 ✗ if (func == nepstoppingbasic_) {
178 ✗ *ierr = NEPSetStoppingTest(*nep,NEP_STOP_BASIC);
179 } else {
180 ✗ *ierr = PetscObjectSetFortranCallback((PetscObject)*nep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.stopping,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
181 ✗ *ierr = PetscObjectSetFortranCallback((PetscObject)*nep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.stopdestroy,(PetscFortranCallbackFn*)destroy,ctx); if (*ierr) return;
182 ✗ *ierr = NEPSetStoppingTestFunction(*nep,ourstopping,*nep,ourstopdestroy);
183 }
184 }
185
186 ✗ SLEPC_EXTERN void nepseteigenvaluecomparison_(NEP *nep,void (*func)(PetscScalar*,PetscScalar*,PetscScalar*,PetscScalar*,PetscInt*,void*),void *ctx,PetscErrorCode *ierr)
187 {
188 ✗ CHKFORTRANNULLOBJECT(ctx);
189 ✗ *ierr = PetscObjectSetFortranCallback((PetscObject)*nep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.comparison,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
190 ✗ *ierr = NEPSetEigenvalueComparison(*nep,oureigenvaluecomparison,*nep);
191 }
192
193 24 SLEPC_EXTERN void nepsetfunction_(NEP *nep,Mat *A,Mat *B,void (*func)(NEP*,PetscScalar*,Mat*,Mat*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr))
194 {
195
1/2
✓ Branch 0 taken 6 times.
✗ Branch 1 not taken.
 24 *ierr = PetscObjectSetFortranCallback((PetscObject)*nep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.function,(PetscFortranCallbackFn*)func,ctx);if (*ierr) return;
196 #if defined(PETSC_HAVE_F90_2PTR_ARG)
197
1/2
✓ Branch 0 taken 1 times.
✗ Branch 1 not taken.
 4 *ierr = PetscObjectSetFortranCallback((PetscObject)*nep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.function_pgiptr,NULL,ptr);if (*ierr) return;
198 #endif
199 24 *ierr = NEPSetFunction(*nep,*A,*B,ournepfunction,NULL);
200 }
201
202 /* func is currently ignored from Fortran */
203 ✗ SLEPC_EXTERN void nepgetfunction_(NEP *nep,Mat *A,Mat *B,void *func,void **ctx,PetscErrorCode *ierr)
204 {
205 ✗ CHKFORTRANNULLINTEGER(ctx);
206 ✗ CHKFORTRANNULLOBJECT(A);
207 ✗ CHKFORTRANNULLOBJECT(B);
208 ✗ *ierr = NEPGetFunction(*nep,A,B,NULL,NULL); if (*ierr) return;
209 ✗ *ierr = PetscObjectGetFortranCallback((PetscObject)*nep,PETSC_FORTRAN_CALLBACK_CLASS,_cb.function,NULL,ctx);
210 }
211
212 24 SLEPC_EXTERN void nepsetjacobian_(NEP *nep,Mat *J,void (*func)(NEP*,PetscScalar*,Mat*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr))
213 {
214
1/2
✓ Branch 0 taken 6 times.
✗ Branch 1 not taken.
 24 *ierr = PetscObjectSetFortranCallback((PetscObject)*nep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.jacobian,(PetscFortranCallbackFn*)func,ctx);if (*ierr) return;
215 #if defined(PETSC_HAVE_F90_2PTR_ARG)
216
1/2
✓ Branch 0 taken 1 times.
✗ Branch 1 not taken.
 4 *ierr = PetscObjectSetFortranCallback((PetscObject)*nep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.jacobian_pgiptr,NULL,ptr);if (*ierr) return;
217 #endif
218 24 *ierr = NEPSetJacobian(*nep,*J,ournepjacobian,NULL);
219 }
220
221 /* func is currently ignored from Fortran */
222 ✗ SLEPC_EXTERN void nepgetjacobian_(NEP *nep,Mat *J,void *func,void **ctx,PetscErrorCode *ierr)
223 {
224 ✗ CHKFORTRANNULLINTEGER(ctx);
225 ✗ CHKFORTRANNULLOBJECT(J);
226 ✗ *ierr = NEPGetJacobian(*nep,J,NULL,NULL); if (*ierr) return;
227 ✗ *ierr = PetscObjectGetFortranCallback((PetscObject)*nep,PETSC_FORTRAN_CALLBACK_CLASS,_cb.jacobian,NULL,ctx);
228 }
229