1: *> \brief \b ZLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm.
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: *> > 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 > 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 through INFO of the final,
152: *> output value of H.
153: *>
154: *> If INFO > 0 and WANTT is .TRUE., then on exit
155: *> (*) (initial value of H)*U = U*(final value of H)
156: *> where U is an orthogonal 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 > 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: *> \ingroup complex16OTHERauxiliary
175: *
176: *> \par Contributors:
177: * ==================
178: *>
179: *> \verbatim
180: *>
181: *> 02-96 Based on modifications by
182: *> David Day, Sandia National Laboratory, USA
183: *>
184: *> 12-04 Further modifications by
185: *> Ralph Byers, University of Kansas, USA
186: *> This is a modified version of ZLAHQR from LAPACK version 3.0.
187: *> It is (1) more robust against overflow and underflow and
188: *> (2) adopts the more conservative Ahues & Tisseur stopping
189: *> criterion (LAWN 122, 1997).
190: *> \endverbatim
191: *>
192: * =====================================================================
193: SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
194: $ IHIZ, Z, LDZ, INFO )
195: IMPLICIT NONE
196: *
197: * -- LAPACK auxiliary routine --
198: * -- LAPACK is a software package provided by Univ. of Tennessee, --
199: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
200: *
201: * .. Scalar Arguments ..
202: INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
203: LOGICAL WANTT, WANTZ
204: * ..
205: * .. Array Arguments ..
206: COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * )
207: * ..
208: *
209: * =========================================================
210: *
211: * .. Parameters ..
212: COMPLEX*16 ZERO, ONE
213: PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
214: $ ONE = ( 1.0d0, 0.0d0 ) )
215: DOUBLE PRECISION RZERO, RONE, HALF
216: PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0, HALF = 0.5d0 )
217: DOUBLE PRECISION DAT1
218: PARAMETER ( DAT1 = 3.0d0 / 4.0d0 )
219: INTEGER KEXSH
220: PARAMETER ( KEXSH = 10 )
221: * ..
222: * .. Local Scalars ..
223: COMPLEX*16 CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U,
224: $ V2, X, Y
225: DOUBLE PRECISION AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX,
226: $ SAFMIN, SMLNUM, SX, T2, TST, ULP
227: INTEGER I, I1, I2, ITS, ITMAX, J, JHI, JLO, K, L, M,
228: $ NH, NZ, KDEFL
229: * ..
230: * .. Local Arrays ..
231: COMPLEX*16 V( 2 )
232: * ..
233: * .. External Functions ..
234: COMPLEX*16 ZLADIV
235: DOUBLE PRECISION DLAMCH
236: EXTERNAL ZLADIV, DLAMCH
237: * ..
238: * .. External Subroutines ..
239: EXTERNAL DLABAD, ZCOPY, ZLARFG, ZSCAL
240: * ..
241: * .. Statement Functions ..
242: DOUBLE PRECISION CABS1
243: * ..
244: * .. Intrinsic Functions ..
245: INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT
246: * ..
247: * .. Statement Function definitions ..
248: CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
249: * ..
250: * .. Executable Statements ..
251: *
252: INFO = 0
253: *
254: * Quick return if possible
255: *
256: IF( N.EQ.0 )
257: $ RETURN
258: IF( ILO.EQ.IHI ) THEN
259: W( ILO ) = H( ILO, ILO )
260: RETURN
261: END IF
262: *
263: * ==== clear out the trash ====
264: DO 10 J = ILO, IHI - 3
265: H( J+2, J ) = ZERO
266: H( J+3, J ) = ZERO
267: 10 CONTINUE
268: IF( ILO.LE.IHI-2 )
269: $ H( IHI, IHI-2 ) = ZERO
270: * ==== ensure that subdiagonal entries are real ====
271: IF( WANTT ) THEN
272: JLO = 1
273: JHI = N
274: ELSE
275: JLO = ILO
276: JHI = IHI
277: END IF
278: DO 20 I = ILO + 1, IHI
279: IF( DIMAG( H( I, I-1 ) ).NE.RZERO ) THEN
280: * ==== The following redundant normalization
281: * . avoids problems with both gradual and
282: * . sudden underflow in ABS(H(I,I-1)) ====
283: SC = H( I, I-1 ) / CABS1( H( I, I-1 ) )
284: SC = DCONJG( SC ) / ABS( SC )
285: H( I, I-1 ) = ABS( H( I, I-1 ) )
286: CALL ZSCAL( JHI-I+1, SC, H( I, I ), LDH )
287: CALL ZSCAL( MIN( JHI, I+1 )-JLO+1, DCONJG( SC ),
288: $ H( JLO, I ), 1 )
289: IF( WANTZ )
290: $ CALL ZSCAL( IHIZ-ILOZ+1, DCONJG( SC ), Z( ILOZ, I ), 1 )
291: END IF
292: 20 CONTINUE
293: *
294: NH = IHI - ILO + 1
295: NZ = IHIZ - ILOZ + 1
296: *
297: * Set machine-dependent constants for the stopping criterion.
298: *
299: SAFMIN = DLAMCH( 'SAFE MINIMUM' )
300: SAFMAX = RONE / SAFMIN
301: CALL DLABAD( SAFMIN, SAFMAX )
302: ULP = DLAMCH( 'PRECISION' )
303: SMLNUM = SAFMIN*( DBLE( NH ) / ULP )
304: *
305: * I1 and I2 are the indices of the first row and last column of H
306: * to which transformations must be applied. If eigenvalues only are
307: * being computed, I1 and I2 are set inside the main loop.
308: *
309: IF( WANTT ) THEN
310: I1 = 1
311: I2 = N
312: END IF
313: *
314: * ITMAX is the total number of QR iterations allowed.
315: *
316: ITMAX = 30 * MAX( 10, NH )
317: *
318: * KDEFL counts the number of iterations since a deflation
319: *
320: KDEFL = 0
321: *
322: * The main loop begins here. I is the loop index and decreases from
323: * IHI to ILO in steps of 1. Each iteration of the loop works
324: * with the active submatrix in rows and columns L to I.
325: * Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
326: * H(L,L-1) is negligible so that the matrix splits.
327: *
328: I = IHI
329: 30 CONTINUE
330: IF( I.LT.ILO )
331: $ GO TO 150
332: *
333: * Perform QR iterations on rows and columns ILO to I until a
334: * submatrix of order 1 splits off at the bottom because a
335: * subdiagonal element has become negligible.
336: *
337: L = ILO
338: DO 130 ITS = 0, ITMAX
339: *
340: * Look for a single small subdiagonal element.
341: *
342: DO 40 K = I, L + 1, -1
343: IF( CABS1( H( K, K-1 ) ).LE.SMLNUM )
344: $ GO TO 50
345: TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) )
346: IF( TST.EQ.ZERO ) THEN
347: IF( K-2.GE.ILO )
348: $ TST = TST + ABS( DBLE( H( K-1, K-2 ) ) )
349: IF( K+1.LE.IHI )
350: $ TST = TST + ABS( DBLE( H( K+1, K ) ) )
351: END IF
352: * ==== The following is a conservative small subdiagonal
353: * . deflation criterion due to Ahues & Tisseur (LAWN 122,
354: * . 1997). It has better mathematical foundation and
355: * . improves accuracy in some examples. ====
356: IF( ABS( DBLE( H( K, K-1 ) ) ).LE.ULP*TST ) THEN
357: AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) )
358: BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) )
359: AA = MAX( CABS1( H( K, K ) ),
360: $ CABS1( H( K-1, K-1 )-H( K, K ) ) )
361: BB = MIN( CABS1( H( K, K ) ),
362: $ CABS1( H( K-1, K-1 )-H( K, K ) ) )
363: S = AA + AB
364: IF( BA*( AB / S ).LE.MAX( SMLNUM,
365: $ ULP*( BB*( AA / S ) ) ) )GO TO 50
366: END IF
367: 40 CONTINUE
368: 50 CONTINUE
369: L = K
370: IF( L.GT.ILO ) THEN
371: *
372: * H(L,L-1) is negligible
373: *
374: H( L, L-1 ) = ZERO
375: END IF
376: *
377: * Exit from loop if a submatrix of order 1 has split off.
378: *
379: IF( L.GE.I )
380: $ GO TO 140
381: KDEFL = KDEFL + 1
382: *
383: * Now the active submatrix is in rows and columns L to I. If
384: * eigenvalues only are being computed, only the active submatrix
385: * need be transformed.
386: *
387: IF( .NOT.WANTT ) THEN
388: I1 = L
389: I2 = I
390: END IF
391: *
392: IF( MOD(KDEFL,2*KEXSH).EQ.0 ) THEN
393: *
394: * Exceptional shift.
395: *
396: S = DAT1*ABS( DBLE( H( I, I-1 ) ) )
397: T = S + H( I, I )
398: ELSE IF( MOD(KDEFL,KEXSH).EQ.0 ) THEN
399: *
400: * Exceptional shift.
401: *
402: S = DAT1*ABS( DBLE( H( L+1, L ) ) )
403: T = S + H( L, L )
404: ELSE
405: *
406: * Wilkinson's shift.
407: *
408: T = H( I, I )
409: U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) )
410: S = CABS1( U )
411: IF( S.NE.RZERO ) THEN
412: X = HALF*( H( I-1, I-1 )-T )
413: SX = CABS1( X )
414: S = MAX( S, CABS1( X ) )
415: Y = S*SQRT( ( X / S )**2+( U / S )**2 )
416: IF( SX.GT.RZERO ) THEN
417: IF( DBLE( X / SX )*DBLE( Y )+DIMAG( X / SX )*
418: $ DIMAG( Y ).LT.RZERO )Y = -Y
419: END IF
420: T = T - U*ZLADIV( U, ( X+Y ) )
421: END IF
422: END IF
423: *
424: * Look for two consecutive small subdiagonal elements.
425: *
426: DO 60 M = I - 1, L + 1, -1
427: *
428: * Determine the effect of starting the single-shift QR
429: * iteration at row M, and see if this would make H(M,M-1)
430: * negligible.
431: *
432: H11 = H( M, M )
433: H22 = H( M+1, M+1 )
434: H11S = H11 - T
435: H21 = DBLE( H( M+1, M ) )
436: S = CABS1( H11S ) + ABS( H21 )
437: H11S = H11S / S
438: H21 = H21 / S
439: V( 1 ) = H11S
440: V( 2 ) = H21
441: H10 = DBLE( H( M, M-1 ) )
442: IF( ABS( H10 )*ABS( H21 ).LE.ULP*
443: $ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) )
444: $ GO TO 70
445: 60 CONTINUE
446: H11 = H( L, L )
447: H22 = H( L+1, L+1 )
448: H11S = H11 - T
449: H21 = DBLE( H( L+1, L ) )
450: S = CABS1( H11S ) + ABS( H21 )
451: H11S = H11S / S
452: H21 = H21 / S
453: V( 1 ) = H11S
454: V( 2 ) = H21
455: 70 CONTINUE
456: *
457: * Single-shift QR step
458: *
459: DO 120 K = M, I - 1
460: *
461: * The first iteration of this loop determines a reflection G
462: * from the vector V and applies it from left and right to H,
463: * thus creating a nonzero bulge below the subdiagonal.
464: *
465: * Each subsequent iteration determines a reflection G to
466: * restore the Hessenberg form in the (K-1)th column, and thus
467: * chases the bulge one step toward the bottom of the active
468: * submatrix.
469: *
470: * V(2) is always real before the call to ZLARFG, and hence
471: * after the call T2 ( = T1*V(2) ) is also real.
472: *
473: IF( K.GT.M )
474: $ CALL ZCOPY( 2, H( K, K-1 ), 1, V, 1 )
475: CALL ZLARFG( 2, V( 1 ), V( 2 ), 1, T1 )
476: IF( K.GT.M ) THEN
477: H( K, K-1 ) = V( 1 )
478: H( K+1, K-1 ) = ZERO
479: END IF
480: V2 = V( 2 )
481: T2 = DBLE( T1*V2 )
482: *
483: * Apply G from the left to transform the rows of the matrix
484: * in columns K to I2.
485: *
486: DO 80 J = K, I2
487: SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J )
488: H( K, J ) = H( K, J ) - SUM
489: H( K+1, J ) = H( K+1, J ) - SUM*V2
490: 80 CONTINUE
491: *
492: * Apply G from the right to transform the columns of the
493: * matrix in rows I1 to min(K+2,I).
494: *
495: DO 90 J = I1, MIN( K+2, I )
496: SUM = T1*H( J, K ) + T2*H( J, K+1 )
497: H( J, K ) = H( J, K ) - SUM
498: H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 )
499: 90 CONTINUE
500: *
501: IF( WANTZ ) THEN
502: *
503: * Accumulate transformations in the matrix Z
504: *
505: DO 100 J = ILOZ, IHIZ
506: SUM = T1*Z( J, K ) + T2*Z( J, K+1 )
507: Z( J, K ) = Z( J, K ) - SUM
508: Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 )
509: 100 CONTINUE
510: END IF
511: *
512: IF( K.EQ.M .AND. M.GT.L ) THEN
513: *
514: * If the QR step was started at row M > L because two
515: * consecutive small subdiagonals were found, then extra
516: * scaling must be performed to ensure that H(M,M-1) remains
517: * real.
518: *
519: TEMP = ONE - T1
520: TEMP = TEMP / ABS( TEMP )
521: H( M+1, M ) = H( M+1, M )*DCONJG( TEMP )
522: IF( M+2.LE.I )
523: $ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP
524: DO 110 J = M, I
525: IF( J.NE.M+1 ) THEN
526: IF( I2.GT.J )
527: $ CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH )
528: CALL ZSCAL( J-I1, DCONJG( TEMP ), H( I1, J ), 1 )
529: IF( WANTZ ) THEN
530: CALL ZSCAL( NZ, DCONJG( TEMP ), Z( ILOZ, J ),
531: $ 1 )
532: END IF
533: END IF
534: 110 CONTINUE
535: END IF
536: 120 CONTINUE
537: *
538: * Ensure that H(I,I-1) is real.
539: *
540: TEMP = H( I, I-1 )
541: IF( DIMAG( TEMP ).NE.RZERO ) THEN
542: RTEMP = ABS( TEMP )
543: H( I, I-1 ) = RTEMP
544: TEMP = TEMP / RTEMP
545: IF( I2.GT.I )
546: $ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH )
547: CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 )
548: IF( WANTZ ) THEN
549: CALL ZSCAL( NZ, TEMP, Z( ILOZ, I ), 1 )
550: END IF
551: END IF
552: *
553: 130 CONTINUE
554: *
555: * Failure to converge in remaining number of iterations
556: *
557: INFO = I
558: RETURN
559: *
560: 140 CONTINUE
561: *
562: * H(I,I-1) is negligible: one eigenvalue has converged.
563: *
564: W( I ) = H( I, I )
565: * reset deflation counter
566: KDEFL = 0
567: *
568: * return to start of the main loop with new value of I.
569: *
570: I = L - 1
571: GO TO 30
572: *
573: 150 CONTINUE
574: RETURN
575: *
576: * End of ZLAHQR
577: *
578: 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