Annotation of rpl/lapack/lapack/zlahqr.f, revision 1.8
1.8 ! bertrand 1: *> \brief \b ZLAHQR
! 2: *
! 3: * =========== DOCUMENTATION ===========
! 4: *
! 5: * Online html documentation available at
! 6: * http://www.netlib.org/lapack/explore-html/
! 7: *
! 8: *> \htmlonly
! 9: *> Download ZLAHQR + dependencies
! 10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlahqr.f">
! 11: *> [TGZ]</a>
! 12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlahqr.f">
! 13: *> [ZIP]</a>
! 14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlahqr.f">
! 15: *> [TXT]</a>
! 16: *> \endhtmlonly
! 17: *
! 18: * Definition:
! 19: * ===========
! 20: *
! 21: * SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
! 22: * IHIZ, Z, LDZ, INFO )
! 23: *
! 24: * .. Scalar Arguments ..
! 25: * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
! 26: * LOGICAL WANTT, WANTZ
! 27: * ..
! 28: * .. Array Arguments ..
! 29: * COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * )
! 30: * ..
! 31: *
! 32: *
! 33: *> \par Purpose:
! 34: * =============
! 35: *>
! 36: *> \verbatim
! 37: *>
! 38: *> ZLAHQR is an auxiliary routine called by CHSEQR to update the
! 39: *> eigenvalues and Schur decomposition already computed by CHSEQR, by
! 40: *> dealing with the Hessenberg submatrix in rows and columns ILO to
! 41: *> IHI.
! 42: *> \endverbatim
! 43: *
! 44: * Arguments:
! 45: * ==========
! 46: *
! 47: *> \param[in] WANTT
! 48: *> \verbatim
! 49: *> WANTT is LOGICAL
! 50: *> = .TRUE. : the full Schur form T is required;
! 51: *> = .FALSE.: only eigenvalues are required.
! 52: *> \endverbatim
! 53: *>
! 54: *> \param[in] WANTZ
! 55: *> \verbatim
! 56: *> WANTZ is LOGICAL
! 57: *> = .TRUE. : the matrix of Schur vectors Z is required;
! 58: *> = .FALSE.: Schur vectors are not required.
! 59: *> \endverbatim
! 60: *>
! 61: *> \param[in] N
! 62: *> \verbatim
! 63: *> N is INTEGER
! 64: *> The order of the matrix H. N >= 0.
! 65: *> \endverbatim
! 66: *>
! 67: *> \param[in] ILO
! 68: *> \verbatim
! 69: *> ILO is INTEGER
! 70: *> \endverbatim
! 71: *>
! 72: *> \param[in] IHI
! 73: *> \verbatim
! 74: *> IHI is INTEGER
! 75: *> It is assumed that H is already upper triangular in rows and
! 76: *> columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).
! 77: *> ZLAHQR works primarily with the Hessenberg submatrix in rows
! 78: *> and columns ILO to IHI, but applies transformations to all of
! 79: *> H if WANTT is .TRUE..
! 80: *> 1 <= ILO <= max(1,IHI); IHI <= N.
! 81: *> \endverbatim
! 82: *>
! 83: *> \param[in,out] H
! 84: *> \verbatim
! 85: *> H is COMPLEX*16 array, dimension (LDH,N)
! 86: *> On entry, the upper Hessenberg matrix H.
! 87: *> On exit, if INFO is zero and if WANTT is .TRUE., then H
! 88: *> is upper triangular in rows and columns ILO:IHI. If INFO
! 89: *> is zero and if WANTT is .FALSE., then the contents of H
! 90: *> are unspecified on exit. The output state of H in case
! 91: *> INF is positive is below under the description of INFO.
! 92: *> \endverbatim
! 93: *>
! 94: *> \param[in] LDH
! 95: *> \verbatim
! 96: *> LDH is INTEGER
! 97: *> The leading dimension of the array H. LDH >= max(1,N).
! 98: *> \endverbatim
! 99: *>
! 100: *> \param[out] W
! 101: *> \verbatim
! 102: *> W is COMPLEX*16 array, dimension (N)
! 103: *> The computed eigenvalues ILO to IHI are stored in the
! 104: *> corresponding elements of W. If WANTT is .TRUE., the
! 105: *> eigenvalues are stored in the same order as on the diagonal
! 106: *> of the Schur form returned in H, with W(i) = H(i,i).
! 107: *> \endverbatim
! 108: *>
! 109: *> \param[in] ILOZ
! 110: *> \verbatim
! 111: *> ILOZ is INTEGER
! 112: *> \endverbatim
! 113: *>
! 114: *> \param[in] IHIZ
! 115: *> \verbatim
! 116: *> IHIZ is INTEGER
! 117: *> Specify the rows of Z to which transformations must be
! 118: *> applied if WANTZ is .TRUE..
! 119: *> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
! 120: *> \endverbatim
! 121: *>
! 122: *> \param[in,out] Z
! 123: *> \verbatim
! 124: *> Z is COMPLEX*16 array, dimension (LDZ,N)
! 125: *> If WANTZ is .TRUE., on entry Z must contain the current
! 126: *> matrix Z of transformations accumulated by CHSEQR, and on
! 127: *> exit Z has been updated; transformations are applied only to
! 128: *> the submatrix Z(ILOZ:IHIZ,ILO:IHI).
! 129: *> If WANTZ is .FALSE., Z is not referenced.
! 130: *> \endverbatim
! 131: *>
! 132: *> \param[in] LDZ
! 133: *> \verbatim
! 134: *> LDZ is INTEGER
! 135: *> The leading dimension of the array Z. LDZ >= max(1,N).
! 136: *> \endverbatim
! 137: *>
! 138: *> \param[out] INFO
! 139: *> \verbatim
! 140: *> INFO is INTEGER
! 141: *> = 0: successful exit
! 142: *> .GT. 0: if INFO = i, ZLAHQR failed to compute all the
! 143: *> eigenvalues ILO to IHI in a total of 30 iterations
! 144: *> per eigenvalue; elements i+1:ihi of W contain
! 145: *> those eigenvalues which have been successfully
! 146: *> computed.
! 147: *>
! 148: *> If INFO .GT. 0 and WANTT is .FALSE., then on exit,
! 149: *> the remaining unconverged eigenvalues are the
! 150: *> eigenvalues of the upper Hessenberg matrix
! 151: *> rows and columns ILO thorugh INFO of the final,
! 152: *> output value of H.
! 153: *>
! 154: *> If INFO .GT. 0 and WANTT is .TRUE., then on exit
! 155: *> (*) (initial value of H)*U = U*(final value of H)
! 156: *> where U is an orthognal matrix. The final
! 157: *> value of H is upper Hessenberg and triangular in
! 158: *> rows and columns INFO+1 through IHI.
! 159: *>
! 160: *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit
! 161: *> (final value of Z) = (initial value of Z)*U
! 162: *> where U is the orthogonal matrix in (*)
! 163: *> (regardless of the value of WANTT.)
! 164: *> \endverbatim
! 165: *
! 166: * Authors:
! 167: * ========
! 168: *
! 169: *> \author Univ. of Tennessee
! 170: *> \author Univ. of California Berkeley
! 171: *> \author Univ. of Colorado Denver
! 172: *> \author NAG Ltd.
! 173: *
! 174: *> \date November 2011
! 175: *
! 176: *> \ingroup complex16OTHERauxiliary
! 177: *
! 178: *> \par Contributors:
! 179: * ==================
! 180: *>
! 181: *> \verbatim
! 182: *>
! 183: *> 02-96 Based on modifications by
! 184: *> David Day, Sandia National Laboratory, USA
! 185: *>
! 186: *> 12-04 Further modifications by
! 187: *> Ralph Byers, University of Kansas, USA
! 188: *> This is a modified version of ZLAHQR from LAPACK version 3.0.
! 189: *> It is (1) more robust against overflow and underflow and
! 190: *> (2) adopts the more conservative Ahues & Tisseur stopping
! 191: *> criterion (LAWN 122, 1997).
! 192: *> \endverbatim
! 193: *>
! 194: * =====================================================================
1.1 bertrand 195: SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
196: $ IHIZ, Z, LDZ, INFO )
197: *
1.8 ! bertrand 198: * -- LAPACK auxiliary routine (version 3.4.0) --
! 199: * -- LAPACK is a software package provided by Univ. of Tennessee, --
! 200: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
! 201: * November 2011
1.1 bertrand 202: *
203: * .. Scalar Arguments ..
204: INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
205: LOGICAL WANTT, WANTZ
206: * ..
207: * .. Array Arguments ..
208: COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * )
209: * ..
210: *
1.8 ! bertrand 211: * =========================================================
1.1 bertrand 212: *
213: * .. Parameters ..
214: INTEGER ITMAX
215: PARAMETER ( ITMAX = 30 )
216: COMPLEX*16 ZERO, ONE
217: PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
218: $ ONE = ( 1.0d0, 0.0d0 ) )
219: DOUBLE PRECISION RZERO, RONE, HALF
220: PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0, HALF = 0.5d0 )
221: DOUBLE PRECISION DAT1
222: PARAMETER ( DAT1 = 3.0d0 / 4.0d0 )
223: * ..
224: * .. Local Scalars ..
225: COMPLEX*16 CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U,
226: $ V2, X, Y
227: DOUBLE PRECISION AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX,
228: $ SAFMIN, SMLNUM, SX, T2, TST, ULP
229: INTEGER I, I1, I2, ITS, J, JHI, JLO, K, L, M, NH, NZ
230: * ..
231: * .. Local Arrays ..
232: COMPLEX*16 V( 2 )
233: * ..
234: * .. External Functions ..
235: COMPLEX*16 ZLADIV
236: DOUBLE PRECISION DLAMCH
237: EXTERNAL ZLADIV, DLAMCH
238: * ..
239: * .. External Subroutines ..
240: EXTERNAL DLABAD, ZCOPY, ZLARFG, ZSCAL
241: * ..
242: * .. Statement Functions ..
243: DOUBLE PRECISION CABS1
244: * ..
245: * .. Intrinsic Functions ..
246: INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT
247: * ..
248: * .. Statement Function definitions ..
249: CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
250: * ..
251: * .. Executable Statements ..
252: *
253: INFO = 0
254: *
255: * Quick return if possible
256: *
257: IF( N.EQ.0 )
258: $ RETURN
259: IF( ILO.EQ.IHI ) THEN
260: W( ILO ) = H( ILO, ILO )
261: RETURN
262: END IF
263: *
264: * ==== clear out the trash ====
265: DO 10 J = ILO, IHI - 3
266: H( J+2, J ) = ZERO
267: H( J+3, J ) = ZERO
268: 10 CONTINUE
269: IF( ILO.LE.IHI-2 )
270: $ H( IHI, IHI-2 ) = ZERO
271: * ==== ensure that subdiagonal entries are real ====
272: IF( WANTT ) THEN
273: JLO = 1
274: JHI = N
275: ELSE
276: JLO = ILO
277: JHI = IHI
278: END IF
279: DO 20 I = ILO + 1, IHI
280: IF( DIMAG( H( I, I-1 ) ).NE.RZERO ) THEN
281: * ==== The following redundant normalization
282: * . avoids problems with both gradual and
283: * . sudden underflow in ABS(H(I,I-1)) ====
284: SC = H( I, I-1 ) / CABS1( H( I, I-1 ) )
285: SC = DCONJG( SC ) / ABS( SC )
286: H( I, I-1 ) = ABS( H( I, I-1 ) )
287: CALL ZSCAL( JHI-I+1, SC, H( I, I ), LDH )
288: CALL ZSCAL( MIN( JHI, I+1 )-JLO+1, DCONJG( SC ),
289: $ H( JLO, I ), 1 )
290: IF( WANTZ )
291: $ CALL ZSCAL( IHIZ-ILOZ+1, DCONJG( SC ), Z( ILOZ, I ), 1 )
292: END IF
293: 20 CONTINUE
294: *
295: NH = IHI - ILO + 1
296: NZ = IHIZ - ILOZ + 1
297: *
298: * Set machine-dependent constants for the stopping criterion.
299: *
300: SAFMIN = DLAMCH( 'SAFE MINIMUM' )
301: SAFMAX = RONE / SAFMIN
302: CALL DLABAD( SAFMIN, SAFMAX )
303: ULP = DLAMCH( 'PRECISION' )
304: SMLNUM = SAFMIN*( DBLE( NH ) / ULP )
305: *
306: * I1 and I2 are the indices of the first row and last column of H
307: * to which transformations must be applied. If eigenvalues only are
308: * being computed, I1 and I2 are set inside the main loop.
309: *
310: IF( WANTT ) THEN
311: I1 = 1
312: I2 = N
313: END IF
314: *
315: * The main loop begins here. I is the loop index and decreases from
316: * IHI to ILO in steps of 1. Each iteration of the loop works
317: * with the active submatrix in rows and columns L to I.
318: * Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
319: * H(L,L-1) is negligible so that the matrix splits.
320: *
321: I = IHI
322: 30 CONTINUE
323: IF( I.LT.ILO )
324: $ GO TO 150
325: *
326: * Perform QR iterations on rows and columns ILO to I until a
327: * submatrix of order 1 splits off at the bottom because a
328: * subdiagonal element has become negligible.
329: *
330: L = ILO
331: DO 130 ITS = 0, ITMAX
332: *
333: * Look for a single small subdiagonal element.
334: *
335: DO 40 K = I, L + 1, -1
336: IF( CABS1( H( K, K-1 ) ).LE.SMLNUM )
337: $ GO TO 50
338: TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) )
339: IF( TST.EQ.ZERO ) THEN
340: IF( K-2.GE.ILO )
341: $ TST = TST + ABS( DBLE( H( K-1, K-2 ) ) )
342: IF( K+1.LE.IHI )
343: $ TST = TST + ABS( DBLE( H( K+1, K ) ) )
344: END IF
345: * ==== The following is a conservative small subdiagonal
346: * . deflation criterion due to Ahues & Tisseur (LAWN 122,
347: * . 1997). It has better mathematical foundation and
348: * . improves accuracy in some examples. ====
349: IF( ABS( DBLE( H( K, K-1 ) ) ).LE.ULP*TST ) THEN
350: AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) )
351: BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) )
352: AA = MAX( CABS1( H( K, K ) ),
353: $ CABS1( H( K-1, K-1 )-H( K, K ) ) )
354: BB = MIN( CABS1( H( K, K ) ),
355: $ CABS1( H( K-1, K-1 )-H( K, K ) ) )
356: S = AA + AB
357: IF( BA*( AB / S ).LE.MAX( SMLNUM,
358: $ ULP*( BB*( AA / S ) ) ) )GO TO 50
359: END IF
360: 40 CONTINUE
361: 50 CONTINUE
362: L = K
363: IF( L.GT.ILO ) THEN
364: *
365: * H(L,L-1) is negligible
366: *
367: H( L, L-1 ) = ZERO
368: END IF
369: *
370: * Exit from loop if a submatrix of order 1 has split off.
371: *
372: IF( L.GE.I )
373: $ GO TO 140
374: *
375: * Now the active submatrix is in rows and columns L to I. If
376: * eigenvalues only are being computed, only the active submatrix
377: * need be transformed.
378: *
379: IF( .NOT.WANTT ) THEN
380: I1 = L
381: I2 = I
382: END IF
383: *
384: IF( ITS.EQ.10 ) THEN
385: *
386: * Exceptional shift.
387: *
388: S = DAT1*ABS( DBLE( H( L+1, L ) ) )
389: T = S + H( L, L )
390: ELSE IF( ITS.EQ.20 ) THEN
391: *
392: * Exceptional shift.
393: *
394: S = DAT1*ABS( DBLE( H( I, I-1 ) ) )
395: T = S + H( I, I )
396: ELSE
397: *
398: * Wilkinson's shift.
399: *
400: T = H( I, I )
401: U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) )
402: S = CABS1( U )
403: IF( S.NE.RZERO ) THEN
404: X = HALF*( H( I-1, I-1 )-T )
405: SX = CABS1( X )
406: S = MAX( S, CABS1( X ) )
407: Y = S*SQRT( ( X / S )**2+( U / S )**2 )
408: IF( SX.GT.RZERO ) THEN
409: IF( DBLE( X / SX )*DBLE( Y )+DIMAG( X / SX )*
410: $ DIMAG( Y ).LT.RZERO )Y = -Y
411: END IF
412: T = T - U*ZLADIV( U, ( X+Y ) )
413: END IF
414: END IF
415: *
416: * Look for two consecutive small subdiagonal elements.
417: *
418: DO 60 M = I - 1, L + 1, -1
419: *
420: * Determine the effect of starting the single-shift QR
421: * iteration at row M, and see if this would make H(M,M-1)
422: * negligible.
423: *
424: H11 = H( M, M )
425: H22 = H( M+1, M+1 )
426: H11S = H11 - T
427: H21 = DBLE( H( M+1, M ) )
428: S = CABS1( H11S ) + ABS( H21 )
429: H11S = H11S / S
430: H21 = H21 / S
431: V( 1 ) = H11S
432: V( 2 ) = H21
433: H10 = DBLE( H( M, M-1 ) )
434: IF( ABS( H10 )*ABS( H21 ).LE.ULP*
435: $ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) )
436: $ GO TO 70
437: 60 CONTINUE
438: H11 = H( L, L )
439: H22 = H( L+1, L+1 )
440: H11S = H11 - T
441: H21 = DBLE( H( L+1, L ) )
442: S = CABS1( H11S ) + ABS( H21 )
443: H11S = H11S / S
444: H21 = H21 / S
445: V( 1 ) = H11S
446: V( 2 ) = H21
447: 70 CONTINUE
448: *
449: * Single-shift QR step
450: *
451: DO 120 K = M, I - 1
452: *
453: * The first iteration of this loop determines a reflection G
454: * from the vector V and applies it from left and right to H,
455: * thus creating a nonzero bulge below the subdiagonal.
456: *
457: * Each subsequent iteration determines a reflection G to
458: * restore the Hessenberg form in the (K-1)th column, and thus
459: * chases the bulge one step toward the bottom of the active
460: * submatrix.
461: *
462: * V(2) is always real before the call to ZLARFG, and hence
463: * after the call T2 ( = T1*V(2) ) is also real.
464: *
465: IF( K.GT.M )
466: $ CALL ZCOPY( 2, H( K, K-1 ), 1, V, 1 )
467: CALL ZLARFG( 2, V( 1 ), V( 2 ), 1, T1 )
468: IF( K.GT.M ) THEN
469: H( K, K-1 ) = V( 1 )
470: H( K+1, K-1 ) = ZERO
471: END IF
472: V2 = V( 2 )
473: T2 = DBLE( T1*V2 )
474: *
475: * Apply G from the left to transform the rows of the matrix
476: * in columns K to I2.
477: *
478: DO 80 J = K, I2
479: SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J )
480: H( K, J ) = H( K, J ) - SUM
481: H( K+1, J ) = H( K+1, J ) - SUM*V2
482: 80 CONTINUE
483: *
484: * Apply G from the right to transform the columns of the
485: * matrix in rows I1 to min(K+2,I).
486: *
487: DO 90 J = I1, MIN( K+2, I )
488: SUM = T1*H( J, K ) + T2*H( J, K+1 )
489: H( J, K ) = H( J, K ) - SUM
490: H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 )
491: 90 CONTINUE
492: *
493: IF( WANTZ ) THEN
494: *
495: * Accumulate transformations in the matrix Z
496: *
497: DO 100 J = ILOZ, IHIZ
498: SUM = T1*Z( J, K ) + T2*Z( J, K+1 )
499: Z( J, K ) = Z( J, K ) - SUM
500: Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 )
501: 100 CONTINUE
502: END IF
503: *
504: IF( K.EQ.M .AND. M.GT.L ) THEN
505: *
506: * If the QR step was started at row M > L because two
507: * consecutive small subdiagonals were found, then extra
508: * scaling must be performed to ensure that H(M,M-1) remains
509: * real.
510: *
511: TEMP = ONE - T1
512: TEMP = TEMP / ABS( TEMP )
513: H( M+1, M ) = H( M+1, M )*DCONJG( TEMP )
514: IF( M+2.LE.I )
515: $ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP
516: DO 110 J = M, I
517: IF( J.NE.M+1 ) THEN
518: IF( I2.GT.J )
519: $ CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH )
520: CALL ZSCAL( J-I1, DCONJG( TEMP ), H( I1, J ), 1 )
521: IF( WANTZ ) THEN
522: CALL ZSCAL( NZ, DCONJG( TEMP ), Z( ILOZ, J ),
523: $ 1 )
524: END IF
525: END IF
526: 110 CONTINUE
527: END IF
528: 120 CONTINUE
529: *
530: * Ensure that H(I,I-1) is real.
531: *
532: TEMP = H( I, I-1 )
533: IF( DIMAG( TEMP ).NE.RZERO ) THEN
534: RTEMP = ABS( TEMP )
535: H( I, I-1 ) = RTEMP
536: TEMP = TEMP / RTEMP
537: IF( I2.GT.I )
538: $ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH )
539: CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 )
540: IF( WANTZ ) THEN
541: CALL ZSCAL( NZ, TEMP, Z( ILOZ, I ), 1 )
542: END IF
543: END IF
544: *
545: 130 CONTINUE
546: *
547: * Failure to converge in remaining number of iterations
548: *
549: INFO = I
550: RETURN
551: *
552: 140 CONTINUE
553: *
554: * H(I,I-1) is negligible: one eigenvalue has converged.
555: *
556: W( I ) = H( I, I )
557: *
558: * return to start of the main loop with new value of I.
559: *
560: I = L - 1
561: GO TO 30
562: *
563: 150 CONTINUE
564: RETURN
565: *
566: * End of ZLAHQR
567: *
568: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to zlahqr.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack