GCC Code Coverage Report

Directory: ./
File: src/nep/tutorials/ex54f.F90
Date: 2025-12-10 04:20:18
Exec Total Coverage
Lines: 65 70 92.9%
Functions: 2 2 100.0%
Branches: 46 98 46.9%
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 ! Program usage: mpiexec -n <np> ./ex54f [-help] [-n <n>] [all SLEPc options]
11 !
12 ! Description: Illustrates use of shell matrices in callback interface from Fortran.
13 ! Similar to ex21.c. This one solves a simple diagonal linear eigenproblem as a NEP.
14 !
15 ! The command line options are:
16 ! -n <n>, where <n> = matrix dimension
17
18 #include <slepc/finclude/slepcnep.h>
19
20 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
21 ! Modules needed to pass and get the context to/from the Mat
22 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
23
24 module shell_ctx
25 use petscmat
26 implicit none
27 type :: MatCtx
28 PetscScalar :: lambda
29 end type MatCtx
30 ✗ end module shell_ctx
31
32 module shell_ctx_interfaces
33 use shell_ctx
34 implicit none
35
36 interface MatCreateShell
37 subroutine MatCreateShell(comm, mloc, nloc, m, n, ctx, mat, ierr)
38 use shell_ctx
39 MPI_Comm :: comm
40 PetscInt :: mloc, nloc, m, n
41 type(MatCtx) :: ctx
42 Mat :: mat
43 PetscErrorCode :: ierr
44 end subroutine MatCreateShell
45 end interface MatCreateShell
46
47 interface MatShellSetContext
48 subroutine MatShellSetContext(mat, ctx, ierr)
49 use shell_ctx
50 Mat :: mat
51 type(MatCtx) :: ctx
52 PetscErrorCode :: ierr
53 end subroutine MatShellSetContext
54 end interface MatShellSetContext
55
56 interface MatShellGetContext
57 subroutine MatShellGetContext(mat, ctx, ierr)
58 use shell_ctx
59 Mat :: mat
60 type(MatCtx), pointer :: ctx
61 PetscErrorCode :: ierr
62 end subroutine matShellGetContext
63 end interface MatShellGetContext
64
65 end module shell_ctx_interfaces
66
67 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
68 ! Module used to implement the shell matrix operations
69 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
70
71 module ex54fmodule
72 use slepcnep
73 implicit none
74
75 contains
76 ! --------------------------------------------------------------
77 ! MyNEPFunction - Computes Function matrix T(lambda)
78 !
79 690 subroutine MyNEPFunction(nep, lambda, T, P, ctx, ierr)
80 use slepcnep
81 use shell_ctx_interfaces
82 implicit none
83
84 NEP :: nep
85 PetscScalar :: lambda
86 Mat :: T, P
87 PetscInt :: ctx
88 PetscErrorCode :: ierr
89 type(MatCtx), pointer :: ctxT
90
91
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 690 PetscCall(MatShellGetContext(T, ctxT, ierr))
92 690 ctxT%lambda = lambda
93 end subroutine MyNEPFunction
94
95 ! --------------------------------------------------------------
96 ! MyNEPJacobian - Computes Jacobian matrix T'(lambda)
97 !
98 18 subroutine MyNEPJacobian(nep, lambda, T, ctx, ierr)
99 use slepcnep
100 use shell_ctx_interfaces
101 implicit none
102
103 NEP :: nep
104 PetscScalar :: lambda
105 Mat :: T
106 PetscInt :: ctx
107 PetscErrorCode :: ierr
108 type(MatCtx), pointer :: ctxT
109
110
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 18 PetscCall(MatShellGetContext(T, ctxT, ierr))
111 18 ctxT%lambda = lambda
112 end subroutine MyNEPJacobian
113
114 ! --------------------------------------------------------------
115 ! MatMult_A - Shell matrix operation, multiples y=A*x
116 ! Here A=(D-lambda*I) where D is a diagonal matrix
117 !
118 8265 subroutine MatMult_A(A, x, y, ierr)
119 use shell_ctx_interfaces
120 implicit none
121
122 Mat :: A
123 Vec :: x, y
124 PetscErrorCode :: ierr
125 PetscInt :: i, istart, iend
126 PetscScalar :: val
127 type(MatCtx), pointer :: ctxA
128 !
129
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 8265 PetscCall(VecGetOwnershipRange(x, istart, iend, ierr))
130
2/2
✓ Branch 0 taken 6 times.
✓ Branch 1 taken 6 times.
 3314265 do i = istart, iend - 1
