Use normwise criterion for inf eigenvalues in QZ

SRC/chgeqz.f

@@ -523,9 +523,7 @@ SUBROUTINE CHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
             END IF
          END IF
 *
-         IF( ABS( T( ILAST, ILAST ) ).LE.MAX( SAFMIN, ULP*( 
-     $         ABS( T( ILAST - 1, ILAST ) ) + ABS( T( ILAST-1, ILAST-1 )
-     $          ) ) ) ) THEN
+         IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN
             T( ILAST, ILAST ) = CZERO
             GO TO 50
          END IF
@@ -551,10 +549,7 @@ SUBROUTINE CHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
 *
 *           Test 2: for T(j,j)=0
 *
-            TEMP = ABS ( T( J, J + 1 ) )
-            IF ( J .GT. ILO )
-     $           TEMP = TEMP + ABS ( T( J - 1, J ) )
-            IF( ABS( T( J, J ) ).LT.MAX( SAFMIN,ULP*TEMP ) ) THEN
+            IF( ABS( T( J, J ) ).LT.BTOL ) THEN
                T( J, J ) = CZERO
 *
 *              Test 1a: Check for 2 consecutive small subdiagonals in A

SRC/claqz0.f

@@ -299,7 +299,7 @@ RECURSIVE SUBROUTINE CLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
       PARAMETER( ZERO = 0.0, ONE = 1.0, HALF = 0.5 )
 
 *     Local scalars
-      REAL :: SMLNUM, ULP, SAFMIN, SAFMAX, C1, TEMPR
+      REAL :: SMLNUM, ULP, SAFMIN, SAFMAX, C1, TEMPR, BNORM, BTOL
       COMPLEX :: ESHIFT, S1, TEMP
       INTEGER :: ISTART, ISTOP, IITER, MAXIT, ISTART2, K, LD, NSHIFTS,
      $           NBLOCK, NW, NMIN, NIBBLE, N_UNDEFLATED, N_DEFLATED,
@@ -312,7 +312,7 @@ RECURSIVE SUBROUTINE CLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
 *     External Functions
       EXTERNAL :: XERBLA, CHGEQZ, CLAQZ2, CLAQZ3, CLASET, SLABAD,
      $            CLARTG, CROT
-      REAL, EXTERNAL :: SLAMCH
+      REAL, EXTERNAL :: SLAMCH, CLANHS
       LOGICAL, EXTERNAL :: LSAME
       INTEGER, EXTERNAL :: ILAENV
 
@@ -466,6 +466,9 @@ RECURSIVE SUBROUTINE CLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
       ULP = SLAMCH( 'PRECISION' )
       SMLNUM = SAFMIN*( REAL( N )/ULP )
 
+      BNORM = CLANHS( 'F', IHI-ILO+1, B( ILO, ILO ), LDB, RWORK )
+      BTOL = MAX( SAFMIN, ULP*BNORM )
+
       ISTART = ILO
       ISTOP = IHI
       MAXIT = 30*( IHI-ILO+1 )
@@ -528,15 +531,8 @@ RECURSIVE SUBROUTINE CLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
 *        slow down the method when many infinite eigenvalues are present
          K = ISTOP
          DO WHILE ( K.GE.ISTART2 )
-            TEMPR = ZERO
-            IF( K .LT. ISTOP ) THEN
-               TEMPR = TEMPR+ABS( B( K, K+1 ) )
-            END IF
-            IF( K .GT. ISTART2 ) THEN
-               TEMPR = TEMPR+ABS( B( K-1, K ) )
-            END IF
 
-            IF( ABS( B( K, K ) ) .LT. MAX( SMLNUM, ULP*TEMPR ) ) THEN
+            IF( ABS( B( K, K ) ) .LT. BTOL ) THEN
 *              A diagonal element of B is negligable, move it
 *              to the top and deflate it
 

SRC/dhgeqz.f

@@ -536,9 +536,7 @@ SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
             END IF
          END IF
 *
-         IF( ABS( T( ILAST, ILAST ) ).LE.MAX( SAFMIN, ULP*( 
-     $         ABS( T( ILAST - 1, ILAST ) ) + ABS( T( ILAST-1, ILAST-1 )
-     $          ) ) ) ) THEN
+         IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN
             T( ILAST, ILAST ) = ZERO
             GO TO 70
          END IF
@@ -564,10 +562,7 @@ SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
 *
 *           Test 2: for T(j,j)=0
 *
-            TEMP = ABS ( T( J, J + 1 ) )
-            IF ( J .GT. ILO )
-     $           TEMP = TEMP + ABS ( T( J - 1, J ) )
-            IF( ABS( T( J, J ) ).LT.MAX( SAFMIN,ULP*TEMP ) ) THEN
+            IF( ABS( T( J, J ) ).LT.BTOL ) THEN
                T( J, J ) = ZERO
 *
 *              Test 1a: Check for 2 consecutive small subdiagonals in A

SRC/dlaqz0.f

