Annotation of rpl/lapack/lapack/dlarrj.f, revision 1.17
1.12 bertrand 1: *> \brief \b DLARRJ performs refinement of the initial estimates of the eigenvalues of the matrix T.
1.9 bertrand 2: *
3: * =========== DOCUMENTATION ===========
4: *
1.16 bertrand 5: * Online html documentation available at
6: * http://www.netlib.org/lapack/explore-html/
1.9 bertrand 7: *
8: *> \htmlonly
1.16 bertrand 9: *> Download DLARRJ + dependencies
10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarrj.f">
11: *> [TGZ]</a>
12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarrj.f">
13: *> [ZIP]</a>
14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarrj.f">
1.9 bertrand 15: *> [TXT]</a>
1.16 bertrand 16: *> \endhtmlonly
1.9 bertrand 17: *
18: * Definition:
19: * ===========
20: *
21: * SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST,
22: * RTOL, OFFSET, W, WERR, WORK, IWORK,
23: * PIVMIN, SPDIAM, INFO )
1.16 bertrand 24: *
1.9 bertrand 25: * .. Scalar Arguments ..
26: * INTEGER IFIRST, ILAST, INFO, N, OFFSET
27: * DOUBLE PRECISION PIVMIN, RTOL, SPDIAM
28: * ..
29: * .. Array Arguments ..
30: * INTEGER IWORK( * )
31: * DOUBLE PRECISION D( * ), E2( * ), W( * ),
32: * $ WERR( * ), WORK( * )
33: * ..
1.16 bertrand 34: *
1.9 bertrand 35: *
36: *> \par Purpose:
37: * =============
38: *>
39: *> \verbatim
40: *>
41: *> Given the initial eigenvalue approximations of T, DLARRJ
42: *> does bisection to refine the eigenvalues of T,
43: *> W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
44: *> guesses for these eigenvalues are input in W, the corresponding estimate
45: *> of the error in these guesses in WERR. During bisection, intervals
46: *> [left, right] are maintained by storing their mid-points and
47: *> semi-widths in the arrays W and WERR respectively.
48: *> \endverbatim
49: *
50: * Arguments:
51: * ==========
52: *
53: *> \param[in] N
54: *> \verbatim
55: *> N is INTEGER
56: *> The order of the matrix.
57: *> \endverbatim
58: *>
59: *> \param[in] D
60: *> \verbatim
61: *> D is DOUBLE PRECISION array, dimension (N)
62: *> The N diagonal elements of T.
63: *> \endverbatim
64: *>
65: *> \param[in] E2
66: *> \verbatim
67: *> E2 is DOUBLE PRECISION array, dimension (N-1)
68: *> The Squares of the (N-1) subdiagonal elements of T.
69: *> \endverbatim
70: *>
71: *> \param[in] IFIRST
72: *> \verbatim
73: *> IFIRST is INTEGER
74: *> The index of the first eigenvalue to be computed.
75: *> \endverbatim
76: *>
77: *> \param[in] ILAST
78: *> \verbatim
79: *> ILAST is INTEGER
80: *> The index of the last eigenvalue to be computed.
81: *> \endverbatim
82: *>
83: *> \param[in] RTOL
84: *> \verbatim
85: *> RTOL is DOUBLE PRECISION
86: *> Tolerance for the convergence of the bisection intervals.
87: *> An interval [LEFT,RIGHT] has converged if
88: *> RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|).
89: *> \endverbatim
90: *>
91: *> \param[in] OFFSET
92: *> \verbatim
93: *> OFFSET is INTEGER
94: *> Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET
95: *> through ILAST-OFFSET elements of these arrays are to be used.
96: *> \endverbatim
97: *>
98: *> \param[in,out] W
99: *> \verbatim
100: *> W is DOUBLE PRECISION array, dimension (N)
101: *> On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
102: *> estimates of the eigenvalues of L D L^T indexed IFIRST through
103: *> ILAST.
104: *> On output, these estimates are refined.
105: *> \endverbatim
106: *>
107: *> \param[in,out] WERR
108: *> \verbatim
109: *> WERR is DOUBLE PRECISION array, dimension (N)
110: *> On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
111: *> the errors in the estimates of the corresponding elements in W.
112: *> On output, these errors are refined.
113: *> \endverbatim
114: *>
115: *> \param[out] WORK
116: *> \verbatim
117: *> WORK is DOUBLE PRECISION array, dimension (2*N)
118: *> Workspace.
119: *> \endverbatim
120: *>
121: *> \param[out] IWORK
122: *> \verbatim
123: *> IWORK is INTEGER array, dimension (2*N)
124: *> Workspace.
125: *> \endverbatim
126: *>
127: *> \param[in] PIVMIN
128: *> \verbatim
129: *> PIVMIN is DOUBLE PRECISION
130: *> The minimum pivot in the Sturm sequence for T.
131: *> \endverbatim
132: *>
133: *> \param[in] SPDIAM
134: *> \verbatim
135: *> SPDIAM is DOUBLE PRECISION
136: *> The spectral diameter of T.
137: *> \endverbatim
138: *>
139: *> \param[out] INFO
140: *> \verbatim
141: *> INFO is INTEGER
142: *> Error flag.
143: *> \endverbatim
144: *
145: * Authors:
146: * ========
147: *
1.16 bertrand 148: *> \author Univ. of Tennessee
149: *> \author Univ. of California Berkeley
150: *> \author Univ. of Colorado Denver
151: *> \author NAG Ltd.
1.9 bertrand 152: *
1.16 bertrand 153: *> \date December 2016
1.9 bertrand 154: *
1.16 bertrand 155: *> \ingroup OTHERauxiliary
1.9 bertrand 156: *
157: *> \par Contributors:
158: * ==================
159: *>
160: *> Beresford Parlett, University of California, Berkeley, USA \n
161: *> Jim Demmel, University of California, Berkeley, USA \n
162: *> Inderjit Dhillon, University of Texas, Austin, USA \n
163: *> Osni Marques, LBNL/NERSC, USA \n
164: *> Christof Voemel, University of California, Berkeley, USA
165: *
166: * =====================================================================
1.1 bertrand 167: SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST,
168: $ RTOL, OFFSET, W, WERR, WORK, IWORK,
169: $ PIVMIN, SPDIAM, INFO )
170: *
1.16 bertrand 171: * -- LAPACK auxiliary routine (version 3.7.0) --
1.1 bertrand 172: * -- LAPACK is a software package provided by Univ. of Tennessee, --
173: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
1.16 bertrand 174: * December 2016
1.1 bertrand 175: *
176: * .. Scalar Arguments ..
177: INTEGER IFIRST, ILAST, INFO, N, OFFSET
178: DOUBLE PRECISION PIVMIN, RTOL, SPDIAM
179: * ..
180: * .. Array Arguments ..
181: INTEGER IWORK( * )
182: DOUBLE PRECISION D( * ), E2( * ), W( * ),
183: $ WERR( * ), WORK( * )
184: * ..
185: *
186: * =====================================================================
187: *
188: * .. Parameters ..
189: DOUBLE PRECISION ZERO, ONE, TWO, HALF
190: PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
191: $ HALF = 0.5D0 )
192: INTEGER MAXITR
193: * ..
194: * .. Local Scalars ..
195: INTEGER CNT, I, I1, I2, II, ITER, J, K, NEXT, NINT,
196: $ OLNINT, P, PREV, SAVI1
197: DOUBLE PRECISION DPLUS, FAC, LEFT, MID, RIGHT, S, TMP, WIDTH
198: *
199: * ..
200: * .. Intrinsic Functions ..
201: INTRINSIC ABS, MAX
202: * ..
203: * .. Executable Statements ..
204: *
205: INFO = 0
206: *
207: MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) /
208: $ LOG( TWO ) ) + 2
209: *
210: * Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
211: * The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
212: * Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
213: * for an unconverged interval is set to the index of the next unconverged
214: * interval, and is -1 or 0 for a converged interval. Thus a linked
215: * list of unconverged intervals is set up.
216: *
217:
218: I1 = IFIRST
219: I2 = ILAST
220: * The number of unconverged intervals
221: NINT = 0
222: * The last unconverged interval found
223: PREV = 0
224: DO 75 I = I1, I2
225: K = 2*I
226: II = I - OFFSET
227: LEFT = W( II ) - WERR( II )
228: MID = W(II)
229: RIGHT = W( II ) + WERR( II )
230: WIDTH = RIGHT - MID
231: TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
232:
233: * The following test prevents the test of converged intervals
234: IF( WIDTH.LT.RTOL*TMP ) THEN
235: * This interval has already converged and does not need refinement.
236: * (Note that the gaps might change through refining the
237: * eigenvalues, however, they can only get bigger.)
238: * Remove it from the list.
239: IWORK( K-1 ) = -1
240: * Make sure that I1 always points to the first unconverged interval
241: IF((I.EQ.I1).AND.(I.LT.I2)) I1 = I + 1
242: IF((PREV.GE.I1).AND.(I.LE.I2)) IWORK( 2*PREV-1 ) = I + 1
243: ELSE
244: * unconverged interval found
245: PREV = I
246: * Make sure that [LEFT,RIGHT] contains the desired eigenvalue
247: *
248: * Do while( CNT(LEFT).GT.I-1 )
249: *
250: FAC = ONE
251: 20 CONTINUE
252: CNT = 0
253: S = LEFT
254: DPLUS = D( 1 ) - S
255: IF( DPLUS.LT.ZERO ) CNT = CNT + 1
256: DO 30 J = 2, N
257: DPLUS = D( J ) - S - E2( J-1 )/DPLUS
258: IF( DPLUS.LT.ZERO ) CNT = CNT + 1
259: 30 CONTINUE
260: IF( CNT.GT.I-1 ) THEN
261: LEFT = LEFT - WERR( II )*FAC
262: FAC = TWO*FAC
263: GO TO 20
264: END IF
265: *
266: * Do while( CNT(RIGHT).LT.I )
267: *
268: FAC = ONE
269: 50 CONTINUE
270: CNT = 0
271: S = RIGHT
272: DPLUS = D( 1 ) - S
273: IF( DPLUS.LT.ZERO ) CNT = CNT + 1
274: DO 60 J = 2, N
275: DPLUS = D( J ) - S - E2( J-1 )/DPLUS
276: IF( DPLUS.LT.ZERO ) CNT = CNT + 1
277: 60 CONTINUE
278: IF( CNT.LT.I ) THEN
279: RIGHT = RIGHT + WERR( II )*FAC
280: FAC = TWO*FAC
281: GO TO 50
282: END IF
283: NINT = NINT + 1
284: IWORK( K-1 ) = I + 1
285: IWORK( K ) = CNT
286: END IF
287: WORK( K-1 ) = LEFT
288: WORK( K ) = RIGHT
289: 75 CONTINUE
290:
291:
292: SAVI1 = I1
293: *
294: * Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
295: * and while (ITER.LT.MAXITR)
296: *
297: ITER = 0
298: 80 CONTINUE
299: PREV = I1 - 1
300: I = I1
301: OLNINT = NINT
302:
303: DO 100 P = 1, OLNINT
304: K = 2*I
305: II = I - OFFSET
306: NEXT = IWORK( K-1 )
307: LEFT = WORK( K-1 )
308: RIGHT = WORK( K )
309: MID = HALF*( LEFT + RIGHT )
310:
311: * semiwidth of interval
312: WIDTH = RIGHT - MID
313: TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
314:
315: IF( ( WIDTH.LT.RTOL*TMP ) .OR.
316: $ (ITER.EQ.MAXITR) )THEN
317: * reduce number of unconverged intervals
318: NINT = NINT - 1
319: * Mark interval as converged.
320: IWORK( K-1 ) = 0
321: IF( I1.EQ.I ) THEN
322: I1 = NEXT
323: ELSE
324: * Prev holds the last unconverged interval previously examined
325: IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT
326: END IF
327: I = NEXT
328: GO TO 100
329: END IF
330: PREV = I
331: *
332: * Perform one bisection step
333: *
334: CNT = 0
335: S = MID
336: DPLUS = D( 1 ) - S
337: IF( DPLUS.LT.ZERO ) CNT = CNT + 1
338: DO 90 J = 2, N
339: DPLUS = D( J ) - S - E2( J-1 )/DPLUS
340: IF( DPLUS.LT.ZERO ) CNT = CNT + 1
341: 90 CONTINUE
342: IF( CNT.LE.I-1 ) THEN
343: WORK( K-1 ) = MID
344: ELSE
345: WORK( K ) = MID
346: END IF
347: I = NEXT
348:
349: 100 CONTINUE
350: ITER = ITER + 1
351: * do another loop if there are still unconverged intervals
352: * However, in the last iteration, all intervals are accepted
353: * since this is the best we can do.
354: IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80
355: *
356: *
357: * At this point, all the intervals have converged
358: DO 110 I = SAVI1, ILAST
359: K = 2*I
360: II = I - OFFSET
361: * All intervals marked by '0' have been refined.
362: IF( IWORK( K-1 ).EQ.0 ) THEN
363: W( II ) = HALF*( WORK( K-1 )+WORK( K ) )
364: WERR( II ) = WORK( K ) - W( II )
365: END IF
366: 110 CONTINUE
367: *
368:
369: RETURN
370: *
371: * End of DLARRJ
372: *
373: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dlarrj.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack