GCC Code Coverage Report

Directory: ./
File: src/pep/interface/ftn-custom/zpepf.c
Date: 2026-05-04 03:58:11
Exec Total Coverage
Lines: 13 57 22.8%
Functions: 2 12 16.7%
Branches: 33 284 11.6%
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 <slepcpep.h>
13
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
37
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*);
45
46 6 SLEPC_EXTERN void pepmonitorconvergedcreate_(PetscViewer *vin,PetscViewerFormat *format,void *ctx,PetscViewerAndFormat **vf,PetscErrorCode *ierr)
47 {
48 6 PetscViewer v;
49
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);
50
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);
51 6 *ierr = PEPMonitorConvergedCreate(v,*format,ctx,vf);
52 }
53
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;
63
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 }
69
70 ✗ static PetscErrorCode ourdestroy(PetscCtxRt ctx)
71 {
72 ✗ PEP pep = *(PEP*)ctx;
73 ✗ PetscObjectUseFortranCallback(pep,_cb.monitordestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
74 }
75
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 }
80
81 ✗ static PetscErrorCode ourconvdestroy(PetscCtxRt ctx)
82 {
83 ✗ PEP pep = *(PEP*)ctx;
84 ✗ PetscObjectUseFortranCallback(pep,_cb.convdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
85 }
86
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 }
91
92 ✗ static PetscErrorCode ourstopdestroy(PetscCtxRt ctx)
93 {
94 ✗ PEP pep = *(PEP*)ctx;
95 ✗ PetscObjectUseFortranCallback(pep,_cb.stopdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
96 }
97
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 }
103
104 12 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
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);
107
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);
108
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)pepmonitorall_) {
109 ✗ *ierr = PEPMonitorSet(*pep,(PEPMonitorFn*)PEPMonitorAll,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
110
2/2
✓ Branch 0 taken 6 times.
✓ Branch 1 taken 6 times.
 12 } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)pepmonitorconverged_) {
111 6 *ierr = PEPMonitorSet(*pep,(PEPMonitorFn*)PEPMonitorConverged,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
112
1/2
✓ Branch 0 taken 6 times.
✗ Branch 1 not taken.
 6 } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)pepmonitorfirst_) {
113 6 *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 }
120
121 SLEPC_EXTERN void pepconvergedabsolute_(PEP*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
122 SLEPC_EXTERN void pepconvergedrelative_(PEP*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
123
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 }
138
139 SLEPC_EXTERN void pepstoppingbasic_(PEP*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,PEPConvergedReason*,void*,PetscErrorCode*);
140
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 }
153
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 }
160