GCC Code Coverage Report

Directory: ./
File: src/svd/interface/ftn-custom/zsvdf.c
Date: 2026-05-04 03:58:11
Exec Total Coverage
Lines: 13 56 23.2%
Functions: 2 10 20.0%
Branches: 33 258 12.8%
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 <slepcsvd.h>
13
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 svdconvergedabsolute_ SVDCONVERGEDABSOLUTE
22 #define svdconvergedrelative_ SVDCONVERGEDRELATIVE
23 #define svdconvergednorm_ SVDCONVERGEDNORM
24 #define svdconvergedmaxit_ SVDCONVERGEDMAXIT
25 #define svdsetconvergencetestfunction_ SVDSETCONVERGENCETESTFUNCTION
26 #define svdstoppingbasic_ SVDSTOPPINGBASIC
27 #define svdstoppingthreshold_ SVDSTOPPINGTHRESHOLD
28 #define svdsetstoppingtestfunction_ SVDSETSTOPPINGTESTFUNCTION
29 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
30 #define svdmonitorset_ svdmonitorset
31 #define svdmonitorall_ svdmonitorall
32 #define svdmonitorfirst_ svdmonitorfirst
33 #define svdmonitorconditioning_ svdmonitorconditioning
34 #define svdmonitorconverged_ svdmonitorconverged
35 #define svdmonitorconvergedcreate_ svdmonitorconvergedcreate
36 #define svdconvergedabsolute_ svdconvergedabsolute
37 #define svdconvergedrelative_ svdconvergedrelative
38 #define svdconvergednorm_ svdconvergednorm
39 #define svdconvergedmaxit_ svdconvergedmaxit
40 #define svdsetconvergencetestfunction_ svdsetconvergencetestfunction
41 #define svdstoppingbasic_ svdstoppingbasic
42 #define svdstoppingthreshold_ svdstoppingthreshold
43 #define svdsetstoppingtestfunction_ svdsetstoppingtestfunction
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 svdmonitorall_(SVD*,PetscInt*,PetscInt*,PetscReal*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
51 SLEPC_EXTERN void svdmonitorfirst_(SVD*,PetscInt*,PetscInt*,PetscReal*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
52 SLEPC_EXTERN void svdmonitorconditioning_(SVD*,PetscInt*,PetscInt*,PetscReal*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
53 SLEPC_EXTERN void svdmonitorconverged_(SVD*,PetscInt*,PetscInt*,PetscReal*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
54
55 30 SLEPC_EXTERN void svdmonitorconvergedcreate_(PetscViewer *vin,PetscViewerFormat *format,void *ctx,PetscViewerAndFormat **vf,PetscErrorCode *ierr)
56 {
57 30 PetscViewer v;
58
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.
 30 PetscPatchDefaultViewers_Fortran(vin,v);
59
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.
 30 CHKFORTRANNULLOBJECT(ctx);
60 30 *ierr = SVDMonitorConvergedCreate(v,*format,ctx,vf);
61 }
62
63 static struct {
64 PetscFortranCallbackId monitor;
65 PetscFortranCallbackId monitordestroy;
66 PetscFortranCallbackId convergence;
67 PetscFortranCallbackId convdestroy;
68 PetscFortranCallbackId stopping;
69 PetscFortranCallbackId stopdestroy;
70 } _cb;
71
72 /* These are not extern C because they are passed into non-extern C user level functions */
73 ✗ static PetscErrorCode ourmonitor(SVD svd,PetscInt i,PetscInt nc,PetscReal *sigma,PetscReal *d,PetscInt l,void *ctx)
74 {
75 ✗ PetscObjectUseFortranCallback(svd,_cb.monitor,(SVD*,PetscInt*,PetscInt*,PetscReal*,PetscReal*,PetscInt*,void*,PetscErrorCode*),(&svd,&i,&nc,sigma,d,&l,_ctx,&ierr));
76 }
77
78 ✗ static PetscErrorCode ourdestroy(PetscCtxRt ctx)
79 {
80 ✗ SVD svd = *(SVD*)ctx;
81 ✗ PetscObjectUseFortranCallback(svd,_cb.monitordestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
82 }
83
84 ✗ static PetscErrorCode ourconvergence(SVD svd,PetscReal sigma,PetscReal res,PetscReal *errest,void *ctx)
85 {
86 ✗ PetscObjectUseFortranCallback(svd,_cb.convergence,(SVD*,PetscReal*,PetscReal*,PetscReal*,void*,PetscErrorCode*),(&svd,&sigma,&res,errest,_ctx,&ierr));
87 }
88
89 ✗ static PetscErrorCode ourconvdestroy(PetscCtxRt ctx)
90 {
91 ✗ SVD svd = *(SVD*)ctx;
92 ✗ PetscObjectUseFortranCallback(svd,_cb.convdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
93 }
94
95 ✗ static PetscErrorCode ourstopping(SVD svd,PetscInt its,PetscInt max_it,PetscInt nconv,PetscInt nsv,SVDConvergedReason *reason,void *ctx)
96 {
97 ✗ PetscObjectUseFortranCallback(svd,_cb.stopping,(SVD*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,SVDConvergedReason*,void*,PetscErrorCode*),(&svd,&its,&max_it,&nconv,&nsv,reason,_ctx,&ierr));
98 }
99
100 ✗ static PetscErrorCode ourstopdestroy(PetscCtxRt ctx)
101 {
102 ✗ SVD svd = *(SVD*)ctx;
103 ✗ PetscObjectUseFortranCallback(svd,_cb.stopdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
104 }
105
106 60 SLEPC_EXTERN void svdmonitorset_(SVD *svd,void (*monitor)(SVD*,PetscInt*,PetscInt*,PetscReal*,PetscReal*,PetscInt*,void*,PetscErrorCode*),void *mctx,void (*monitordestroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
107 {
108
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.
 60 CHKFORTRANNULLOBJECT(mctx);
109
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.
 60 CHKFORTRANNULLFUNCTION(monitordestroy);
110
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 60 if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)svdmonitorall_) {
111 ✗ *ierr = SVDMonitorSet(*svd,(SVDMonitorFn*)SVDMonitorAll,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
112
2/2
✓ Branch 0 taken 6 times.
✓ Branch 1 taken 6 times.
 60 } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)svdmonitorconverged_) {
113 30 *ierr = SVDMonitorSet(*svd,(SVDMonitorFn*)SVDMonitorConverged,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
114
1/2
✓ Branch 0 taken 6 times.
✗ Branch 1 not taken.
 30 } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)svdmonitorfirst_) {
115 30 *ierr = SVDMonitorSet(*svd,(SVDMonitorFn*)SVDMonitorFirst,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
116 } else {
117 ✗ *ierr = PetscObjectSetFortranCallback((PetscObject)*svd,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitor,(PetscFortranCallbackFn*)monitor,mctx); if (*ierr) return;
118 ✗ *ierr = PetscObjectSetFortranCallback((PetscObject)*svd,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitordestroy,(PetscFortranCallbackFn*)monitordestroy,mctx); if (*ierr) return;
119 ✗ *ierr = SVDMonitorSet(*svd,ourmonitor,*svd,ourdestroy);
120 }
121 }
122
123 SLEPC_EXTERN void svdconvergedabsolute_(SVD*,PetscReal*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
124 SLEPC_EXTERN void svdconvergedrelative_(SVD*,PetscReal*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
125 SLEPC_EXTERN void svdconvergednorm_(SVD*,PetscReal*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
126 SLEPC_EXTERN void svdconvergedmaxit_(SVD*,PetscReal*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
127
128 ✗ SLEPC_EXTERN void svdsetconvergencetestfunction_(SVD *svd,void (*func)(SVD*,PetscReal*,PetscReal*,PetscReal*,void*,PetscErrorCode*),void *ctx,void (*destroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
129 {
130 ✗ CHKFORTRANNULLOBJECT(ctx);
131 ✗ CHKFORTRANNULLFUNCTION(destroy);
132 ✗ if (func == svdconvergedabsolute_) {
133 ✗ *ierr = SVDSetConvergenceTest(*svd,SVD_CONV_ABS);
134 ✗ } else if (func == svdconvergedrelative_) {
135 ✗ *ierr = SVDSetConvergenceTest(*svd,SVD_CONV_REL);
136 ✗ } else if (func == svdconvergednorm_) {
137 ✗ *ierr = SVDSetConvergenceTest(*svd,SVD_CONV_NORM);
138 ✗ } else if (func == svdconvergedmaxit_) {
139 ✗ *ierr = SVDSetConvergenceTest(*svd,SVD_CONV_MAXIT);
140 } else {
141 ✗ *ierr = PetscObjectSetFortranCallback((PetscObject)*svd,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.convergence,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
142 ✗ *ierr = PetscObjectSetFortranCallback((PetscObject)*svd,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.convdestroy,(PetscFortranCallbackFn*)destroy,ctx); if (*ierr) return;
143 ✗ *ierr = SVDSetConvergenceTestFunction(*svd,ourconvergence,*svd,ourconvdestroy);
144 }
145 }
146
147 SLEPC_EXTERN void svdstoppingbasic_(SVD*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,SVDConvergedReason*,void*,PetscErrorCode*);
148 SLEPC_EXTERN void svdstoppingthreshold_(SVD*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,SVDConvergedReason*,void*,PetscErrorCode*);
149
150 ✗ SLEPC_EXTERN void svdsetstoppingtestfunction_(SVD *svd,void (*func)(SVD*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,SVDConvergedReason*,void*,PetscErrorCode*),void *ctx,void (*destroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
151 {
152 ✗ CHKFORTRANNULLOBJECT(ctx);
153 ✗ CHKFORTRANNULLFUNCTION(destroy);
154 ✗ if (func == svdstoppingbasic_) {
155 ✗ *ierr = SVDSetStoppingTest(*svd,SVD_STOP_BASIC);
156 ✗ } else if (func == svdstoppingthreshold_) {
157 ✗ *ierr = SVDSetStoppingTest(*svd,SVD_STOP_THRESHOLD);
158 } else {
159 ✗ *ierr = PetscObjectSetFortranCallback((PetscObject)*svd,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.stopping,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
160 ✗ *ierr = PetscObjectSetFortranCallback((PetscObject)*svd,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.stopdestroy,(PetscFortranCallbackFn*)destroy,ctx); if (*ierr) return;
161 ✗ *ierr = SVDSetStoppingTestFunction(*svd,ourstopping,*svd,ourstopdestroy);
162 }
163 }
164