1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
|
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: igraphdgetv0
c
c\Description:
c Generate a random initial residual vector for the Arnoldi process.
c Force the residual vector to be in the range of the operator OP.
c
c\Usage:
c call igraphdgetv0
c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM,
c IPNTR, WORKD, IERR )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag. IDO must be zero on the first
c call to igraphdgetv0.
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c This is for the initialization phase to force the
c starting vector into the range of OP.
c IDO = 2: compute Y = B * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c IDO = 99: done
c -------------------------------------------------------------
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of the matrix B in the (generalized)
c eigenvalue problem A*x = lambda*B*x.
c B = 'I' -> standard eigenvalue problem A*x = lambda*x
c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x
c
c ITRY Integer. (INPUT)
c ITRY counts the number of times that igraphdgetv0 is called.
c It should be set to 1 on the initial call to igraphdgetv0.
c
c INITV Logical variable. (INPUT)
c .TRUE. => the initial residual vector is given in RESID.
c .FALSE. => generate a random initial residual vector.
c
c N Integer. (INPUT)
c Dimension of the problem.
c
c J Integer. (INPUT)
c Index of the residual vector to be generated, with respect to
c the Arnoldi process. J > 1 in case of a "restart".
c
c V Double precision N by J array. (INPUT)
c The first J-1 columns of V contain the current Arnoldi basis
c if this is a "restart".
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c RESID Double precision array of length N. (INPUT/OUTPUT)
c Initial residual vector to be generated. If RESID is
c provided, force RESID into the range of the operator OP.
c
c RNORM Double precision scalar. (OUTPUT)
c B-norm of the generated residual.
c
c IPNTR Integer array of length 3. (OUTPUT)
c
c WORKD Double precision work array of length 2*N. (REVERSE COMMUNICATION).
c On exit, WORK(1:N) = B*RESID to be used in SSAITR.
c
c IERR Integer. (OUTPUT)
c = 0: Normal exit.
c = -1: Cannot generate a nontrivial restarted residual vector
c in the range of the operator OP.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c
c\Routines called:
c igraphsecond ARPACK utility routine for timing.
c igraphdvout ARPACK utility routine for vector output.
c dlarnv LAPACK routine for generating a random vector.
c dgemv Level 2 BLAS routine for matrix vector multiplication.
c dcopy Level 1 BLAS that copies one vector to another.
c ddot Level 1 BLAS that computes the scalar product of two vectors.
c dnrm2 Level 1 BLAS that computes the norm of a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: getv0.F SID: 2.6 DATE OF SID: 8/27/96 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine igraphdgetv0
& ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm,
& ipntr, workd, ierr )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1
logical initv
integer ido, ierr, itry, j, ldv, n
Double precision
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(3)
Double precision
& resid(n), v(ldv,j), workd(2*n)
c
c %------------%
c | Parameters |
c %------------%
c
Double precision
& one, zero
parameter (one = 1.0D+0, zero = 0.0D+0)
c
c %------------------------%
c | Local Scalars & Arrays |
c %------------------------%
c
logical first, inits, orth
integer idist, iseed(4), iter, msglvl, jj
Double precision
& rnorm0
save first, iseed, inits, iter, msglvl, orth, rnorm0
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external dlarnv, igraphdvout, dcopy, dgemv, igraphsecond
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& ddot, dnrm2
external ddot, dnrm2
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic abs, sqrt
c
c %-----------------%
c | Data Statements |
c %-----------------%
c
data inits /.true./
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c
c %-----------------------------------%
c | Initialize the seed of the LAPACK |
c | random number generator |
c %-----------------------------------%
c
if (inits) then
iseed(1) = 1
iseed(2) = 3
iseed(3) = 5
iseed(4) = 7
inits = .false.
end if
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call igraphsecond (t0)
msglvl = mgetv0
c
ierr = 0
iter = 0
first = .FALSE.
orth = .FALSE.
c
c %-----------------------------------------------------%
c | Possibly generate a random starting vector in RESID |
c | Use a LAPACK random number generator used by the |
c | matrix generation routines. |
c | idist = 1: uniform (0,1) distribution; |
c | idist = 2: uniform (-1,1) distribution; |
c | idist = 3: normal (0,1) distribution; |
c %-----------------------------------------------------%
c
if (.not.initv) then
idist = 2
call dlarnv (idist, iseed, n, resid)
end if
c
c %----------------------------------------------------------%
c | Force the starting vector into the range of OP to handle |
c | the generalized problem when B is possibly (singular). |
c %----------------------------------------------------------%
c
call igraphsecond (t2)
if (bmat .eq. 'G') then
nopx = nopx + 1
ipntr(1) = 1
ipntr(2) = n + 1
call dcopy (n, resid, 1, workd, 1)
ido = -1
go to 9000
end if
end if
c
c %-----------------------------------------%
c | Back from computing OP*(initial-vector) |
c %-----------------------------------------%
c
if (first) go to 20
c
c %-----------------------------------------------%
c | Back from computing B*(orthogonalized-vector) |
c %-----------------------------------------------%
c
if (orth) go to 40
c
if (bmat .eq. 'G') then
call igraphsecond (t3)
tmvopx = tmvopx + (t3 - t2)
end if
c
c %------------------------------------------------------%
c | Starting vector is now in the range of OP; r = OP*r; |
c | Compute B-norm of starting vector. |
c %------------------------------------------------------%
c
call igraphsecond (t2)
first = .TRUE.
if (bmat .eq. 'G') then
nbx = nbx + 1
call dcopy (n, workd(n+1), 1, resid, 1)
ipntr(1) = n + 1
ipntr(2) = 1
ido = 2
go to 9000
else if (bmat .eq. 'I') then
call dcopy (n, resid, 1, workd, 1)
end if
c
20 continue
c
if (bmat .eq. 'G') then
call igraphsecond (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
first = .FALSE.
if (bmat .eq. 'G') then
rnorm0 = ddot (n, resid, 1, workd, 1)
rnorm0 = sqrt(abs(rnorm0))
else if (bmat .eq. 'I') then
rnorm0 = dnrm2(n, resid, 1)
end if
rnorm = rnorm0
c
c %---------------------------------------------%
c | Exit if this is the very first Arnoldi step |
c %---------------------------------------------%
c
if (j .eq. 1) go to 50
c
c %----------------------------------------------------------------
c | Otherwise need to B-orthogonalize the starting vector against |
c | the current Arnoldi basis using Gram-Schmidt with iter. ref. |
c | This is the case where an invariant subspace is encountered |
c | in the middle of the Arnoldi factorization. |
c | |
c | s = V^{T}*B*r; r = r - V*s; |
c | |
c | Stopping criteria used for iter. ref. is discussed in |
c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. |
c %---------------------------------------------------------------%
c
orth = .TRUE.
30 continue
c
call dgemv ('T', n, j-1, one, v, ldv, workd, 1,
& zero, workd(n+1), 1)
call dgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1,
& one, resid, 1)
c
c %----------------------------------------------------------%
c | Compute the B-norm of the orthogonalized starting vector |
c %----------------------------------------------------------%
c
call igraphsecond (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call dcopy (n, resid, 1, workd(n+1), 1)
ipntr(1) = n + 1
ipntr(2) = 1
ido = 2
go to 9000
else if (bmat .eq. 'I') then
call dcopy (n, resid, 1, workd, 1)
end if
c
40 continue
c
if (bmat .eq. 'G') then
call igraphsecond (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
if (bmat .eq. 'G') then
rnorm = ddot (n, resid, 1, workd, 1)
rnorm = sqrt(abs(rnorm))
else if (bmat .eq. 'I') then
rnorm = dnrm2(n, resid, 1)
end if
c
c %--------------------------------------%
c | Check for further orthogonalization. |
c %--------------------------------------%
c
if (msglvl .gt. 2) then
call igraphdvout (logfil, 1, rnorm0, ndigit,
& '_getv0: re-orthonalization ; rnorm0 is')
call igraphdvout (logfil, 1, rnorm, ndigit,
& '_getv0: re-orthonalization ; rnorm is')
end if
c
if (rnorm .gt. 0.717*rnorm0) go to 50
c
iter = iter + 1
if (iter .le. 1) then
c
c %-----------------------------------%
c | Perform iterative refinement step |
c %-----------------------------------%
c
rnorm0 = rnorm
go to 30
else
c
c %------------------------------------%
c | Iterative refinement step "failed" |
c %------------------------------------%
c
do 45 jj = 1, n
resid(jj) = zero
45 continue
rnorm = zero
ierr = -1
end if
c
50 continue
c
if (msglvl .gt. 0) then
call igraphdvout (logfil, 1, rnorm, ndigit,
& '_getv0: B-norm of initial / restarted starting vector')
end if
if (msglvl .gt. 2) then
call igraphdvout (logfil, n, resid, ndigit,
& '_getv0: initial / restarted starting vector')
end if
ido = 99
c
call igraphsecond (t1)
tgetv0 = tgetv0 + (t1 - t0)
c
9000 continue
return
c
c %---------------%
c | End of igraphdgetv0 |
c %---------------%
c
end
|
