LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ slaqz0()

recursive subroutine slaqz0 ( character, intent(in)  WANTS,
character, intent(in)  WANTQ,
character, intent(in)  WANTZ,
integer, intent(in)  N,
integer, intent(in)  ILO,
integer, intent(in)  IHI,
real, dimension( lda, * ), intent(inout)  A,
integer, intent(in)  LDA,
real, dimension( ldb, * ), intent(inout)  B,
integer, intent(in)  LDB,
real, dimension( * ), intent(inout)  ALPHAR,
real, dimension( * ), intent(inout)  ALPHAI,
real, dimension( * ), intent(inout)  BETA,
real, dimension( ldq, * ), intent(inout)  Q,
integer, intent(in)  LDQ,
real, dimension( ldz, * ), intent(inout)  Z,
integer, intent(in)  LDZ,
real, dimension( * ), intent(inout)  WORK,
integer, intent(in)  LWORK,
integer, intent(in)  REC,
integer, intent(out)  INFO 
)

SLAQZ0

Download SLAQZ0 + dependencies [TGZ] [ZIP] [TXT]

Purpose:
 SLAQZ0 computes the eigenvalues of a real matrix pair (H,T),
 where H is an upper Hessenberg matrix and T is upper triangular,
 using the double-shift QZ method.
 Matrix pairs of this type are produced by the reduction to
 generalized upper Hessenberg form of a real matrix pair (A,B):

    A = Q1*H*Z1**T,  B = Q1*T*Z1**T,

 as computed by SGGHRD.

 If JOB='S', then the Hessenberg-triangular pair (H,T) is
 also reduced to generalized Schur form,

    H = Q*S*Z**T,  T = Q*P*Z**T,

 where Q and Z are orthogonal matrices, P is an upper triangular
 matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2
 diagonal blocks.

 The 1-by-1 blocks correspond to real eigenvalues of the matrix pair
 (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of
 eigenvalues.

 Additionally, the 2-by-2 upper triangular diagonal blocks of P
 corresponding to 2-by-2 blocks of S are reduced to positive diagonal
 form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,
 P(j,j) > 0, and P(j+1,j+1) > 0.

 Optionally, the orthogonal matrix Q from the generalized Schur
 factorization may be postmultiplied into an input matrix Q1, and the
 orthogonal matrix Z may be postmultiplied into an input matrix Z1.
 If Q1 and Z1 are the orthogonal matrices from SGGHRD that reduced
 the matrix pair (A,B) to generalized upper Hessenberg form, then the
 output matrices Q1*Q and Z1*Z are the orthogonal factors from the
 generalized Schur factorization of (A,B):

    A = (Q1*Q)*S*(Z1*Z)**T,  B = (Q1*Q)*P*(Z1*Z)**T.

 To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,
 of (A,B)) are computed as a pair of values (alpha,beta), where alpha is
 complex and beta real.
 If beta is nonzero, lambda = alpha / beta is an eigenvalue of the
 generalized nonsymmetric eigenvalue problem (GNEP)
    A*x = lambda*B*x
 and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
 alternate form of the GNEP
    mu*A*y = B*y.
 Real eigenvalues can be read directly from the generalized Schur
 form:
   alpha = S(i,i), beta = P(i,i).

 Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
      Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
      pp. 241--256.

 Ref: B. Kagstrom, D. Kressner, "Multishift Variants of the QZ
      Algorithm with Aggressive Early Deflation", SIAM J. Numer.
      Anal., 29(2006), pp. 199--227.

 Ref: T. Steel, D. Camps, K. Meerbergen, R. Vandebril "A multishift,
      multipole rational QZ method with agressive early deflation"
Parameters
[in]WANTS
          WANTS is CHARACTER*1
          = 'E': Compute eigenvalues only;
          = 'S': Compute eigenvalues and the Schur form.
[in]WANTQ
          WANTQ is CHARACTER*1
          = 'N': Left Schur vectors (Q) are not computed;
          = 'I': Q is initialized to the unit matrix and the matrix Q
                 of left Schur vectors of (A,B) is returned;
          = 'V': Q must contain an orthogonal matrix Q1 on entry and
                 the product Q1*Q is returned.
