Annotation of rpl/lapack/lapack/dlarrj.f, revision 1.9
1.9 ! bertrand 1: *> \brief \b DLARRJ
! 2: *
! 3: * =========== DOCUMENTATION ===========
! 4: *
! 5: * Online html documentation available at
! 6: * http://www.netlib.org/lapack/explore-html/
! 7: *
! 8: *> \htmlonly
! 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">
! 15: *> [TXT]</a>
! 16: *> \endhtmlonly
! 17: *
! 18: * Definition:
! 19: * ===========
! 20: *
! 21: * SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST,
! 22: * RTOL, OFFSET, W, WERR, WORK, IWORK,
! 23: * PIVMIN, SPDIAM, INFO )
! 24: *
! 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: * ..
! 34: *
! 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: *
! 148: *> \author Univ. of Tennessee
! 149: *> \author Univ. of California Berkeley
! 150: *> \author Univ. of Colorado Denver
! 151: *> \author NAG Ltd.
! 152: *
! 153: *> \date November 2011
! 154: *
! 155: *> \ingroup auxOTHERauxiliary
! 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.9 ! bertrand 171: * -- LAPACK auxiliary routine (version 3.4.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.9 ! bertrand 174: * November 2011
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