263 SUBROUTINE dlaqr4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
264 $ iloz, ihiz, z, ldz, work, lwork, info )
272 INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
276 DOUBLE PRECISION H( ldh, * ), WI( * ), WORK( * ), WR( * ),
287 parameter ( ntiny = 11 )
293 parameter ( kexnw = 5 )
299 parameter ( kexsh = 6 )
303 DOUBLE PRECISION WILK1, WILK2
304 parameter ( wilk1 = 0.75d0, wilk2 = -0.4375d0 )
305 DOUBLE PRECISION ZERO, ONE
306 parameter ( zero = 0.0d0, one = 1.0d0 )
309 DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP
310 INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
311 $ kt, ktop, ku, kv, kwh, kwtop, kwv, ld, ls,
312 $ lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns,
313 $ nsmax, nsr, nve, nw, nwmax, nwr, nwupbd
322 DOUBLE PRECISION ZDUM( 1, 1 )
328 INTRINSIC abs, dble, int, max, min, mod
340 IF( n.LE.ntiny )
THEN
346 $
CALL dlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,
347 $ iloz, ihiz, z, ldz, info )
376 nwr = ilaenv( 13,
'DLAQR4', jbcmpz, n, ilo, ihi, lwork )
378 nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr )
385 nsr = ilaenv( 15,
'DLAQR4', jbcmpz, n, ilo, ihi, lwork )
386 nsr = min( nsr, ( n+6 ) / 9, ihi-ilo )
387 nsr = max( 2, nsr-mod( nsr, 2 ) )
393 CALL dlaqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,
394 $ ihiz, z, ldz, ls, ld, wr, wi, h, ldh, n, h, ldh,
395 $ n, h, ldh, work, -1 )
399 lwkopt = max( 3*nsr / 2, int( work( 1 ) ) )
403 IF( lwork.EQ.-1 )
THEN
404 work( 1 ) = dble( lwkopt )
410 nmin = ilaenv( 12,
'DLAQR4', jbcmpz, n, ilo, ihi, lwork )
411 nmin = max( ntiny, nmin )
415 nibble = ilaenv( 14,
'DLAQR4', jbcmpz, n, ilo, ihi, lwork )
416 nibble = max( 0, nibble )
421 kacc22 = ilaenv( 16,
'DLAQR4', jbcmpz, n, ilo, ihi, lwork )
422 kacc22 = max( 0, kacc22 )
423 kacc22 = min( 2, kacc22 )
428 nwmax = min( ( n-1 ) / 3, lwork / 2 )
434 nsmax = min( ( n+6 ) / 9, 2*lwork / 3 )
435 nsmax = nsmax - mod( nsmax, 2 )
443 itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) )
460 DO 10 k = kbot, ilo + 1, -1
461 IF( h( k, k-1 ).EQ.zero )
485 nwupbd = min( nh, nwmax )
486 IF( ndfl.LT.kexnw )
THEN
487 nw = min( nwupbd, nwr )
489 nw = min( nwupbd, 2*nw )
491 IF( nw.LT.nwmax )
THEN
492 IF( nw.GE.nh-1 )
THEN
495 kwtop = kbot - nw + 1
496 IF( abs( h( kwtop, kwtop-1 ) ).GT.
497 $ abs( h( kwtop-1, kwtop-2 ) ) )nw = nw + 1
500 IF( ndfl.LT.kexnw )
THEN
502 ELSE IF( ndec.GE.0 .OR. nw.GE.nwupbd )
THEN
522 nho = ( n-nw-1 ) - kt + 1
524 nve = ( n-nw ) - kwv + 1
528 CALL dlaqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,
529 $ ihiz, z, ldz, ls, ld, wr, wi, h( kv, 1 ), ldh,
530 $ nho, h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh,
547 IF( ( ld.EQ.0 ) .OR. ( ( 100*ld.LE.nw*nibble ) .AND. ( kbot-
548 $ ktop+1.GT.min( nmin, nwmax ) ) ) )
THEN
554 ns = min( nsmax, nsr, max( 2, kbot-ktop ) )
555 ns = ns - mod( ns, 2 )
564 IF( mod( ndfl, kexsh ).EQ.0 )
THEN
566 DO 30 i = kbot, max( ks+1, ktop+2 ), -2
567 ss = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) )
568 aa = wilk1*ss + h( i, i )
572 CALL dlanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),
573 $ wr( i ), wi( i ), cs, sn )
575 IF( ks.EQ.ktop )
THEN
576 wr( ks+1 ) = h( ks+1, ks+1 )
578 wr( ks ) = wr( ks+1 )
579 wi( ks ) = wi( ks+1 )
589 IF( kbot-ks+1.LE.ns / 2 )
THEN
592 CALL dlacpy(
'A', ns, ns, h( ks, ks ), ldh,
594 CALL dlahqr( .false., .false., ns, 1, ns,
595 $ h( kt, 1 ), ldh, wr( ks ), wi( ks ),
596 $ 1, 1, zdum, 1, inf )
603 IF( ks.GE.kbot )
THEN
604 aa = h( kbot-1, kbot-1 )
605 cc = h( kbot, kbot-1 )
606 bb = h( kbot-1, kbot )
608 CALL dlanv2( aa, bb, cc, dd, wr( kbot-1 ),
609 $ wi( kbot-1 ), wr( kbot ),
610 $ wi( kbot ), cs, sn )
615 IF( kbot-ks+1.GT.ns )
THEN
622 DO 50 k = kbot, ks + 1, -1
627 IF( abs( wr( i ) )+abs( wi( i ) ).LT.
628 $ abs( wr( i+1 ) )+abs( wi( i+1 ) ) )
THEN
650 DO 70 i = kbot, ks + 2, -2
651 IF( wi( i ).NE.-wi( i-1 ) )
THEN
655 wr( i-1 ) = wr( i-2 )
660 wi( i-1 ) = wi( i-2 )
669 IF( kbot-ks+1.EQ.2 )
THEN
670 IF( wi( kbot ).EQ.zero )
THEN
671 IF( abs( wr( kbot )-h( kbot, kbot ) ).LT.
672 $ abs( wr( kbot-1 )-h( kbot, kbot ) ) )
THEN
673 wr( kbot-1 ) = wr( kbot )
675 wr( kbot ) = wr( kbot-1 )
685 ns = min( ns, kbot-ks+1 )
686 ns = ns - mod( ns, 2 )
703 nho = ( n-kdu+1-4 ) - ( kdu+1 ) + 1
705 nve = n - kdu - kwv + 1
709 CALL dlaqr5( wantt, wantz, kacc22, n, ktop, kbot, ns,
710 $ wr( ks ), wi( ks ), h, ldh, iloz, ihiz, z,
711 $ ldz, work, 3, h( ku, 1 ), ldh, nve,
712 $ h( kwv, 1 ), ldh, nho, h( ku, kwh ), ldh )
735 work( 1 ) = dble( lwkopt )
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dlahqr(WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, INFO)
DLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm.
subroutine dlaqr2(WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK)
DLAQR2 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate...
subroutine dlaqr4(WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO)
DLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur de...
subroutine dlaqr5(WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH)
DLAQR5 performs a single small-bulge multi-shift QR sweep.
subroutine dlanv2(A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN)
DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form...