@@ -322,7 +322,7 @@ RECURSIVE SUBROUTINE DLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
 
 *     Local scalars
       DOUBLE PRECISION :: SMLNUM, ULP, ESHIFT, SAFMIN, SAFMAX, C1, S1,
-     $                    TEMP, SWAP
+     $                    TEMP, SWAP, BNORM, BTOL
       INTEGER :: ISTART, ISTOP, IITER, MAXIT, ISTART2, K, LD, NSHIFTS,
      $           NBLOCK, NW, NMIN, NIBBLE, N_UNDEFLATED, N_DEFLATED,
      $           NS, SWEEP_INFO, SHIFTPOS, LWORKREQ, K2, ISTARTM,
@@ -334,7 +334,7 @@ RECURSIVE SUBROUTINE DLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
 *     External Functions
       EXTERNAL :: XERBLA, DHGEQZ, DLASET, DLAQZ3, DLAQZ4, DLABAD,
      $            DLARTG, DROT
-      DOUBLE PRECISION, EXTERNAL :: DLAMCH
+      DOUBLE PRECISION, EXTERNAL :: DLAMCH, DLANHS
       LOGICAL, EXTERNAL :: LSAME
       INTEGER, EXTERNAL :: ILAENV
 
@@ -486,6 +486,9 @@ RECURSIVE SUBROUTINE DLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
       ULP = DLAMCH( 'PRECISION' )
       SMLNUM = SAFMIN*( DBLE( N )/ULP )
 
+      BNORM = DLANHS( 'F', IHI-ILO+1, B( ILO, ILO ), LDB, WORK )
+      BTOL = MAX( SAFMIN, ULP*BNORM )
+
       ISTART = ILO
       ISTOP = IHI
       MAXIT = 3*( IHI-ILO+1 )
@@ -562,15 +565,8 @@ RECURSIVE SUBROUTINE DLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
 *        slow down the method when many infinite eigenvalues are present
          K = ISTOP
          DO WHILE ( K.GE.ISTART2 )
-            TEMP = ZERO
-            IF( K .LT. ISTOP ) THEN
-               TEMP = TEMP+ABS( B( K, K+1 ) )
-            END IF
-            IF( K .GT. ISTART2 ) THEN
-               TEMP = TEMP+ABS( B( K-1, K ) )
-            END IF
 
-            IF( ABS( B( K, K ) ) .LT. MAX( SMLNUM, ULP*TEMP ) ) THEN
+            IF( ABS( B( K, K ) ) .LT. BTOL ) THEN
 *              A diagonal element of B is negligable, move it
 *              to the top and deflate it
 

SRC/shgeqz.f

@@ -536,9 +536,7 @@ SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
             END IF
          END IF
 *
-         IF( ABS( T( ILAST, ILAST ) ).LE.MAX( SAFMIN, ULP*( 
-     $         ABS( T( ILAST - 1, ILAST ) ) + ABS( T( ILAST-1, ILAST-1 )
-     $          ) ) ) ) THEN
+         IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN
             T( ILAST, ILAST ) = ZERO
             GO TO 70
          END IF
@@ -564,10 +562,7 @@ SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
 *
 *           Test 2: for T(j,j)=0
 *
-            TEMP = ABS ( T( J, J + 1 ) )
-            IF ( J .GT. ILO )
-     $           TEMP = TEMP + ABS ( T( J - 1, J ) )
-            IF( ABS( T( J, J ) ).LT.MAX( SAFMIN,ULP*TEMP ) ) THEN
+            IF( ABS( T( J, J ) ).LT.BTOL ) THEN
                T( J, J ) = ZERO
 *
 *              Test 1a: Check for 2 consecutive small subdiagonals in A

SRC/slaqz0.f

@@ -318,7 +318,8 @@ RECURSIVE SUBROUTINE SLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
       PARAMETER( ZERO = 0.0, ONE = 1.0, HALF = 0.5 )
 
 *     Local scalars
-      REAL :: SMLNUM, ULP, ESHIFT, SAFMIN, SAFMAX, C1, S1, TEMP, SWAP
+      REAL :: SMLNUM, ULP, ESHIFT, SAFMIN, SAFMAX, C1, S1, TEMP, SWAP,
+     $        BNORM, BTOL 
       INTEGER :: ISTART, ISTOP, IITER, MAXIT, ISTART2, K, LD, NSHIFTS,
      $           NBLOCK, NW, NMIN, NIBBLE, N_UNDEFLATED, N_DEFLATED,
      $           NS, SWEEP_INFO, SHIFTPOS, LWORKREQ, K2, ISTARTM,
@@ -330,7 +331,7 @@ RECURSIVE SUBROUTINE SLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
 *     External Functions
       EXTERNAL :: XERBLA, SHGEQZ, SLAQZ3, SLAQZ4, SLASET, SLABAD,
      $            SLARTG, SROT
-      REAL, EXTERNAL :: SLAMCH
+      REAL, EXTERNAL :: SLAMCH, SLANHS
       LOGICAL, EXTERNAL :: LSAME
       INTEGER, EXTERNAL :: ILAENV
 
