diff --git a/SRC/chgeqz.f b/SRC/chgeqz.f index 8c1d62a875..50c6827ff9 100644 --- a/SRC/chgeqz.f +++ b/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 diff --git a/SRC/claqz0.f b/SRC/claqz0.f index 2284fd65d9..9cc25c6dcd 100644 --- a/SRC/claqz0.f +++ b/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 diff --git a/SRC/dhgeqz.f b/SRC/dhgeqz.f index 3fe2a083c8..b5a2917e32 100644 --- a/SRC/dhgeqz.f +++ b/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 diff --git a/SRC/dlaqz0.f b/SRC/dlaqz0.f index 1bf65fd601..5b09654068 100644 --- a/SRC/dlaqz0.f +++ b/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 diff --git a/SRC/shgeqz.f b/SRC/shgeqz.f index 79a9c60925..10fb2b7d76 100644 --- a/SRC/shgeqz.f +++ b/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 diff --git a/SRC/slaqz0.f b/SRC/slaqz0.f index 15913be88c..69f4029148 100644 --- a/SRC/slaqz0.f +++ b/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 diff --git a/SRC/zhgeqz.f b/SRC/zhgeqz.f index 302b69f347..c15e7aace4 100644 --- a/SRC/zhgeqz.f +++ b/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 diff --git a/SRC/zlaqz0.f b/SRC/zlaqz0.f index 2616f20b5b..0d8884ed5e 100644 --- a/SRC/zlaqz0.f +++ b/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