[in]WANTZ
          WANTZ is CHARACTER*1
          = 'N': Right Schur vectors (Z) are not computed;
          = 'I': Z is initialized to the unit matrix and the matrix Z
                 of right Schur vectors of (A,B) is returned;
          = 'V': Z must contain an orthogonal matrix Z1 on entry and
                 the product Z1*Z is returned.
[in]N
          N is INTEGER
          The order of the matrices A, B, Q, and Z.  N >= 0.
[in]ILO
          ILO is INTEGER
[in]IHI
          IHI is INTEGER
          ILO and IHI mark the rows and columns of A which are in
          Hessenberg form.  It is assumed that A is already upper
          triangular in rows and columns 1:ILO-1 and IHI+1:N.
          If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
[in,out]A
          A is REAL array, dimension (LDA, N)
          On entry, the N-by-N upper Hessenberg matrix A.
          On exit, if JOB = 'S', A contains the upper quasi-triangular
          matrix S from the generalized Schur factorization.
          If JOB = 'E', the diagonal blocks of A match those of S, but
          the rest of A is unspecified.
[in]LDA
          LDA is INTEGER
          The leading dimension of the array A.  LDA >= max( 1, N ).
[in,out]B
          B is REAL array, dimension (LDB, N)
          On entry, the N-by-N upper triangular matrix B.
          On exit, if JOB = 'S', B contains the upper triangular
          matrix P from the generalized Schur factorization;
          2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S
          are reduced to positive diagonal form, i.e., if A(j+1,j) is
          non-zero, then B(j+1,j) = B(j,j+1) = 0, B(j,j) > 0, and
          B(j+1,j+1) > 0.
          If JOB = 'E', the diagonal blocks of B match those of P, but
          the rest of B is unspecified.
[in]LDB
          LDB is INTEGER
          The leading dimension of the array B.  LDB >= max( 1, N ).
[out]ALPHAR
          ALPHAR is REAL array, dimension (N)
          The real parts of each scalar alpha defining an eigenvalue
          of GNEP.
[out]ALPHAI
          ALPHAI is REAL array, dimension (N)
          The imaginary parts of each scalar alpha defining an
          eigenvalue of GNEP.
          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
          positive, then the j-th and (j+1)-st eigenvalues are a
          complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).
[out]BETA
          BETA is REAL array, dimension (N)
          The scalars beta that define the eigenvalues of GNEP.
          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
          beta = BETA(j) represent the j-th eigenvalue of the matrix
          pair (A,B), in one of the forms lambda = alpha/beta or
          mu = beta/alpha.  Since either lambda or mu may overflow,
          they should not, in general, be computed.
[in,out]Q
          Q is REAL array, dimension (LDQ, N)
          On entry, if COMPQ = 'V', the orthogonal matrix Q1 used in
          the reduction of (A,B) to generalized Hessenberg form.
          On exit, if COMPQ = 'I', the orthogonal matrix of left Schur
          vectors of (A,B), and if COMPQ = 'V', the orthogonal matrix
          of left Schur vectors of (A,B).
          Not referenced if COMPQ = 'N'.
[in]LDQ
          LDQ is INTEGER
          The leading dimension of the array Q.  LDQ >= 1.
          If COMPQ='V' or 'I', then LDQ >= N.
[in,out]Z
          Z is REAL array, dimension (LDZ, N)
          On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in
          the reduction of (A,B) to generalized Hessenberg form.
          On exit, if COMPZ = 'I', the orthogonal matrix of
          right Schur vectors of (H,T), and if COMPZ = 'V', the
          orthogonal matrix of right Schur vectors of (A,B).
          Not referenced if COMPZ = 'N'.
[in]LDZ
          LDZ is INTEGER
          The leading dimension of the array Z.  LDZ >= 1.
          If COMPZ='V' or 'I', then LDZ >= N.
[out]WORK
          WORK is REAL array, dimension (MAX(1,LWORK))
          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
