GCC Code Coverage Report

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