131 3306000 val = i + 1
132 3306000 val = 1.0/val
133
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 3314265 PetscCall(VecSetValue(y, i, val, INSERT_VALUES, ierr))
134 end do
135
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 8265 PetscCall(VecAssemblyBegin(y, ierr))
136
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 8265 PetscCall(VecAssemblyEnd(y, ierr))
137
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 8265 PetscCall(VecPointwiseMult(y, y, x, ierr))
138
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 8265 PetscCall(MatShellGetContext(A, ctxA, ierr))
139
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 8265 PetscCall(VecAXPY(y, -ctxA%lambda, x, ierr))
140 end subroutine MatMult_A
141
142 ! --------------------------------------------------------------
143 ! MatDuplicate_A - Shell matrix operation, duplicates A
144 !
145 18 subroutine MatDuplicate_A(A, opt, M, ierr)
146 use shell_ctx_interfaces
147 implicit none
148
149 Mat :: A, M
150 MatDuplicateOption :: opt
151 PetscErrorCode :: ierr
152 PetscInt :: ml, nl
153 type(MatCtx), pointer :: ctxM, ctxA
154
155
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 18 PetscCall(MatGetLocalSize(A, ml, nl, ierr))
156
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 18 PetscCall(MatShellGetContext(A, ctxA, ierr))
157
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 18 allocate (ctxM)
158 18 ctxM%lambda = ctxA%lambda
159
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 18 PetscCall(MatCreateShell(PETSC_COMM_WORLD, ml, nl, PETSC_DETERMINE, PETSC_DETERMINE, ctxM, M, ierr))
160
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 18 PetscCall(MatShellSetOperation(M, MATOP_MULT, MatMult_A, ierr))
161
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 18 PetscCall(MatShellSetOperation(M, MATOP_DESTROY, MatDestroy_A, ierr))
162 end subroutine MatDuplicate_A
163
164 ! --------------------------------------------------------------
165 ! MatDestroy_A - Shell matrix operation, destroys A
166 !
167 18 subroutine MatDestroy_A(A, ierr)
168 use shell_ctx_interfaces
169 implicit none
170
171 Mat :: A
172 PetscErrorCode :: ierr
173 type(MatCtx), pointer :: ctxA
174
175
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 18 PetscCall(MatShellGetContext(A, ctxA, ierr))
176
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 18 deallocate (ctxA)
177 end subroutine MatDestroy_A
178
179 ! --------------------------------------------------------------
180 ! MatMult_B - Shell matrix operation, multiples y=B*x
181 ! Here B=-I
182 !
183 306 subroutine MatMult_B(B, x, y, ierr)
184 use petscmat
185 implicit none
186
187 Mat :: B
188 Vec :: x
189 Vec :: y
190 PetscErrorCode :: ierr
191 PetscScalar :: mone
192
193
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 306 PetscCall(VecCopy(x, y, ierr))
194 306 mone = -1.0
195
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 306 PetscCall(VecScale(y, mone, ierr))
196 end subroutine MatMult_B
197
198 end module ex54fmodule
199
200 !=================================================================================================
201
202 16 program ex54f
203 12 use slepcnep
204 use shell_ctx_interfaces
205 use ex54fmodule
206 implicit none
207
208 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
209 ! Declarations
210 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
211
212 NEP :: nep
213 Mat :: A, B
214 PetscInt :: n = 400, nev = 3, nconv
215 PetscErrorCode :: ierr
216 PetscScalar :: sigma
217 PetscBool :: flg, terse
218 PetscMPIInt :: rank
219 type(MatCtx) :: ctxA, ctxB
220
221 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
222 ! Beginning of program
223 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
224
225
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(SlepcInitialize(PETSC_NULL_CHARACTER, ierr))
226
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(PetscOptionsGetInt(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-n', n, flg, ierr))
227
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallMPIA(MPI_Comm_rank(PETSC_COMM_WORLD, rank, ierr))
228
1/2
✓ Branch 0 taken 6 times.
✗ Branch 1 not taken.
 12 if (rank == 0) then
229 12 write (*, '(/a,i4)') 'Nonlinear eigenproblem with shell matrices, n =', n
230 end if
231
232 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
233 ! Create matrix-free operators for A and B corresponding to T and T'
234 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
235
236 12 ctxA%lambda = 0.0
237
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(MatCreateShell(PETSC_COMM_WORLD, PETSC_DECIDE, PETSC_DECIDE, n, n, ctxA, A, ierr))
238
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(MatShellSetOperation(A, MATOP_MULT, MatMult_A, ierr))
239
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(MatShellSetOperation(A, MATOP_DUPLICATE, MatDuplicate_A, ierr))
240
241 12 ctxB%lambda = 0.0 ! unused
242
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(MatCreateShell(PETSC_COMM_WORLD, PETSC_DECIDE, PETSC_DECIDE, n, n, ctxB, B, ierr))
243
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(MatShellSetOperation(B, MATOP_MULT, MatMult_B, ierr))
244
245 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
246 ! Create the eigensolver and set various options
247 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
248
249
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(NEPCreate(PETSC_COMM_WORLD, nep, ierr))
250
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(NEPSetFunction(nep, A, A, MyNEPFunction, PETSC_NULL_INTEGER, ierr))
251
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(NEPSetJacobian(nep, B, MyNEPJacobian, PETSC_NULL_INTEGER, ierr))
252
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(NEPSetDimensions(nep, nev, PETSC_DETERMINE_INTEGER, PETSC_DETERMINE_INTEGER, ierr))
253 12 sigma = 1.05
254
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(NEPSetTarget(nep, sigma, ierr))
255
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(NEPSetFromOptions(nep, ierr))
256
257 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
258 ! Solve the eigensystem, display solution and clean up
259 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
260
261
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(NEPSolve(nep, ierr))
262
263
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(NEPGetConverged(nep, nconv, ierr))
264
1/2
✓ Branch 0 taken 6 times.
✗ Branch 1 not taken.
 12 if (rank == 0) then
265 12 write (*, '(a,i2/)') ' Number of converged approximate eigenpairs:', nconv
266 end if
267 !
268 ! ** show detailed info unless -terse option is given by user
269
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(PetscOptionsHasName(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-terse', terse, ierr))
270
1/2
✓ Branch 0 taken 6 times.
✗ Branch 1 not taken.
 12 if (terse) then
271
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(NEPErrorView(nep, NEP_ERROR_RELATIVE, PETSC_NULL_VIEWER, ierr))
272 else
273 ✗ PetscCallA(PetscViewerPushFormat(PETSC_VIEWER_STDOUT_WORLD, PETSC_VIEWER_ASCII_INFO_DETAIL, ierr))
274 ✗ PetscCallA(NEPConvergedReasonView(nep, PETSC_VIEWER_STDOUT_WORLD, ierr))
275 ✗ PetscCallA(NEPErrorView(nep, NEP_ERROR_RELATIVE, PETSC_VIEWER_STDOUT_WORLD, ierr))
276 ✗ PetscCallA(PetscViewerPopFormat(PETSC_VIEWER_STDOUT_WORLD, ierr))
277 end if
278
279
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(NEPDestroy(nep, ierr))
280
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(MatDestroy(A, ierr))
281
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6 times.
 12 PetscCallA(MatDestroy(B, ierr))
282
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 1 times.
 12 PetscCallA(SlepcFinalize(ierr))
283
284 2 end program ex54f
285
286 !/*TEST
287 !
288 ! testset:
289 ! args: -terse
290 ! output_file: output/ex54f_1.out
291 ! filter: grep -v approximate | sed -e "s/[+-]0\.0*i//g"
292 ! test:
293 ! suffix: 1_slp
294 ! args: -nep_type slp -nep_slp_ksp_type gmres -nep_slp_pc_type none
295 ! requires: double
296 ! test:
297 ! suffix: 1_nleigs
298 ! args: -nep_type nleigs -rg_interval_endpoints 0.2,1.1 -nep_nleigs_ksp_type gmres -nep_nleigs_pc_type none
299 ! requires: !complex
300 ! test:
301 ! suffix: 1_nleigs_complex
302 ! args: -nep_type nleigs -rg_interval_endpoints 0.2,1.1,-.1,.1 -nep_nleigs_ksp_type gmres -nep_nleigs_pc_type none
303 ! requires: complex
304 !
305 !TEST*/
306