[in]LWORK
          LWORK is INTEGER
          The dimension of the array WORK.  LWORK >= max(1,N).

          If LWORK = -1, then a workspace query is assumed; the routine
          only calculates the optimal size of the WORK array, returns
          this value as the first entry of the WORK array, and no error
          message related to LWORK is issued by XERBLA.
[in]REC
          REC is INTEGER
             REC indicates the current recursion level. Should be set
             to 0 on first call.
[out]INFO
          INFO is INTEGER
          = 0: successful exit
          < 0: if INFO = -i, the i-th argument had an illegal value
          = 1,...,N: the QZ iteration did not converge.  (A,B) is not
                     in Schur form, but ALPHAR(i), ALPHAI(i), and
                     BETA(i), i=INFO+1,...,N should be correct.
Author
Thijs Steel, KU Leuven
Date
May 2020

Definition at line 300 of file slaqz0.f.

304  IMPLICIT NONE
305 
306 * Arguments
307  CHARACTER, INTENT( IN ) :: WANTS, WANTQ, WANTZ
308  INTEGER, INTENT( IN ) :: N, ILO, IHI, LDA, LDB, LDQ, LDZ, LWORK,
309  $ REC
310 
311  INTEGER, INTENT( OUT ) :: INFO
312 
313  REAL, INTENT( INOUT ) :: A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
314  $ Z( LDZ, * ), ALPHAR( * ), ALPHAI( * ), BETA( * ), WORK( * )
315 
316 * Parameters
317  REAL :: ZERO, ONE, HALF
318  parameter( zero = 0.0, one = 1.0, half = 0.5 )
319 
320 * Local scalars
321  REAL :: SMLNUM, ULP, ESHIFT, SAFMIN, SAFMAX, C1, S1, TEMP, SWAP
322  INTEGER :: ISTART, ISTOP, IITER, MAXIT, ISTART2, K, LD, NSHIFTS,
323  $ NBLOCK, NW, NMIN, NIBBLE, N_UNDEFLATED, N_DEFLATED,
324  $ NS, SWEEP_INFO, SHIFTPOS, LWORKREQ, K2, ISTARTM,
325  $ ISTOPM, IWANTS, IWANTQ, IWANTZ, NORM_INFO, AED_INFO,
326  $ NWR, NBR, NSR, ITEMP1, ITEMP2, RCOST, I
327  LOGICAL :: ILSCHUR, ILQ, ILZ
328  CHARACTER :: JBCMPZ*3
329 
330 * External Functions
331  EXTERNAL :: xerbla, shgeqz, slaqz3, slaqz4, slaset, slabad,
332  $ slartg, srot
333  REAL, EXTERNAL :: SLAMCH
334  LOGICAL, EXTERNAL :: LSAME
335  INTEGER, EXTERNAL :: ILAENV
336 
337 *
338 * Decode wantS,wantQ,wantZ
339 *
340  IF( lsame( wants, 'E' ) ) THEN
341  ilschur = .false.
342  iwants = 1
343  ELSE IF( lsame( wants, 'S' ) ) THEN
344  ilschur = .true.
345  iwants = 2
346  ELSE
347  iwants = 0
348  END IF
349 
350  IF( lsame( wantq, 'N' ) ) THEN
351  ilq = .false.
352  iwantq = 1
353  ELSE IF( lsame( wantq, 'V' ) ) THEN
354  ilq = .true.
355  iwantq = 2
356  ELSE IF( lsame( wantq, 'I' ) ) THEN
357  ilq = .true.
358  iwantq = 3
359  ELSE
360  iwantq = 0
361  END IF
362 
363  IF( lsame( wantz, 'N' ) ) THEN
364  ilz = .false.
365  iwantz = 1
366  ELSE IF( lsame( wantz, 'V' ) ) THEN
367  ilz = .true.
368  iwantz = 2
369  ELSE IF( lsame( wantz, 'I' ) ) THEN
370  ilz = .true.
371  iwantz = 3
372  ELSE
373  iwantz = 0
374  END IF
375 *
376 * Check Argument Values
377 *
378  info = 0
379  IF( iwants.EQ.0 ) THEN
380  info = -1
381  ELSE IF( iwantq.EQ.0 ) THEN
382  info = -2
383  ELSE IF( iwantz.EQ.0 ) THEN
384  info = -3
385  ELSE IF( n.LT.0 ) THEN
386  info = -4
387  ELSE IF( ilo.LT.1 ) THEN
388  info = -5
389  ELSE IF( ihi.GT.n .OR. ihi.LT.ilo-1 ) THEN
390  info = -6
391  ELSE IF( lda.LT.n ) THEN
392  info = -8
393  ELSE IF( ldb.LT.n ) THEN
394  info = -10
395  ELSE IF( ldq.LT.1 .OR. ( ilq .AND. ldq.LT.n ) ) THEN
396  info = -15
397  ELSE IF( ldz.LT.1 .OR. ( ilz .AND. ldz.LT.n ) ) THEN
398  info = -17
399  END IF
400  IF( info.NE.0 ) THEN
401  CALL xerbla( 'SLAQZ0', -info )
402  RETURN
403  END IF
404 
405 *
406 * Quick return if possible
407 *
408  IF( n.LE.0 ) THEN
409  work( 1 ) = real( 1 )
410  RETURN
411  END IF
412 
413 *
414 * Get the parameters
415 *
416  jbcmpz( 1:1 ) = wants
417  jbcmpz( 2:2 ) = wantq
418  jbcmpz( 3:3 ) = wantz
419 
420  nmin = ilaenv( 12, 'SLAQZ0', jbcmpz, n, ilo, ihi, lwork )
421 
422  nwr = ilaenv( 13, 'SLAQZ0', jbcmpz, n, ilo, ihi, lwork )
423  nwr = max( 2, nwr )
424  nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr )
425 
426  nibble = ilaenv( 14, 'SLAQZ0', jbcmpz, n, ilo, ihi, lwork )
427 
428  nsr = ilaenv( 15, 'SLAQZ0', jbcmpz, n, ilo, ihi, lwork )
429  nsr = min( nsr, ( n+6 ) / 9, ihi-ilo )
430  nsr = max( 2, nsr-mod( nsr, 2 ) )
431 
432  rcost = ilaenv( 17, 'SLAQZ0', jbcmpz, n, ilo, ihi, lwork )
433  itemp1 = int( nsr/sqrt( 1+2*nsr/( real( rcost )/100*n ) ) )
434  itemp1 = ( ( itemp1-1 )/4 )*4+4
435  nbr = nsr+itemp1
436 
437  IF( n .LT. nmin .OR. rec .GE. 2 ) THEN
438  CALL shgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,
439  $ alphar, alphai, beta, q, ldq, z, ldz, work,
440  $ lwork, info )
441  RETURN
442  END IF
443 
444 *
445 * Find out required workspace
446 *
447 
448 * Workspace query to slaqz3
449  nw = max( nwr, nmin )
450  CALL slaqz3( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,
451  $ q, ldq, z, ldz, n_undeflated, n_deflated, alphar,
452  $ alphai, beta, work, nw, work, nw, work, -1, rec,
453  $ aed_info )
454  itemp1 = int( work( 1 ) )
455 * Workspace query to slaqz4
456  CALL slaqz4( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alphar,
457  $ alphai, beta, a, lda, b, ldb, q, ldq, z, ldz, work,
458  $ nbr, work, nbr, work, -1, sweep_info )
459  itemp2 = int( work( 1 ) )
460 
461  lworkreq = max( itemp1+2*nw**2, itemp2+2*nbr**2 )
462  IF ( lwork .EQ.-1 ) THEN
463  work( 1 ) = real( lworkreq )
464  RETURN
465  ELSE IF ( lwork .LT. lworkreq ) THEN
466  info = -19
467  END IF
468  IF( info.NE.0 ) THEN
469  CALL xerbla( 'SLAQZ0', info )
470  RETURN
471  END IF
472 *
473 * Initialize Q and Z
474 *
475  IF( iwantq.EQ.3 ) CALL slaset( 'FULL', n, n, zero, one, q, ldq )
476  IF( iwantz.EQ.3 ) CALL slaset( 'FULL', n, n, zero, one, z, ldz )
477 
478 * Get machine constants
479  safmin = slamch( 'SAFE MINIMUM' )
480  safmax = one/safmin
481  CALL slabad( safmin, safmax )
482  ulp = slamch( 'PRECISION' )
483  smlnum = safmin*( real( n )/ulp )
484 
485  istart = ilo
486  istop = ihi
487  maxit = 3*( ihi-ilo+1 )
488  ld = 0
489 
490  DO iiter = 1, maxit
491  IF( iiter .GE. maxit ) THEN
492  info = istop+1
493  GOTO 80
494  END IF
495  IF ( istart+1 .GE. istop ) THEN
496  istop = istart
497  EXIT
498  END IF
499 
500 * Check deflations at the end
501  IF ( abs( a( istop-1, istop-2 ) ) .LE. max( smlnum,
502  $ ulp*( abs( a( istop-1, istop-1 ) )+abs( a( istop-2,
503  $ istop-2 ) ) ) ) ) THEN
504  a( istop-1, istop-2 ) = zero
505  istop = istop-2
506  ld = 0
507  eshift = zero
508  ELSE IF ( abs( a( istop, istop-1 ) ) .LE. max( smlnum,
509  $ ulp*( abs( a( istop, istop ) )+abs( a( istop-1,
510  $ istop-1 ) ) ) ) ) THEN
511  a( istop, istop-1 ) = zero
512  istop = istop-1
513  ld = 0
514  eshift = zero
515  END IF
516 * Check deflations at the start
517  IF ( abs( a( istart+2, istart+1 ) ) .LE. max( smlnum,
518  $ ulp*( abs( a( istart+1, istart+1 ) )+abs( a( istart+2,
519  $ istart+2 ) ) ) ) ) THEN
520  a( istart+2, istart+1 ) = zero
521  istart = istart+2
522  ld = 0
523  eshift = zero
524  ELSE IF ( abs( a( istart+1, istart ) ) .LE. max( smlnum,
525  $ ulp*( abs( a( istart, istart ) )+abs( a( istart+1,
526  $ istart+1 ) ) ) ) ) THEN
527  a( istart+1, istart ) = zero
528  istart = istart+1
529  ld = 0
530  eshift = zero
531  END IF
532 
533  IF ( istart+1 .GE. istop ) THEN
534  EXIT
535  END IF
536 
537 * Check interior deflations
538  istart2 = istart
539  DO k = istop, istart+1, -1
540  IF ( abs( a( k, k-1 ) ) .LE. max( smlnum, ulp*( abs( a( k,
541  $ k ) )+abs( a( k-1, k-1 ) ) ) ) ) THEN
542  a( k, k-1 ) = zero
543  istart2 = k
544  EXIT
545  END IF
546  END DO
547 
548 * Get range to apply rotations to
549  IF ( ilschur ) THEN
550  istartm = 1
551  istopm = n
552  ELSE
553  istartm = istart2
554  istopm = istop
555  END IF
556 
557 * Check infinite eigenvalues, this is done without blocking so might
558 * slow down the method when many infinite eigenvalues are present
559  k = istop
560  DO WHILE ( k.GE.istart2 )
561  temp = zero
562  IF( k .LT. istop ) THEN
563  temp = temp+abs( b( k, k+1 ) )
564  END IF
565  IF( k .GT. istart2 ) THEN
566  temp = temp+abs( b( k-1, k ) )
567  END IF
568 
569  IF( abs( b( k, k ) ) .LT. max( smlnum, ulp*temp ) ) THEN
570 * A diagonal element of B is negligable, move it
571 * to the top and deflate it
572 
573  DO k2 = k, istart2+1, -1
574  CALL slartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,
575  $ temp )
576  b( k2-1, k2 ) = temp
577  b( k2-1, k2-1 ) = zero
578 
579  CALL srot( k2-2-istartm+1, b( istartm, k2 ), 1,
580  $ b( istartm, k2-1 ), 1, c1, s1 )
581  CALL srot( min( k2+1, istop )-istartm+1, a( istartm,
582  $ k2 ), 1, a( istartm, k2-1 ), 1, c1, s1 )
583  IF ( ilz ) THEN
584  CALL srot( n, z( 1, k2 ), 1, z( 1, k2-1 ), 1, c1,
585  $ s1 )
586  END IF
587 
588  IF( k2.LT.istop ) THEN
589  CALL slartg( a( k2, k2-1 ), a( k2+1, k2-1 ), c1,
590  $ s1, temp )
591  a( k2, k2-1 ) = temp
592  a( k2+1, k2-1 ) = zero
593 
594  CALL srot( istopm-k2+1, a( k2, k2 ), lda, a( k2+1,
595  $ k2 ), lda, c1, s1 )
596  CALL srot( istopm-k2+1, b( k2, k2 ), ldb, b( k2+1,
597  $ k2 ), ldb, c1, s1 )
598  IF( ilq ) THEN
599  CALL srot( n, q( 1, k2 ), 1, q( 1, k2+1 ), 1,
600  $ c1, s1 )
601  END IF
602  END IF
603 
604  END DO
605 
606  IF( istart2.LT.istop )THEN
607  CALL slartg( a( istart2, istart2 ), a( istart2+1,
608  $ istart2 ), c1, s1, temp )
609  a( istart2, istart2 ) = temp
610  a( istart2+1, istart2 ) = zero
611 
612  CALL srot( istopm-( istart2+1 )+1, a( istart2,
613  $ istart2+1 ), lda, a( istart2+1,
614  $ istart2+1 ), lda, c1, s1 )
615  CALL srot( istopm-( istart2+1 )+1, b( istart2,
616  $ istart2+1 ), ldb, b( istart2+1,
617  $ istart2+1 ), ldb, c1, s1 )
618  IF( ilq ) THEN
619  CALL srot( n, q( 1, istart2 ), 1, q( 1,
620  $ istart2+1 ), 1, c1, s1 )
621  END IF
622  END IF
623 
624  istart2 = istart2+1
625 
626  END IF
627  k = k-1
628  END DO
629 
630 * istart2 now points to the top of the bottom right
631 * unreduced Hessenberg block
632  IF ( istart2 .GE. istop ) THEN
633  istop = istart2-1
634  ld = 0
635  eshift = zero
636  cycle
637  END IF
638 
639  nw = nwr
640  nshifts = nsr
641  nblock = nbr
642 
643  IF ( istop-istart2+1 .LT. nmin ) THEN
644 * Setting nw to the size of the subblock will make AED deflate
645 * all the eigenvalues. This is slightly more efficient than just
646 * using qz_small because the off diagonal part gets updated via BLAS.
647  IF ( istop-istart+1 .LT. nmin ) THEN
648  nw = istop-istart+1
649  istart2 = istart
650  ELSE
651  nw = istop-istart2+1
652  END IF
653  END IF
654 
655 *
656 * Time for AED
657 *
658  CALL slaqz3( ilschur, ilq, ilz, n, istart2, istop, nw, a, lda,
659  $ b, ldb, q, ldq, z, ldz, n_undeflated, n_deflated,
660  $ alphar, alphai, beta, work, nw, work( nw**2+1 ),
661  $ nw, work( 2*nw**2+1 ), lwork-2*nw**2, rec,
662  $ aed_info )
663 
664  IF ( n_deflated > 0 ) THEN
665  istop = istop-n_deflated
666  ld = 0
667  eshift = zero
668  END IF
669 
670  IF ( 100*n_deflated > nibble*( n_deflated+n_undeflated ) .OR.
671  $ istop-istart2+1 .LT. nmin ) THEN
672 * AED has uncovered many eigenvalues. Skip a QZ sweep and run
673 * AED again.
674  cycle
675  END IF
676 
677  ld = ld+1
678 
679  ns = min( nshifts, istop-istart2 )
680  ns = min( ns, n_undeflated )
681  shiftpos = istop-n_deflated-n_undeflated+1
682 *
683 * Shuffle shifts to put double shifts in front
684 * This ensures that we don't split up a double shift
685 *
686  DO i = shiftpos, shiftpos+n_undeflated-1, 2
687  IF( alphai( i ).NE.-alphai( i+1 ) ) THEN
688 *
689  swap = alphar( i )
690  alphar( i ) = alphar( i+1 )
691  alphar( i+1 ) = alphar( i+2 )
692  alphar( i+2 ) = swap
693 
694  swap = alphai( i )
695  alphai( i ) = alphai( i+1 )
696  alphai( i+1 ) = alphai( i+2 )
697  alphai( i+2 ) = swap
698 
699  swap = beta( i )
700  beta( i ) = beta( i+1 )
701  beta( i+1 ) = beta( i+2 )
702  beta( i+2 ) = swap
703  END IF
704  END DO
705 
706  IF ( mod( ld, 6 ) .EQ. 0 ) THEN
707 *
708 * Exceptional shift. Chosen for no particularly good reason.
709 *
710  IF( ( real( maxit )*safmin )*abs( a( istop,
711  $ istop-1 ) ).LT.abs( a( istop-1, istop-1 ) ) ) THEN
712  eshift = a( istop, istop-1 )/b( istop-1, istop-1 )
713  ELSE
714  eshift = eshift+one/( safmin*real( maxit ) )
715  END IF
716  alphar( shiftpos ) = one
717  alphar( shiftpos+1 ) = zero
718  alphai( shiftpos ) = zero
719  alphai( shiftpos+1 ) = zero
720  beta( shiftpos ) = eshift
721  beta( shiftpos+1 ) = eshift
722  ns = 2
723  END IF
724 
725 *
726 * Time for a QZ sweep
727 *
728  CALL slaqz4( ilschur, ilq, ilz, n, istart2, istop, ns, nblock,
729  $ alphar( shiftpos ), alphai( shiftpos ),
730  $ beta( shiftpos ), a, lda, b, ldb, q, ldq, z, ldz,
731  $ work, nblock, work( nblock**2+1 ), nblock,
732  $ work( 2*nblock**2+1 ), lwork-2*nblock**2,
733  $ sweep_info )
734 
735  END DO
736 
737 *
738 * Call SHGEQZ to normalize the eigenvalue blocks and set the eigenvalues
739 * If all the eigenvalues have been found, SHGEQZ will not do any iterations
740 * and only normalize the blocks. In case of a rare convergence failure,
741 * the single shift might perform better.
742 *
743  80 CALL shgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,
744  $ alphar, alphai, beta, q, ldq, z, ldz, work, lwork,
745  $ norm_info )
746 
747  info = norm_info
748 
subroutine slabad(SMALL, LARGE)
SLABAD
Definition: slabad.f:74
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition: slaset.f:110
subroutine slartg(f, g, c, s, r)
SLARTG generates a plane rotation with real cosine and real sine.
Definition: slartg.f90:113
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
ILAENV
Definition: ilaenv.f:162
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:60
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:53
subroutine slaqz4(ILSCHUR, ILQ, ILZ, N, ILO, IHI, NSHIFTS, NBLOCK_DESIRED, SR, SI, SS, A, LDA, B, LDB, Q, LDQ, Z, LDZ, QC, LDQC, ZC, LDZC, WORK, LWORK, INFO)
SLAQZ4
Definition: slaqz4.f:214
recursive subroutine slaqz3(ILSCHUR, ILQ, ILZ, N, ILO, IHI, NW, A, LDA, B, LDB, Q, LDQ, Z, LDZ, NS, ND, ALPHAR, ALPHAI, BETA, QC, LDQC, ZC, LDZC, WORK, LWORK, REC, INFO)
SLAQZ3
Definition: slaqz3.f:238
subroutine shgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO)
SHGEQZ
Definition: shgeqz.f:304
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT
Definition: srot.f:92
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:68
Here is the call graph for this function:
Here is the caller graph for this function: