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 579