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
|
/* slarrb.f -- translated by f2c (version 20061008).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#include "f2c.h"
#include "blaswrap.h"
/* Subroutine */ int slarrb_(integer *n, real *d__, real *lld, integer *
ifirst, integer *ilast, real *rtol1, real *rtol2, integer *offset,
real *w, real *wgap, real *werr, real *work, integer *iwork, real *
pivmin, real *spdiam, integer *twist, integer *info)
{
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Builtin functions */
double log(doublereal);
/* Local variables */
integer i__, k, r__, i1, ii, ip;
real gap, mid, tmp, back, lgap, rgap, left;
integer iter, nint, prev, next;
real cvrgd, right, width;
extern integer slaneg_(integer *, real *, real *, real *, real *, integer
*);
integer negcnt;
real mnwdth;
integer olnint, maxitr;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* Given the relatively robust representation(RRR) L D L^T, SLARRB */
/* does "limited" bisection to refine the eigenvalues of L D L^T, */
/* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial */
/* guesses for these eigenvalues are input in W, the corresponding estimate */
/* of the error in these guesses and their gaps are input in WERR */
/* and WGAP, respectively. During bisection, intervals */
/* [left, right] are maintained by storing their mid-points and */
/* semi-widths in the arrays W and WERR respectively. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. */
/* D (input) REAL array, dimension (N) */
/* The N diagonal elements of the diagonal matrix D. */
/* LLD (input) REAL array, dimension (N-1) */
/* The (N-1) elements L(i)*L(i)*D(i). */
/* IFIRST (input) INTEGER */
/* The index of the first eigenvalue to be computed. */
/* ILAST (input) INTEGER */
/* The index of the last eigenvalue to be computed. */
/* RTOL1 (input) REAL */
/* RTOL2 (input) REAL */
/* Tolerance for the convergence of the bisection intervals. */
/* An interval [LEFT,RIGHT] has converged if */
/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
/* where GAP is the (estimated) distance to the nearest */
/* eigenvalue. */
/* OFFSET (input) INTEGER */
/* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET */
/* through ILAST-OFFSET elements of these arrays are to be used. */
/* W (input/output) REAL array, dimension (N) */
/* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are */
/* estimates of the eigenvalues of L D L^T indexed IFIRST throug */
/* ILAST. */
/* On output, these estimates are refined. */
/* WGAP (input/output) REAL array, dimension (N-1) */
/* On input, the (estimated) gaps between consecutive */
/* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between */
/* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST */
/* then WGAP(IFIRST-OFFSET) must be set to ZERO. */
/* On output, these gaps are refined. */
/* WERR (input/output) REAL array, dimension (N) */
/* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are */
/* the errors in the estimates of the corresponding elements in W. */
/* On output, these errors are refined. */
/* WORK (workspace) REAL array, dimension (2*N) */
/* Workspace. */
/* IWORK (workspace) INTEGER array, dimension (2*N) */
/* Workspace. */
/* PIVMIN (input) DOUBLE PRECISION */
/* The minimum pivot in the Sturm sequence. */
/* SPDIAM (input) DOUBLE PRECISION */
/* The spectral diameter of the matrix. */
/* TWIST (input) INTEGER */
/* The twist index for the twisted factorization that is used */
/* for the negcount. */
/* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T */
/* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T */
/* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r) */
/* INFO (output) INTEGER */
/* Error flag. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Beresford Parlett, University of California, Berkeley, USA */
/* Jim Demmel, University of California, Berkeley, USA */
/* Inderjit Dhillon, University of Texas, Austin, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* Christof Voemel, University of California, Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--iwork;
--work;
--werr;
--wgap;
--w;
--lld;
--d__;
/* Function Body */
*info = 0;
maxitr = (integer) ((log(*spdiam + *pivmin) - log(*pivmin)) / log(2.f)) +
2;
mnwdth = *pivmin * 2.f;
r__ = *twist;
if (r__ < 1 || r__ > *n) {
r__ = *n;
}
/* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. */
/* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while */
/* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) */
/* for an unconverged interval is set to the index of the next unconverged */
/* interval, and is -1 or 0 for a converged interval. Thus a linked */
/* list of unconverged intervals is set up. */
i1 = *ifirst;
/* The number of unconverged intervals */
nint = 0;
/* The last unconverged interval found */
prev = 0;
rgap = wgap[i1 - *offset];
i__1 = *ilast;
for (i__ = i1; i__ <= i__1; ++i__) {
k = i__ << 1;
ii = i__ - *offset;
left = w[ii] - werr[ii];
right = w[ii] + werr[ii];
lgap = rgap;
rgap = wgap[ii];
gap = dmin(lgap,rgap);
/* Make sure that [LEFT,RIGHT] contains the desired eigenvalue */
/* Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT */
/* Do while( NEGCNT(LEFT).GT.I-1 ) */
back = werr[ii];
L20:
negcnt = slaneg_(n, &d__[1], &lld[1], &left, pivmin, &r__);
if (negcnt > i__ - 1) {
left -= back;
back *= 2.f;
goto L20;
}
/* Do while( NEGCNT(RIGHT).LT.I ) */
/* Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT */
back = werr[ii];
L50:
negcnt = slaneg_(n, &d__[1], &lld[1], &right, pivmin, &r__);
if (negcnt < i__) {
right += back;
back *= 2.f;
goto L50;
}
width = (r__1 = left - right, dabs(r__1)) * .5f;
/* Computing MAX */
r__1 = dabs(left), r__2 = dabs(right);
tmp = dmax(r__1,r__2);
/* Computing MAX */
r__1 = *rtol1 * gap, r__2 = *rtol2 * tmp;
cvrgd = dmax(r__1,r__2);
if (width <= cvrgd || width <= mnwdth) {
/* This interval has already converged and does not need refinement. */
/* (Note that the gaps might change through refining the */
/* eigenvalues, however, they can only get bigger.) */
/* Remove it from the list. */
iwork[k - 1] = -1;
/* Make sure that I1 always points to the first unconverged interval */
if (i__ == i1 && i__ < *ilast) {
i1 = i__ + 1;
}
if (prev >= i1 && i__ <= *ilast) {
iwork[(prev << 1) - 1] = i__ + 1;
}
} else {
/* unconverged interval found */
prev = i__;
++nint;
iwork[k - 1] = i__ + 1;
iwork[k] = negcnt;
}
work[k - 1] = left;
work[k] = right;
/* L75: */
}
/* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals */
/* and while (ITER.LT.MAXITR) */
iter = 0;
L80:
prev = i1 - 1;
i__ = i1;
olnint = nint;
i__1 = olnint;
for (ip = 1; ip <= i__1; ++ip) {
k = i__ << 1;
ii = i__ - *offset;
rgap = wgap[ii];
lgap = rgap;
if (ii > 1) {
lgap = wgap[ii - 1];
}
gap = dmin(lgap,rgap);
next = iwork[k - 1];
left = work[k - 1];
right = work[k];
mid = (left + right) * .5f;
/* semiwidth of interval */
width = right - mid;
/* Computing MAX */
r__1 = dabs(left), r__2 = dabs(right);
tmp = dmax(r__1,r__2);
/* Computing MAX */
r__1 = *rtol1 * gap, r__2 = *rtol2 * tmp;
cvrgd = dmax(r__1,r__2);
if (width <= cvrgd || width <= mnwdth || iter == maxitr) {
/* reduce number of unconverged intervals */
--nint;
/* Mark interval as converged. */
iwork[k - 1] = 0;
if (i1 == i__) {
i1 = next;
} else {
/* Prev holds the last unconverged interval previously examined */
if (prev >= i1) {
iwork[(prev << 1) - 1] = next;
}
}
i__ = next;
goto L100;
}
prev = i__;
/* Perform one bisection step */
negcnt = slaneg_(n, &d__[1], &lld[1], &mid, pivmin, &r__);
if (negcnt <= i__ - 1) {
work[k - 1] = mid;
} else {
work[k] = mid;
}
i__ = next;
L100:
;
}
++iter;
/* do another loop if there are still unconverged intervals */
/* However, in the last iteration, all intervals are accepted */
/* since this is the best we can do. */
if (nint > 0 && iter <= maxitr) {
goto L80;
}
/* At this point, all the intervals have converged */
i__1 = *ilast;
for (i__ = *ifirst; i__ <= i__1; ++i__) {
k = i__ << 1;
ii = i__ - *offset;
/* All intervals marked by '0' have been refined. */
if (iwork[k - 1] == 0) {
w[ii] = (work[k - 1] + work[k]) * .5f;
werr[ii] = work[k] - w[ii];
}
/* L110: */
}
i__1 = *ilast;
for (i__ = *ifirst + 1; i__ <= i__1; ++i__) {
k = i__ << 1;
ii = i__ - *offset;
/* Computing MAX */
r__1 = 0.f, r__2 = w[ii] - werr[ii] - w[ii - 1] - werr[ii - 1];
wgap[ii - 1] = dmax(r__1,r__2);
/* L111: */
}
return 0;
/* End of SLARRB */
} /* slarrb_ */
|