@@ -482,6 +483,9 @@ RECURSIVE SUBROUTINE SLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
       ULP = SLAMCH( 'PRECISION' )
       SMLNUM = SAFMIN*( REAL( N )/ULP )
 
+      BNORM = SLANHS( 'F', IHI-ILO+1, B( ILO, ILO ), LDB, WORK )
+      BTOL = MAX( SAFMIN, ULP*BNORM )
+
       ISTART = ILO
       ISTOP = IHI
       MAXIT = 3*( IHI-ILO+1 )
@@ -558,15 +562,8 @@ RECURSIVE SUBROUTINE SLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
 *        slow down the method when many infinite eigenvalues are present
          K = ISTOP
          DO WHILE ( K.GE.ISTART2 )
-            TEMP = ZERO
-            IF( K .LT. ISTOP ) THEN
-               TEMP = TEMP+ABS( B( K, K+1 ) )
-            END IF
-            IF( K .GT. ISTART2 ) THEN
-               TEMP = TEMP+ABS( B( K-1, K ) )
-            END IF
 
-            IF( ABS( B( K, K ) ) .LT. MAX( SMLNUM, ULP*TEMP ) ) THEN
+            IF( ABS( B( K, K ) ) .LT. BTOL ) THEN
 *              A diagonal element of B is negligable, move it
 *              to the top and deflate it
 

SRC/zhgeqz.f

@@ -524,9 +524,7 @@ SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
             END IF
          END IF
 *
-         IF( ABS( T( ILAST, ILAST ) ).LE.MAX( SAFMIN, ULP*( 
-     $         ABS( T( ILAST - 1, ILAST ) ) + ABS( T( ILAST-1, ILAST-1 )
-     $          ) ) ) ) THEN
+         IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN
             T( ILAST, ILAST ) = CZERO
             GO TO 50
          END IF
@@ -552,10 +550,7 @@ SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
 *
 *           Test 2: for T(j,j)=0
 *
-            TEMP = ABS ( T( J, J + 1 ) )
-            IF ( J .GT. ILO )
-     $           TEMP = TEMP + ABS ( T( J - 1, J ) )
-            IF( ABS( T( J, J ) ).LT.MAX( SAFMIN,ULP*TEMP ) ) THEN
+            IF( ABS( T( J, J ) ).LT.BTOL ) THEN
                T( J, J ) = CZERO
 *
 *              Test 1a: Check for 2 consecutive small subdiagonals in A

SRC/zlaqz0.f

@@ -300,7 +300,8 @@ RECURSIVE SUBROUTINE ZLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
       PARAMETER( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D0 )
 
 *     Local scalars
-      DOUBLE PRECISION :: SMLNUM, ULP, SAFMIN, SAFMAX, C1, TEMPR
+      DOUBLE PRECISION :: SMLNUM, ULP, SAFMIN, SAFMAX, C1, TEMPR,
+     $                    BNORM, BTOL
       COMPLEX*16 :: ESHIFT, S1, TEMP
       INTEGER :: ISTART, ISTOP, IITER, MAXIT, ISTART2, K, LD, NSHIFTS,
      $           NBLOCK, NW, NMIN, NIBBLE, N_UNDEFLATED, N_DEFLATED,
@@ -313,7 +314,7 @@ RECURSIVE SUBROUTINE ZLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
 *     External Functions
       EXTERNAL :: XERBLA, ZHGEQZ, ZLAQZ2, ZLAQZ3, ZLASET, DLABAD,
      $            ZLARTG, ZROT
-      DOUBLE PRECISION, EXTERNAL :: DLAMCH
+      DOUBLE PRECISION, EXTERNAL :: DLAMCH, ZLANHS
       LOGICAL, EXTERNAL :: LSAME
       INTEGER, EXTERNAL :: ILAENV
 
@@ -467,6 +468,9 @@ RECURSIVE SUBROUTINE ZLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
       ULP = DLAMCH( 'PRECISION' )
       SMLNUM = SAFMIN*( DBLE( N )/ULP )
 
+      BNORM = ZLANHS( 'F', IHI-ILO+1, B( ILO, ILO ), LDB, RWORK )
+      BTOL = MAX( SAFMIN, ULP*BNORM )
+
       ISTART = ILO
       ISTOP = IHI
       MAXIT = 30*( IHI-ILO+1 )
@@ -529,15 +533,8 @@ RECURSIVE SUBROUTINE ZLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
 *        slow down the method when many infinite eigenvalues are present
          K = ISTOP
          DO WHILE ( K.GE.ISTART2 )
-            TEMPR = ZERO
-            IF( K .LT. ISTOP ) THEN
-               TEMPR = TEMPR+ABS( B( K, K+1 ) )
-            END IF
-            IF( K .GT. ISTART2 ) THEN
-               TEMPR = TEMPR+ABS( B( K-1, K ) )
-            END IF
 
-            IF( ABS( B( K, K ) ) .LT. MAX( SMLNUM, ULP*TEMPR ) ) THEN
+            IF( ABS( B( K, K ) ) .LT. BTOL ) THEN
 *              A diagonal element of B is negligable, move it
 *              to the top and deflate it