From 7bd0c3ddaa2c46f09615e36137612d4f713168dc Mon Sep 17 00:00:00 2001 From: Rasmus Munk Larsen Date: Sun, 6 Sep 2026 11:13:04 -0700 Subject: [PATCH 1/4] Avoid overflow in the 2x2 pivot inverse of the symmetric-indefinite factorizations The Bunch-Kaufman 2x2 pivot block D_k = [[d11, d21],[d21, d22]] is inverted by dividing through by the off-diagonal d21 so that the scaled determinant DENOM = d11*d22/d21^2 - 1 stays O(1). The factor entries are l_j = (1/DENOM) * ((d11/d21)*w0_j - w1_j) / d21 (and its d22 partner), a per-entry division by d21 and a scaling by T = 1/DENOM. The reference code does these two operations in an order that overflows at the extremes of the exponent range, silently in the classic path and with a false INFO in the rook/RK path: * The classic unblocked/packed routines (xSYTF2, xHETF2, xSPTRF, xHPTRF) and the classic panel routines (xLASYF, xLAHEF) hoist the reciprocal as D21 = T/d21 and then multiply. T/d21 overflows to +-Inf when d21 is subnormal, so a well-conditioned system with a subnormal off-diagonal is factored into Inf/NaN and solved to NaN with INFO = 0. * The rook/RK routines (xSYTF2_ROOK, xHETF2_ROOK, xSYTF2_RK, xHETF2_RK) form T*(d22*w0_j - w1_j) and divide by d21 afterwards. The intermediate T*(...) overflows when the block is near the overflow threshold, even though the factor entry is O(1); the resulting Inf trips the isnan pivot guard and reports INFO > 0 (a false singularity) for a nonsingular matrix. Divide each entry by d21 first and scale by T afterwards, in every routine: l_j = T * (((d11/d21)*w0_j - w1_j) / d21). The quotient equals DENOM*l_j, which is within a factor 1 + alpha^2 (< 2) of the result, so it overflows only where l_j itself is within that factor of the overflow threshold, while the subnormal case is a plain correctly-rounded division. This is the order xSYTRS/xSYTRS_3 already use to apply D^-1 in the solve. The hoisted 1/d21 becomes a per-entry division; the extra cost is one division per factor entry of a 2x2 pivot. The full LAPACK linear-equation test suite (xlintst{s,d,c,z}) passes with no new failures across the SY/SR/SK/SA/SP and HE/HR/HK/HA families. Co-Authored-By: Claude Fable 5.1 --- SRC/chetf2.f | 12 ++++++------ SRC/chetf2_rk.f | 32 ++++++++++++++++---------------- SRC/chetf2_rook.f | 32 ++++++++++++++++---------------- SRC/chptrf.f | 19 +++++++++---------- SRC/clahef.f | 36 ++++++++++++++++++------------------ SRC/clasyf.f | 24 ++++++++++++++---------- SRC/csptrf.f | 18 ++++++++---------- SRC/csytf2.f | 10 ++++------ SRC/csytf2_rk.f | 26 +++++++++++++------------- SRC/csytf2_rook.f | 26 +++++++++++++------------- SRC/dlasyf.f | 24 ++++++++++++++---------- SRC/dsptrf.f | 18 ++++++++---------- SRC/dsytf2.f | 10 ++++------ SRC/dsytf2_rk.f | 26 +++++++++++++------------- SRC/dsytf2_rook.f | 26 +++++++++++++------------- SRC/slasyf.f | 24 ++++++++++++++---------- SRC/ssptrf.f | 18 ++++++++---------- SRC/ssytf2.f | 10 ++++------ SRC/ssytf2_rk.f | 26 +++++++++++++------------- SRC/ssytf2_rook.f | 26 +++++++++++++------------- SRC/zhetf2.f | 14 ++++++-------- SRC/zhetf2_rk.f | 32 ++++++++++++++++---------------- SRC/zhetf2_rook.f | 32 ++++++++++++++++---------------- SRC/zhptrf.f | 18 ++++++++---------- SRC/zlahef.f | 36 ++++++++++++++++++------------------ SRC/zlasyf.f | 24 ++++++++++++++---------- SRC/zsptrf.f | 18 ++++++++---------- SRC/zsytf2.f | 10 ++++------ SRC/zsytf2_rk.f | 26 +++++++++++++------------- SRC/zsytf2_rook.f | 26 +++++++++++++------------- 30 files changed, 337 insertions(+), 342 deletions(-) diff --git a/SRC/chetf2.f b/SRC/chetf2.f index 0a6adfcef..28dcbd3c3 100644 --- a/SRC/chetf2.f +++ b/SRC/chetf2.f @@ -403,11 +403,11 @@ SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO ) D11 = REAL( A( K, K ) ) / D TT = ONE / ( D11*D22-ONE ) D12 = A( K-1, K ) / D - D = TT / D * DO 40 J = K - 2, 1, -1 - WKM1 = D*( D11*A( J, K-1 )-CONJG( D12 )*A( J, K ) ) - WK = D*( D22*A( J, K )-D12*A( J, K-1 ) ) + WKM1 = TT*( ( D11*A( J, K-1 )-CONJG( D12 )* + $ A( J, K ) ) / D ) + WK = TT*( ( D22*A( J, K )-D12*A( J, K-1 ) ) / D ) DO 30 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*CONJG( WK ) - $ A( I, K-1 )*CONJG( WKM1 ) @@ -593,11 +593,11 @@ SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO ) D22 = REAL( A( K, K ) ) / D TT = ONE / ( D11*D22-ONE ) D21 = A( K+1, K ) / D - D = TT / D * DO 80 J = K + 2, N - WK = D*( D11*A( J, K )-D21*A( J, K+1 ) ) - WKP1 = D*( D22*A( J, K+1 )-CONJG( D21 )*A( J, K ) ) + WK = TT*( ( D11*A( J, K )-D21*A( J, K+1 ) ) / D ) + WKP1 = TT*( ( D22*A( J, K+1 )-CONJG( D21 )* + $ A( J, K ) ) / D ) DO 70 I = J, N A( I, J ) = A( I, J ) - A( I, K )*CONJG( WK ) - $ A( I, K+1 )*CONJG( WKP1 ) diff --git a/SRC/chetf2_rk.f b/SRC/chetf2_rk.f index e9b427434..bcd8e1d0b 100644 --- a/SRC/chetf2_rk.f +++ b/SRC/chetf2_rk.f @@ -617,24 +617,24 @@ SUBROUTINE CHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WKM1 = TT*( D11*A( J, K-1 )-CONJG( D12 )* - $ A( J, K ) ) - WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) ) + WKM1 = TT*( ( D11*A( J, K-1 )-CONJG( D12 )* + $ A( J, K ) ) / D ) + WK = TT*( ( D22*A( J, K )-D12*A( J, K-1 ) ) / D ) * * Perform a rank-2 update of A(1:k-2,1:k-2) * DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - - $ ( A( I, K ) / D )*CONJG( WK ) - - $ ( A( I, K-1 ) / D )*CONJG( WKM1 ) + $ A( I, K )*CONJG( WK ) - + $ A( I, K-1 )*CONJG( WKM1 ) 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D - A( J, K-1 ) = WKM1 / D + A( J, K ) = WK + A( J, K-1 ) = WKM1 * (*) Make sure that diagonal element of pivot is real A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO ) * @@ -978,24 +978,24 @@ SUBROUTINE CHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) ) - WKP1 = TT*( D22*A( J, K+1 )-CONJG( D21 )* - $ A( J, K ) ) + WK = TT*( ( D11*A( J, K )-D21*A( J, K+1 ) ) / D ) + WKP1 = TT*( ( D22*A( J, K+1 )-CONJG( D21 )* + $ A( J, K ) ) / D ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N A( I, J ) = A( I, J ) - - $ ( A( I, K ) / D )*CONJG( WK ) - - $ ( A( I, K+1 ) / D )*CONJG( WKP1 ) + $ A( I, K )*CONJG( WK ) - + $ A( I, K+1 )*CONJG( WKP1 ) 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D - A( J, K+1 ) = WKP1 / D + A( J, K ) = WK + A( J, K+1 ) = WKP1 * (*) Make sure that diagonal element of pivot is real A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO ) * diff --git a/SRC/chetf2_rook.f b/SRC/chetf2_rook.f index 1f49b604b..fcaef0922 100644 --- a/SRC/chetf2_rook.f +++ b/SRC/chetf2_rook.f @@ -536,24 +536,24 @@ SUBROUTINE CHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WKM1 = TT*( D11*A( J, K-1 )-CONJG( D12 )* - $ A( J, K ) ) - WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) ) + WKM1 = TT*( ( D11*A( J, K-1 )-CONJG( D12 )* + $ A( J, K ) ) / D ) + WK = TT*( ( D22*A( J, K )-D12*A( J, K-1 ) ) / D ) * * Perform a rank-2 update of A(1:k-2,1:k-2) * DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - - $ ( A( I, K ) / D )*CONJG( WK ) - - $ ( A( I, K-1 ) / D )*CONJG( WKM1 ) + $ A( I, K )*CONJG( WK ) - + $ A( I, K-1 )*CONJG( WKM1 ) 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D - A( J, K-1 ) = WKM1 / D + A( J, K ) = WK + A( J, K-1 ) = WKM1 * (*) Make sure that diagonal element of pivot is real A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO ) * @@ -857,24 +857,24 @@ SUBROUTINE CHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) ) - WKP1 = TT*( D22*A( J, K+1 )-CONJG( D21 )* - $ A( J, K ) ) + WK = TT*( ( D11*A( J, K )-D21*A( J, K+1 ) ) / D ) + WKP1 = TT*( ( D22*A( J, K+1 )-CONJG( D21 )* + $ A( J, K ) ) / D ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N A( I, J ) = A( I, J ) - - $ ( A( I, K ) / D )*CONJG( WK ) - - $ ( A( I, K+1 ) / D )*CONJG( WKP1 ) + $ A( I, K )*CONJG( WK ) - + $ A( I, K+1 )*CONJG( WKP1 ) 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D - A( J, K+1 ) = WKP1 / D + A( J, K ) = WK + A( J, K+1 ) = WKP1 * (*) Make sure that diagonal element of pivot is real A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO ) * diff --git a/SRC/chptrf.f b/SRC/chptrf.f index 3d584fd51..bc4048f33 100644 --- a/SRC/chptrf.f +++ b/SRC/chptrf.f @@ -389,13 +389,12 @@ SUBROUTINE CHPTRF( UPLO, N, AP, IPIV, INFO ) D11 = REAL( AP( K+( K-1 )*K / 2 ) ) / D TT = ONE / ( D11*D22-ONE ) D12 = AP( K-1+( K-1 )*K / 2 ) / D - D = TT / D * DO 50 J = K - 2, 1, -1 - WKM1 = D*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ CONJG( D12 )*AP( J+( K-1 )*K / 2 ) ) - WK = D*( D22*AP( J+( K-1 )*K / 2 )-D12* - $ AP( J+( K-2 )*( K-1 ) / 2 ) ) + WKM1 = TT*( ( D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ CONJG( D12 )*AP( J+( K-1 )*K / 2 ) ) / D ) + WK = TT*( ( D22*AP( J+( K-1 )*K / 2 )-D12* + $ AP( J+( K-2 )*( K-1 ) / 2 ) ) / D ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*CONJG( WK ) - @@ -603,13 +602,13 @@ SUBROUTINE CHPTRF( UPLO, N, AP, IPIV, INFO ) D22 = REAL( AP( K+( K-1 )*( 2*N-K ) / 2 ) ) / D TT = ONE / ( D11*D22-ONE ) D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 ) / D - D = TT / D * DO 100 J = K + 2, N - WK = D*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-D21* - $ AP( J+K*( 2*N-K-1 ) / 2 ) ) - WKP1 = D*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- - $ CONJG( D21 )*AP( J+( K-1 )*( 2*N-K ) / 2 ) ) + WK = TT*( ( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-D21* + $ AP( J+K*( 2*N-K-1 ) / 2 ) ) / D ) + WKP1 = TT*( ( D22*AP( J+K*( 2*N-K-1 ) / 2 )- + $ CONJG( D21 )*AP( J+( K-1 )*( 2*N-K ) / 2 ) + $ ) / D ) DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / diff --git a/SRC/clahef.f b/SRC/clahef.f index 21c9f0986..d1654b8b6 100644 --- a/SRC/clahef.f +++ b/SRC/clahef.f @@ -481,17 +481,17 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = * ( ( -1 ) ( D22 ) ) * -* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ), * ( ( -1 ) ( D22 ) ) * -* = ( conj(D21)*( D11 ) D21*( -1 ) ) -* ( ( -1 ) ( D22 ) ), -* * where D11 = d22/d21, * D22 = d11/conj(d21), -* D21 = T/d21, * T = 1/(D22*D11-1). * +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 or conj(d21) and then scaled by T. +* * (NOTE: No need to check for division by ZERO, * since that was ensured earlier in pivot search: * (a) d21 != 0, since in 2x2 pivot case(4) @@ -503,16 +503,16 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, D11 = W( K, KW ) / CONJG( D21 ) D22 = W( K-1, KW-1 ) / D21 T = ONE / ( REAL( D11*D22 )-ONE ) - D21 = T / D21 * * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) * DO 20 J = 1, K - 2 - A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) - A( J, K ) = CONJG( D21 )* - $ ( D22*W( J, KW )-W( J, KW-1 ) ) + A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ CONJG( D21 ) ) 20 CONTINUE END IF * @@ -828,17 +828,17 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = * ( ( -1 ) ( D22 ) ) * -* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ), * ( ( -1 ) ( D22 ) ) * -* = ( conj(D21)*( D11 ) D21*( -1 ) ) -* ( ( -1 ) ( D22 ) ) -* * where D11 = d22/d21, * D22 = d11/conj(d21), -* D21 = T/d21, * T = 1/(D22*D11-1). * +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 or conj(d21) and then scaled by T. +* * (NOTE: No need to check for division by ZERO, * since that was ensured earlier in pivot search: * (a) d21 != 0, since in 2x2 pivot case(4) @@ -850,16 +850,16 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / CONJG( D21 ) T = ONE / ( REAL( D11*D22 )-ONE ) - D21 = T / D21 * * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) * DO 80 J = K + 2, N - A( J, K ) = CONJG( D21 )* - $ ( D11*W( J, K )-W( J, K+1 ) ) - A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ CONJG( D21 ) ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/clasyf.f b/SRC/clasyf.f index 926c62de6..0b9248a29 100644 --- a/SRC/clasyf.f +++ b/SRC/clasyf.f @@ -432,8 +432,9 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* = D21 * ( ( D11 ) ( -1 ) ) -* ( ( -1 ) ( D22 ) ) +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 @@ -444,10 +445,11 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) * - D21 = T / D21 DO 20 J = 1, K - 2 - A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) - A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D21 ) 20 CONTINUE END IF * @@ -712,22 +714,24 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* = D21 * ( ( D11 ) ( -1 ) ) -* ( ( -1 ) ( D22 ) ) +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = CONE / ( D11*D22-CONE ) - D21 = T / D21 * * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) * DO 80 J = K + 2, N - A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) - A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/csptrf.f b/SRC/csptrf.f index 64f8e678b..c7d2d7f41 100644 --- a/SRC/csptrf.f +++ b/SRC/csptrf.f @@ -375,13 +375,12 @@ SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 D11 = AP( K+( K-1 )*K / 2 ) / D12 T = CONE / ( D11*D22-CONE ) - D12 = T / D12 * DO 50 J = K - 2, 1, -1 - WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ AP( J+( K-1 )*K / 2 ) ) - WK = D12*( D22*AP( J+( K-1 )*K / 2 )- - $ AP( J+( K-2 )*( K-1 ) / 2 ) ) + WKM1 = T*( ( D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ AP( J+( K-1 )*K / 2 ) ) / D12 ) + WK = T*( ( D22*AP( J+( K-1 )*K / 2 )- + $ AP( J+( K-2 )*( K-1 ) / 2 ) ) / D12 ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*WK - @@ -576,13 +575,12 @@ SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 T = CONE / ( D11*D22-CONE ) - D21 = T / D21 * DO 100 J = K + 2, N - WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- - $ AP( J+K*( 2*N-K-1 ) / 2 ) ) - WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- - $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) + WK = T*( ( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- + $ AP( J+K*( 2*N-K-1 ) / 2 ) ) / D21 ) + WKP1 = T*( ( D22*AP( J+K*( 2*N-K-1 ) / 2 )- + $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) / D21 ) DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / diff --git a/SRC/csytf2.f b/SRC/csytf2.f index 01c882fad..09228ec9f 100644 --- a/SRC/csytf2.f +++ b/SRC/csytf2.f @@ -394,11 +394,10 @@ SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = CONE / ( D11*D22-CONE ) - D12 = T / D12 * DO 30 J = K - 2, 1, -1 - WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) ) - WK = D12*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K-1 )*WKM1 @@ -569,11 +568,10 @@ SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = CONE / ( D11*D22-CONE ) - D21 = T / D21 * DO 60 J = K + 2, N - WK = D21*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) DO 50 I = J, N A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K+1 )*WKP1 diff --git a/SRC/csytf2_rk.f b/SRC/csytf2_rk.f index a2ff8ad9e..a52f69a0b 100644 --- a/SRC/csytf2_rk.f +++ b/SRC/csytf2_rk.f @@ -582,18 +582,18 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) - WK = T*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - - $ ( A( I, K-1 ) / D12 )*WKM1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D12 - A( J, K-1 ) = WKM1 / D12 + A( J, K ) = WK + A( J, K-1 ) = WKM1 * 30 CONTINUE * @@ -898,22 +898,22 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N - A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - - $ ( A( I, K+1 ) / D21 )*WKP1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D21 - A( J, K+1 ) = WKP1 / D21 + A( J, K ) = WK + A( J, K+1 ) = WKP1 * 60 CONTINUE * diff --git a/SRC/csytf2_rook.f b/SRC/csytf2_rook.f index df504cef8..50f2894b4 100644 --- a/SRC/csytf2_rook.f +++ b/SRC/csytf2_rook.f @@ -502,18 +502,18 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) - WK = T*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - - $ ( A( I, K-1 ) / D12 )*WKM1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D12 - A( J, K-1 ) = WKM1 / D12 + A( J, K ) = WK + A( J, K-1 ) = WKM1 * 30 CONTINUE * @@ -776,22 +776,22 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N - A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - - $ ( A( I, K+1 ) / D21 )*WKP1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D21 - A( J, K+1 ) = WKP1 / D21 + A( J, K ) = WK + A( J, K+1 ) = WKP1 * 60 CONTINUE * diff --git a/SRC/dlasyf.f b/SRC/dlasyf.f index 68e0087f3..a3e66e965 100644 --- a/SRC/dlasyf.f +++ b/SRC/dlasyf.f @@ -424,22 +424,24 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* = D21 * ( ( D11 ) ( -1 ) ) -* ( ( -1 ) ( D22 ) ) +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 D22 = W( K-1, KW-1 ) / D21 T = ONE / ( D11*D22-ONE ) - D21 = T / D21 * * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) * DO 20 J = 1, K - 2 - A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) - A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D21 ) 20 CONTINUE END IF * @@ -703,22 +705,24 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* = D21 * ( ( D11 ) ( -1 ) ) -* ( ( -1 ) ( D22 ) ) +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = ONE / ( D11*D22-ONE ) - D21 = T / D21 * * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) * DO 80 J = K + 2, N - A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) - A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/dsptrf.f b/SRC/dsptrf.f index acd029043..2a05f0138 100644 --- a/SRC/dsptrf.f +++ b/SRC/dsptrf.f @@ -368,13 +368,12 @@ SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 D11 = AP( K+( K-1 )*K / 2 ) / D12 T = ONE / ( D11*D22-ONE ) - D12 = T / D12 * DO 50 J = K - 2, 1, -1 - WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ AP( J+( K-1 )*K / 2 ) ) - WK = D12*( D22*AP( J+( K-1 )*K / 2 )- - $ AP( J+( K-2 )*( K-1 ) / 2 ) ) + WKM1 = T*( ( D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ AP( J+( K-1 )*K / 2 ) ) / D12 ) + WK = T*( ( D22*AP( J+( K-1 )*K / 2 )- + $ AP( J+( K-2 )*( K-1 ) / 2 ) ) / D12 ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*WK - @@ -570,13 +569,12 @@ SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 T = ONE / ( D11*D22-ONE ) - D21 = T / D21 * DO 100 J = K + 2, N - WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- - $ AP( J+K*( 2*N-K-1 ) / 2 ) ) - WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- - $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) + WK = T*( ( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- + $ AP( J+K*( 2*N-K-1 ) / 2 ) ) / D21 ) + WKP1 = T*( ( D22*AP( J+K*( 2*N-K-1 ) / 2 )- + $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) / D21 ) * DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* diff --git a/SRC/dsytf2.f b/SRC/dsytf2.f index bd4340a6a..39685c36a 100644 --- a/SRC/dsytf2.f +++ b/SRC/dsytf2.f @@ -390,11 +390,10 @@ SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = ONE / ( D11*D22-ONE ) - D12 = T / D12 * DO 30 J = K - 2, 1, -1 - WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) ) - WK = D12*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K-1 )*WKM1 @@ -565,12 +564,11 @@ SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = ONE / ( D11*D22-ONE ) - D21 = T / D21 * DO 60 J = K + 2, N * - WK = D21*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * DO 50 I = J, N A( I, J ) = A( I, J ) - A( I, K )*WK - diff --git a/SRC/dsytf2_rk.f b/SRC/dsytf2_rk.f index 0c464ec0f..1628d9f0e 100644 --- a/SRC/dsytf2_rk.f +++ b/SRC/dsytf2_rk.f @@ -573,18 +573,18 @@ SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) - WK = T*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - - $ ( A( I, K-1 ) / D12 )*WKM1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D12 - A( J, K-1 ) = WKM1 / D12 + A( J, K ) = WK + A( J, K-1 ) = WKM1 * 30 CONTINUE * @@ -889,22 +889,22 @@ SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N - A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - - $ ( A( I, K+1 ) / D21 )*WKP1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D21 - A( J, K+1 ) = WKP1 / D21 + A( J, K ) = WK + A( J, K+1 ) = WKP1 * 60 CONTINUE * diff --git a/SRC/dsytf2_rook.f b/SRC/dsytf2_rook.f index 270deab60..e5935aec7 100644 --- a/SRC/dsytf2_rook.f +++ b/SRC/dsytf2_rook.f @@ -494,18 +494,18 @@ SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) - WK = T*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - - $ ( A( I, K-1 ) / D12 )*WKM1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D12 - A( J, K-1 ) = WKM1 / D12 + A( J, K ) = WK + A( J, K-1 ) = WKM1 * 30 CONTINUE * @@ -768,22 +768,22 @@ SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N - A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - - $ ( A( I, K+1 ) / D21 )*WKP1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D21 - A( J, K+1 ) = WKP1 / D21 + A( J, K ) = WK + A( J, K+1 ) = WKP1 * 60 CONTINUE * diff --git a/SRC/slasyf.f b/SRC/slasyf.f index 129607a2b..195a388d8 100644 --- a/SRC/slasyf.f +++ b/SRC/slasyf.f @@ -424,22 +424,24 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* = D21 * ( ( D11 ) ( -1 ) ) -* ( ( -1 ) ( D22 ) ) +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 D22 = W( K-1, KW-1 ) / D21 T = ONE / ( D11*D22-ONE ) - D21 = T / D21 * * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) * DO 20 J = 1, K - 2 - A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) - A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D21 ) 20 CONTINUE END IF * @@ -703,22 +705,24 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* = D21 * ( ( D11 ) ( -1 ) ) -* ( ( -1 ) ( D22 ) ) +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = ONE / ( D11*D22-ONE ) - D21 = T / D21 * * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) * DO 80 J = K + 2, N - A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) - A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/ssptrf.f b/SRC/ssptrf.f index 3c4456a14..dd54eb1f5 100644 --- a/SRC/ssptrf.f +++ b/SRC/ssptrf.f @@ -366,13 +366,12 @@ SUBROUTINE SSPTRF( UPLO, N, AP, IPIV, INFO ) D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 D11 = AP( K+( K-1 )*K / 2 ) / D12 T = ONE / ( D11*D22-ONE ) - D12 = T / D12 * DO 50 J = K - 2, 1, -1 - WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ AP( J+( K-1 )*K / 2 ) ) - WK = D12*( D22*AP( J+( K-1 )*K / 2 )- - $ AP( J+( K-2 )*( K-1 ) / 2 ) ) + WKM1 = T*( ( D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ AP( J+( K-1 )*K / 2 ) ) / D12 ) + WK = T*( ( D22*AP( J+( K-1 )*K / 2 )- + $ AP( J+( K-2 )*( K-1 ) / 2 ) ) / D12 ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*WK - @@ -568,13 +567,12 @@ SUBROUTINE SSPTRF( UPLO, N, AP, IPIV, INFO ) D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 T = ONE / ( D11*D22-ONE ) - D21 = T / D21 * DO 100 J = K + 2, N - WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- - $ AP( J+K*( 2*N-K-1 ) / 2 ) ) - WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- - $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) + WK = T*( ( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- + $ AP( J+K*( 2*N-K-1 ) / 2 ) ) / D21 ) + WKP1 = T*( ( D22*AP( J+K*( 2*N-K-1 ) / 2 )- + $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) / D21 ) * DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* diff --git a/SRC/ssytf2.f b/SRC/ssytf2.f index d5defcccc..739852112 100644 --- a/SRC/ssytf2.f +++ b/SRC/ssytf2.f @@ -391,11 +391,10 @@ SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = ONE / ( D11*D22-ONE ) - D12 = T / D12 * DO 30 J = K - 2, 1, -1 - WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) ) - WK = D12*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K-1 )*WKM1 @@ -566,12 +565,11 @@ SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = ONE / ( D11*D22-ONE ) - D21 = T / D21 * DO 60 J = K + 2, N * - WK = D21*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * DO 50 I = J, N A( I, J ) = A( I, J ) - A( I, K )*WK - diff --git a/SRC/ssytf2_rk.f b/SRC/ssytf2_rk.f index d78f621f0..12e76adc8 100644 --- a/SRC/ssytf2_rk.f +++ b/SRC/ssytf2_rk.f @@ -573,18 +573,18 @@ SUBROUTINE SSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) - WK = T*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - - $ ( A( I, K-1 ) / D12 )*WKM1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D12 - A( J, K-1 ) = WKM1 / D12 + A( J, K ) = WK + A( J, K-1 ) = WKM1 * 30 CONTINUE * @@ -889,22 +889,22 @@ SUBROUTINE SSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N - A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - - $ ( A( I, K+1 ) / D21 )*WKP1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D21 - A( J, K+1 ) = WKP1 / D21 + A( J, K ) = WK + A( J, K+1 ) = WKP1 * 60 CONTINUE * diff --git a/SRC/ssytf2_rook.f b/SRC/ssytf2_rook.f index 9e6488728..dae4093a7 100644 --- a/SRC/ssytf2_rook.f +++ b/SRC/ssytf2_rook.f @@ -494,18 +494,18 @@ SUBROUTINE SSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) - WK = T*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - - $ ( A( I, K-1 ) / D12 )*WKM1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D12 - A( J, K-1 ) = WKM1 / D12 + A( J, K ) = WK + A( J, K-1 ) = WKM1 * 30 CONTINUE * @@ -768,22 +768,22 @@ SUBROUTINE SSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N - A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - - $ ( A( I, K+1 ) / D21 )*WKP1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D21 - A( J, K+1 ) = WKP1 / D21 + A( J, K ) = WK + A( J, K+1 ) = WKP1 * 60 CONTINUE * diff --git a/SRC/zhetf2.f b/SRC/zhetf2.f index eb47f4925..40a7b0398 100644 --- a/SRC/zhetf2.f +++ b/SRC/zhetf2.f @@ -418,12 +418,11 @@ SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO ) D11 = DBLE( A( K, K ) ) / D TT = ONE / ( D11*D22-ONE ) D12 = A( K-1, K ) / D - D = TT / D * DO 40 J = K - 2, 1, -1 - WKM1 = D*( D11*A( J, K-1 )-DCONJG( D12 )* - $ A( J, K ) ) - WK = D*( D22*A( J, K )-D12*A( J, K-1 ) ) + WKM1 = TT*( ( D11*A( J, K-1 )-DCONJG( D12 )* + $ A( J, K ) ) / D ) + WK = TT*( ( D22*A( J, K )-D12*A( J, K-1 ) ) / D ) DO 30 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*DCONJG( WK ) - $ A( I, K-1 )*DCONJG( WKM1 ) @@ -619,12 +618,11 @@ SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO ) D22 = DBLE( A( K, K ) ) / D TT = ONE / ( D11*D22-ONE ) D21 = A( K+1, K ) / D - D = TT / D * DO 80 J = K + 2, N - WK = D*( D11*A( J, K )-D21*A( J, K+1 ) ) - WKP1 = D*( D22*A( J, K+1 )-DCONJG( D21 )* - $ A( J, K ) ) + WK = TT*( ( D11*A( J, K )-D21*A( J, K+1 ) ) / D ) + WKP1 = TT*( ( D22*A( J, K+1 )-DCONJG( D21 )* + $ A( J, K ) ) / D ) DO 70 I = J, N A( I, J ) = A( I, J ) - A( I, K )*DCONJG( WK ) - $ A( I, K+1 )*DCONJG( WKP1 ) diff --git a/SRC/zhetf2_rk.f b/SRC/zhetf2_rk.f index 5e2afb066..b8c9bc905 100644 --- a/SRC/zhetf2_rk.f +++ b/SRC/zhetf2_rk.f @@ -617,24 +617,24 @@ SUBROUTINE ZHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WKM1 = TT*( D11*A( J, K-1 )-DCONJG( D12 )* - $ A( J, K ) ) - WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) ) + WKM1 = TT*( ( D11*A( J, K-1 )-DCONJG( D12 )* + $ A( J, K ) ) / D ) + WK = TT*( ( D22*A( J, K )-D12*A( J, K-1 ) ) / D ) * * Perform a rank-2 update of A(1:k-2,1:k-2) * DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - - $ ( A( I, K ) / D )*DCONJG( WK ) - - $ ( A( I, K-1 ) / D )*DCONJG( WKM1 ) + $ A( I, K )*DCONJG( WK ) - + $ A( I, K-1 )*DCONJG( WKM1 ) 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D - A( J, K-1 ) = WKM1 / D + A( J, K ) = WK + A( J, K-1 ) = WKM1 * (*) Make sure that diagonal element of pivot is real A( J, J ) = DCMPLX( DBLE( A( J, J ) ), ZERO ) * @@ -978,24 +978,24 @@ SUBROUTINE ZHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) ) - WKP1 = TT*( D22*A( J, K+1 )-DCONJG( D21 )* - $ A( J, K ) ) + WK = TT*( ( D11*A( J, K )-D21*A( J, K+1 ) ) / D ) + WKP1 = TT*( ( D22*A( J, K+1 )-DCONJG( D21 )* + $ A( J, K ) ) / D ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N A( I, J ) = A( I, J ) - - $ ( A( I, K ) / D )*DCONJG( WK ) - - $ ( A( I, K+1 ) / D )*DCONJG( WKP1 ) + $ A( I, K )*DCONJG( WK ) - + $ A( I, K+1 )*DCONJG( WKP1 ) 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D - A( J, K+1 ) = WKP1 / D + A( J, K ) = WK + A( J, K+1 ) = WKP1 * (*) Make sure that diagonal element of pivot is real A( J, J ) = DCMPLX( DBLE( A( J, J ) ), ZERO ) * diff --git a/SRC/zhetf2_rook.f b/SRC/zhetf2_rook.f index 4e86aec7b..333150bcb 100644 --- a/SRC/zhetf2_rook.f +++ b/SRC/zhetf2_rook.f @@ -536,24 +536,24 @@ SUBROUTINE ZHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WKM1 = TT*( D11*A( J, K-1 )-DCONJG( D12 )* - $ A( J, K ) ) - WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) ) + WKM1 = TT*( ( D11*A( J, K-1 )-DCONJG( D12 )* + $ A( J, K ) ) / D ) + WK = TT*( ( D22*A( J, K )-D12*A( J, K-1 ) ) / D ) * * Perform a rank-2 update of A(1:k-2,1:k-2) * DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - - $ ( A( I, K ) / D )*DCONJG( WK ) - - $ ( A( I, K-1 ) / D )*DCONJG( WKM1 ) + $ A( I, K )*DCONJG( WK ) - + $ A( I, K-1 )*DCONJG( WKM1 ) 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D - A( J, K-1 ) = WKM1 / D + A( J, K ) = WK + A( J, K-1 ) = WKM1 * (*) Make sure that diagonal element of pivot is real A( J, J ) = DCMPLX( DBLE( A( J, J ) ), ZERO ) * @@ -857,24 +857,24 @@ SUBROUTINE ZHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) ) - WKP1 = TT*( D22*A( J, K+1 )-DCONJG( D21 )* - $ A( J, K ) ) + WK = TT*( ( D11*A( J, K )-D21*A( J, K+1 ) ) / D ) + WKP1 = TT*( ( D22*A( J, K+1 )-DCONJG( D21 )* + $ A( J, K ) ) / D ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N A( I, J ) = A( I, J ) - - $ ( A( I, K ) / D )*DCONJG( WK ) - - $ ( A( I, K+1 ) / D )*DCONJG( WKP1 ) + $ A( I, K )*DCONJG( WK ) - + $ A( I, K+1 )*DCONJG( WKP1 ) 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D - A( J, K+1 ) = WKP1 / D + A( J, K ) = WK + A( J, K+1 ) = WKP1 * (*) Make sure that diagonal element of pivot is real A( J, J ) = DCMPLX( DBLE( A( J, J ) ), ZERO ) * diff --git a/SRC/zhptrf.f b/SRC/zhptrf.f index 6558a1bb8..b7d22d2f0 100644 --- a/SRC/zhptrf.f +++ b/SRC/zhptrf.f @@ -389,13 +389,12 @@ SUBROUTINE ZHPTRF( UPLO, N, AP, IPIV, INFO ) D11 = DBLE( AP( K+( K-1 )*K / 2 ) ) / D TT = ONE / ( D11*D22-ONE ) D12 = AP( K-1+( K-1 )*K / 2 ) / D - D = TT / D * DO 50 J = K - 2, 1, -1 - WKM1 = D*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ DCONJG( D12 )*AP( J+( K-1 )*K / 2 ) ) - WK = D*( D22*AP( J+( K-1 )*K / 2 )-D12* - $ AP( J+( K-2 )*( K-1 ) / 2 ) ) + WKM1 = TT*( ( D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ DCONJG( D12 )*AP( J+( K-1 )*K / 2 ) ) / D ) + WK = TT*( ( D22*AP( J+( K-1 )*K / 2 )-D12* + $ AP( J+( K-2 )*( K-1 ) / 2 ) ) / D ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*DCONJG( WK ) - @@ -603,14 +602,13 @@ SUBROUTINE ZHPTRF( UPLO, N, AP, IPIV, INFO ) D22 = DBLE( AP( K+( K-1 )*( 2*N-K ) / 2 ) ) / D TT = ONE / ( D11*D22-ONE ) D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 ) / D - D = TT / D * DO 100 J = K + 2, N - WK = D*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-D21* - $ AP( J+K*( 2*N-K-1 ) / 2 ) ) - WKP1 = D*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- + WK = TT*( ( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-D21* + $ AP( J+K*( 2*N-K-1 ) / 2 ) ) / D ) + WKP1 = TT*( ( D22*AP( J+K*( 2*N-K-1 ) / 2 )- $ DCONJG( D21 )*AP( J+( K-1 )*( 2*N-K ) / - $ 2 ) ) + $ 2 ) ) / D ) DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / diff --git a/SRC/zlahef.f b/SRC/zlahef.f index 039444a0d..3fdde8113 100644 --- a/SRC/zlahef.f +++ b/SRC/zlahef.f @@ -480,17 +480,17 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = * ( ( -1 ) ( D22 ) ) * -* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ), * ( ( -1 ) ( D22 ) ) * -* = ( conj(D21)*( D11 ) D21*( -1 ) ) -* ( ( -1 ) ( D22 ) ), -* * where D11 = d22/d21, * D22 = d11/conj(d21), -* D21 = T/d21, * T = 1/(D22*D11-1). * +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 or conj(d21) and then scaled by T. +* * (NOTE: No need to check for division by ZERO, * since that was ensured earlier in pivot search: * (a) d21 != 0, since in 2x2 pivot case(4) @@ -502,16 +502,16 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, D11 = W( K, KW ) / DCONJG( D21 ) D22 = W( K-1, KW-1 ) / D21 T = ONE / ( DBLE( D11*D22 )-ONE ) - D21 = T / D21 * * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) * DO 20 J = 1, K - 2 - A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) - A( J, K ) = DCONJG( D21 )* - $ ( D22*W( J, KW )-W( J, KW-1 ) ) + A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ DCONJG( D21 ) ) 20 CONTINUE END IF * @@ -827,17 +827,17 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = * ( ( -1 ) ( D22 ) ) * -* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ), * ( ( -1 ) ( D22 ) ) * -* = ( conj(D21)*( D11 ) D21*( -1 ) ) -* ( ( -1 ) ( D22 ) ), -* * where D11 = d22/d21, * D22 = d11/conj(d21), -* D21 = T/d21, * T = 1/(D22*D11-1). * +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 or conj(d21) and then scaled by T. +* * (NOTE: No need to check for division by ZERO, * since that was ensured earlier in pivot search: * (a) d21 != 0, since in 2x2 pivot case(4) @@ -849,16 +849,16 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / DCONJG( D21 ) T = ONE / ( DBLE( D11*D22 )-ONE ) - D21 = T / D21 * * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) * DO 80 J = K + 2, N - A( J, K ) = DCONJG( D21 )* - $ ( D11*W( J, K )-W( J, K+1 ) ) - A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ DCONJG( D21 ) ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/zlasyf.f b/SRC/zlasyf.f index 5363c390e..9411871fb 100644 --- a/SRC/zlasyf.f +++ b/SRC/zlasyf.f @@ -431,22 +431,24 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* = D21 * ( ( D11 ) ( -1 ) ) -* ( ( -1 ) ( D22 ) ) +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 D22 = W( K-1, KW-1 ) / D21 T = CONE / ( D11*D22-CONE ) - D21 = T / D21 * * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) * DO 20 J = 1, K - 2 - A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) - A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D21 ) 20 CONTINUE END IF * @@ -710,22 +712,24 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* = D21 * ( ( D11 ) ( -1 ) ) -* ( ( -1 ) ( D22 ) ) +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = CONE / ( D11*D22-CONE ) - D21 = T / D21 * * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) * DO 80 J = K + 2, N - A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) - A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/zsptrf.f b/SRC/zsptrf.f index 4a5a7a50b..42a916cdb 100644 --- a/SRC/zsptrf.f +++ b/SRC/zsptrf.f @@ -375,13 +375,12 @@ SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 D11 = AP( K+( K-1 )*K / 2 ) / D12 T = CONE / ( D11*D22-CONE ) - D12 = T / D12 * DO 50 J = K - 2, 1, -1 - WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ AP( J+( K-1 )*K / 2 ) ) - WK = D12*( D22*AP( J+( K-1 )*K / 2 )- - $ AP( J+( K-2 )*( K-1 ) / 2 ) ) + WKM1 = T*( ( D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ AP( J+( K-1 )*K / 2 ) ) / D12 ) + WK = T*( ( D22*AP( J+( K-1 )*K / 2 )- + $ AP( J+( K-2 )*( K-1 ) / 2 ) ) / D12 ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*WK - @@ -576,13 +575,12 @@ SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 T = CONE / ( D11*D22-CONE ) - D21 = T / D21 * DO 100 J = K + 2, N - WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- - $ AP( J+K*( 2*N-K-1 ) / 2 ) ) - WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- - $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) + WK = T*( ( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- + $ AP( J+K*( 2*N-K-1 ) / 2 ) ) / D21 ) + WKP1 = T*( ( D22*AP( J+K*( 2*N-K-1 ) / 2 )- + $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) / D21 ) DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / diff --git a/SRC/zsytf2.f b/SRC/zsytf2.f index 63cb9709f..26ed82a08 100644 --- a/SRC/zsytf2.f +++ b/SRC/zsytf2.f @@ -394,11 +394,10 @@ SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = CONE / ( D11*D22-CONE ) - D12 = T / D12 * DO 30 J = K - 2, 1, -1 - WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) ) - WK = D12*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K-1 )*WKM1 @@ -569,11 +568,10 @@ SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = CONE / ( D11*D22-CONE ) - D21 = T / D21 * DO 60 J = K + 2, N - WK = D21*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) DO 50 I = J, N A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K+1 )*WKP1 diff --git a/SRC/zsytf2_rk.f b/SRC/zsytf2_rk.f index 9d549adc5..66bac797a 100644 --- a/SRC/zsytf2_rk.f +++ b/SRC/zsytf2_rk.f @@ -582,18 +582,18 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) - WK = T*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - - $ ( A( I, K-1 ) / D12 )*WKM1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D12 - A( J, K-1 ) = WKM1 / D12 + A( J, K ) = WK + A( J, K-1 ) = WKM1 * 30 CONTINUE * @@ -898,22 +898,22 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N - A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - - $ ( A( I, K+1 ) / D21 )*WKP1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D21 - A( J, K+1 ) = WKP1 / D21 + A( J, K ) = WK + A( J, K+1 ) = WKP1 * 60 CONTINUE * diff --git a/SRC/zsytf2_rook.f b/SRC/zsytf2_rook.f index 9038e0bbd..5ca176196 100644 --- a/SRC/zsytf2_rook.f +++ b/SRC/zsytf2_rook.f @@ -502,18 +502,18 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) - WK = T*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - - $ ( A( I, K-1 ) / D12 )*WKM1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D12 - A( J, K-1 ) = WKM1 / D12 + A( J, K ) = WK + A( J, K-1 ) = WKM1 * 30 CONTINUE * @@ -776,22 +776,22 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N - A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - - $ ( A( I, K+1 ) / D21 )*WKP1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D21 - A( J, K+1 ) = WKP1 / D21 + A( J, K ) = WK + A( J, K+1 ) = WKP1 * 60 CONTINUE * From 273ab29c7650c5e8fa8ce7ae54cae9e4f1f7eb74 Mon Sep 17 00:00:00 2001 From: Rasmus Munk Larsen Date: Mon, 7 Sep 2026 13:17:26 -0700 Subject: [PATCH 2/4] LAPACK: Guard complex 2x2 pivot division Use scaled complex division for extreme operands. Retain reciprocal multiplication only when the pivot, reciprocal, and numerator bounds exclude intermediate overflow. Add regression coverage for all four precisions, both triangles, packed storage, and blocked panels, including a large numerator with a moderate pivot. Register the tests in both CMake and Make builds. --- SRC/clahef.f | 84 +++++++++-- SRC/clahef_rk.f | 70 +++++++-- SRC/clahef_rook.f | 70 +++++++-- SRC/clasyf.f | 84 +++++++++-- SRC/clasyf_rk.f | 70 +++++++-- SRC/clasyf_rook.f | 70 +++++++-- SRC/csptrf.f | 76 ++++++++-- SRC/csytf2.f | 68 ++++++++- SRC/csytf2_rk.f | 66 ++++++++- SRC/csytf2_rook.f | 66 ++++++++- SRC/zlahef.f | 84 +++++++++-- SRC/zlahef_rk.f | 70 +++++++-- SRC/zlahef_rook.f | 70 +++++++-- SRC/zlasyf.f | 84 +++++++++-- SRC/zlasyf_rk.f | 70 +++++++-- SRC/zlasyf_rook.f | 70 +++++++-- SRC/zsptrf.f | 76 ++++++++-- SRC/zsytf2.f | 68 ++++++++- SRC/zsytf2_rk.f | 66 ++++++++- SRC/zsytf2_rook.f | 66 ++++++++- TESTING/LIN/CMakeLists.txt | 8 +- TESTING/LIN/Makefile | 8 +- TESTING/LIN/cchksy.f | 3 + TESTING/LIN/cchksy_2x2.f | 287 +++++++++++++++++++++++++++++++++++++ TESTING/LIN/dchksy.f | 3 + TESTING/LIN/dchksy_2x2.f | 194 +++++++++++++++++++++++++ TESTING/LIN/schksy.f | 3 + TESTING/LIN/schksy_2x2.f | 194 +++++++++++++++++++++++++ TESTING/LIN/zchksy.f | 3 + TESTING/LIN/zchksy_2x2.f | 287 +++++++++++++++++++++++++++++++++++++ 30 files changed, 2250 insertions(+), 188 deletions(-) create mode 100644 TESTING/LIN/cchksy_2x2.f create mode 100644 TESTING/LIN/dchksy_2x2.f create mode 100644 TESTING/LIN/schksy_2x2.f create mode 100644 TESTING/LIN/zchksy_2x2.f diff --git a/SRC/clahef.f b/SRC/clahef.f index d1654b8b6..d6be10ffe 100644 --- a/SRC/clahef.f +++ b/SRC/clahef.f @@ -199,15 +199,21 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX DINV, W1, W2 INTEGER IMAX, J, JJ, JMAX, JP, K, KK, KKW, KP, $ KSTEP, KW REAL ABSAKK, ALPHA, COLMAX, R1, ROWMAX, T COMPLEX D11, D21, D22, Z * .. * .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH + COMPLEX CLADIV LOGICAL LSAME INTEGER ICAMAX - EXTERNAL LSAME, ICAMAX + EXTERNAL LSAME, ICAMAX, CLADIV * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEMMTR, CGEMV, CLACGV, CSSCAL, @@ -229,6 +235,8 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( SLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * IF( LSAME( UPLO, 'U' ) ) THEN * @@ -488,9 +496,9 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * D22 = d11/conj(d21), * T = 1/(D22*D11-1). * -* T/d21 is not formed, since it overflows when d21 is -* subnormal: each entry of the product is divided by -* d21 or conj(d21) and then scaled by T. +* T/d21 is formed only in a safe range. Otherwise each +* entry is divided by d21 or conj(d21) using scaled +* division before multiplication by T. * * (NOTE: No need to check for division by ZERO, * since that was ensured earlier in pivot search: @@ -507,12 +515,35 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 20 J = 1, K - 2 - A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / - $ D21 ) - A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / - $ CONJG( D21 ) ) + W1 = D11*W( J, KW-1 )- W( J, KW ) + W2 = D22*W( J, KW )- W( J, KW-1 ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K-1 ) = W1*DINV + A( J, K ) = W2*CONJG( DINV ) + ELSE + A( J, K-1 ) = T*CLADIV( W1, D21 ) + A( J, K ) = T*CLADIV( W2, CONJG( D21 ) ) + END IF 20 CONTINUE END IF * @@ -835,9 +866,9 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * D22 = d11/conj(d21), * T = 1/(D22*D11-1). * -* T/d21 is not formed, since it overflows when d21 is -* subnormal: each entry of the product is divided by -* d21 or conj(d21) and then scaled by T. +* T/d21 is formed only in a safe range. Otherwise each +* entry is divided by d21 or conj(d21) using scaled +* division before multiplication by T. * * (NOTE: No need to check for division by ZERO, * since that was ensured earlier in pivot search: @@ -854,12 +885,35 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 80 J = K + 2, N - A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / - $ CONJG( D21 ) ) - A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / - $ D21 ) + W1 = D11*W( J, K )- W( J, K+1 ) + W2 = D22*W( J, K+1 )- W( J, K ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K ) = W1*CONJG( DINV ) + A( J, K+1 ) = W2*DINV + ELSE + A( J, K ) = T*CLADIV( W1, CONJG( D21 ) ) + A( J, K+1 ) = T*CLADIV( W2, D21 ) + END IF 80 CONTINUE END IF * diff --git a/SRC/clahef_rk.f b/SRC/clahef_rk.f index fa17636ea..15047de24 100644 --- a/SRC/clahef_rk.f +++ b/SRC/clahef_rk.f @@ -284,6 +284,9 @@ SUBROUTINE CLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, $ CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX DINV, W1, W2 LOGICAL DONE INTEGER IMAX, ITEMP, II, J, JMAX, K, KK, KKW, $ KP, KSTEP, KW, P @@ -292,10 +295,11 @@ SUBROUTINE CLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, COMPLEX D11, D21, D22, Z * .. * .. External Functions .. + COMPLEX CLADIV LOGICAL LSAME INTEGER ICAMAX REAL SLAMCH - EXTERNAL LSAME, ICAMAX, SLAMCH + EXTERNAL LSAME, ICAMAX, SLAMCH, CLADIV * .. * .. External Subroutines .. EXTERNAL CCOPY, CSSCAL, CGEMMTR, @@ -317,6 +321,8 @@ SUBROUTINE CLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( SLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -704,12 +710,35 @@ SUBROUTINE CLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 20 J = 1, K - 2 - A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / - $ D21 ) - A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / - $ CONJG( D21 ) ) + W1 = D11*W( J, KW-1 )- W( J, KW ) + W2 = D22*W( J, KW )- W( J, KW-1 ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K-1 ) = W1*DINV + A( J, K ) = W2*CONJG( DINV ) + ELSE + A( J, K-1 ) = T*CLADIV( W1, D21 ) + A( J, K ) = T*CLADIV( W2, CONJG( D21 ) ) + END IF 20 CONTINUE END IF * @@ -1134,12 +1163,35 @@ SUBROUTINE CLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 80 J = K + 2, N - A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / - $ CONJG( D21 ) ) - A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / - $ D21 ) + W1 = D11*W( J, K )- W( J, K+1 ) + W2 = D22*W( J, K+1 )- W( J, K ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K ) = W1*CONJG( DINV ) + A( J, K+1 ) = W2*DINV + ELSE + A( J, K ) = T*CLADIV( W1, CONJG( D21 ) ) + A( J, K+1 ) = T*CLADIV( W2, D21 ) + END IF 80 CONTINUE END IF * diff --git a/SRC/clahef_rook.f b/SRC/clahef_rook.f index 2f9ccaf1b..d741ad3e3 100644 --- a/SRC/clahef_rook.f +++ b/SRC/clahef_rook.f @@ -205,6 +205,9 @@ SUBROUTINE CLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX DINV, W1, W2 LOGICAL DONE INTEGER IMAX, ITEMP, II, J, JB, JJ, JMAX, JP1, JP2, K, $ KK, KKW, KP, KSTEP, KW, P @@ -213,10 +216,11 @@ SUBROUTINE CLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, COMPLEX D11, D21, D22, Z * .. * .. External Functions .. + COMPLEX CLADIV LOGICAL LSAME INTEGER ICAMAX REAL SLAMCH - EXTERNAL LSAME, ICAMAX, SLAMCH + EXTERNAL LSAME, ICAMAX, SLAMCH, CLADIV * .. * .. External Subroutines .. EXTERNAL CCOPY, CSSCAL, CGEMM, CGEMV, CLACGV, @@ -238,6 +242,8 @@ SUBROUTINE CLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( SLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -609,12 +615,35 @@ SUBROUTINE CLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 20 J = 1, K - 2 - A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / - $ D21 ) - A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / - $ CONJG( D21 ) ) + W1 = D11*W( J, KW-1 )- W( J, KW ) + W2 = D22*W( J, KW )- W( J, KW-1 ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K-1 ) = W1*DINV + A( J, K ) = W2*CONJG( DINV ) + ELSE + A( J, K-1 ) = T*CLADIV( W1, D21 ) + A( J, K ) = T*CLADIV( W2, CONJG( D21 ) ) + END IF 20 CONTINUE END IF * @@ -1068,12 +1097,35 @@ SUBROUTINE CLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 80 J = K + 2, N - A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / - $ CONJG( D21 ) ) - A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / - $ D21 ) + W1 = D11*W( J, K )- W( J, K+1 ) + W2 = D22*W( J, K+1 )- W( J, K ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K ) = W1*CONJG( DINV ) + A( J, K+1 ) = W2*DINV + ELSE + A( J, K ) = T*CLADIV( W1, CONJG( D21 ) ) + A( J, K+1 ) = T*CLADIV( W2, D21 ) + END IF 80 CONTINUE END IF * diff --git a/SRC/clasyf.f b/SRC/clasyf.f index 0b9248a29..d9f084da8 100644 --- a/SRC/clasyf.f +++ b/SRC/clasyf.f @@ -199,15 +199,21 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX DINV, W1, W2 INTEGER IMAX, J, JJ, JMAX, JP, K, KK, KKW, KP, $ KSTEP, KW REAL ABSAKK, ALPHA, COLMAX, ROWMAX COMPLEX D11, D21, D22, R1, T, Z * .. * .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH + COMPLEX CLADIV LOGICAL LSAME INTEGER ICAMAX - EXTERNAL LSAME, ICAMAX + EXTERNAL LSAME, ICAMAX, CLADIV * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEMMTR, CGEMV, CSCAL, CSWAP @@ -228,6 +234,8 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( SLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * IF( LSAME( UPLO, 'U' ) ) THEN * @@ -432,9 +440,9 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* T/d21 is not formed, since it overflows when d21 is -* subnormal: each entry of the product is divided by -* d21 and then scaled by T. +* T/d21 is formed only in a safe range. Otherwise each +* entry is divided by d21 using scaled division before +* multiplication by T. * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 @@ -444,12 +452,35 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 20 J = 1, K - 2 - A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / - $ D21 ) - A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / - $ D21 ) + W1 = D11*W( J, KW-1 )- W( J, KW ) + W2 = D22*W( J, KW )- W( J, KW-1 ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K-1 ) = W1*DINV + A( J, K ) = W2*DINV + ELSE + A( J, K-1 ) = T*CLADIV( W1, D21 ) + A( J, K ) = T*CLADIV( W2, D21 ) + END IF 20 CONTINUE END IF * @@ -714,9 +745,9 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* T/d21 is not formed, since it overflows when d21 is -* subnormal: each entry of the product is divided by -* d21 and then scaled by T. +* T/d21 is formed only in a safe range. Otherwise each +* entry is divided by d21 using scaled division before +* multiplication by T. * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 @@ -726,12 +757,35 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 80 J = K + 2, N - A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / - $ D21 ) - A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / - $ D21 ) + W1 = D11*W( J, K )- W( J, K+1 ) + W2 = D22*W( J, K+1 )- W( J, K ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K ) = W1*DINV + A( J, K+1 ) = W2*DINV + ELSE + A( J, K ) = T*CLADIV( W1, D21 ) + A( J, K+1 ) = T*CLADIV( W2, D21 ) + END IF 80 CONTINUE END IF * diff --git a/SRC/clasyf_rk.f b/SRC/clasyf_rk.f index a9e736461..f32355d71 100644 --- a/SRC/clasyf_rk.f +++ b/SRC/clasyf_rk.f @@ -284,6 +284,9 @@ SUBROUTINE CLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, $ CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX DINV, W1, W2 LOGICAL DONE INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, K, KK, KW, KKW, $ KP, KSTEP, P, II @@ -291,10 +294,11 @@ SUBROUTINE CLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, COMPLEX D11, D12, D21, D22, R1, T, Z * .. * .. External Functions .. + COMPLEX CLADIV LOGICAL LSAME INTEGER ICAMAX REAL SLAMCH - EXTERNAL LSAME, ICAMAX, SLAMCH + EXTERNAL LSAME, ICAMAX, SLAMCH, CLADIV * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEMMTR, CGEMV, CSCAL, CSWAP @@ -315,6 +319,8 @@ SUBROUTINE CLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( SLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -582,11 +588,34 @@ SUBROUTINE CLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, D11 = W( K, KW ) / D12 D22 = W( K-1, KW-1 ) / D12 T = CONE / ( D11*D22-CONE ) +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D12 ) ), ABS( AIMAG( D12 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D12 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF +* DO 20 J = 1, K - 2 - A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / - $ D12 ) - A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / - $ D12 ) + W1 = D11*W( J, KW-1 )- W( J, KW ) + W2 = D22*W( J, KW )- W( J, KW-1 ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K-1 ) = W1*DINV + A( J, K ) = W2*DINV + ELSE + A( J, K-1 ) = T*CLADIV( W1, D12 ) + A( J, K ) = T*CLADIV( W2, D12 ) + END IF 20 CONTINUE END IF * @@ -883,11 +912,34 @@ SUBROUTINE CLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = CONE / ( D11*D22-CONE ) +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF +* DO 80 J = K + 2, N - A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / - $ D21 ) - A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / - $ D21 ) + W1 = D11*W( J, K )- W( J, K+1 ) + W2 = D22*W( J, K+1 )- W( J, K ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K ) = W1*DINV + A( J, K+1 ) = W2*DINV + ELSE + A( J, K ) = T*CLADIV( W1, D21 ) + A( J, K+1 ) = T*CLADIV( W2, D21 ) + END IF 80 CONTINUE END IF * diff --git a/SRC/clasyf_rook.f b/SRC/clasyf_rook.f index b0c6440c2..f99655a1c 100644 --- a/SRC/clasyf_rook.f +++ b/SRC/clasyf_rook.f @@ -206,6 +206,9 @@ SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, $ CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX DINV, W1, W2 LOGICAL DONE INTEGER IMAX, ITEMP, J, JJ, JMAX, JP1, JP2, K, KK, $ KW, KKW, KP, KSTEP, P, II @@ -213,10 +216,11 @@ SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, COMPLEX D11, D12, D21, D22, R1, T, Z * .. * .. External Functions .. + COMPLEX CLADIV LOGICAL LSAME INTEGER ICAMAX REAL SLAMCH - EXTERNAL LSAME, ICAMAX, SLAMCH + EXTERNAL LSAME, ICAMAX, SLAMCH, CLADIV * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEMMTR, CGEMV, CSCAL, CSWAP @@ -237,6 +241,8 @@ SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( SLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -488,11 +494,34 @@ SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, D11 = W( K, KW ) / D12 D22 = W( K-1, KW-1 ) / D12 T = CONE / ( D11*D22-CONE ) +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D12 ) ), ABS( AIMAG( D12 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D12 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF +* DO 20 J = 1, K - 2 - A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / - $ D12 ) - A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / - $ D12 ) + W1 = D11*W( J, KW-1 )- W( J, KW ) + W2 = D22*W( J, KW )- W( J, KW-1 ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K-1 ) = W1*DINV + A( J, K ) = W2*DINV + ELSE + A( J, K-1 ) = T*CLADIV( W1, D12 ) + A( J, K ) = T*CLADIV( W2, D12 ) + END IF 20 CONTINUE END IF * @@ -794,11 +823,34 @@ SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = CONE / ( D11*D22-CONE ) +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF +* DO 80 J = K + 2, N - A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / - $ D21 ) - A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / - $ D21 ) + W1 = D11*W( J, K )- W( J, K+1 ) + W2 = D22*W( J, K+1 )- W( J, K ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K ) = W1*DINV + A( J, K+1 ) = W2*DINV + ELSE + A( J, K ) = T*CLADIV( W1, D21 ) + A( J, K+1 ) = T*CLADIV( W2, D21 ) + END IF 80 CONTINUE END IF * diff --git a/SRC/csptrf.f b/SRC/csptrf.f index c7d2d7f41..b474323b8 100644 --- a/SRC/csptrf.f +++ b/SRC/csptrf.f @@ -179,6 +179,9 @@ SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX DINV, W1, W2 LOGICAL UPPER INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC, $ KSTEP, KX, NPP @@ -186,9 +189,12 @@ SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) COMPLEX D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, ZDUM * .. * .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH + COMPLEX CLADIV LOGICAL LSAME, SISNAN INTEGER ICAMAX - EXTERNAL LSAME, ICAMAX, SISNAN + EXTERNAL LSAME, ICAMAX, CLADIV, SISNAN * .. * .. External Subroutines .. EXTERNAL CSCAL, CSPR, CSWAP, XERBLA @@ -221,6 +227,8 @@ SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( SLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * IF( UPPER ) THEN * @@ -375,12 +383,37 @@ SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 D11 = AP( K+( K-1 )*K / 2 ) / D12 T = CONE / ( D11*D22-CONE ) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D12 ) ), ABS( AIMAG( D12 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D12 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 50 J = K - 2, 1, -1 - WKM1 = T*( ( D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ AP( J+( K-1 )*K / 2 ) ) / D12 ) - WK = T*( ( D22*AP( J+( K-1 )*K / 2 )- - $ AP( J+( K-2 )*( K-1 ) / 2 ) ) / D12 ) + W1 = D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ AP( J+( K-1 )*K / 2 ) + W2 = D22*AP( J+( K-1 )*K / 2 )- + $ AP( J+( K-2 )*( K-1 ) / 2 ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + WKM1 = W1*DINV + WK = W2*DINV + ELSE + WKM1 = T*CLADIV( W1, D12 ) + WK = T*CLADIV( W2, D12 ) + END IF DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*WK - @@ -575,12 +608,37 @@ SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 T = CONE / ( D11*D22-CONE ) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 100 J = K + 2, N - WK = T*( ( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- - $ AP( J+K*( 2*N-K-1 ) / 2 ) ) / D21 ) - WKP1 = T*( ( D22*AP( J+K*( 2*N-K-1 ) / 2 )- - $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) / D21 ) + W1 = D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- + $ AP( J+K*( 2*N-K-1 ) / 2 ) + W2 = D22*AP( J+K*( 2*N-K-1 ) / 2 )- + $ AP( J+( K-1 )*( 2*N-K ) / 2 ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + WK = W1*DINV + WKP1 = W2*DINV + ELSE + WK = T*CLADIV( W1, D21 ) + WKP1 = T*CLADIV( W2, D21 ) + END IF DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / diff --git a/SRC/csytf2.f b/SRC/csytf2.f index 09228ec9f..4059a01d2 100644 --- a/SRC/csytf2.f +++ b/SRC/csytf2.f @@ -212,15 +212,21 @@ SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX DINV, W1, W2 LOGICAL UPPER INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP REAL ABSAKK, ALPHA, COLMAX, ROWMAX COMPLEX D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, Z * .. * .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH + COMPLEX CLADIV LOGICAL LSAME, SISNAN INTEGER ICAMAX - EXTERNAL LSAME, ICAMAX, SISNAN + EXTERNAL LSAME, ICAMAX, SISNAN, CLADIV * .. * .. External Subroutines .. EXTERNAL CSCAL, CSWAP, CSYR, XERBLA @@ -255,6 +261,8 @@ SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( SLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * IF( UPPER ) THEN * @@ -394,10 +402,35 @@ SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = CONE / ( D11*D22-CONE ) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D12 ) ), ABS( AIMAG( D12 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D12 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 30 J = K - 2, 1, -1 - WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) - WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) + W1 = D11*A( J, K-1 )-A( J, K ) + W2 = D22*A( J, K )-A( J, K-1 ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + WKM1 = W1*DINV + WK = W2*DINV + ELSE + WKM1 = T*CLADIV( W1, D12 ) + WK = T*CLADIV( W2, D12 ) + END IF DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K-1 )*WKM1 @@ -568,10 +601,35 @@ SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = CONE / ( D11*D22-CONE ) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 60 J = K + 2, N - WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) - WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) + W1 = D11*A( J, K )-A( J, K+1 ) + W2 = D22*A( J, K+1 )-A( J, K ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + WK = W1*DINV + WKP1 = W2*DINV + ELSE + WK = T*CLADIV( W1, D21 ) + WKP1 = T*CLADIV( W2, D21 ) + END IF DO 50 I = J, N A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K+1 )*WKP1 diff --git a/SRC/csytf2_rk.f b/SRC/csytf2_rk.f index a52f69a0b..e41ed0053 100644 --- a/SRC/csytf2_rk.f +++ b/SRC/csytf2_rk.f @@ -263,6 +263,9 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) $ CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX DINV, W1, W2 LOGICAL UPPER, DONE INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, $ P, II @@ -270,10 +273,11 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) COMPLEX D11, D12, D21, D22, T, WK, WKM1, WKP1, Z * .. * .. External Functions .. + COMPLEX CLADIV LOGICAL LSAME INTEGER ICAMAX REAL SLAMCH - EXTERNAL LSAME, ICAMAX, SLAMCH + EXTERNAL LSAME, ICAMAX, SLAMCH, CLADIV * .. * .. External Subroutines .. EXTERNAL CSCAL, CSWAP, CSYR, XERBLA @@ -308,6 +312,8 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( SLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -579,11 +585,36 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = CONE / ( D11*D22-CONE ) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D12 ) ), ABS( AIMAG( D12 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D12 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) - WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) + W1 = D11*A( J, K-1 )-A( J, K ) + W2 = D22*A( J, K )-A( J, K-1 ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + WKM1 = W1*DINV + WK = W2*DINV + ELSE + WKM1 = T*CLADIV( W1, D12 ) + WK = T*CLADIV( W2, D12 ) + END IF * DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - @@ -895,13 +926,38 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = CONE / ( D11*D22-CONE ) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 60 J = K + 2, N * * Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) - WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) + W1 = D11*A( J, K )-A( J, K+1 ) + W2 = D22*A( J, K+1 )-A( J, K ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + WK = W1*DINV + WKP1 = W2*DINV + ELSE + WK = T*CLADIV( W1, D21 ) + WKP1 = T*CLADIV( W2, D21 ) + END IF * * Perform a rank-2 update of A(k+2:n,k+2:n) * diff --git a/SRC/csytf2_rook.f b/SRC/csytf2_rook.f index 50f2894b4..3336786d4 100644 --- a/SRC/csytf2_rook.f +++ b/SRC/csytf2_rook.f @@ -215,6 +215,9 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX DINV, W1, W2 LOGICAL UPPER, DONE INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, $ P, II @@ -222,10 +225,11 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) COMPLEX D11, D12, D21, D22, T, WK, WKM1, WKP1, Z * .. * .. External Functions .. + COMPLEX CLADIV LOGICAL LSAME INTEGER ICAMAX REAL SLAMCH - EXTERNAL LSAME, ICAMAX, SLAMCH + EXTERNAL LSAME, ICAMAX, SLAMCH, CLADIV * .. * .. External Subroutines .. EXTERNAL CSCAL, CSWAP, CSYR, XERBLA @@ -260,6 +264,8 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( SLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -499,11 +505,36 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = CONE / ( D11*D22-CONE ) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D12 ) ), ABS( AIMAG( D12 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D12 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) - WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) + W1 = D11*A( J, K-1 )-A( J, K ) + W2 = D22*A( J, K )-A( J, K-1 ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + WKM1 = W1*DINV + WK = W2*DINV + ELSE + WKM1 = T*CLADIV( W1, D12 ) + WK = T*CLADIV( W2, D12 ) + END IF * DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - @@ -773,13 +804,38 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = CONE / ( D11*D22-CONE ) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( REAL( DINV ) ), + $ ABS( AIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 60 J = K + 2, N * * Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) - WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) + W1 = D11*A( J, K )-A( J, K+1 ) + W2 = D22*A( J, K+1 )-A( J, K ) + ABSW1 = MAX( ABS( REAL( W1 ) ), + $ ABS( AIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( REAL( W2 ) ), + $ ABS( AIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + WK = W1*DINV + WKP1 = W2*DINV + ELSE + WK = T*CLADIV( W1, D21 ) + WKP1 = T*CLADIV( W2, D21 ) + END IF * * Perform a rank-2 update of A(k+2:n,k+2:n) * diff --git a/SRC/zlahef.f b/SRC/zlahef.f index 3fdde8113..205254022 100644 --- a/SRC/zlahef.f +++ b/SRC/zlahef.f @@ -199,15 +199,21 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX*16 DINV, W1, W2 INTEGER IMAX, J, JJ, JMAX, JP, K, KK, KKW, KP, $ KSTEP, KW DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, R1, ROWMAX, T COMPLEX*16 D11, D21, D22, Z * .. * .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH + COMPLEX*16 ZLADIV LOGICAL LSAME INTEGER IZAMAX - EXTERNAL LSAME, IZAMAX + EXTERNAL LSAME, IZAMAX, ZLADIV * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZDSCAL, ZGEMMTR, ZGEMV, ZLACGV, @@ -229,6 +235,8 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( DLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * IF( LSAME( UPLO, 'U' ) ) THEN * @@ -487,9 +495,9 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * D22 = d11/conj(d21), * T = 1/(D22*D11-1). * -* T/d21 is not formed, since it overflows when d21 is -* subnormal: each entry of the product is divided by -* d21 or conj(d21) and then scaled by T. +* T/d21 is formed only in a safe range. Otherwise each +* entry is divided by d21 or conj(d21) using scaled +* division before multiplication by T. * * (NOTE: No need to check for division by ZERO, * since that was ensured earlier in pivot search: @@ -506,12 +514,35 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 20 J = 1, K - 2 - A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / - $ D21 ) - A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / - $ DCONJG( D21 ) ) + W1 = D11*W( J, KW-1 )- W( J, KW ) + W2 = D22*W( J, KW )- W( J, KW-1 ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K-1 ) = W1*DINV + A( J, K ) = W2*DCONJG( DINV ) + ELSE + A( J, K-1 ) = T*ZLADIV( W1, D21 ) + A( J, K ) = T*ZLADIV( W2, DCONJG( D21 ) ) + END IF 20 CONTINUE END IF * @@ -834,9 +865,9 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * D22 = d11/conj(d21), * T = 1/(D22*D11-1). * -* T/d21 is not formed, since it overflows when d21 is -* subnormal: each entry of the product is divided by -* d21 or conj(d21) and then scaled by T. +* T/d21 is formed only in a safe range. Otherwise each +* entry is divided by d21 or conj(d21) using scaled +* division before multiplication by T. * * (NOTE: No need to check for division by ZERO, * since that was ensured earlier in pivot search: @@ -853,12 +884,35 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 80 J = K + 2, N - A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / - $ DCONJG( D21 ) ) - A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / - $ D21 ) + W1 = D11*W( J, K )- W( J, K+1 ) + W2 = D22*W( J, K+1 )- W( J, K ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K ) = W1*DCONJG( DINV ) + A( J, K+1 ) = W2*DINV + ELSE + A( J, K ) = T*ZLADIV( W1, DCONJG( D21 ) ) + A( J, K+1 ) = T*ZLADIV( W2, D21 ) + END IF 80 CONTINUE END IF * diff --git a/SRC/zlahef_rk.f b/SRC/zlahef_rk.f index a82ddf472..719f4bdd6 100644 --- a/SRC/zlahef_rk.f +++ b/SRC/zlahef_rk.f @@ -285,6 +285,9 @@ SUBROUTINE ZLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX*16 DINV, W1, W2 LOGICAL DONE INTEGER IMAX, ITEMP, II, J, JMAX, K, KK, KKW, $ KP, KSTEP, KW, P @@ -293,10 +296,11 @@ SUBROUTINE ZLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, COMPLEX*16 D11, D21, D22, Z * .. * .. External Functions .. + COMPLEX*16 ZLADIV LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IZAMAX, DLAMCH + EXTERNAL LSAME, IZAMAX, DLAMCH, ZLADIV * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZDSCAL, ZGEMMTR, ZGEMV, ZLACGV, @@ -318,6 +322,8 @@ SUBROUTINE ZLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( DLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -704,12 +710,35 @@ SUBROUTINE ZLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 20 J = 1, K - 2 - A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / - $ D21 ) - A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / - $ DCONJG( D21 ) ) + W1 = D11*W( J, KW-1 )- W( J, KW ) + W2 = D22*W( J, KW )- W( J, KW-1 ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K-1 ) = W1*DINV + A( J, K ) = W2*DCONJG( DINV ) + ELSE + A( J, K-1 ) = T*ZLADIV( W1, D21 ) + A( J, K ) = T*ZLADIV( W2, DCONJG( D21 ) ) + END IF 20 CONTINUE END IF * @@ -1134,12 +1163,35 @@ SUBROUTINE ZLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 80 J = K + 2, N - A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / - $ DCONJG( D21 ) ) - A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / - $ D21 ) + W1 = D11*W( J, K )- W( J, K+1 ) + W2 = D22*W( J, K+1 )- W( J, K ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K ) = W1*DCONJG( DINV ) + A( J, K+1 ) = W2*DINV + ELSE + A( J, K ) = T*ZLADIV( W1, DCONJG( D21 ) ) + A( J, K+1 ) = T*ZLADIV( W2, D21 ) + END IF 80 CONTINUE END IF * diff --git a/SRC/zlahef_rook.f b/SRC/zlahef_rook.f index 06ddcb4e9..8769a4435 100644 --- a/SRC/zlahef_rook.f +++ b/SRC/zlahef_rook.f @@ -205,6 +205,9 @@ SUBROUTINE ZLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX*16 DINV, W1, W2 LOGICAL DONE INTEGER IMAX, ITEMP, II, J, JB, JJ, JMAX, JP1, JP2, K, $ KK, KKW, KP, KSTEP, KW, P @@ -213,10 +216,11 @@ SUBROUTINE ZLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, COMPLEX*16 D11, D21, D22, Z * .. * .. External Functions .. + COMPLEX*16 ZLADIV LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IZAMAX, DLAMCH + EXTERNAL LSAME, IZAMAX, DLAMCH, ZLADIV * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZDSCAL, ZGEMM, ZGEMV, ZLACGV, @@ -238,6 +242,8 @@ SUBROUTINE ZLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( DLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -609,12 +615,35 @@ SUBROUTINE ZLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 20 J = 1, K - 2 - A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / - $ D21 ) - A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / - $ DCONJG( D21 ) ) + W1 = D11*W( J, KW-1 )- W( J, KW ) + W2 = D22*W( J, KW )- W( J, KW-1 ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K-1 ) = W1*DINV + A( J, K ) = W2*DCONJG( DINV ) + ELSE + A( J, K-1 ) = T*ZLADIV( W1, D21 ) + A( J, K ) = T*ZLADIV( W2, DCONJG( D21 ) ) + END IF 20 CONTINUE END IF * @@ -1068,12 +1097,35 @@ SUBROUTINE ZLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 80 J = K + 2, N - A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / - $ DCONJG( D21 ) ) - A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / - $ D21 ) + W1 = D11*W( J, K )- W( J, K+1 ) + W2 = D22*W( J, K+1 )- W( J, K ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K ) = W1*DCONJG( DINV ) + A( J, K+1 ) = W2*DINV + ELSE + A( J, K ) = T*ZLADIV( W1, DCONJG( D21 ) ) + A( J, K+1 ) = T*ZLADIV( W2, D21 ) + END IF 80 CONTINUE END IF * diff --git a/SRC/zlasyf.f b/SRC/zlasyf.f index 9411871fb..7d658468b 100644 --- a/SRC/zlasyf.f +++ b/SRC/zlasyf.f @@ -199,15 +199,21 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX*16 DINV, W1, W2 INTEGER IMAX, J, JJ, JMAX, JP, K, KK, KKW, KP, $ KSTEP, KW DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX COMPLEX*16 D11, D21, D22, R1, T, Z * .. * .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH + COMPLEX*16 ZLADIV LOGICAL LSAME INTEGER IZAMAX - EXTERNAL LSAME, IZAMAX + EXTERNAL LSAME, IZAMAX, ZLADIV * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZGEMMTR, ZGEMV, ZSCAL, ZSWAP @@ -228,6 +234,8 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( DLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * IF( LSAME( UPLO, 'U' ) ) THEN * @@ -431,9 +439,9 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* T/d21 is not formed, since it overflows when d21 is -* subnormal: each entry of the product is divided by -* d21 and then scaled by T. +* T/d21 is formed only in a safe range. Otherwise each +* entry is divided by d21 using scaled division before +* multiplication by T. * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 @@ -443,12 +451,35 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 20 J = 1, K - 2 - A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / - $ D21 ) - A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / - $ D21 ) + W1 = D11*W( J, KW-1 )- W( J, KW ) + W2 = D22*W( J, KW )- W( J, KW-1 ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K-1 ) = W1*DINV + A( J, K ) = W2*DINV + ELSE + A( J, K-1 ) = T*ZLADIV( W1, D21 ) + A( J, K ) = T*ZLADIV( W2, D21 ) + END IF 20 CONTINUE END IF * @@ -712,9 +743,9 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* T/d21 is not formed, since it overflows when d21 is -* subnormal: each entry of the product is divided by -* d21 and then scaled by T. +* T/d21 is formed only in a safe range. Otherwise each +* entry is divided by d21 using scaled division before +* multiplication by T. * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 @@ -724,12 +755,35 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 80 J = K + 2, N - A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / - $ D21 ) - A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / - $ D21 ) + W1 = D11*W( J, K )- W( J, K+1 ) + W2 = D22*W( J, K+1 )- W( J, K ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K ) = W1*DINV + A( J, K+1 ) = W2*DINV + ELSE + A( J, K ) = T*ZLADIV( W1, D21 ) + A( J, K+1 ) = T*ZLADIV( W2, D21 ) + END IF 80 CONTINUE END IF * diff --git a/SRC/zlasyf_rk.f b/SRC/zlasyf_rk.f index 16499a556..8f746030b 100644 --- a/SRC/zlasyf_rk.f +++ b/SRC/zlasyf_rk.f @@ -284,6 +284,9 @@ SUBROUTINE ZLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, $ CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX*16 DINV, W1, W2 LOGICAL DONE INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, K, KK, KW, KKW, $ KP, KSTEP, P, II @@ -291,10 +294,11 @@ SUBROUTINE ZLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, COMPLEX*16 D11, D12, D21, D22, R1, T, Z * .. * .. External Functions .. + COMPLEX*16 ZLADIV LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IZAMAX, DLAMCH + EXTERNAL LSAME, IZAMAX, DLAMCH, ZLADIV * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZGEMMTR, ZGEMV, ZSCAL, ZSWAP @@ -315,6 +319,8 @@ SUBROUTINE ZLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( DLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -582,11 +588,34 @@ SUBROUTINE ZLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, D11 = W( K, KW ) / D12 D22 = W( K-1, KW-1 ) / D12 T = CONE / ( D11*D22-CONE ) +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D12 ) ), ABS( DIMAG( D12 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D12 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF +* DO 20 J = 1, K - 2 - A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / - $ D12 ) - A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / - $ D12 ) + W1 = D11*W( J, KW-1 )- W( J, KW ) + W2 = D22*W( J, KW )- W( J, KW-1 ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K-1 ) = W1*DINV + A( J, K ) = W2*DINV + ELSE + A( J, K-1 ) = T*ZLADIV( W1, D12 ) + A( J, K ) = T*ZLADIV( W2, D12 ) + END IF 20 CONTINUE END IF * @@ -883,11 +912,34 @@ SUBROUTINE ZLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = CONE / ( D11*D22-CONE ) +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF +* DO 80 J = K + 2, N - A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / - $ D21 ) - A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / - $ D21 ) + W1 = D11*W( J, K )- W( J, K+1 ) + W2 = D22*W( J, K+1 )- W( J, K ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K ) = W1*DINV + A( J, K+1 ) = W2*DINV + ELSE + A( J, K ) = T*ZLADIV( W1, D21 ) + A( J, K+1 ) = T*ZLADIV( W2, D21 ) + END IF 80 CONTINUE END IF * diff --git a/SRC/zlasyf_rook.f b/SRC/zlasyf_rook.f index 57bd229ef..51001d932 100644 --- a/SRC/zlasyf_rook.f +++ b/SRC/zlasyf_rook.f @@ -206,6 +206,9 @@ SUBROUTINE ZLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, $ CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX*16 DINV, W1, W2 LOGICAL DONE INTEGER IMAX, ITEMP, J, JJ, JMAX, JP1, JP2, K, KK, $ KW, KKW, KP, KSTEP, P, II @@ -213,10 +216,11 @@ SUBROUTINE ZLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, COMPLEX*16 D11, D12, D21, D22, R1, T, Z * .. * .. External Functions .. + COMPLEX*16 ZLADIV LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IZAMAX, DLAMCH + EXTERNAL LSAME, IZAMAX, DLAMCH, ZLADIV * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZGEMMTR, ZGEMV, ZSCAL, ZSWAP @@ -237,6 +241,8 @@ SUBROUTINE ZLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( DLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -488,11 +494,34 @@ SUBROUTINE ZLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, D11 = W( K, KW ) / D12 D22 = W( K-1, KW-1 ) / D12 T = CONE / ( D11*D22-CONE ) +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D12 ) ), ABS( DIMAG( D12 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D12 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF +* DO 20 J = 1, K - 2 - A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / - $ D12 ) - A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / - $ D12 ) + W1 = D11*W( J, KW-1 )- W( J, KW ) + W2 = D22*W( J, KW )- W( J, KW-1 ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K-1 ) = W1*DINV + A( J, K ) = W2*DINV + ELSE + A( J, K-1 ) = T*ZLADIV( W1, D12 ) + A( J, K ) = T*ZLADIV( W2, D12 ) + END IF 20 CONTINUE END IF * @@ -794,11 +823,34 @@ SUBROUTINE ZLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = CONE / ( D11*D22-CONE ) +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF +* DO 80 J = K + 2, N - A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / - $ D21 ) - A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / - $ D21 ) + W1 = D11*W( J, K )- W( J, K+1 ) + W2 = D22*W( J, K+1 )- W( J, K ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + A( J, K ) = W1*DINV + A( J, K+1 ) = W2*DINV + ELSE + A( J, K ) = T*ZLADIV( W1, D21 ) + A( J, K+1 ) = T*ZLADIV( W2, D21 ) + END IF 80 CONTINUE END IF * diff --git a/SRC/zsptrf.f b/SRC/zsptrf.f index 42a916cdb..033940cb0 100644 --- a/SRC/zsptrf.f +++ b/SRC/zsptrf.f @@ -179,6 +179,9 @@ SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX*16 DINV, W1, W2 LOGICAL UPPER INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC, $ KSTEP, KX, NPP @@ -186,9 +189,12 @@ SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) COMPLEX*16 D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, ZDUM * .. * .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH + COMPLEX*16 ZLADIV LOGICAL LSAME, DISNAN INTEGER IZAMAX - EXTERNAL LSAME, IZAMAX, DISNAN + EXTERNAL LSAME, IZAMAX, ZLADIV, DISNAN * .. * .. External Subroutines .. EXTERNAL XERBLA, ZSCAL, ZSPR, ZSWAP @@ -221,6 +227,8 @@ SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( DLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * IF( UPPER ) THEN * @@ -375,12 +383,37 @@ SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 D11 = AP( K+( K-1 )*K / 2 ) / D12 T = CONE / ( D11*D22-CONE ) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D12 ) ), ABS( DIMAG( D12 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D12 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 50 J = K - 2, 1, -1 - WKM1 = T*( ( D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ AP( J+( K-1 )*K / 2 ) ) / D12 ) - WK = T*( ( D22*AP( J+( K-1 )*K / 2 )- - $ AP( J+( K-2 )*( K-1 ) / 2 ) ) / D12 ) + W1 = D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ AP( J+( K-1 )*K / 2 ) + W2 = D22*AP( J+( K-1 )*K / 2 )- + $ AP( J+( K-2 )*( K-1 ) / 2 ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + WKM1 = W1*DINV + WK = W2*DINV + ELSE + WKM1 = T*ZLADIV( W1, D12 ) + WK = T*ZLADIV( W2, D12 ) + END IF DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*WK - @@ -575,12 +608,37 @@ SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 T = CONE / ( D11*D22-CONE ) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 100 J = K + 2, N - WK = T*( ( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- - $ AP( J+K*( 2*N-K-1 ) / 2 ) ) / D21 ) - WKP1 = T*( ( D22*AP( J+K*( 2*N-K-1 ) / 2 )- - $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) / D21 ) + W1 = D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- + $ AP( J+K*( 2*N-K-1 ) / 2 ) + W2 = D22*AP( J+K*( 2*N-K-1 ) / 2 )- + $ AP( J+( K-1 )*( 2*N-K ) / 2 ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + WK = W1*DINV + WKP1 = W2*DINV + ELSE + WK = T*ZLADIV( W1, D21 ) + WKP1 = T*ZLADIV( W2, D21 ) + END IF DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / diff --git a/SRC/zsytf2.f b/SRC/zsytf2.f index 26ed82a08..60dcf3c89 100644 --- a/SRC/zsytf2.f +++ b/SRC/zsytf2.f @@ -212,15 +212,21 @@ SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX*16 DINV, W1, W2 LOGICAL UPPER INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX COMPLEX*16 D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, Z * .. * .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH + COMPLEX*16 ZLADIV LOGICAL DISNAN, LSAME INTEGER IZAMAX - EXTERNAL DISNAN, LSAME, IZAMAX + EXTERNAL DISNAN, LSAME, IZAMAX, ZLADIV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZSCAL, ZSWAP, ZSYR @@ -255,6 +261,8 @@ SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( DLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * IF( UPPER ) THEN * @@ -394,10 +402,35 @@ SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = CONE / ( D11*D22-CONE ) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D12 ) ), ABS( DIMAG( D12 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D12 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 30 J = K - 2, 1, -1 - WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) - WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) + W1 = D11*A( J, K-1 )-A( J, K ) + W2 = D22*A( J, K )-A( J, K-1 ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + WKM1 = W1*DINV + WK = W2*DINV + ELSE + WKM1 = T*ZLADIV( W1, D12 ) + WK = T*ZLADIV( W2, D12 ) + END IF DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K-1 )*WKM1 @@ -568,10 +601,35 @@ SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = CONE / ( D11*D22-CONE ) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 60 J = K + 2, N - WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) - WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) + W1 = D11*A( J, K )-A( J, K+1 ) + W2 = D22*A( J, K+1 )-A( J, K ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + WK = W1*DINV + WKP1 = W2*DINV + ELSE + WK = T*ZLADIV( W1, D21 ) + WKP1 = T*ZLADIV( W2, D21 ) + END IF DO 50 I = J, N A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K+1 )*WKP1 diff --git a/SRC/zsytf2_rk.f b/SRC/zsytf2_rk.f index 66bac797a..45d85ee42 100644 --- a/SRC/zsytf2_rk.f +++ b/SRC/zsytf2_rk.f @@ -263,6 +263,9 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) $ CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX*16 DINV, W1, W2 LOGICAL UPPER, DONE INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, $ P, II @@ -270,10 +273,11 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) COMPLEX*16 D11, D12, D21, D22, T, WK, WKM1, WKP1, Z * .. * .. External Functions .. + COMPLEX*16 ZLADIV LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IZAMAX, DLAMCH + EXTERNAL LSAME, IZAMAX, DLAMCH, ZLADIV * .. * .. External Subroutines .. EXTERNAL ZSCAL, ZSWAP, ZSYR, XERBLA @@ -308,6 +312,8 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( DLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -579,11 +585,36 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = CONE / ( D11*D22-CONE ) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D12 ) ), ABS( DIMAG( D12 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D12 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) - WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) + W1 = D11*A( J, K-1 )-A( J, K ) + W2 = D22*A( J, K )-A( J, K-1 ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + WKM1 = W1*DINV + WK = W2*DINV + ELSE + WKM1 = T*ZLADIV( W1, D12 ) + WK = T*ZLADIV( W2, D12 ) + END IF * DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - @@ -895,13 +926,38 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = CONE / ( D11*D22-CONE ) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 60 J = K + 2, N * * Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) - WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) + W1 = D11*A( J, K )-A( J, K+1 ) + W2 = D22*A( J, K+1 )-A( J, K ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + WK = W1*DINV + WKP1 = W2*DINV + ELSE + WK = T*ZLADIV( W1, D21 ) + WKP1 = T*ZLADIV( W2, D21 ) + END IF * * Perform a rank-2 update of A(k+2:n,k+2:n) * diff --git a/SRC/zsytf2_rook.f b/SRC/zsytf2_rook.f index 5ca176196..9a3b51109 100644 --- a/SRC/zsytf2_rook.f +++ b/SRC/zsytf2_rook.f @@ -215,6 +215,9 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. + LOGICAL SAFEDIV + DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 + COMPLEX*16 DINV, W1, W2 LOGICAL UPPER, DONE INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, $ P, II @@ -222,10 +225,11 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) COMPLEX*16 D11, D12, D21, D22, T, WK, WKM1, WKP1, Z * .. * .. External Functions .. + COMPLEX*16 ZLADIV LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IZAMAX, DLAMCH + EXTERNAL LSAME, IZAMAX, DLAMCH, ZLADIV * .. * .. External Subroutines .. EXTERNAL ZSCAL, ZSWAP, ZSYR, XERBLA @@ -260,6 +264,8 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT + SMLNUM = SQRT( DLAMCH( 'S' ) ) + BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -499,11 +505,36 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = CONE / ( D11*D22-CONE ) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D12 ) ), ABS( DIMAG( D12 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D12 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) - WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) + W1 = D11*A( J, K-1 )-A( J, K ) + W2 = D22*A( J, K )-A( J, K-1 ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + WKM1 = W1*DINV + WK = W2*DINV + ELSE + WKM1 = T*ZLADIV( W1, D12 ) + WK = T*ZLADIV( W2, D12 ) + END IF * DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - @@ -773,13 +804,38 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = CONE / ( D11*D22-CONE ) +* +* Bound reciprocal and numerators by BIGNUM, so each +* complex product is at most 2*BIGNUM**2. +* + ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM + IF( SAFEDIV ) THEN + DINV = T / D21 + ABSD = MAX( ABS( DBLE( DINV ) ), + $ ABS( DIMAG( DINV ) ) ) + SAFEDIV = ABSD.GE.SMLNUM .AND. + $ ABSD.LE.BIGNUM + END IF * DO 60 J = K + 2, N * * Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) - WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) + W1 = D11*A( J, K )-A( J, K+1 ) + W2 = D22*A( J, K+1 )-A( J, K ) + ABSW1 = MAX( ABS( DBLE( W1 ) ), + $ ABS( DIMAG( W1 ) ) ) + ABSW2 = MAX( ABS( DBLE( W2 ) ), + $ ABS( DIMAG( W2 ) ) ) + IF( SAFEDIV .AND. + $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN + WK = W1*DINV + WKP1 = W2*DINV + ELSE + WK = T*ZLADIV( W1, D21 ) + WKP1 = T*ZLADIV( W2, D21 ) + END IF * * Perform a rank-2 update of A(k+2:n,k+2:n) * diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt index 2313fa0c4..40e213458 100644 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -10,7 +10,7 @@ set(SLINTST schkaa.F schkeq.f schkgb.f schkge.f schkgt.f schklq.f schkpb.f schkpo.f schkps.f schkpp.f schkpt.f schkq3.f schkqp3rk.f schkcxx.f schkql.f schkqr.f schkrq.f - schksp.f schksy.f schksy_rook.f schksy_rk.f + schksp.f schksy.f schksy_2x2.f schksy_rook.f schksy_rk.f schksy_aa.f schksy_aa_2stage.f schktb.f schktp.f schktr.f schktz.f @@ -60,7 +60,7 @@ set(CLINTST cchkhe_aa.f cchkhe_aa_2stage.f cchkhp.f cchklq.f cchkpb.f cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkqp3rk.f cchkcxx.f cchkql.f - cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_rook.f cchksy_rk.f + cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_2x2.f cchksy_rook.f cchksy_rk.f cchksy_aa.f cchksy_aa_2stage.f cchktb.f cchktp.f cchktr.f cchktz.f @@ -117,7 +117,7 @@ set(DLINTST dchkaa.F dchkeq.f dchkgb.f dchkge.f dchkgt.f dchklq.f dchkpb.f dchkpo.f dchkps.f dchkpp.f dchkpt.f dchkq3.f dchkqp3rk.f dchkcxx.f dchkql.f dchkqr.f dchkrq.f - dchksp.f dchksy.f dchksy_rook.f dchksy_rk.f + dchksp.f dchksy.f dchksy_2x2.f dchksy_rook.f dchksy_rk.f dchksy_aa.f dchksy_aa_2stage.f dchktb.f dchktp.f dchktr.f dchktz.f @@ -168,7 +168,7 @@ set(ZLINTST zchkhe_aa.f zchkhe_aa_2stage.f zchkhp.f zchklq.f zchkpb.f zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkqp3rk.f zchkcxx.f - zchkql.f zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchksy_rk.f + zchkql.f zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_2x2.f zchksy_rook.f zchksy_rk.f zchksy_aa.f zchksy_aa_2stage.f zchktb.f zchktp.f zchktr.f zchktz.f diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile index f79329ea4..8092e7024 100644 --- a/TESTING/LIN/Makefile +++ b/TESTING/LIN/Makefile @@ -46,7 +46,7 @@ SLINTST = schkaa.o \ schkeq.o schkgb.o schkge.o schkgt.o \ schklq.o schkpb.o schkpo.o schkps.o schkpp.o \ schkpt.o schkq3.o schkqp3rk.o schkcxx.o schkql.o schkqr.o schkrq.o \ - schksp.o schksy.o schksy_rook.o schksy_rk.o \ + schksp.o schksy.o schksy_2x2.o schksy_rook.o schksy_rk.o \ schksy_aa.o schksy_aa_2stage.o schktb.o schktp.o schktr.o \ schktz.o \ sdrvgt.o sdrvls.o sdrvpb.o \ @@ -90,7 +90,7 @@ CLINTST = cchkaa.o \ cchkhe.o cchkhe_rook.o cchkhe_rk.o \ cchkhe_aa.o cchkhe_aa_2stage.o cchkhp.o cchklq.o cchkpb.o \ cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkqp3rk.o cchkcxx.o cchkql.o \ - cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchksy_rk.o \ + cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_2x2.o cchksy_rook.o cchksy_rk.o \ cchksy_aa.o cchksy_aa_2stage.o cchktb.o \ cchktp.o cchktr.o cchktz.o \ cdrvgt.o cdrvhe_rook.o cdrvhe_rk.o cdrvhe_aa.o cdrvhp.o \ @@ -138,7 +138,7 @@ DLINTST = dchkaa.o \ dchkeq.o dchkgb.o dchkge.o dchkgt.o \ dchklq.o dchkpb.o dchkpo.o dchkps.o dchkpp.o \ dchkpt.o dchkq3.o dchkqp3rk.o dchkcxx.o dchkql.o dchkqr.o \ - dchkrq.o dchksp.o dchksy.o dchksy_rook.o dchksy_rk.o \ + dchkrq.o dchksp.o dchksy.o dchksy_2x2.o dchksy_rook.o dchksy_rk.o \ dchksy_aa.o dchksy_aa_2stage.o dchktb.o dchktp.o dchktr.o \ dchktz.o \ ddrvgt.o ddrvls.o ddrvpb.o \ @@ -183,7 +183,7 @@ ZLINTST = zchkaa.o \ zchkhe.o zchkhe_rook.o zchkhe_rk.o zchkhe_aa.o zchkhe_aa_2stage.o \ zchkhp.o zchklq.o zchkpb.o \ zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkqp3rk.o zchkcxx.o zchkql.o \ - zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchksy_rk.o \ + zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_2x2.o zchksy_rook.o zchksy_rk.o \ zchksy_aa.o zchksy_aa_2stage.o zchktb.o \ zchktp.o zchktr.o zchktz.o \ zdrvgt.o zdrvhe_rook.o zdrvhe_rk.o zdrvhe_aa.o zdrvhe_aa_2stage.o zdrvhp.o \ diff --git a/TESTING/LIN/cchksy.f b/TESTING/LIN/cchksy.f index f33cb879f..766182a0e 100644 --- a/TESTING/LIN/cchksy.f +++ b/TESTING/LIN/cchksy.f @@ -218,6 +218,7 @@ SUBROUTINE CCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, EXTERNAL SGET06, CLANSY * .. * .. External Subroutines .. + EXTERNAL CCHKSY_2X2 EXTERNAL ALAERH, ALAHD, ALASUM, CERRSY, CGET04, CLACPY, $ CLARHS, CLATB4, CLATMS, CLATSY, CPOT05, CSYCON, $ CSYRFS, CSYT01, CSYT02, CSYT03, CSYTRF, @@ -669,6 +670,8 @@ SUBROUTINE CCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 160 CONTINUE 170 CONTINUE 180 CONTINUE +* + CALL CCHKSY_2X2( NOUT, NFAIL, NRUN ) * * Print a summary of the results. * diff --git a/TESTING/LIN/cchksy_2x2.f b/TESTING/LIN/cchksy_2x2.f new file mode 100644 index 000000000..5b0b44d3b --- /dev/null +++ b/TESTING/LIN/cchksy_2x2.f @@ -0,0 +1,287 @@ +*> \brief \b CCHKSY_2X2 checks extreme-scale 2-by-2 pivots. +*> +*> \par Purpose: +*> ============= +*> +*> \verbatim +*> Test factorization and solve with subnormal and near-overflow pivots, +*> using both triangles and the classic, rook, RK and packed routines. +*> Orders 3 and 130 exercise unblocked code and panels with NB = 64. +*> Each right-hand side is a column of A; the solution is a unit vector. +*> Subnormal cases are skipped if gradual underflow is unavailable. +*> Failures and test counts are added to NFAIL and NRUN, respectively. +*> \endverbatim +*> +*> \param[in] NOUT +*> Output unit for failure diagnostics. +*> \param[in,out] NFAIL +*> Number of failed tests. +*> \param[in,out] NRUN +*> Number of tests run. +*> + SUBROUTINE CCHKSY_2X2( NOUT, NFAIL, NRUN ) + IMPLICIT NONE + INTEGER NOUT, NFAIL, NRUN +* +* .. Parameters .. + INTEGER NMAX, NB, LWORK + PARAMETER ( NMAX = 130, NB = 64, LWORK = NMAX*NB ) + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) +* .. Local Scalars .. + CHARACTER UPLO + CHARACTER*2 KIND + INTEGER I, J, II, JJ, IC, IFAM, IMETH, ISIZE, + $ IUPLO, K, N, NBOLD, ICOL, INFO + LOGICAL BAD + REAL BIG, SMALL, TOL, ERR, MAG +* .. Local Arrays .. + INTEGER IPIV( NMAX ) + COMPLEX G( 3, 3 ), A( NMAX, NMAX ), B( NMAX ), + $ AP( NMAX*( NMAX+1 ) / 2 ), E( NMAX ), + $ WORK( LWORK ) + COMPLEX PHASE( 3 ) +* .. External Functions .. + REAL SLAMCH + INTEGER ILAENV + EXTERNAL SLAMCH, ILAENV, XLAENV + EXTERNAL CSYTRF, CSYTRF_ROOK, CSYTRF_RK + EXTERNAL CSYTRS, CSYTRS_ROOK, CSYTRS_3 + EXTERNAL CHETRF, CHETRF_ROOK, CHETRF_RK + EXTERNAL CHETRS, CHETRS_ROOK, CHETRS_3 + EXTERNAL CSPTRF, CSPTRS, CHPTRF + EXTERNAL CHPTRS +* + BIG = HUGE( ONE ) + SMALL = SCALE( TINY( ONE ), -10 ) + TOL = 128*SLAMCH( 'Epsilon' ) + NBOLD = ILAENV( 1, 'CSYTRF', 'L', NMAX, -1, -1, -1 ) + CALL XLAENV( 1, NB ) +* + DO IFAM = 1, 2 + KIND = 'SY' + IF( IFAM.EQ.2 ) KIND = 'HE' + PHASE( 1 ) = ONE + PHASE( 2 ) = CMPLX( ZERO, ONE ) + PHASE( 3 ) = -ONE + DO IC = 1, 7 + IF( IC.EQ.1 .AND. ( SMALL.LE.ZERO .OR. + $ SMALL.GE.TINY( ONE ) ) ) CYCLE + IF( IFAM.EQ.2 .AND. IC.GE.3 ) CYCLE + G = ZERO + IF( IC.EQ.1 ) THEN +* 1 / (4*SMALL) overflows, but the multipliers are bounded. + G( 1, 1 ) = SMALL + G( 2, 2 ) = SMALL + G( 1, 2 ) = 4*SMALL + G( 1, 3 ) = SMALL + G( 2, 3 ) = SMALL + G( 3, 3 ) = ONE + ELSE IF( IC.EQ.2 ) THEN +* T*W overflows before division by the off-diagonal pivot. + G( 1, 1 ) = 0.5E0*BIG + G( 2, 2 ) = 0.5E0*BIG + G( 1, 2 ) = BIG + G( 2, 3 ) = 0.9E0*BIG + ELSE +* The intrinsic complex division can overflow internally: +* (.53125 + .53125*i) / (-.5 - .5*i), both scaled by BIG. +* Also cover ordinary values and both reciprocal guards. + MAG = BIG + IF( IC.EQ.4 ) MAG = ONE + IF( IC.EQ.5 ) MAG = SQRT( SLAMCH( 'S' ) ) / 16 + IF( IC.EQ.6 ) MAG = 16 / SQRT( SLAMCH( 'S' ) ) + G( 1, 2 ) = CMPLX( MAG / 8, -MAG / 8 ) + G( 1, 3 ) = CMPLX( -MAG / 2, -MAG / 2 ) + G( 2, 3 ) = G( 1, 3 ) + G( 3, 3 ) = G( 1, 2 ) + IF( IC.EQ.7 ) THEN +* Moderate pivot, large numerator: a pivot-only guard +* would form (-1.2-.4*i)*(.9+.34*i)*BIG and overflow. + G( 1, 2 ) = CMPLX( .75E0, -.25E0 ) + G( 1, 3 ) = CMPLX( .4E0, .2E0 ) + G( 2, 2 ) = CMPLX( .3E0, -.2E0 )*BIG + G( 2, 3 ) = CMPLX( -.7E0, -.3E0 )*BIG + G( 3, 3 ) = CMPLX( -.2E0, -.3E0 )*BIG + END IF + END IF + DO J = 1, 3 + DO I = 1, J - 1 + G( J, I ) = G( I, J ) + END DO + END DO + IF( IFAM.EQ.2 ) THEN +* Unitary diagonal scaling gives Hermitian imaginary pivots. + DO J = 1, 3 + DO I = 1, 3 + G( I, J ) = PHASE( I )*G( I, J )* + $ CONJG( PHASE( J ) ) + END DO + END DO + END IF + DO ISIZE = 1, 2 + N = 3 + IF( ISIZE.EQ.2 ) N = NMAX + DO IUPLO = 1, 2 + UPLO = 'L' + ICOL = 3 + IF( IUPLO.EQ.2 ) THEN + UPLO = 'U' + ICOL = N - 2 + END IF + DO IMETH = 1, 4 + IF( IC.EQ.7 .AND. + $ ( IMETH.EQ.2 .OR. IMETH.EQ.3 ) ) CYCLE + A = ZERO + E = ZERO + DO I = 1, N + A( I, I ) = ONE + END DO + DO J = 1, 3 + DO I = 1, 3 + II = I + JJ = J + IF( IUPLO.EQ.2 ) THEN + II = N + 1 - I + JJ = N + 1 - J + END IF + A( II, JJ ) = G( I, J ) + END DO + END DO + B( 1:N ) = A( 1:N, ICOL ) + K = 0 + DO J = 1, N + DO I = 1, N + IF( ( UPLO.EQ.'U' .AND. I.LE.J ) .OR. + $ ( UPLO.EQ.'L' .AND. I.GE.J ) ) THEN + K = K + 1 + AP( K ) = A( I, J ) + END IF + END DO + END DO + IF( IFAM.EQ.1 ) THEN + IF( IMETH.EQ.1 ) THEN + CALL CSYTRF( UPLO, N, A, NMAX, IPIV, WORK, + $ LWORK, INFO ) + ELSE IF( IMETH.EQ.2 ) THEN + CALL CSYTRF_ROOK( UPLO, N, A, NMAX, IPIV, + $ WORK, LWORK, INFO ) + ELSE IF( IMETH.EQ.3 ) THEN + CALL CSYTRF_RK( UPLO, N, A, NMAX, E, IPIV, + $ WORK, LWORK, INFO ) + ELSE + CALL CSPTRF( UPLO, N, AP, IPIV, INFO ) + END IF + ELSE + IF( IMETH.EQ.1 ) THEN + CALL CHETRF( UPLO, N, A, NMAX, IPIV, WORK, + $ LWORK, INFO ) + ELSE IF( IMETH.EQ.2 ) THEN + CALL CHETRF_ROOK( UPLO, N, A, NMAX, IPIV, + $ WORK, LWORK, INFO ) + ELSE IF( IMETH.EQ.3 ) THEN + CALL CHETRF_RK( UPLO, N, A, NMAX, E, IPIV, + $ WORK, LWORK, INFO ) + ELSE + CALL CHPTRF( UPLO, N, AP, IPIV, INFO ) + END IF + END IF + BAD = INFO.NE.0 +* Confirm a 2-by-2 pivot and reject nonfinite factors +* before passing them to the solve routine. + IF( UPLO.EQ.'L' ) THEN + BAD = BAD .OR. IPIV( 1 ).GE.0 + ELSE + BAD = BAD .OR. IPIV( N ).GE.0 + END IF + DO J = 1, N + DO I = 1, N + IF( .NOT.( ABS( REAL( A( I, J ) ) ).LE. + $ BIG .AND. ABS( AIMAG( A( I, J ) ) ).LE. + $ BIG ) ) BAD = .TRUE. + END DO + END DO + DO I = 1, K + IF( .NOT.( ABS( REAL( AP( I ) ) ).LE. + $ BIG .AND. ABS( AIMAG( AP( I ) ) ).LE. + $ BIG ) ) BAD = .TRUE. + END DO + DO I = 1, N + IF( .NOT.( ABS( REAL( E( I ) ) ).LE. + $ BIG .AND. ABS( AIMAG( E( I ) ) ).LE. + $ BIG ) ) BAD = .TRUE. + END DO + IF( IC.EQ.7 .AND. .NOT.BAD ) THEN +* This matrix is ill-conditioned; check the known +* multiplier instead of a forward solve error. + II = 3 + JJ = 1 + K = 3 + IF( UPLO.EQ.'U' ) THEN + II = N - 2 + JJ = N + K = N*( N-1 ) / 2 + N - 2 + END IF + WORK( 1 ) = A( II, JJ ) / BIG + IF( IMETH.EQ.4 ) WORK( 1 ) = AP( K ) / BIG + ERR = ABS( WORK( 1 )- + $ CMPLX( -.944E0, -.768E0 ) ) + BAD = .NOT.( ERR.LE.TOL ) + END IF + IF( .NOT.BAD .AND. IC.NE.7 ) THEN + IF( IFAM.EQ.1 ) THEN + IF( IMETH.EQ.1 ) THEN + CALL CSYTRS( UPLO, N, 1, A, NMAX, IPIV, B, + $ NMAX, INFO ) + ELSE IF( IMETH.EQ.2 ) THEN + CALL CSYTRS_ROOK( UPLO, N, 1, A, NMAX, + $ IPIV, B, NMAX, INFO ) + ELSE IF( IMETH.EQ.3 ) THEN + CALL CSYTRS_3( UPLO, N, 1, A, NMAX, E, + $ IPIV, B, NMAX, INFO ) + ELSE + CALL CSPTRS( UPLO, N, 1, AP, IPIV, B, + $ NMAX, INFO ) + END IF + ELSE + IF( IMETH.EQ.1 ) THEN + CALL CHETRS( UPLO, N, 1, A, NMAX, IPIV, B, + $ NMAX, INFO ) + ELSE IF( IMETH.EQ.2 ) THEN + CALL CHETRS_ROOK( UPLO, N, 1, A, NMAX, + $ IPIV, B, NMAX, INFO ) + ELSE IF( IMETH.EQ.3 ) THEN + CALL CHETRS_3( UPLO, N, 1, A, NMAX, E, + $ IPIV, B, NMAX, INFO ) + ELSE + CALL CHPTRS( UPLO, N, 1, AP, IPIV, B, + $ NMAX, INFO ) + END IF + END IF + BAD = INFO.NE.0 + B( ICOL ) = B( ICOL ) - ONE + ERR = ZERO + DO I = 1, N + IF( .NOT.( ABS( REAL( B( I ) ) ).LE. + $ BIG .AND. ABS( AIMAG( B( I ) ) ).LE. + $ BIG ) ) BAD = .TRUE. + ERR = MAX( ERR, ABS( B( I ) ) ) + END DO + BAD = BAD .OR. .NOT.( ERR.LE.TOL ) + END IF + NRUN = NRUN + 1 + IF( BAD ) THEN + NFAIL = NFAIL + 1 + WRITE( NOUT, 9999 ) KIND, UPLO, N, IC, + $ IMETH, INFO + END IF + END DO + END DO + END DO + END DO + END DO + CALL XLAENV( 1, NBOLD ) + RETURN + 9999 FORMAT( ' CCHKSY_2X2: ', A2, ' UPLO=', A1, ' N=', I3, + $ ' case=', I1, ' method=', I1, ' INFO=', I3 ) + END diff --git a/TESTING/LIN/dchksy.f b/TESTING/LIN/dchksy.f index 4d9789e74..3ed0f0a2a 100644 --- a/TESTING/LIN/dchksy.f +++ b/TESTING/LIN/dchksy.f @@ -214,6 +214,7 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, EXTERNAL DGET06, DLANSY * .. * .. External Subroutines .. + EXTERNAL DCHKSY_2X2 EXTERNAL ALAERH, ALAHD, ALASUM, DERRSY, DGET04, DLACPY, $ DLARHS, DLATB4, DLATMS, DPOT02, DPOT03, DPOT05, $ DSYCON, DSYRFS, DSYT01, DSYTRF, @@ -655,6 +656,8 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 160 CONTINUE 170 CONTINUE 180 CONTINUE +* + CALL DCHKSY_2X2( NOUT, NFAIL, NRUN ) * * Print a summary of the results. * diff --git a/TESTING/LIN/dchksy_2x2.f b/TESTING/LIN/dchksy_2x2.f new file mode 100644 index 000000000..d870dabe7 --- /dev/null +++ b/TESTING/LIN/dchksy_2x2.f @@ -0,0 +1,194 @@ +*> \brief \b DCHKSY_2X2 checks extreme-scale 2-by-2 pivots. +*> +*> \par Purpose: +*> ============= +*> +*> \verbatim +*> Test factorization and solve with subnormal and near-overflow pivots, +*> using both triangles and the classic, rook, RK and packed routines. +*> Orders 3 and 130 exercise unblocked code and panels with NB = 64. +*> Each right-hand side is a column of A; the solution is a unit vector. +*> Subnormal cases are skipped if gradual underflow is unavailable. +*> Failures and test counts are added to NFAIL and NRUN, respectively. +*> \endverbatim +*> +*> \param[in] NOUT +*> Output unit for failure diagnostics. +*> \param[in,out] NFAIL +*> Number of failed tests. +*> \param[in,out] NRUN +*> Number of tests run. +*> + SUBROUTINE DCHKSY_2X2( NOUT, NFAIL, NRUN ) + IMPLICIT NONE + INTEGER NOUT, NFAIL, NRUN +* +* .. Parameters .. + INTEGER NMAX, NB, LWORK + PARAMETER ( NMAX = 130, NB = 64, LWORK = NMAX*NB ) + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +* .. Local Scalars .. + CHARACTER UPLO + CHARACTER*2 KIND + INTEGER I, J, II, JJ, IC, IFAM, IMETH, ISIZE, + $ IUPLO, K, N, NBOLD, ICOL, INFO + LOGICAL BAD + DOUBLE PRECISION BIG, SMALL, TOL, ERR +* .. Local Arrays .. + INTEGER IPIV( NMAX ) + DOUBLE PRECISION G( 3, 3 ), A( NMAX, NMAX ), B( NMAX ), + $ AP( NMAX*( NMAX+1 ) / 2 ), E( NMAX ), + $ WORK( LWORK ) +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + EXTERNAL DLAMCH, ILAENV, XLAENV + EXTERNAL DSYTRF, DSYTRF_ROOK, DSYTRF_RK + EXTERNAL DSYTRS, DSYTRS_ROOK, DSYTRS_3 + EXTERNAL DSPTRF, DSPTRS +* + BIG = HUGE( ONE ) + SMALL = SCALE( TINY( ONE ), -10 ) + TOL = 128*DLAMCH( 'Epsilon' ) + NBOLD = ILAENV( 1, 'DSYTRF', 'L', NMAX, -1, -1, -1 ) + CALL XLAENV( 1, NB ) +* + DO IFAM = 1, 1 + KIND = 'SY' + DO IC = 1, 2 + IF( IC.EQ.1 .AND. ( SMALL.LE.ZERO .OR. + $ SMALL.GE.TINY( ONE ) ) ) CYCLE + G = ZERO + IF( IC.EQ.1 ) THEN +* 1 / (4*SMALL) overflows, but the multipliers are bounded. + G( 1, 1 ) = SMALL + G( 2, 2 ) = SMALL + G( 1, 2 ) = 4*SMALL + G( 1, 3 ) = SMALL + G( 2, 3 ) = SMALL + G( 3, 3 ) = ONE + ELSE IF( IC.EQ.2 ) THEN +* T*W overflows before division by the off-diagonal pivot. + G( 1, 1 ) = 0.5D0*BIG + G( 2, 2 ) = 0.5D0*BIG + G( 1, 2 ) = BIG + G( 2, 3 ) = 0.9D0*BIG + END IF + DO J = 1, 3 + DO I = 1, J - 1 + G( J, I ) = G( I, J ) + END DO + END DO + DO ISIZE = 1, 2 + N = 3 + IF( ISIZE.EQ.2 ) N = NMAX + DO IUPLO = 1, 2 + UPLO = 'L' + ICOL = 3 + IF( IUPLO.EQ.2 ) THEN + UPLO = 'U' + ICOL = N - 2 + END IF + DO IMETH = 1, 4 + A = ZERO + E = ZERO + DO I = 1, N + A( I, I ) = ONE + END DO + DO J = 1, 3 + DO I = 1, 3 + II = I + JJ = J + IF( IUPLO.EQ.2 ) THEN + II = N + 1 - I + JJ = N + 1 - J + END IF + A( II, JJ ) = G( I, J ) + END DO + END DO + B( 1:N ) = A( 1:N, ICOL ) + K = 0 + DO J = 1, N + DO I = 1, N + IF( ( UPLO.EQ.'U' .AND. I.LE.J ) .OR. + $ ( UPLO.EQ.'L' .AND. I.GE.J ) ) THEN + K = K + 1 + AP( K ) = A( I, J ) + END IF + END DO + END DO + IF( IMETH.EQ.1 ) THEN + CALL DSYTRF( UPLO, N, A, NMAX, IPIV, WORK, + $ LWORK, INFO ) + ELSE IF( IMETH.EQ.2 ) THEN + CALL DSYTRF_ROOK( UPLO, N, A, NMAX, IPIV, WORK, + $ LWORK, INFO ) + ELSE IF( IMETH.EQ.3 ) THEN + CALL DSYTRF_RK( UPLO, N, A, NMAX, E, IPIV, WORK, + $ LWORK, INFO ) + ELSE + CALL DSPTRF( UPLO, N, AP, IPIV, INFO ) + END IF + BAD = INFO.NE.0 +* Confirm a 2-by-2 pivot and reject nonfinite factors +* before passing them to the solve routine. + IF( UPLO.EQ.'L' ) THEN + BAD = BAD .OR. IPIV( 1 ).GE.0 + ELSE + BAD = BAD .OR. IPIV( N ).GE.0 + END IF + DO J = 1, N + DO I = 1, N + IF( .NOT.( ABS( A( I, J ) ).LE.BIG ) ) + $ BAD = .TRUE. + END DO + END DO + DO I = 1, K + IF( .NOT.( ABS( AP( I ) ).LE.BIG ) ) + $ BAD = .TRUE. + END DO + DO I = 1, N + IF( .NOT.( ABS( E( I ) ).LE.BIG ) ) + $ BAD = .TRUE. + END DO + IF( .NOT.BAD ) THEN + IF( IMETH.EQ.1 ) THEN + CALL DSYTRS( UPLO, N, 1, A, NMAX, IPIV, B, + $ NMAX, INFO ) + ELSE IF( IMETH.EQ.2 ) THEN + CALL DSYTRS_ROOK( UPLO, N, 1, A, NMAX, IPIV, + $ B, NMAX, INFO ) + ELSE IF( IMETH.EQ.3 ) THEN + CALL DSYTRS_3( UPLO, N, 1, A, NMAX, E, IPIV, + $ B, NMAX, INFO ) + ELSE + CALL DSPTRS( UPLO, N, 1, AP, IPIV, B, NMAX, + $ INFO ) + END IF + BAD = INFO.NE.0 + B( ICOL ) = B( ICOL ) - ONE + ERR = ZERO + DO I = 1, N + IF( .NOT.( ABS( B( I ) ).LE.BIG ) ) + $ BAD = .TRUE. + ERR = MAX( ERR, ABS( B( I ) ) ) + END DO + BAD = BAD .OR. .NOT.( ERR.LE.TOL ) + END IF + NRUN = NRUN + 1 + IF( BAD ) THEN + NFAIL = NFAIL + 1 + WRITE( NOUT, 9999 ) KIND, UPLO, N, IC, + $ IMETH, INFO + END IF + END DO + END DO + END DO + END DO + END DO + CALL XLAENV( 1, NBOLD ) + RETURN + 9999 FORMAT( ' DCHKSY_2X2: ', A2, ' UPLO=', A1, ' N=', I3, + $ ' case=', I1, ' method=', I1, ' INFO=', I3 ) + END diff --git a/TESTING/LIN/schksy.f b/TESTING/LIN/schksy.f index a8de72ca6..ccae972b6 100644 --- a/TESTING/LIN/schksy.f +++ b/TESTING/LIN/schksy.f @@ -214,6 +214,7 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, EXTERNAL SGET06, SLANSY * .. * .. External Subroutines .. + EXTERNAL SCHKSY_2X2 EXTERNAL ALAERH, ALAHD, ALASUM, SERRSY, SGET04, SLACPY, $ SLARHS, SLATB4, SLATMS, SPOT02, SPOT03, SPOT05, $ SSYCON, SSYRFS, SSYT01, SSYTRF, SSYTRI2, @@ -654,6 +655,8 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 160 CONTINUE 170 CONTINUE 180 CONTINUE +* + CALL SCHKSY_2X2( NOUT, NFAIL, NRUN ) * * Print a summary of the results. * diff --git a/TESTING/LIN/schksy_2x2.f b/TESTING/LIN/schksy_2x2.f new file mode 100644 index 000000000..54b33a017 --- /dev/null +++ b/TESTING/LIN/schksy_2x2.f @@ -0,0 +1,194 @@ +*> \brief \b SCHKSY_2X2 checks extreme-scale 2-by-2 pivots. +*> +*> \par Purpose: +*> ============= +*> +*> \verbatim +*> Test factorization and solve with subnormal and near-overflow pivots, +*> using both triangles and the classic, rook, RK and packed routines. +*> Orders 3 and 130 exercise unblocked code and panels with NB = 64. +*> Each right-hand side is a column of A; the solution is a unit vector. +*> Subnormal cases are skipped if gradual underflow is unavailable. +*> Failures and test counts are added to NFAIL and NRUN, respectively. +*> \endverbatim +*> +*> \param[in] NOUT +*> Output unit for failure diagnostics. +*> \param[in,out] NFAIL +*> Number of failed tests. +*> \param[in,out] NRUN +*> Number of tests run. +*> + SUBROUTINE SCHKSY_2X2( NOUT, NFAIL, NRUN ) + IMPLICIT NONE + INTEGER NOUT, NFAIL, NRUN +* +* .. Parameters .. + INTEGER NMAX, NB, LWORK + PARAMETER ( NMAX = 130, NB = 64, LWORK = NMAX*NB ) + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) +* .. Local Scalars .. + CHARACTER UPLO + CHARACTER*2 KIND + INTEGER I, J, II, JJ, IC, IFAM, IMETH, ISIZE, + $ IUPLO, K, N, NBOLD, ICOL, INFO + LOGICAL BAD + REAL BIG, SMALL, TOL, ERR +* .. Local Arrays .. + INTEGER IPIV( NMAX ) + REAL G( 3, 3 ), A( NMAX, NMAX ), B( NMAX ), + $ AP( NMAX*( NMAX+1 ) / 2 ), E( NMAX ), + $ WORK( LWORK ) +* .. External Functions .. + REAL SLAMCH + INTEGER ILAENV + EXTERNAL SLAMCH, ILAENV, XLAENV + EXTERNAL SSYTRF, SSYTRF_ROOK, SSYTRF_RK + EXTERNAL SSYTRS, SSYTRS_ROOK, SSYTRS_3 + EXTERNAL SSPTRF, SSPTRS +* + BIG = HUGE( ONE ) + SMALL = SCALE( TINY( ONE ), -10 ) + TOL = 128*SLAMCH( 'Epsilon' ) + NBOLD = ILAENV( 1, 'SSYTRF', 'L', NMAX, -1, -1, -1 ) + CALL XLAENV( 1, NB ) +* + DO IFAM = 1, 1 + KIND = 'SY' + DO IC = 1, 2 + IF( IC.EQ.1 .AND. ( SMALL.LE.ZERO .OR. + $ SMALL.GE.TINY( ONE ) ) ) CYCLE + G = ZERO + IF( IC.EQ.1 ) THEN +* 1 / (4*SMALL) overflows, but the multipliers are bounded. + G( 1, 1 ) = SMALL + G( 2, 2 ) = SMALL + G( 1, 2 ) = 4*SMALL + G( 1, 3 ) = SMALL + G( 2, 3 ) = SMALL + G( 3, 3 ) = ONE + ELSE IF( IC.EQ.2 ) THEN +* T*W overflows before division by the off-diagonal pivot. + G( 1, 1 ) = 0.5E0*BIG + G( 2, 2 ) = 0.5E0*BIG + G( 1, 2 ) = BIG + G( 2, 3 ) = 0.9E0*BIG + END IF + DO J = 1, 3 + DO I = 1, J - 1 + G( J, I ) = G( I, J ) + END DO + END DO + DO ISIZE = 1, 2 + N = 3 + IF( ISIZE.EQ.2 ) N = NMAX + DO IUPLO = 1, 2 + UPLO = 'L' + ICOL = 3 + IF( IUPLO.EQ.2 ) THEN + UPLO = 'U' + ICOL = N - 2 + END IF + DO IMETH = 1, 4 + A = ZERO + E = ZERO + DO I = 1, N + A( I, I ) = ONE + END DO + DO J = 1, 3 + DO I = 1, 3 + II = I + JJ = J + IF( IUPLO.EQ.2 ) THEN + II = N + 1 - I + JJ = N + 1 - J + END IF + A( II, JJ ) = G( I, J ) + END DO + END DO + B( 1:N ) = A( 1:N, ICOL ) + K = 0 + DO J = 1, N + DO I = 1, N + IF( ( UPLO.EQ.'U' .AND. I.LE.J ) .OR. + $ ( UPLO.EQ.'L' .AND. I.GE.J ) ) THEN + K = K + 1 + AP( K ) = A( I, J ) + END IF + END DO + END DO + IF( IMETH.EQ.1 ) THEN + CALL SSYTRF( UPLO, N, A, NMAX, IPIV, WORK, + $ LWORK, INFO ) + ELSE IF( IMETH.EQ.2 ) THEN + CALL SSYTRF_ROOK( UPLO, N, A, NMAX, IPIV, WORK, + $ LWORK, INFO ) + ELSE IF( IMETH.EQ.3 ) THEN + CALL SSYTRF_RK( UPLO, N, A, NMAX, E, IPIV, WORK, + $ LWORK, INFO ) + ELSE + CALL SSPTRF( UPLO, N, AP, IPIV, INFO ) + END IF + BAD = INFO.NE.0 +* Confirm a 2-by-2 pivot and reject nonfinite factors +* before passing them to the solve routine. + IF( UPLO.EQ.'L' ) THEN + BAD = BAD .OR. IPIV( 1 ).GE.0 + ELSE + BAD = BAD .OR. IPIV( N ).GE.0 + END IF + DO J = 1, N + DO I = 1, N + IF( .NOT.( ABS( A( I, J ) ).LE.BIG ) ) + $ BAD = .TRUE. + END DO + END DO + DO I = 1, K + IF( .NOT.( ABS( AP( I ) ).LE.BIG ) ) + $ BAD = .TRUE. + END DO + DO I = 1, N + IF( .NOT.( ABS( E( I ) ).LE.BIG ) ) + $ BAD = .TRUE. + END DO + IF( .NOT.BAD ) THEN + IF( IMETH.EQ.1 ) THEN + CALL SSYTRS( UPLO, N, 1, A, NMAX, IPIV, B, + $ NMAX, INFO ) + ELSE IF( IMETH.EQ.2 ) THEN + CALL SSYTRS_ROOK( UPLO, N, 1, A, NMAX, IPIV, + $ B, NMAX, INFO ) + ELSE IF( IMETH.EQ.3 ) THEN + CALL SSYTRS_3( UPLO, N, 1, A, NMAX, E, IPIV, + $ B, NMAX, INFO ) + ELSE + CALL SSPTRS( UPLO, N, 1, AP, IPIV, B, NMAX, + $ INFO ) + END IF + BAD = INFO.NE.0 + B( ICOL ) = B( ICOL ) - ONE + ERR = ZERO + DO I = 1, N + IF( .NOT.( ABS( B( I ) ).LE.BIG ) ) + $ BAD = .TRUE. + ERR = MAX( ERR, ABS( B( I ) ) ) + END DO + BAD = BAD .OR. .NOT.( ERR.LE.TOL ) + END IF + NRUN = NRUN + 1 + IF( BAD ) THEN + NFAIL = NFAIL + 1 + WRITE( NOUT, 9999 ) KIND, UPLO, N, IC, + $ IMETH, INFO + END IF + END DO + END DO + END DO + END DO + END DO + CALL XLAENV( 1, NBOLD ) + RETURN + 9999 FORMAT( ' SCHKSY_2X2: ', A2, ' UPLO=', A1, ' N=', I3, + $ ' case=', I1, ' method=', I1, ' INFO=', I3 ) + END diff --git a/TESTING/LIN/zchksy.f b/TESTING/LIN/zchksy.f index 0c8c2c2b1..edf513a0f 100644 --- a/TESTING/LIN/zchksy.f +++ b/TESTING/LIN/zchksy.f @@ -218,6 +218,7 @@ SUBROUTINE ZCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, EXTERNAL DGET06, ZLANSY * .. * .. External Subroutines .. + EXTERNAL ZCHKSY_2X2 EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, ZERRSY, ZGET04, $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZLATSY, ZPOT05, $ ZSYCON, ZSYRFS, ZSYT01, ZSYT02, ZSYT03, ZSYTRF, @@ -670,6 +671,8 @@ SUBROUTINE ZCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 160 CONTINUE 170 CONTINUE 180 CONTINUE +* + CALL ZCHKSY_2X2( NOUT, NFAIL, NRUN ) * * Print a summary of the results. * diff --git a/TESTING/LIN/zchksy_2x2.f b/TESTING/LIN/zchksy_2x2.f new file mode 100644 index 000000000..72fc89951 --- /dev/null +++ b/TESTING/LIN/zchksy_2x2.f @@ -0,0 +1,287 @@ +*> \brief \b ZCHKSY_2X2 checks extreme-scale 2-by-2 pivots. +*> +*> \par Purpose: +*> ============= +*> +*> \verbatim +*> Test factorization and solve with subnormal and near-overflow pivots, +*> using both triangles and the classic, rook, RK and packed routines. +*> Orders 3 and 130 exercise unblocked code and panels with NB = 64. +*> Each right-hand side is a column of A; the solution is a unit vector. +*> Subnormal cases are skipped if gradual underflow is unavailable. +*> Failures and test counts are added to NFAIL and NRUN, respectively. +*> \endverbatim +*> +*> \param[in] NOUT +*> Output unit for failure diagnostics. +*> \param[in,out] NFAIL +*> Number of failed tests. +*> \param[in,out] NRUN +*> Number of tests run. +*> + SUBROUTINE ZCHKSY_2X2( NOUT, NFAIL, NRUN ) + IMPLICIT NONE + INTEGER NOUT, NFAIL, NRUN +* +* .. Parameters .. + INTEGER NMAX, NB, LWORK + PARAMETER ( NMAX = 130, NB = 64, LWORK = NMAX*NB ) + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +* .. Local Scalars .. + CHARACTER UPLO + CHARACTER*2 KIND + INTEGER I, J, II, JJ, IC, IFAM, IMETH, ISIZE, + $ IUPLO, K, N, NBOLD, ICOL, INFO + LOGICAL BAD + DOUBLE PRECISION BIG, SMALL, TOL, ERR, MAG +* .. Local Arrays .. + INTEGER IPIV( NMAX ) + COMPLEX*16 G( 3, 3 ), A( NMAX, NMAX ), B( NMAX ), + $ AP( NMAX*( NMAX+1 ) / 2 ), E( NMAX ), + $ WORK( LWORK ) + COMPLEX*16 PHASE( 3 ) +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + EXTERNAL DLAMCH, ILAENV, XLAENV + EXTERNAL ZSYTRF, ZSYTRF_ROOK, ZSYTRF_RK + EXTERNAL ZSYTRS, ZSYTRS_ROOK, ZSYTRS_3 + EXTERNAL ZHETRF, ZHETRF_ROOK, ZHETRF_RK + EXTERNAL ZHETRS, ZHETRS_ROOK, ZHETRS_3 + EXTERNAL ZSPTRF, ZSPTRS, ZHPTRF + EXTERNAL ZHPTRS +* + BIG = HUGE( ONE ) + SMALL = SCALE( TINY( ONE ), -10 ) + TOL = 128*DLAMCH( 'Epsilon' ) + NBOLD = ILAENV( 1, 'ZSYTRF', 'L', NMAX, -1, -1, -1 ) + CALL XLAENV( 1, NB ) +* + DO IFAM = 1, 2 + KIND = 'SY' + IF( IFAM.EQ.2 ) KIND = 'HE' + PHASE( 1 ) = ONE + PHASE( 2 ) = DCMPLX( ZERO, ONE ) + PHASE( 3 ) = -ONE + DO IC = 1, 7 + IF( IC.EQ.1 .AND. ( SMALL.LE.ZERO .OR. + $ SMALL.GE.TINY( ONE ) ) ) CYCLE + IF( IFAM.EQ.2 .AND. IC.GE.3 ) CYCLE + G = ZERO + IF( IC.EQ.1 ) THEN +* 1 / (4*SMALL) overflows, but the multipliers are bounded. + G( 1, 1 ) = SMALL + G( 2, 2 ) = SMALL + G( 1, 2 ) = 4*SMALL + G( 1, 3 ) = SMALL + G( 2, 3 ) = SMALL + G( 3, 3 ) = ONE + ELSE IF( IC.EQ.2 ) THEN +* T*W overflows before division by the off-diagonal pivot. + G( 1, 1 ) = 0.5D0*BIG + G( 2, 2 ) = 0.5D0*BIG + G( 1, 2 ) = BIG + G( 2, 3 ) = 0.9D0*BIG + ELSE +* The intrinsic complex division can overflow internally: +* (.53125 + .53125*i) / (-.5 - .5*i), both scaled by BIG. +* Also cover ordinary values and both reciprocal guards. + MAG = BIG + IF( IC.EQ.4 ) MAG = ONE + IF( IC.EQ.5 ) MAG = SQRT( DLAMCH( 'S' ) ) / 16 + IF( IC.EQ.6 ) MAG = 16 / SQRT( DLAMCH( 'S' ) ) + G( 1, 2 ) = DCMPLX( MAG / 8, -MAG / 8 ) + G( 1, 3 ) = DCMPLX( -MAG / 2, -MAG / 2 ) + G( 2, 3 ) = G( 1, 3 ) + G( 3, 3 ) = G( 1, 2 ) + IF( IC.EQ.7 ) THEN +* Moderate pivot, large numerator: a pivot-only guard +* would form (-1.2-.4*i)*(.9+.34*i)*BIG and overflow. + G( 1, 2 ) = DCMPLX( .75D0, -.25D0 ) + G( 1, 3 ) = DCMPLX( .4D0, .2D0 ) + G( 2, 2 ) = DCMPLX( .3D0, -.2D0 )*BIG + G( 2, 3 ) = DCMPLX( -.7D0, -.3D0 )*BIG + G( 3, 3 ) = DCMPLX( -.2D0, -.3D0 )*BIG + END IF + END IF + DO J = 1, 3 + DO I = 1, J - 1 + G( J, I ) = G( I, J ) + END DO + END DO + IF( IFAM.EQ.2 ) THEN +* Unitary diagonal scaling gives Hermitian imaginary pivots. + DO J = 1, 3 + DO I = 1, 3 + G( I, J ) = PHASE( I )*G( I, J )* + $ DCONJG( PHASE( J ) ) + END DO + END DO + END IF + DO ISIZE = 1, 2 + N = 3 + IF( ISIZE.EQ.2 ) N = NMAX + DO IUPLO = 1, 2 + UPLO = 'L' + ICOL = 3 + IF( IUPLO.EQ.2 ) THEN + UPLO = 'U' + ICOL = N - 2 + END IF + DO IMETH = 1, 4 + IF( IC.EQ.7 .AND. + $ ( IMETH.EQ.2 .OR. IMETH.EQ.3 ) ) CYCLE + A = ZERO + E = ZERO + DO I = 1, N + A( I, I ) = ONE + END DO + DO J = 1, 3 + DO I = 1, 3 + II = I + JJ = J + IF( IUPLO.EQ.2 ) THEN + II = N + 1 - I + JJ = N + 1 - J + END IF + A( II, JJ ) = G( I, J ) + END DO + END DO + B( 1:N ) = A( 1:N, ICOL ) + K = 0 + DO J = 1, N + DO I = 1, N + IF( ( UPLO.EQ.'U' .AND. I.LE.J ) .OR. + $ ( UPLO.EQ.'L' .AND. I.GE.J ) ) THEN + K = K + 1 + AP( K ) = A( I, J ) + END IF + END DO + END DO + IF( IFAM.EQ.1 ) THEN + IF( IMETH.EQ.1 ) THEN + CALL ZSYTRF( UPLO, N, A, NMAX, IPIV, WORK, + $ LWORK, INFO ) + ELSE IF( IMETH.EQ.2 ) THEN + CALL ZSYTRF_ROOK( UPLO, N, A, NMAX, IPIV, + $ WORK, LWORK, INFO ) + ELSE IF( IMETH.EQ.3 ) THEN + CALL ZSYTRF_RK( UPLO, N, A, NMAX, E, IPIV, + $ WORK, LWORK, INFO ) + ELSE + CALL ZSPTRF( UPLO, N, AP, IPIV, INFO ) + END IF + ELSE + IF( IMETH.EQ.1 ) THEN + CALL ZHETRF( UPLO, N, A, NMAX, IPIV, WORK, + $ LWORK, INFO ) + ELSE IF( IMETH.EQ.2 ) THEN + CALL ZHETRF_ROOK( UPLO, N, A, NMAX, IPIV, + $ WORK, LWORK, INFO ) + ELSE IF( IMETH.EQ.3 ) THEN + CALL ZHETRF_RK( UPLO, N, A, NMAX, E, IPIV, + $ WORK, LWORK, INFO ) + ELSE + CALL ZHPTRF( UPLO, N, AP, IPIV, INFO ) + END IF + END IF + BAD = INFO.NE.0 +* Confirm a 2-by-2 pivot and reject nonfinite factors +* before passing them to the solve routine. + IF( UPLO.EQ.'L' ) THEN + BAD = BAD .OR. IPIV( 1 ).GE.0 + ELSE + BAD = BAD .OR. IPIV( N ).GE.0 + END IF + DO J = 1, N + DO I = 1, N + IF( .NOT.( ABS( DBLE( A( I, J ) ) ).LE. + $ BIG .AND. ABS( DIMAG( A( I, J ) ) ).LE. + $ BIG ) ) BAD = .TRUE. + END DO + END DO + DO I = 1, K + IF( .NOT.( ABS( DBLE( AP( I ) ) ).LE. + $ BIG .AND. ABS( DIMAG( AP( I ) ) ).LE. + $ BIG ) ) BAD = .TRUE. + END DO + DO I = 1, N + IF( .NOT.( ABS( DBLE( E( I ) ) ).LE. + $ BIG .AND. ABS( DIMAG( E( I ) ) ).LE. + $ BIG ) ) BAD = .TRUE. + END DO + IF( IC.EQ.7 .AND. .NOT.BAD ) THEN +* This matrix is ill-conditioned; check the known +* multiplier instead of a forward solve error. + II = 3 + JJ = 1 + K = 3 + IF( UPLO.EQ.'U' ) THEN + II = N - 2 + JJ = N + K = N*( N-1 ) / 2 + N - 2 + END IF + WORK( 1 ) = A( II, JJ ) / BIG + IF( IMETH.EQ.4 ) WORK( 1 ) = AP( K ) / BIG + ERR = ABS( WORK( 1 )- + $ DCMPLX( -.944D0, -.768D0 ) ) + BAD = .NOT.( ERR.LE.TOL ) + END IF + IF( .NOT.BAD .AND. IC.NE.7 ) THEN + IF( IFAM.EQ.1 ) THEN + IF( IMETH.EQ.1 ) THEN + CALL ZSYTRS( UPLO, N, 1, A, NMAX, IPIV, B, + $ NMAX, INFO ) + ELSE IF( IMETH.EQ.2 ) THEN + CALL ZSYTRS_ROOK( UPLO, N, 1, A, NMAX, + $ IPIV, B, NMAX, INFO ) + ELSE IF( IMETH.EQ.3 ) THEN + CALL ZSYTRS_3( UPLO, N, 1, A, NMAX, E, + $ IPIV, B, NMAX, INFO ) + ELSE + CALL ZSPTRS( UPLO, N, 1, AP, IPIV, B, + $ NMAX, INFO ) + END IF + ELSE + IF( IMETH.EQ.1 ) THEN + CALL ZHETRS( UPLO, N, 1, A, NMAX, IPIV, B, + $ NMAX, INFO ) + ELSE IF( IMETH.EQ.2 ) THEN + CALL ZHETRS_ROOK( UPLO, N, 1, A, NMAX, + $ IPIV, B, NMAX, INFO ) + ELSE IF( IMETH.EQ.3 ) THEN + CALL ZHETRS_3( UPLO, N, 1, A, NMAX, E, + $ IPIV, B, NMAX, INFO ) + ELSE + CALL ZHPTRS( UPLO, N, 1, AP, IPIV, B, + $ NMAX, INFO ) + END IF + END IF + BAD = INFO.NE.0 + B( ICOL ) = B( ICOL ) - ONE + ERR = ZERO + DO I = 1, N + IF( .NOT.( ABS( DBLE( B( I ) ) ).LE. + $ BIG .AND. ABS( DIMAG( B( I ) ) ).LE. + $ BIG ) ) BAD = .TRUE. + ERR = MAX( ERR, ABS( B( I ) ) ) + END DO + BAD = BAD .OR. .NOT.( ERR.LE.TOL ) + END IF + NRUN = NRUN + 1 + IF( BAD ) THEN + NFAIL = NFAIL + 1 + WRITE( NOUT, 9999 ) KIND, UPLO, N, IC, + $ IMETH, INFO + END IF + END DO + END DO + END DO + END DO + END DO + CALL XLAENV( 1, NBOLD ) + RETURN + 9999 FORMAT( ' ZCHKSY_2X2: ', A2, ' UPLO=', A1, ' N=', I3, + $ ' case=', I1, ' method=', I1, ' INFO=', I3 ) + END From 36b5001d88688b6c6b3ea07313d233fd600e3f52 Mon Sep 17 00:00:00 2001 From: Rasmus Munk Larsen Date: Mon, 7 Sep 2026 13:32:11 -0700 Subject: [PATCH 3/4] Revert "LAPACK: Guard complex 2x2 pivot division" This reverts commit 8a8021e65632131b00f6173c6537df6e431825b6. --- SRC/clahef.f | 84 ++--------- SRC/clahef_rk.f | 70 ++------- SRC/clahef_rook.f | 70 ++------- SRC/clasyf.f | 84 ++--------- SRC/clasyf_rk.f | 70 ++------- SRC/clasyf_rook.f | 70 ++------- SRC/csptrf.f | 76 ++-------- SRC/csytf2.f | 68 +-------- SRC/csytf2_rk.f | 66 +-------- SRC/csytf2_rook.f | 66 +-------- SRC/zlahef.f | 84 ++--------- SRC/zlahef_rk.f | 70 ++------- SRC/zlahef_rook.f | 70 ++------- SRC/zlasyf.f | 84 ++--------- SRC/zlasyf_rk.f | 70 ++------- SRC/zlasyf_rook.f | 70 ++------- SRC/zsptrf.f | 76 ++-------- SRC/zsytf2.f | 68 +-------- SRC/zsytf2_rk.f | 66 +-------- SRC/zsytf2_rook.f | 66 +-------- TESTING/LIN/CMakeLists.txt | 8 +- TESTING/LIN/Makefile | 8 +- TESTING/LIN/cchksy.f | 3 - TESTING/LIN/cchksy_2x2.f | 287 ------------------------------------- TESTING/LIN/dchksy.f | 3 - TESTING/LIN/dchksy_2x2.f | 194 ------------------------- TESTING/LIN/schksy.f | 3 - TESTING/LIN/schksy_2x2.f | 194 ------------------------- TESTING/LIN/zchksy.f | 3 - TESTING/LIN/zchksy_2x2.f | 287 ------------------------------------- 30 files changed, 188 insertions(+), 2250 deletions(-) delete mode 100644 TESTING/LIN/cchksy_2x2.f delete mode 100644 TESTING/LIN/dchksy_2x2.f delete mode 100644 TESTING/LIN/schksy_2x2.f delete mode 100644 TESTING/LIN/zchksy_2x2.f diff --git a/SRC/clahef.f b/SRC/clahef.f index d6be10ffe..d1654b8b6 100644 --- a/SRC/clahef.f +++ b/SRC/clahef.f @@ -199,21 +199,15 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX DINV, W1, W2 INTEGER IMAX, J, JJ, JMAX, JP, K, KK, KKW, KP, $ KSTEP, KW REAL ABSAKK, ALPHA, COLMAX, R1, ROWMAX, T COMPLEX D11, D21, D22, Z * .. * .. External Functions .. - REAL SLAMCH - EXTERNAL SLAMCH - COMPLEX CLADIV LOGICAL LSAME INTEGER ICAMAX - EXTERNAL LSAME, ICAMAX, CLADIV + EXTERNAL LSAME, ICAMAX * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEMMTR, CGEMV, CLACGV, CSSCAL, @@ -235,8 +229,6 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( SLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * IF( LSAME( UPLO, 'U' ) ) THEN * @@ -496,9 +488,9 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * D22 = d11/conj(d21), * T = 1/(D22*D11-1). * -* T/d21 is formed only in a safe range. Otherwise each -* entry is divided by d21 or conj(d21) using scaled -* division before multiplication by T. +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 or conj(d21) and then scaled by T. * * (NOTE: No need to check for division by ZERO, * since that was ensured earlier in pivot search: @@ -515,35 +507,12 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 20 J = 1, K - 2 - W1 = D11*W( J, KW-1 )- W( J, KW ) - W2 = D22*W( J, KW )- W( J, KW-1 ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K-1 ) = W1*DINV - A( J, K ) = W2*CONJG( DINV ) - ELSE - A( J, K-1 ) = T*CLADIV( W1, D21 ) - A( J, K ) = T*CLADIV( W2, CONJG( D21 ) ) - END IF + A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ CONJG( D21 ) ) 20 CONTINUE END IF * @@ -866,9 +835,9 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * D22 = d11/conj(d21), * T = 1/(D22*D11-1). * -* T/d21 is formed only in a safe range. Otherwise each -* entry is divided by d21 or conj(d21) using scaled -* division before multiplication by T. +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 or conj(d21) and then scaled by T. * * (NOTE: No need to check for division by ZERO, * since that was ensured earlier in pivot search: @@ -885,35 +854,12 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 80 J = K + 2, N - W1 = D11*W( J, K )- W( J, K+1 ) - W2 = D22*W( J, K+1 )- W( J, K ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K ) = W1*CONJG( DINV ) - A( J, K+1 ) = W2*DINV - ELSE - A( J, K ) = T*CLADIV( W1, CONJG( D21 ) ) - A( J, K+1 ) = T*CLADIV( W2, D21 ) - END IF + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ CONJG( D21 ) ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/clahef_rk.f b/SRC/clahef_rk.f index 15047de24..fa17636ea 100644 --- a/SRC/clahef_rk.f +++ b/SRC/clahef_rk.f @@ -284,9 +284,6 @@ SUBROUTINE CLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, $ CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX DINV, W1, W2 LOGICAL DONE INTEGER IMAX, ITEMP, II, J, JMAX, K, KK, KKW, $ KP, KSTEP, KW, P @@ -295,11 +292,10 @@ SUBROUTINE CLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, COMPLEX D11, D21, D22, Z * .. * .. External Functions .. - COMPLEX CLADIV LOGICAL LSAME INTEGER ICAMAX REAL SLAMCH - EXTERNAL LSAME, ICAMAX, SLAMCH, CLADIV + EXTERNAL LSAME, ICAMAX, SLAMCH * .. * .. External Subroutines .. EXTERNAL CCOPY, CSSCAL, CGEMMTR, @@ -321,8 +317,6 @@ SUBROUTINE CLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( SLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -710,35 +704,12 @@ SUBROUTINE CLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 20 J = 1, K - 2 - W1 = D11*W( J, KW-1 )- W( J, KW ) - W2 = D22*W( J, KW )- W( J, KW-1 ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K-1 ) = W1*DINV - A( J, K ) = W2*CONJG( DINV ) - ELSE - A( J, K-1 ) = T*CLADIV( W1, D21 ) - A( J, K ) = T*CLADIV( W2, CONJG( D21 ) ) - END IF + A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ CONJG( D21 ) ) 20 CONTINUE END IF * @@ -1163,35 +1134,12 @@ SUBROUTINE CLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 80 J = K + 2, N - W1 = D11*W( J, K )- W( J, K+1 ) - W2 = D22*W( J, K+1 )- W( J, K ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K ) = W1*CONJG( DINV ) - A( J, K+1 ) = W2*DINV - ELSE - A( J, K ) = T*CLADIV( W1, CONJG( D21 ) ) - A( J, K+1 ) = T*CLADIV( W2, D21 ) - END IF + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ CONJG( D21 ) ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/clahef_rook.f b/SRC/clahef_rook.f index d741ad3e3..2f9ccaf1b 100644 --- a/SRC/clahef_rook.f +++ b/SRC/clahef_rook.f @@ -205,9 +205,6 @@ SUBROUTINE CLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX DINV, W1, W2 LOGICAL DONE INTEGER IMAX, ITEMP, II, J, JB, JJ, JMAX, JP1, JP2, K, $ KK, KKW, KP, KSTEP, KW, P @@ -216,11 +213,10 @@ SUBROUTINE CLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, COMPLEX D11, D21, D22, Z * .. * .. External Functions .. - COMPLEX CLADIV LOGICAL LSAME INTEGER ICAMAX REAL SLAMCH - EXTERNAL LSAME, ICAMAX, SLAMCH, CLADIV + EXTERNAL LSAME, ICAMAX, SLAMCH * .. * .. External Subroutines .. EXTERNAL CCOPY, CSSCAL, CGEMM, CGEMV, CLACGV, @@ -242,8 +238,6 @@ SUBROUTINE CLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( SLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -615,35 +609,12 @@ SUBROUTINE CLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 20 J = 1, K - 2 - W1 = D11*W( J, KW-1 )- W( J, KW ) - W2 = D22*W( J, KW )- W( J, KW-1 ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K-1 ) = W1*DINV - A( J, K ) = W2*CONJG( DINV ) - ELSE - A( J, K-1 ) = T*CLADIV( W1, D21 ) - A( J, K ) = T*CLADIV( W2, CONJG( D21 ) ) - END IF + A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ CONJG( D21 ) ) 20 CONTINUE END IF * @@ -1097,35 +1068,12 @@ SUBROUTINE CLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 80 J = K + 2, N - W1 = D11*W( J, K )- W( J, K+1 ) - W2 = D22*W( J, K+1 )- W( J, K ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K ) = W1*CONJG( DINV ) - A( J, K+1 ) = W2*DINV - ELSE - A( J, K ) = T*CLADIV( W1, CONJG( D21 ) ) - A( J, K+1 ) = T*CLADIV( W2, D21 ) - END IF + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ CONJG( D21 ) ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/clasyf.f b/SRC/clasyf.f index d9f084da8..0b9248a29 100644 --- a/SRC/clasyf.f +++ b/SRC/clasyf.f @@ -199,21 +199,15 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX DINV, W1, W2 INTEGER IMAX, J, JJ, JMAX, JP, K, KK, KKW, KP, $ KSTEP, KW REAL ABSAKK, ALPHA, COLMAX, ROWMAX COMPLEX D11, D21, D22, R1, T, Z * .. * .. External Functions .. - REAL SLAMCH - EXTERNAL SLAMCH - COMPLEX CLADIV LOGICAL LSAME INTEGER ICAMAX - EXTERNAL LSAME, ICAMAX, CLADIV + EXTERNAL LSAME, ICAMAX * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEMMTR, CGEMV, CSCAL, CSWAP @@ -234,8 +228,6 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( SLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * IF( LSAME( UPLO, 'U' ) ) THEN * @@ -440,9 +432,9 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* T/d21 is formed only in a safe range. Otherwise each -* entry is divided by d21 using scaled division before -* multiplication by T. +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 @@ -452,35 +444,12 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 20 J = 1, K - 2 - W1 = D11*W( J, KW-1 )- W( J, KW ) - W2 = D22*W( J, KW )- W( J, KW-1 ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K-1 ) = W1*DINV - A( J, K ) = W2*DINV - ELSE - A( J, K-1 ) = T*CLADIV( W1, D21 ) - A( J, K ) = T*CLADIV( W2, D21 ) - END IF + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D21 ) 20 CONTINUE END IF * @@ -745,9 +714,9 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* T/d21 is formed only in a safe range. Otherwise each -* entry is divided by d21 using scaled division before -* multiplication by T. +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 @@ -757,35 +726,12 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 80 J = K + 2, N - W1 = D11*W( J, K )- W( J, K+1 ) - W2 = D22*W( J, K+1 )- W( J, K ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K ) = W1*DINV - A( J, K+1 ) = W2*DINV - ELSE - A( J, K ) = T*CLADIV( W1, D21 ) - A( J, K+1 ) = T*CLADIV( W2, D21 ) - END IF + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/clasyf_rk.f b/SRC/clasyf_rk.f index f32355d71..a9e736461 100644 --- a/SRC/clasyf_rk.f +++ b/SRC/clasyf_rk.f @@ -284,9 +284,6 @@ SUBROUTINE CLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, $ CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX DINV, W1, W2 LOGICAL DONE INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, K, KK, KW, KKW, $ KP, KSTEP, P, II @@ -294,11 +291,10 @@ SUBROUTINE CLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, COMPLEX D11, D12, D21, D22, R1, T, Z * .. * .. External Functions .. - COMPLEX CLADIV LOGICAL LSAME INTEGER ICAMAX REAL SLAMCH - EXTERNAL LSAME, ICAMAX, SLAMCH, CLADIV + EXTERNAL LSAME, ICAMAX, SLAMCH * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEMMTR, CGEMV, CSCAL, CSWAP @@ -319,8 +315,6 @@ SUBROUTINE CLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( SLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -588,34 +582,11 @@ SUBROUTINE CLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, D11 = W( K, KW ) / D12 D22 = W( K-1, KW-1 ) / D12 T = CONE / ( D11*D22-CONE ) -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D12 ) ), ABS( AIMAG( D12 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D12 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF -* DO 20 J = 1, K - 2 - W1 = D11*W( J, KW-1 )- W( J, KW ) - W2 = D22*W( J, KW )- W( J, KW-1 ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K-1 ) = W1*DINV - A( J, K ) = W2*DINV - ELSE - A( J, K-1 ) = T*CLADIV( W1, D12 ) - A( J, K ) = T*CLADIV( W2, D12 ) - END IF + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D12 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D12 ) 20 CONTINUE END IF * @@ -912,34 +883,11 @@ SUBROUTINE CLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = CONE / ( D11*D22-CONE ) -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF -* DO 80 J = K + 2, N - W1 = D11*W( J, K )- W( J, K+1 ) - W2 = D22*W( J, K+1 )- W( J, K ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K ) = W1*DINV - A( J, K+1 ) = W2*DINV - ELSE - A( J, K ) = T*CLADIV( W1, D21 ) - A( J, K+1 ) = T*CLADIV( W2, D21 ) - END IF + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/clasyf_rook.f b/SRC/clasyf_rook.f index f99655a1c..b0c6440c2 100644 --- a/SRC/clasyf_rook.f +++ b/SRC/clasyf_rook.f @@ -206,9 +206,6 @@ SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, $ CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX DINV, W1, W2 LOGICAL DONE INTEGER IMAX, ITEMP, J, JJ, JMAX, JP1, JP2, K, KK, $ KW, KKW, KP, KSTEP, P, II @@ -216,11 +213,10 @@ SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, COMPLEX D11, D12, D21, D22, R1, T, Z * .. * .. External Functions .. - COMPLEX CLADIV LOGICAL LSAME INTEGER ICAMAX REAL SLAMCH - EXTERNAL LSAME, ICAMAX, SLAMCH, CLADIV + EXTERNAL LSAME, ICAMAX, SLAMCH * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEMMTR, CGEMV, CSCAL, CSWAP @@ -241,8 +237,6 @@ SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( SLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -494,34 +488,11 @@ SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, D11 = W( K, KW ) / D12 D22 = W( K-1, KW-1 ) / D12 T = CONE / ( D11*D22-CONE ) -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D12 ) ), ABS( AIMAG( D12 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D12 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF -* DO 20 J = 1, K - 2 - W1 = D11*W( J, KW-1 )- W( J, KW ) - W2 = D22*W( J, KW )- W( J, KW-1 ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K-1 ) = W1*DINV - A( J, K ) = W2*DINV - ELSE - A( J, K-1 ) = T*CLADIV( W1, D12 ) - A( J, K ) = T*CLADIV( W2, D12 ) - END IF + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D12 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D12 ) 20 CONTINUE END IF * @@ -823,34 +794,11 @@ SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = CONE / ( D11*D22-CONE ) -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF -* DO 80 J = K + 2, N - W1 = D11*W( J, K )- W( J, K+1 ) - W2 = D22*W( J, K+1 )- W( J, K ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K ) = W1*DINV - A( J, K+1 ) = W2*DINV - ELSE - A( J, K ) = T*CLADIV( W1, D21 ) - A( J, K+1 ) = T*CLADIV( W2, D21 ) - END IF + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/csptrf.f b/SRC/csptrf.f index b474323b8..c7d2d7f41 100644 --- a/SRC/csptrf.f +++ b/SRC/csptrf.f @@ -179,9 +179,6 @@ SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX DINV, W1, W2 LOGICAL UPPER INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC, $ KSTEP, KX, NPP @@ -189,12 +186,9 @@ SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) COMPLEX D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, ZDUM * .. * .. External Functions .. - REAL SLAMCH - EXTERNAL SLAMCH - COMPLEX CLADIV LOGICAL LSAME, SISNAN INTEGER ICAMAX - EXTERNAL LSAME, ICAMAX, CLADIV, SISNAN + EXTERNAL LSAME, ICAMAX, SISNAN * .. * .. External Subroutines .. EXTERNAL CSCAL, CSPR, CSWAP, XERBLA @@ -227,8 +221,6 @@ SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( SLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * IF( UPPER ) THEN * @@ -383,37 +375,12 @@ SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 D11 = AP( K+( K-1 )*K / 2 ) / D12 T = CONE / ( D11*D22-CONE ) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D12 ) ), ABS( AIMAG( D12 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D12 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 50 J = K - 2, 1, -1 - W1 = D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ AP( J+( K-1 )*K / 2 ) - W2 = D22*AP( J+( K-1 )*K / 2 )- - $ AP( J+( K-2 )*( K-1 ) / 2 ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - WKM1 = W1*DINV - WK = W2*DINV - ELSE - WKM1 = T*CLADIV( W1, D12 ) - WK = T*CLADIV( W2, D12 ) - END IF + WKM1 = T*( ( D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ AP( J+( K-1 )*K / 2 ) ) / D12 ) + WK = T*( ( D22*AP( J+( K-1 )*K / 2 )- + $ AP( J+( K-2 )*( K-1 ) / 2 ) ) / D12 ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*WK - @@ -608,37 +575,12 @@ SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 T = CONE / ( D11*D22-CONE ) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 100 J = K + 2, N - W1 = D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- - $ AP( J+K*( 2*N-K-1 ) / 2 ) - W2 = D22*AP( J+K*( 2*N-K-1 ) / 2 )- - $ AP( J+( K-1 )*( 2*N-K ) / 2 ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - WK = W1*DINV - WKP1 = W2*DINV - ELSE - WK = T*CLADIV( W1, D21 ) - WKP1 = T*CLADIV( W2, D21 ) - END IF + WK = T*( ( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- + $ AP( J+K*( 2*N-K-1 ) / 2 ) ) / D21 ) + WKP1 = T*( ( D22*AP( J+K*( 2*N-K-1 ) / 2 )- + $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) / D21 ) DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / diff --git a/SRC/csytf2.f b/SRC/csytf2.f index 4059a01d2..09228ec9f 100644 --- a/SRC/csytf2.f +++ b/SRC/csytf2.f @@ -212,21 +212,15 @@ SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX DINV, W1, W2 LOGICAL UPPER INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP REAL ABSAKK, ALPHA, COLMAX, ROWMAX COMPLEX D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, Z * .. * .. External Functions .. - REAL SLAMCH - EXTERNAL SLAMCH - COMPLEX CLADIV LOGICAL LSAME, SISNAN INTEGER ICAMAX - EXTERNAL LSAME, ICAMAX, SISNAN, CLADIV + EXTERNAL LSAME, ICAMAX, SISNAN * .. * .. External Subroutines .. EXTERNAL CSCAL, CSWAP, CSYR, XERBLA @@ -261,8 +255,6 @@ SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( SLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * IF( UPPER ) THEN * @@ -402,35 +394,10 @@ SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = CONE / ( D11*D22-CONE ) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D12 ) ), ABS( AIMAG( D12 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D12 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 30 J = K - 2, 1, -1 - W1 = D11*A( J, K-1 )-A( J, K ) - W2 = D22*A( J, K )-A( J, K-1 ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - WKM1 = W1*DINV - WK = W2*DINV - ELSE - WKM1 = T*CLADIV( W1, D12 ) - WK = T*CLADIV( W2, D12 ) - END IF + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K-1 )*WKM1 @@ -601,35 +568,10 @@ SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = CONE / ( D11*D22-CONE ) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 60 J = K + 2, N - W1 = D11*A( J, K )-A( J, K+1 ) - W2 = D22*A( J, K+1 )-A( J, K ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - WK = W1*DINV - WKP1 = W2*DINV - ELSE - WK = T*CLADIV( W1, D21 ) - WKP1 = T*CLADIV( W2, D21 ) - END IF + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) DO 50 I = J, N A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K+1 )*WKP1 diff --git a/SRC/csytf2_rk.f b/SRC/csytf2_rk.f index e41ed0053..a52f69a0b 100644 --- a/SRC/csytf2_rk.f +++ b/SRC/csytf2_rk.f @@ -263,9 +263,6 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) $ CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX DINV, W1, W2 LOGICAL UPPER, DONE INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, $ P, II @@ -273,11 +270,10 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) COMPLEX D11, D12, D21, D22, T, WK, WKM1, WKP1, Z * .. * .. External Functions .. - COMPLEX CLADIV LOGICAL LSAME INTEGER ICAMAX REAL SLAMCH - EXTERNAL LSAME, ICAMAX, SLAMCH, CLADIV + EXTERNAL LSAME, ICAMAX, SLAMCH * .. * .. External Subroutines .. EXTERNAL CSCAL, CSWAP, CSYR, XERBLA @@ -312,8 +308,6 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( SLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -585,36 +579,11 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = CONE / ( D11*D22-CONE ) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D12 ) ), ABS( AIMAG( D12 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D12 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 30 J = K - 2, 1, -1 * - W1 = D11*A( J, K-1 )-A( J, K ) - W2 = D22*A( J, K )-A( J, K-1 ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - WKM1 = W1*DINV - WK = W2*DINV - ELSE - WKM1 = T*CLADIV( W1, D12 ) - WK = T*CLADIV( W2, D12 ) - END IF + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - @@ -926,38 +895,13 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = CONE / ( D11*D22-CONE ) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 60 J = K + 2, N * * Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - W1 = D11*A( J, K )-A( J, K+1 ) - W2 = D22*A( J, K+1 )-A( J, K ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - WK = W1*DINV - WKP1 = W2*DINV - ELSE - WK = T*CLADIV( W1, D21 ) - WKP1 = T*CLADIV( W2, D21 ) - END IF + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * diff --git a/SRC/csytf2_rook.f b/SRC/csytf2_rook.f index 3336786d4..50f2894b4 100644 --- a/SRC/csytf2_rook.f +++ b/SRC/csytf2_rook.f @@ -215,9 +215,6 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - REAL SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX DINV, W1, W2 LOGICAL UPPER, DONE INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, $ P, II @@ -225,11 +222,10 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) COMPLEX D11, D12, D21, D22, T, WK, WKM1, WKP1, Z * .. * .. External Functions .. - COMPLEX CLADIV LOGICAL LSAME INTEGER ICAMAX REAL SLAMCH - EXTERNAL LSAME, ICAMAX, SLAMCH, CLADIV + EXTERNAL LSAME, ICAMAX, SLAMCH * .. * .. External Subroutines .. EXTERNAL CSCAL, CSWAP, CSYR, XERBLA @@ -264,8 +260,6 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( SLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -505,36 +499,11 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = CONE / ( D11*D22-CONE ) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D12 ) ), ABS( AIMAG( D12 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D12 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 30 J = K - 2, 1, -1 * - W1 = D11*A( J, K-1 )-A( J, K ) - W2 = D22*A( J, K )-A( J, K-1 ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - WKM1 = W1*DINV - WK = W2*DINV - ELSE - WKM1 = T*CLADIV( W1, D12 ) - WK = T*CLADIV( W2, D12 ) - END IF + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - @@ -804,38 +773,13 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = CONE / ( D11*D22-CONE ) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( REAL( D21 ) ), ABS( AIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( REAL( DINV ) ), - $ ABS( AIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 60 J = K + 2, N * * Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - W1 = D11*A( J, K )-A( J, K+1 ) - W2 = D22*A( J, K+1 )-A( J, K ) - ABSW1 = MAX( ABS( REAL( W1 ) ), - $ ABS( AIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( REAL( W2 ) ), - $ ABS( AIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - WK = W1*DINV - WKP1 = W2*DINV - ELSE - WK = T*CLADIV( W1, D21 ) - WKP1 = T*CLADIV( W2, D21 ) - END IF + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * diff --git a/SRC/zlahef.f b/SRC/zlahef.f index 205254022..3fdde8113 100644 --- a/SRC/zlahef.f +++ b/SRC/zlahef.f @@ -199,21 +199,15 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX*16 DINV, W1, W2 INTEGER IMAX, J, JJ, JMAX, JP, K, KK, KKW, KP, $ KSTEP, KW DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, R1, ROWMAX, T COMPLEX*16 D11, D21, D22, Z * .. * .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH - COMPLEX*16 ZLADIV LOGICAL LSAME INTEGER IZAMAX - EXTERNAL LSAME, IZAMAX, ZLADIV + EXTERNAL LSAME, IZAMAX * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZDSCAL, ZGEMMTR, ZGEMV, ZLACGV, @@ -235,8 +229,6 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( DLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * IF( LSAME( UPLO, 'U' ) ) THEN * @@ -495,9 +487,9 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * D22 = d11/conj(d21), * T = 1/(D22*D11-1). * -* T/d21 is formed only in a safe range. Otherwise each -* entry is divided by d21 or conj(d21) using scaled -* division before multiplication by T. +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 or conj(d21) and then scaled by T. * * (NOTE: No need to check for division by ZERO, * since that was ensured earlier in pivot search: @@ -514,35 +506,12 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 20 J = 1, K - 2 - W1 = D11*W( J, KW-1 )- W( J, KW ) - W2 = D22*W( J, KW )- W( J, KW-1 ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K-1 ) = W1*DINV - A( J, K ) = W2*DCONJG( DINV ) - ELSE - A( J, K-1 ) = T*ZLADIV( W1, D21 ) - A( J, K ) = T*ZLADIV( W2, DCONJG( D21 ) ) - END IF + A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ DCONJG( D21 ) ) 20 CONTINUE END IF * @@ -865,9 +834,9 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * D22 = d11/conj(d21), * T = 1/(D22*D11-1). * -* T/d21 is formed only in a safe range. Otherwise each -* entry is divided by d21 or conj(d21) using scaled -* division before multiplication by T. +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 or conj(d21) and then scaled by T. * * (NOTE: No need to check for division by ZERO, * since that was ensured earlier in pivot search: @@ -884,35 +853,12 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 80 J = K + 2, N - W1 = D11*W( J, K )- W( J, K+1 ) - W2 = D22*W( J, K+1 )- W( J, K ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K ) = W1*DCONJG( DINV ) - A( J, K+1 ) = W2*DINV - ELSE - A( J, K ) = T*ZLADIV( W1, DCONJG( D21 ) ) - A( J, K+1 ) = T*ZLADIV( W2, D21 ) - END IF + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ DCONJG( D21 ) ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/zlahef_rk.f b/SRC/zlahef_rk.f index 719f4bdd6..a82ddf472 100644 --- a/SRC/zlahef_rk.f +++ b/SRC/zlahef_rk.f @@ -285,9 +285,6 @@ SUBROUTINE ZLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX*16 DINV, W1, W2 LOGICAL DONE INTEGER IMAX, ITEMP, II, J, JMAX, K, KK, KKW, $ KP, KSTEP, KW, P @@ -296,11 +293,10 @@ SUBROUTINE ZLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, COMPLEX*16 D11, D21, D22, Z * .. * .. External Functions .. - COMPLEX*16 ZLADIV LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IZAMAX, DLAMCH, ZLADIV + EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZDSCAL, ZGEMMTR, ZGEMV, ZLACGV, @@ -322,8 +318,6 @@ SUBROUTINE ZLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( DLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -710,35 +704,12 @@ SUBROUTINE ZLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 20 J = 1, K - 2 - W1 = D11*W( J, KW-1 )- W( J, KW ) - W2 = D22*W( J, KW )- W( J, KW-1 ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K-1 ) = W1*DINV - A( J, K ) = W2*DCONJG( DINV ) - ELSE - A( J, K-1 ) = T*ZLADIV( W1, D21 ) - A( J, K ) = T*ZLADIV( W2, DCONJG( D21 ) ) - END IF + A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ DCONJG( D21 ) ) 20 CONTINUE END IF * @@ -1163,35 +1134,12 @@ SUBROUTINE ZLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 80 J = K + 2, N - W1 = D11*W( J, K )- W( J, K+1 ) - W2 = D22*W( J, K+1 )- W( J, K ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K ) = W1*DCONJG( DINV ) - A( J, K+1 ) = W2*DINV - ELSE - A( J, K ) = T*ZLADIV( W1, DCONJG( D21 ) ) - A( J, K+1 ) = T*ZLADIV( W2, D21 ) - END IF + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ DCONJG( D21 ) ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/zlahef_rook.f b/SRC/zlahef_rook.f index 8769a4435..06ddcb4e9 100644 --- a/SRC/zlahef_rook.f +++ b/SRC/zlahef_rook.f @@ -205,9 +205,6 @@ SUBROUTINE ZLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX*16 DINV, W1, W2 LOGICAL DONE INTEGER IMAX, ITEMP, II, J, JB, JJ, JMAX, JP1, JP2, K, $ KK, KKW, KP, KSTEP, KW, P @@ -216,11 +213,10 @@ SUBROUTINE ZLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, COMPLEX*16 D11, D21, D22, Z * .. * .. External Functions .. - COMPLEX*16 ZLADIV LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IZAMAX, DLAMCH, ZLADIV + EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZDSCAL, ZGEMM, ZGEMV, ZLACGV, @@ -242,8 +238,6 @@ SUBROUTINE ZLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( DLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -615,35 +609,12 @@ SUBROUTINE ZLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 20 J = 1, K - 2 - W1 = D11*W( J, KW-1 )- W( J, KW ) - W2 = D22*W( J, KW )- W( J, KW-1 ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K-1 ) = W1*DINV - A( J, K ) = W2*DCONJG( DINV ) - ELSE - A( J, K-1 ) = T*ZLADIV( W1, D21 ) - A( J, K ) = T*ZLADIV( W2, DCONJG( D21 ) ) - END IF + A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ DCONJG( D21 ) ) 20 CONTINUE END IF * @@ -1097,35 +1068,12 @@ SUBROUTINE ZLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 80 J = K + 2, N - W1 = D11*W( J, K )- W( J, K+1 ) - W2 = D22*W( J, K+1 )- W( J, K ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K ) = W1*DCONJG( DINV ) - A( J, K+1 ) = W2*DINV - ELSE - A( J, K ) = T*ZLADIV( W1, DCONJG( D21 ) ) - A( J, K+1 ) = T*ZLADIV( W2, D21 ) - END IF + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ DCONJG( D21 ) ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/zlasyf.f b/SRC/zlasyf.f index 7d658468b..9411871fb 100644 --- a/SRC/zlasyf.f +++ b/SRC/zlasyf.f @@ -199,21 +199,15 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX*16 DINV, W1, W2 INTEGER IMAX, J, JJ, JMAX, JP, K, KK, KKW, KP, $ KSTEP, KW DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX COMPLEX*16 D11, D21, D22, R1, T, Z * .. * .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH - COMPLEX*16 ZLADIV LOGICAL LSAME INTEGER IZAMAX - EXTERNAL LSAME, IZAMAX, ZLADIV + EXTERNAL LSAME, IZAMAX * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZGEMMTR, ZGEMV, ZSCAL, ZSWAP @@ -234,8 +228,6 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( DLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * IF( LSAME( UPLO, 'U' ) ) THEN * @@ -439,9 +431,9 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* T/d21 is formed only in a safe range. Otherwise each -* entry is divided by d21 using scaled division before -* multiplication by T. +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 @@ -451,35 +443,12 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 20 J = 1, K - 2 - W1 = D11*W( J, KW-1 )- W( J, KW ) - W2 = D22*W( J, KW )- W( J, KW-1 ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K-1 ) = W1*DINV - A( J, K ) = W2*DINV - ELSE - A( J, K-1 ) = T*ZLADIV( W1, D21 ) - A( J, K ) = T*ZLADIV( W2, D21 ) - END IF + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D21 ) 20 CONTINUE END IF * @@ -743,9 +712,9 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* T/d21 is formed only in a safe range. Otherwise each -* entry is divided by d21 using scaled division before -* multiplication by T. +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 @@ -755,35 +724,12 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 80 J = K + 2, N - W1 = D11*W( J, K )- W( J, K+1 ) - W2 = D22*W( J, K+1 )- W( J, K ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K ) = W1*DINV - A( J, K+1 ) = W2*DINV - ELSE - A( J, K ) = T*ZLADIV( W1, D21 ) - A( J, K+1 ) = T*ZLADIV( W2, D21 ) - END IF + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/zlasyf_rk.f b/SRC/zlasyf_rk.f index 8f746030b..16499a556 100644 --- a/SRC/zlasyf_rk.f +++ b/SRC/zlasyf_rk.f @@ -284,9 +284,6 @@ SUBROUTINE ZLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, $ CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX*16 DINV, W1, W2 LOGICAL DONE INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, K, KK, KW, KKW, $ KP, KSTEP, P, II @@ -294,11 +291,10 @@ SUBROUTINE ZLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, COMPLEX*16 D11, D12, D21, D22, R1, T, Z * .. * .. External Functions .. - COMPLEX*16 ZLADIV LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IZAMAX, DLAMCH, ZLADIV + EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZGEMMTR, ZGEMV, ZSCAL, ZSWAP @@ -319,8 +315,6 @@ SUBROUTINE ZLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( DLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -588,34 +582,11 @@ SUBROUTINE ZLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, D11 = W( K, KW ) / D12 D22 = W( K-1, KW-1 ) / D12 T = CONE / ( D11*D22-CONE ) -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D12 ) ), ABS( DIMAG( D12 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D12 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF -* DO 20 J = 1, K - 2 - W1 = D11*W( J, KW-1 )- W( J, KW ) - W2 = D22*W( J, KW )- W( J, KW-1 ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K-1 ) = W1*DINV - A( J, K ) = W2*DINV - ELSE - A( J, K-1 ) = T*ZLADIV( W1, D12 ) - A( J, K ) = T*ZLADIV( W2, D12 ) - END IF + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D12 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D12 ) 20 CONTINUE END IF * @@ -912,34 +883,11 @@ SUBROUTINE ZLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = CONE / ( D11*D22-CONE ) -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF -* DO 80 J = K + 2, N - W1 = D11*W( J, K )- W( J, K+1 ) - W2 = D22*W( J, K+1 )- W( J, K ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K ) = W1*DINV - A( J, K+1 ) = W2*DINV - ELSE - A( J, K ) = T*ZLADIV( W1, D21 ) - A( J, K+1 ) = T*ZLADIV( W2, D21 ) - END IF + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/zlasyf_rook.f b/SRC/zlasyf_rook.f index 51001d932..57bd229ef 100644 --- a/SRC/zlasyf_rook.f +++ b/SRC/zlasyf_rook.f @@ -206,9 +206,6 @@ SUBROUTINE ZLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, $ CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX*16 DINV, W1, W2 LOGICAL DONE INTEGER IMAX, ITEMP, J, JJ, JMAX, JP1, JP2, K, KK, $ KW, KKW, KP, KSTEP, P, II @@ -216,11 +213,10 @@ SUBROUTINE ZLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, COMPLEX*16 D11, D12, D21, D22, R1, T, Z * .. * .. External Functions .. - COMPLEX*16 ZLADIV LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IZAMAX, DLAMCH, ZLADIV + EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZGEMMTR, ZGEMV, ZSCAL, ZSWAP @@ -241,8 +237,6 @@ SUBROUTINE ZLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( DLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -494,34 +488,11 @@ SUBROUTINE ZLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, D11 = W( K, KW ) / D12 D22 = W( K-1, KW-1 ) / D12 T = CONE / ( D11*D22-CONE ) -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D12 ) ), ABS( DIMAG( D12 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D12 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF -* DO 20 J = 1, K - 2 - W1 = D11*W( J, KW-1 )- W( J, KW ) - W2 = D22*W( J, KW )- W( J, KW-1 ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K-1 ) = W1*DINV - A( J, K ) = W2*DINV - ELSE - A( J, K-1 ) = T*ZLADIV( W1, D12 ) - A( J, K ) = T*ZLADIV( W2, D12 ) - END IF + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D12 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D12 ) 20 CONTINUE END IF * @@ -823,34 +794,11 @@ SUBROUTINE ZLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = CONE / ( D11*D22-CONE ) -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF -* DO 80 J = K + 2, N - W1 = D11*W( J, K )- W( J, K+1 ) - W2 = D22*W( J, K+1 )- W( J, K ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - A( J, K ) = W1*DINV - A( J, K+1 ) = W2*DINV - ELSE - A( J, K ) = T*ZLADIV( W1, D21 ) - A( J, K+1 ) = T*ZLADIV( W2, D21 ) - END IF + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * diff --git a/SRC/zsptrf.f b/SRC/zsptrf.f index 033940cb0..42a916cdb 100644 --- a/SRC/zsptrf.f +++ b/SRC/zsptrf.f @@ -179,9 +179,6 @@ SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX*16 DINV, W1, W2 LOGICAL UPPER INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC, $ KSTEP, KX, NPP @@ -189,12 +186,9 @@ SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) COMPLEX*16 D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, ZDUM * .. * .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH - COMPLEX*16 ZLADIV LOGICAL LSAME, DISNAN INTEGER IZAMAX - EXTERNAL LSAME, IZAMAX, ZLADIV, DISNAN + EXTERNAL LSAME, IZAMAX, DISNAN * .. * .. External Subroutines .. EXTERNAL XERBLA, ZSCAL, ZSPR, ZSWAP @@ -227,8 +221,6 @@ SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( DLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * IF( UPPER ) THEN * @@ -383,37 +375,12 @@ SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 D11 = AP( K+( K-1 )*K / 2 ) / D12 T = CONE / ( D11*D22-CONE ) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D12 ) ), ABS( DIMAG( D12 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D12 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 50 J = K - 2, 1, -1 - W1 = D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ AP( J+( K-1 )*K / 2 ) - W2 = D22*AP( J+( K-1 )*K / 2 )- - $ AP( J+( K-2 )*( K-1 ) / 2 ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - WKM1 = W1*DINV - WK = W2*DINV - ELSE - WKM1 = T*ZLADIV( W1, D12 ) - WK = T*ZLADIV( W2, D12 ) - END IF + WKM1 = T*( ( D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ AP( J+( K-1 )*K / 2 ) ) / D12 ) + WK = T*( ( D22*AP( J+( K-1 )*K / 2 )- + $ AP( J+( K-2 )*( K-1 ) / 2 ) ) / D12 ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*WK - @@ -608,37 +575,12 @@ SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 T = CONE / ( D11*D22-CONE ) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 100 J = K + 2, N - W1 = D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- - $ AP( J+K*( 2*N-K-1 ) / 2 ) - W2 = D22*AP( J+K*( 2*N-K-1 ) / 2 )- - $ AP( J+( K-1 )*( 2*N-K ) / 2 ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - WK = W1*DINV - WKP1 = W2*DINV - ELSE - WK = T*ZLADIV( W1, D21 ) - WKP1 = T*ZLADIV( W2, D21 ) - END IF + WK = T*( ( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- + $ AP( J+K*( 2*N-K-1 ) / 2 ) ) / D21 ) + WKP1 = T*( ( D22*AP( J+K*( 2*N-K-1 ) / 2 )- + $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) / D21 ) DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / diff --git a/SRC/zsytf2.f b/SRC/zsytf2.f index 60dcf3c89..26ed82a08 100644 --- a/SRC/zsytf2.f +++ b/SRC/zsytf2.f @@ -212,21 +212,15 @@ SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX*16 DINV, W1, W2 LOGICAL UPPER INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX COMPLEX*16 D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, Z * .. * .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH - COMPLEX*16 ZLADIV LOGICAL DISNAN, LSAME INTEGER IZAMAX - EXTERNAL DISNAN, LSAME, IZAMAX, ZLADIV + EXTERNAL DISNAN, LSAME, IZAMAX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZSCAL, ZSWAP, ZSYR @@ -261,8 +255,6 @@ SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( DLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * IF( UPPER ) THEN * @@ -402,35 +394,10 @@ SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = CONE / ( D11*D22-CONE ) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D12 ) ), ABS( DIMAG( D12 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D12 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 30 J = K - 2, 1, -1 - W1 = D11*A( J, K-1 )-A( J, K ) - W2 = D22*A( J, K )-A( J, K-1 ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - WKM1 = W1*DINV - WK = W2*DINV - ELSE - WKM1 = T*ZLADIV( W1, D12 ) - WK = T*ZLADIV( W2, D12 ) - END IF + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K-1 )*WKM1 @@ -601,35 +568,10 @@ SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = CONE / ( D11*D22-CONE ) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 60 J = K + 2, N - W1 = D11*A( J, K )-A( J, K+1 ) - W2 = D22*A( J, K+1 )-A( J, K ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - WK = W1*DINV - WKP1 = W2*DINV - ELSE - WK = T*ZLADIV( W1, D21 ) - WKP1 = T*ZLADIV( W2, D21 ) - END IF + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) DO 50 I = J, N A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K+1 )*WKP1 diff --git a/SRC/zsytf2_rk.f b/SRC/zsytf2_rk.f index 45d85ee42..66bac797a 100644 --- a/SRC/zsytf2_rk.f +++ b/SRC/zsytf2_rk.f @@ -263,9 +263,6 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) $ CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX*16 DINV, W1, W2 LOGICAL UPPER, DONE INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, $ P, II @@ -273,11 +270,10 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) COMPLEX*16 D11, D12, D21, D22, T, WK, WKM1, WKP1, Z * .. * .. External Functions .. - COMPLEX*16 ZLADIV LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IZAMAX, DLAMCH, ZLADIV + EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL ZSCAL, ZSWAP, ZSYR, XERBLA @@ -312,8 +308,6 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( DLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -585,36 +579,11 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = CONE / ( D11*D22-CONE ) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D12 ) ), ABS( DIMAG( D12 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D12 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 30 J = K - 2, 1, -1 * - W1 = D11*A( J, K-1 )-A( J, K ) - W2 = D22*A( J, K )-A( J, K-1 ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - WKM1 = W1*DINV - WK = W2*DINV - ELSE - WKM1 = T*ZLADIV( W1, D12 ) - WK = T*ZLADIV( W2, D12 ) - END IF + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - @@ -926,38 +895,13 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = CONE / ( D11*D22-CONE ) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 60 J = K + 2, N * * Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - W1 = D11*A( J, K )-A( J, K+1 ) - W2 = D22*A( J, K+1 )-A( J, K ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - WK = W1*DINV - WKP1 = W2*DINV - ELSE - WK = T*ZLADIV( W1, D21 ) - WKP1 = T*ZLADIV( W2, D21 ) - END IF + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * diff --git a/SRC/zsytf2_rook.f b/SRC/zsytf2_rook.f index 9a3b51109..5ca176196 100644 --- a/SRC/zsytf2_rook.f +++ b/SRC/zsytf2_rook.f @@ -215,9 +215,6 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - LOGICAL SAFEDIV - DOUBLE PRECISION SMLNUM, BIGNUM, ABSD, ABSW1, ABSW2 - COMPLEX*16 DINV, W1, W2 LOGICAL UPPER, DONE INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, $ P, II @@ -225,11 +222,10 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) COMPLEX*16 D11, D12, D21, D22, T, WK, WKM1, WKP1, Z * .. * .. External Functions .. - COMPLEX*16 ZLADIV LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IZAMAX, DLAMCH, ZLADIV + EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL ZSCAL, ZSWAP, ZSYR, XERBLA @@ -264,8 +260,6 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT - SMLNUM = SQRT( DLAMCH( 'S' ) ) - BIGNUM = ONE / ( 4*SMLNUM ) * * Compute machine safe minimum * @@ -505,36 +499,11 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = CONE / ( D11*D22-CONE ) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D12 ) ), ABS( DIMAG( D12 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D12 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 30 J = K - 2, 1, -1 * - W1 = D11*A( J, K-1 )-A( J, K ) - W2 = D22*A( J, K )-A( J, K-1 ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - WKM1 = W1*DINV - WK = W2*DINV - ELSE - WKM1 = T*ZLADIV( W1, D12 ) - WK = T*ZLADIV( W2, D12 ) - END IF + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - @@ -804,38 +773,13 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = CONE / ( D11*D22-CONE ) -* -* Bound reciprocal and numerators by BIGNUM, so each -* complex product is at most 2*BIGNUM**2. -* - ABSD = MAX( ABS( DBLE( D21 ) ), ABS( DIMAG( D21 ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. ABSD.LE.BIGNUM - IF( SAFEDIV ) THEN - DINV = T / D21 - ABSD = MAX( ABS( DBLE( DINV ) ), - $ ABS( DIMAG( DINV ) ) ) - SAFEDIV = ABSD.GE.SMLNUM .AND. - $ ABSD.LE.BIGNUM - END IF * DO 60 J = K + 2, N * * Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - W1 = D11*A( J, K )-A( J, K+1 ) - W2 = D22*A( J, K+1 )-A( J, K ) - ABSW1 = MAX( ABS( DBLE( W1 ) ), - $ ABS( DIMAG( W1 ) ) ) - ABSW2 = MAX( ABS( DBLE( W2 ) ), - $ ABS( DIMAG( W2 ) ) ) - IF( SAFEDIV .AND. - $ MAX( ABSW1, ABSW2 ).LE.BIGNUM ) THEN - WK = W1*DINV - WKP1 = W2*DINV - ELSE - WK = T*ZLADIV( W1, D21 ) - WKP1 = T*ZLADIV( W2, D21 ) - END IF + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt index 40e213458..2313fa0c4 100644 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -10,7 +10,7 @@ set(SLINTST schkaa.F schkeq.f schkgb.f schkge.f schkgt.f schklq.f schkpb.f schkpo.f schkps.f schkpp.f schkpt.f schkq3.f schkqp3rk.f schkcxx.f schkql.f schkqr.f schkrq.f - schksp.f schksy.f schksy_2x2.f schksy_rook.f schksy_rk.f + schksp.f schksy.f schksy_rook.f schksy_rk.f schksy_aa.f schksy_aa_2stage.f schktb.f schktp.f schktr.f schktz.f @@ -60,7 +60,7 @@ set(CLINTST cchkhe_aa.f cchkhe_aa_2stage.f cchkhp.f cchklq.f cchkpb.f cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkqp3rk.f cchkcxx.f cchkql.f - cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_2x2.f cchksy_rook.f cchksy_rk.f + cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_rook.f cchksy_rk.f cchksy_aa.f cchksy_aa_2stage.f cchktb.f cchktp.f cchktr.f cchktz.f @@ -117,7 +117,7 @@ set(DLINTST dchkaa.F dchkeq.f dchkgb.f dchkge.f dchkgt.f dchklq.f dchkpb.f dchkpo.f dchkps.f dchkpp.f dchkpt.f dchkq3.f dchkqp3rk.f dchkcxx.f dchkql.f dchkqr.f dchkrq.f - dchksp.f dchksy.f dchksy_2x2.f dchksy_rook.f dchksy_rk.f + dchksp.f dchksy.f dchksy_rook.f dchksy_rk.f dchksy_aa.f dchksy_aa_2stage.f dchktb.f dchktp.f dchktr.f dchktz.f @@ -168,7 +168,7 @@ set(ZLINTST zchkhe_aa.f zchkhe_aa_2stage.f zchkhp.f zchklq.f zchkpb.f zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkqp3rk.f zchkcxx.f - zchkql.f zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_2x2.f zchksy_rook.f zchksy_rk.f + zchkql.f zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchksy_rk.f zchksy_aa.f zchksy_aa_2stage.f zchktb.f zchktp.f zchktr.f zchktz.f diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile index 8092e7024..f79329ea4 100644 --- a/TESTING/LIN/Makefile +++ b/TESTING/LIN/Makefile @@ -46,7 +46,7 @@ SLINTST = schkaa.o \ schkeq.o schkgb.o schkge.o schkgt.o \ schklq.o schkpb.o schkpo.o schkps.o schkpp.o \ schkpt.o schkq3.o schkqp3rk.o schkcxx.o schkql.o schkqr.o schkrq.o \ - schksp.o schksy.o schksy_2x2.o schksy_rook.o schksy_rk.o \ + schksp.o schksy.o schksy_rook.o schksy_rk.o \ schksy_aa.o schksy_aa_2stage.o schktb.o schktp.o schktr.o \ schktz.o \ sdrvgt.o sdrvls.o sdrvpb.o \ @@ -90,7 +90,7 @@ CLINTST = cchkaa.o \ cchkhe.o cchkhe_rook.o cchkhe_rk.o \ cchkhe_aa.o cchkhe_aa_2stage.o cchkhp.o cchklq.o cchkpb.o \ cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkqp3rk.o cchkcxx.o cchkql.o \ - cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_2x2.o cchksy_rook.o cchksy_rk.o \ + cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchksy_rk.o \ cchksy_aa.o cchksy_aa_2stage.o cchktb.o \ cchktp.o cchktr.o cchktz.o \ cdrvgt.o cdrvhe_rook.o cdrvhe_rk.o cdrvhe_aa.o cdrvhp.o \ @@ -138,7 +138,7 @@ DLINTST = dchkaa.o \ dchkeq.o dchkgb.o dchkge.o dchkgt.o \ dchklq.o dchkpb.o dchkpo.o dchkps.o dchkpp.o \ dchkpt.o dchkq3.o dchkqp3rk.o dchkcxx.o dchkql.o dchkqr.o \ - dchkrq.o dchksp.o dchksy.o dchksy_2x2.o dchksy_rook.o dchksy_rk.o \ + dchkrq.o dchksp.o dchksy.o dchksy_rook.o dchksy_rk.o \ dchksy_aa.o dchksy_aa_2stage.o dchktb.o dchktp.o dchktr.o \ dchktz.o \ ddrvgt.o ddrvls.o ddrvpb.o \ @@ -183,7 +183,7 @@ ZLINTST = zchkaa.o \ zchkhe.o zchkhe_rook.o zchkhe_rk.o zchkhe_aa.o zchkhe_aa_2stage.o \ zchkhp.o zchklq.o zchkpb.o \ zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkqp3rk.o zchkcxx.o zchkql.o \ - zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_2x2.o zchksy_rook.o zchksy_rk.o \ + zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchksy_rk.o \ zchksy_aa.o zchksy_aa_2stage.o zchktb.o \ zchktp.o zchktr.o zchktz.o \ zdrvgt.o zdrvhe_rook.o zdrvhe_rk.o zdrvhe_aa.o zdrvhe_aa_2stage.o zdrvhp.o \ diff --git a/TESTING/LIN/cchksy.f b/TESTING/LIN/cchksy.f index 766182a0e..f33cb879f 100644 --- a/TESTING/LIN/cchksy.f +++ b/TESTING/LIN/cchksy.f @@ -218,7 +218,6 @@ SUBROUTINE CCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, EXTERNAL SGET06, CLANSY * .. * .. External Subroutines .. - EXTERNAL CCHKSY_2X2 EXTERNAL ALAERH, ALAHD, ALASUM, CERRSY, CGET04, CLACPY, $ CLARHS, CLATB4, CLATMS, CLATSY, CPOT05, CSYCON, $ CSYRFS, CSYT01, CSYT02, CSYT03, CSYTRF, @@ -670,8 +669,6 @@ SUBROUTINE CCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 160 CONTINUE 170 CONTINUE 180 CONTINUE -* - CALL CCHKSY_2X2( NOUT, NFAIL, NRUN ) * * Print a summary of the results. * diff --git a/TESTING/LIN/cchksy_2x2.f b/TESTING/LIN/cchksy_2x2.f deleted file mode 100644 index 5b0b44d3b..000000000 --- a/TESTING/LIN/cchksy_2x2.f +++ /dev/null @@ -1,287 +0,0 @@ -*> \brief \b CCHKSY_2X2 checks extreme-scale 2-by-2 pivots. -*> -*> \par Purpose: -*> ============= -*> -*> \verbatim -*> Test factorization and solve with subnormal and near-overflow pivots, -*> using both triangles and the classic, rook, RK and packed routines. -*> Orders 3 and 130 exercise unblocked code and panels with NB = 64. -*> Each right-hand side is a column of A; the solution is a unit vector. -*> Subnormal cases are skipped if gradual underflow is unavailable. -*> Failures and test counts are added to NFAIL and NRUN, respectively. -*> \endverbatim -*> -*> \param[in] NOUT -*> Output unit for failure diagnostics. -*> \param[in,out] NFAIL -*> Number of failed tests. -*> \param[in,out] NRUN -*> Number of tests run. -*> - SUBROUTINE CCHKSY_2X2( NOUT, NFAIL, NRUN ) - IMPLICIT NONE - INTEGER NOUT, NFAIL, NRUN -* -* .. Parameters .. - INTEGER NMAX, NB, LWORK - PARAMETER ( NMAX = 130, NB = 64, LWORK = NMAX*NB ) - REAL ONE, ZERO - PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) -* .. Local Scalars .. - CHARACTER UPLO - CHARACTER*2 KIND - INTEGER I, J, II, JJ, IC, IFAM, IMETH, ISIZE, - $ IUPLO, K, N, NBOLD, ICOL, INFO - LOGICAL BAD - REAL BIG, SMALL, TOL, ERR, MAG -* .. Local Arrays .. - INTEGER IPIV( NMAX ) - COMPLEX G( 3, 3 ), A( NMAX, NMAX ), B( NMAX ), - $ AP( NMAX*( NMAX+1 ) / 2 ), E( NMAX ), - $ WORK( LWORK ) - COMPLEX PHASE( 3 ) -* .. External Functions .. - REAL SLAMCH - INTEGER ILAENV - EXTERNAL SLAMCH, ILAENV, XLAENV - EXTERNAL CSYTRF, CSYTRF_ROOK, CSYTRF_RK - EXTERNAL CSYTRS, CSYTRS_ROOK, CSYTRS_3 - EXTERNAL CHETRF, CHETRF_ROOK, CHETRF_RK - EXTERNAL CHETRS, CHETRS_ROOK, CHETRS_3 - EXTERNAL CSPTRF, CSPTRS, CHPTRF - EXTERNAL CHPTRS -* - BIG = HUGE( ONE ) - SMALL = SCALE( TINY( ONE ), -10 ) - TOL = 128*SLAMCH( 'Epsilon' ) - NBOLD = ILAENV( 1, 'CSYTRF', 'L', NMAX, -1, -1, -1 ) - CALL XLAENV( 1, NB ) -* - DO IFAM = 1, 2 - KIND = 'SY' - IF( IFAM.EQ.2 ) KIND = 'HE' - PHASE( 1 ) = ONE - PHASE( 2 ) = CMPLX( ZERO, ONE ) - PHASE( 3 ) = -ONE - DO IC = 1, 7 - IF( IC.EQ.1 .AND. ( SMALL.LE.ZERO .OR. - $ SMALL.GE.TINY( ONE ) ) ) CYCLE - IF( IFAM.EQ.2 .AND. IC.GE.3 ) CYCLE - G = ZERO - IF( IC.EQ.1 ) THEN -* 1 / (4*SMALL) overflows, but the multipliers are bounded. - G( 1, 1 ) = SMALL - G( 2, 2 ) = SMALL - G( 1, 2 ) = 4*SMALL - G( 1, 3 ) = SMALL - G( 2, 3 ) = SMALL - G( 3, 3 ) = ONE - ELSE IF( IC.EQ.2 ) THEN -* T*W overflows before division by the off-diagonal pivot. - G( 1, 1 ) = 0.5E0*BIG - G( 2, 2 ) = 0.5E0*BIG - G( 1, 2 ) = BIG - G( 2, 3 ) = 0.9E0*BIG - ELSE -* The intrinsic complex division can overflow internally: -* (.53125 + .53125*i) / (-.5 - .5*i), both scaled by BIG. -* Also cover ordinary values and both reciprocal guards. - MAG = BIG - IF( IC.EQ.4 ) MAG = ONE - IF( IC.EQ.5 ) MAG = SQRT( SLAMCH( 'S' ) ) / 16 - IF( IC.EQ.6 ) MAG = 16 / SQRT( SLAMCH( 'S' ) ) - G( 1, 2 ) = CMPLX( MAG / 8, -MAG / 8 ) - G( 1, 3 ) = CMPLX( -MAG / 2, -MAG / 2 ) - G( 2, 3 ) = G( 1, 3 ) - G( 3, 3 ) = G( 1, 2 ) - IF( IC.EQ.7 ) THEN -* Moderate pivot, large numerator: a pivot-only guard -* would form (-1.2-.4*i)*(.9+.34*i)*BIG and overflow. - G( 1, 2 ) = CMPLX( .75E0, -.25E0 ) - G( 1, 3 ) = CMPLX( .4E0, .2E0 ) - G( 2, 2 ) = CMPLX( .3E0, -.2E0 )*BIG - G( 2, 3 ) = CMPLX( -.7E0, -.3E0 )*BIG - G( 3, 3 ) = CMPLX( -.2E0, -.3E0 )*BIG - END IF - END IF - DO J = 1, 3 - DO I = 1, J - 1 - G( J, I ) = G( I, J ) - END DO - END DO - IF( IFAM.EQ.2 ) THEN -* Unitary diagonal scaling gives Hermitian imaginary pivots. - DO J = 1, 3 - DO I = 1, 3 - G( I, J ) = PHASE( I )*G( I, J )* - $ CONJG( PHASE( J ) ) - END DO - END DO - END IF - DO ISIZE = 1, 2 - N = 3 - IF( ISIZE.EQ.2 ) N = NMAX - DO IUPLO = 1, 2 - UPLO = 'L' - ICOL = 3 - IF( IUPLO.EQ.2 ) THEN - UPLO = 'U' - ICOL = N - 2 - END IF - DO IMETH = 1, 4 - IF( IC.EQ.7 .AND. - $ ( IMETH.EQ.2 .OR. IMETH.EQ.3 ) ) CYCLE - A = ZERO - E = ZERO - DO I = 1, N - A( I, I ) = ONE - END DO - DO J = 1, 3 - DO I = 1, 3 - II = I - JJ = J - IF( IUPLO.EQ.2 ) THEN - II = N + 1 - I - JJ = N + 1 - J - END IF - A( II, JJ ) = G( I, J ) - END DO - END DO - B( 1:N ) = A( 1:N, ICOL ) - K = 0 - DO J = 1, N - DO I = 1, N - IF( ( UPLO.EQ.'U' .AND. I.LE.J ) .OR. - $ ( UPLO.EQ.'L' .AND. I.GE.J ) ) THEN - K = K + 1 - AP( K ) = A( I, J ) - END IF - END DO - END DO - IF( IFAM.EQ.1 ) THEN - IF( IMETH.EQ.1 ) THEN - CALL CSYTRF( UPLO, N, A, NMAX, IPIV, WORK, - $ LWORK, INFO ) - ELSE IF( IMETH.EQ.2 ) THEN - CALL CSYTRF_ROOK( UPLO, N, A, NMAX, IPIV, - $ WORK, LWORK, INFO ) - ELSE IF( IMETH.EQ.3 ) THEN - CALL CSYTRF_RK( UPLO, N, A, NMAX, E, IPIV, - $ WORK, LWORK, INFO ) - ELSE - CALL CSPTRF( UPLO, N, AP, IPIV, INFO ) - END IF - ELSE - IF( IMETH.EQ.1 ) THEN - CALL CHETRF( UPLO, N, A, NMAX, IPIV, WORK, - $ LWORK, INFO ) - ELSE IF( IMETH.EQ.2 ) THEN - CALL CHETRF_ROOK( UPLO, N, A, NMAX, IPIV, - $ WORK, LWORK, INFO ) - ELSE IF( IMETH.EQ.3 ) THEN - CALL CHETRF_RK( UPLO, N, A, NMAX, E, IPIV, - $ WORK, LWORK, INFO ) - ELSE - CALL CHPTRF( UPLO, N, AP, IPIV, INFO ) - END IF - END IF - BAD = INFO.NE.0 -* Confirm a 2-by-2 pivot and reject nonfinite factors -* before passing them to the solve routine. - IF( UPLO.EQ.'L' ) THEN - BAD = BAD .OR. IPIV( 1 ).GE.0 - ELSE - BAD = BAD .OR. IPIV( N ).GE.0 - END IF - DO J = 1, N - DO I = 1, N - IF( .NOT.( ABS( REAL( A( I, J ) ) ).LE. - $ BIG .AND. ABS( AIMAG( A( I, J ) ) ).LE. - $ BIG ) ) BAD = .TRUE. - END DO - END DO - DO I = 1, K - IF( .NOT.( ABS( REAL( AP( I ) ) ).LE. - $ BIG .AND. ABS( AIMAG( AP( I ) ) ).LE. - $ BIG ) ) BAD = .TRUE. - END DO - DO I = 1, N - IF( .NOT.( ABS( REAL( E( I ) ) ).LE. - $ BIG .AND. ABS( AIMAG( E( I ) ) ).LE. - $ BIG ) ) BAD = .TRUE. - END DO - IF( IC.EQ.7 .AND. .NOT.BAD ) THEN -* This matrix is ill-conditioned; check the known -* multiplier instead of a forward solve error. - II = 3 - JJ = 1 - K = 3 - IF( UPLO.EQ.'U' ) THEN - II = N - 2 - JJ = N - K = N*( N-1 ) / 2 + N - 2 - END IF - WORK( 1 ) = A( II, JJ ) / BIG - IF( IMETH.EQ.4 ) WORK( 1 ) = AP( K ) / BIG - ERR = ABS( WORK( 1 )- - $ CMPLX( -.944E0, -.768E0 ) ) - BAD = .NOT.( ERR.LE.TOL ) - END IF - IF( .NOT.BAD .AND. IC.NE.7 ) THEN - IF( IFAM.EQ.1 ) THEN - IF( IMETH.EQ.1 ) THEN - CALL CSYTRS( UPLO, N, 1, A, NMAX, IPIV, B, - $ NMAX, INFO ) - ELSE IF( IMETH.EQ.2 ) THEN - CALL CSYTRS_ROOK( UPLO, N, 1, A, NMAX, - $ IPIV, B, NMAX, INFO ) - ELSE IF( IMETH.EQ.3 ) THEN - CALL CSYTRS_3( UPLO, N, 1, A, NMAX, E, - $ IPIV, B, NMAX, INFO ) - ELSE - CALL CSPTRS( UPLO, N, 1, AP, IPIV, B, - $ NMAX, INFO ) - END IF - ELSE - IF( IMETH.EQ.1 ) THEN - CALL CHETRS( UPLO, N, 1, A, NMAX, IPIV, B, - $ NMAX, INFO ) - ELSE IF( IMETH.EQ.2 ) THEN - CALL CHETRS_ROOK( UPLO, N, 1, A, NMAX, - $ IPIV, B, NMAX, INFO ) - ELSE IF( IMETH.EQ.3 ) THEN - CALL CHETRS_3( UPLO, N, 1, A, NMAX, E, - $ IPIV, B, NMAX, INFO ) - ELSE - CALL CHPTRS( UPLO, N, 1, AP, IPIV, B, - $ NMAX, INFO ) - END IF - END IF - BAD = INFO.NE.0 - B( ICOL ) = B( ICOL ) - ONE - ERR = ZERO - DO I = 1, N - IF( .NOT.( ABS( REAL( B( I ) ) ).LE. - $ BIG .AND. ABS( AIMAG( B( I ) ) ).LE. - $ BIG ) ) BAD = .TRUE. - ERR = MAX( ERR, ABS( B( I ) ) ) - END DO - BAD = BAD .OR. .NOT.( ERR.LE.TOL ) - END IF - NRUN = NRUN + 1 - IF( BAD ) THEN - NFAIL = NFAIL + 1 - WRITE( NOUT, 9999 ) KIND, UPLO, N, IC, - $ IMETH, INFO - END IF - END DO - END DO - END DO - END DO - END DO - CALL XLAENV( 1, NBOLD ) - RETURN - 9999 FORMAT( ' CCHKSY_2X2: ', A2, ' UPLO=', A1, ' N=', I3, - $ ' case=', I1, ' method=', I1, ' INFO=', I3 ) - END diff --git a/TESTING/LIN/dchksy.f b/TESTING/LIN/dchksy.f index 3ed0f0a2a..4d9789e74 100644 --- a/TESTING/LIN/dchksy.f +++ b/TESTING/LIN/dchksy.f @@ -214,7 +214,6 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, EXTERNAL DGET06, DLANSY * .. * .. External Subroutines .. - EXTERNAL DCHKSY_2X2 EXTERNAL ALAERH, ALAHD, ALASUM, DERRSY, DGET04, DLACPY, $ DLARHS, DLATB4, DLATMS, DPOT02, DPOT03, DPOT05, $ DSYCON, DSYRFS, DSYT01, DSYTRF, @@ -656,8 +655,6 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 160 CONTINUE 170 CONTINUE 180 CONTINUE -* - CALL DCHKSY_2X2( NOUT, NFAIL, NRUN ) * * Print a summary of the results. * diff --git a/TESTING/LIN/dchksy_2x2.f b/TESTING/LIN/dchksy_2x2.f deleted file mode 100644 index d870dabe7..000000000 --- a/TESTING/LIN/dchksy_2x2.f +++ /dev/null @@ -1,194 +0,0 @@ -*> \brief \b DCHKSY_2X2 checks extreme-scale 2-by-2 pivots. -*> -*> \par Purpose: -*> ============= -*> -*> \verbatim -*> Test factorization and solve with subnormal and near-overflow pivots, -*> using both triangles and the classic, rook, RK and packed routines. -*> Orders 3 and 130 exercise unblocked code and panels with NB = 64. -*> Each right-hand side is a column of A; the solution is a unit vector. -*> Subnormal cases are skipped if gradual underflow is unavailable. -*> Failures and test counts are added to NFAIL and NRUN, respectively. -*> \endverbatim -*> -*> \param[in] NOUT -*> Output unit for failure diagnostics. -*> \param[in,out] NFAIL -*> Number of failed tests. -*> \param[in,out] NRUN -*> Number of tests run. -*> - SUBROUTINE DCHKSY_2X2( NOUT, NFAIL, NRUN ) - IMPLICIT NONE - INTEGER NOUT, NFAIL, NRUN -* -* .. Parameters .. - INTEGER NMAX, NB, LWORK - PARAMETER ( NMAX = 130, NB = 64, LWORK = NMAX*NB ) - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -* .. Local Scalars .. - CHARACTER UPLO - CHARACTER*2 KIND - INTEGER I, J, II, JJ, IC, IFAM, IMETH, ISIZE, - $ IUPLO, K, N, NBOLD, ICOL, INFO - LOGICAL BAD - DOUBLE PRECISION BIG, SMALL, TOL, ERR -* .. Local Arrays .. - INTEGER IPIV( NMAX ) - DOUBLE PRECISION G( 3, 3 ), A( NMAX, NMAX ), B( NMAX ), - $ AP( NMAX*( NMAX+1 ) / 2 ), E( NMAX ), - $ WORK( LWORK ) -* .. External Functions .. - DOUBLE PRECISION DLAMCH - INTEGER ILAENV - EXTERNAL DLAMCH, ILAENV, XLAENV - EXTERNAL DSYTRF, DSYTRF_ROOK, DSYTRF_RK - EXTERNAL DSYTRS, DSYTRS_ROOK, DSYTRS_3 - EXTERNAL DSPTRF, DSPTRS -* - BIG = HUGE( ONE ) - SMALL = SCALE( TINY( ONE ), -10 ) - TOL = 128*DLAMCH( 'Epsilon' ) - NBOLD = ILAENV( 1, 'DSYTRF', 'L', NMAX, -1, -1, -1 ) - CALL XLAENV( 1, NB ) -* - DO IFAM = 1, 1 - KIND = 'SY' - DO IC = 1, 2 - IF( IC.EQ.1 .AND. ( SMALL.LE.ZERO .OR. - $ SMALL.GE.TINY( ONE ) ) ) CYCLE - G = ZERO - IF( IC.EQ.1 ) THEN -* 1 / (4*SMALL) overflows, but the multipliers are bounded. - G( 1, 1 ) = SMALL - G( 2, 2 ) = SMALL - G( 1, 2 ) = 4*SMALL - G( 1, 3 ) = SMALL - G( 2, 3 ) = SMALL - G( 3, 3 ) = ONE - ELSE IF( IC.EQ.2 ) THEN -* T*W overflows before division by the off-diagonal pivot. - G( 1, 1 ) = 0.5D0*BIG - G( 2, 2 ) = 0.5D0*BIG - G( 1, 2 ) = BIG - G( 2, 3 ) = 0.9D0*BIG - END IF - DO J = 1, 3 - DO I = 1, J - 1 - G( J, I ) = G( I, J ) - END DO - END DO - DO ISIZE = 1, 2 - N = 3 - IF( ISIZE.EQ.2 ) N = NMAX - DO IUPLO = 1, 2 - UPLO = 'L' - ICOL = 3 - IF( IUPLO.EQ.2 ) THEN - UPLO = 'U' - ICOL = N - 2 - END IF - DO IMETH = 1, 4 - A = ZERO - E = ZERO - DO I = 1, N - A( I, I ) = ONE - END DO - DO J = 1, 3 - DO I = 1, 3 - II = I - JJ = J - IF( IUPLO.EQ.2 ) THEN - II = N + 1 - I - JJ = N + 1 - J - END IF - A( II, JJ ) = G( I, J ) - END DO - END DO - B( 1:N ) = A( 1:N, ICOL ) - K = 0 - DO J = 1, N - DO I = 1, N - IF( ( UPLO.EQ.'U' .AND. I.LE.J ) .OR. - $ ( UPLO.EQ.'L' .AND. I.GE.J ) ) THEN - K = K + 1 - AP( K ) = A( I, J ) - END IF - END DO - END DO - IF( IMETH.EQ.1 ) THEN - CALL DSYTRF( UPLO, N, A, NMAX, IPIV, WORK, - $ LWORK, INFO ) - ELSE IF( IMETH.EQ.2 ) THEN - CALL DSYTRF_ROOK( UPLO, N, A, NMAX, IPIV, WORK, - $ LWORK, INFO ) - ELSE IF( IMETH.EQ.3 ) THEN - CALL DSYTRF_RK( UPLO, N, A, NMAX, E, IPIV, WORK, - $ LWORK, INFO ) - ELSE - CALL DSPTRF( UPLO, N, AP, IPIV, INFO ) - END IF - BAD = INFO.NE.0 -* Confirm a 2-by-2 pivot and reject nonfinite factors -* before passing them to the solve routine. - IF( UPLO.EQ.'L' ) THEN - BAD = BAD .OR. IPIV( 1 ).GE.0 - ELSE - BAD = BAD .OR. IPIV( N ).GE.0 - END IF - DO J = 1, N - DO I = 1, N - IF( .NOT.( ABS( A( I, J ) ).LE.BIG ) ) - $ BAD = .TRUE. - END DO - END DO - DO I = 1, K - IF( .NOT.( ABS( AP( I ) ).LE.BIG ) ) - $ BAD = .TRUE. - END DO - DO I = 1, N - IF( .NOT.( ABS( E( I ) ).LE.BIG ) ) - $ BAD = .TRUE. - END DO - IF( .NOT.BAD ) THEN - IF( IMETH.EQ.1 ) THEN - CALL DSYTRS( UPLO, N, 1, A, NMAX, IPIV, B, - $ NMAX, INFO ) - ELSE IF( IMETH.EQ.2 ) THEN - CALL DSYTRS_ROOK( UPLO, N, 1, A, NMAX, IPIV, - $ B, NMAX, INFO ) - ELSE IF( IMETH.EQ.3 ) THEN - CALL DSYTRS_3( UPLO, N, 1, A, NMAX, E, IPIV, - $ B, NMAX, INFO ) - ELSE - CALL DSPTRS( UPLO, N, 1, AP, IPIV, B, NMAX, - $ INFO ) - END IF - BAD = INFO.NE.0 - B( ICOL ) = B( ICOL ) - ONE - ERR = ZERO - DO I = 1, N - IF( .NOT.( ABS( B( I ) ).LE.BIG ) ) - $ BAD = .TRUE. - ERR = MAX( ERR, ABS( B( I ) ) ) - END DO - BAD = BAD .OR. .NOT.( ERR.LE.TOL ) - END IF - NRUN = NRUN + 1 - IF( BAD ) THEN - NFAIL = NFAIL + 1 - WRITE( NOUT, 9999 ) KIND, UPLO, N, IC, - $ IMETH, INFO - END IF - END DO - END DO - END DO - END DO - END DO - CALL XLAENV( 1, NBOLD ) - RETURN - 9999 FORMAT( ' DCHKSY_2X2: ', A2, ' UPLO=', A1, ' N=', I3, - $ ' case=', I1, ' method=', I1, ' INFO=', I3 ) - END diff --git a/TESTING/LIN/schksy.f b/TESTING/LIN/schksy.f index ccae972b6..a8de72ca6 100644 --- a/TESTING/LIN/schksy.f +++ b/TESTING/LIN/schksy.f @@ -214,7 +214,6 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, EXTERNAL SGET06, SLANSY * .. * .. External Subroutines .. - EXTERNAL SCHKSY_2X2 EXTERNAL ALAERH, ALAHD, ALASUM, SERRSY, SGET04, SLACPY, $ SLARHS, SLATB4, SLATMS, SPOT02, SPOT03, SPOT05, $ SSYCON, SSYRFS, SSYT01, SSYTRF, SSYTRI2, @@ -655,8 +654,6 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 160 CONTINUE 170 CONTINUE 180 CONTINUE -* - CALL SCHKSY_2X2( NOUT, NFAIL, NRUN ) * * Print a summary of the results. * diff --git a/TESTING/LIN/schksy_2x2.f b/TESTING/LIN/schksy_2x2.f deleted file mode 100644 index 54b33a017..000000000 --- a/TESTING/LIN/schksy_2x2.f +++ /dev/null @@ -1,194 +0,0 @@ -*> \brief \b SCHKSY_2X2 checks extreme-scale 2-by-2 pivots. -*> -*> \par Purpose: -*> ============= -*> -*> \verbatim -*> Test factorization and solve with subnormal and near-overflow pivots, -*> using both triangles and the classic, rook, RK and packed routines. -*> Orders 3 and 130 exercise unblocked code and panels with NB = 64. -*> Each right-hand side is a column of A; the solution is a unit vector. -*> Subnormal cases are skipped if gradual underflow is unavailable. -*> Failures and test counts are added to NFAIL and NRUN, respectively. -*> \endverbatim -*> -*> \param[in] NOUT -*> Output unit for failure diagnostics. -*> \param[in,out] NFAIL -*> Number of failed tests. -*> \param[in,out] NRUN -*> Number of tests run. -*> - SUBROUTINE SCHKSY_2X2( NOUT, NFAIL, NRUN ) - IMPLICIT NONE - INTEGER NOUT, NFAIL, NRUN -* -* .. Parameters .. - INTEGER NMAX, NB, LWORK - PARAMETER ( NMAX = 130, NB = 64, LWORK = NMAX*NB ) - REAL ONE, ZERO - PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) -* .. Local Scalars .. - CHARACTER UPLO - CHARACTER*2 KIND - INTEGER I, J, II, JJ, IC, IFAM, IMETH, ISIZE, - $ IUPLO, K, N, NBOLD, ICOL, INFO - LOGICAL BAD - REAL BIG, SMALL, TOL, ERR -* .. Local Arrays .. - INTEGER IPIV( NMAX ) - REAL G( 3, 3 ), A( NMAX, NMAX ), B( NMAX ), - $ AP( NMAX*( NMAX+1 ) / 2 ), E( NMAX ), - $ WORK( LWORK ) -* .. External Functions .. - REAL SLAMCH - INTEGER ILAENV - EXTERNAL SLAMCH, ILAENV, XLAENV - EXTERNAL SSYTRF, SSYTRF_ROOK, SSYTRF_RK - EXTERNAL SSYTRS, SSYTRS_ROOK, SSYTRS_3 - EXTERNAL SSPTRF, SSPTRS -* - BIG = HUGE( ONE ) - SMALL = SCALE( TINY( ONE ), -10 ) - TOL = 128*SLAMCH( 'Epsilon' ) - NBOLD = ILAENV( 1, 'SSYTRF', 'L', NMAX, -1, -1, -1 ) - CALL XLAENV( 1, NB ) -* - DO IFAM = 1, 1 - KIND = 'SY' - DO IC = 1, 2 - IF( IC.EQ.1 .AND. ( SMALL.LE.ZERO .OR. - $ SMALL.GE.TINY( ONE ) ) ) CYCLE - G = ZERO - IF( IC.EQ.1 ) THEN -* 1 / (4*SMALL) overflows, but the multipliers are bounded. - G( 1, 1 ) = SMALL - G( 2, 2 ) = SMALL - G( 1, 2 ) = 4*SMALL - G( 1, 3 ) = SMALL - G( 2, 3 ) = SMALL - G( 3, 3 ) = ONE - ELSE IF( IC.EQ.2 ) THEN -* T*W overflows before division by the off-diagonal pivot. - G( 1, 1 ) = 0.5E0*BIG - G( 2, 2 ) = 0.5E0*BIG - G( 1, 2 ) = BIG - G( 2, 3 ) = 0.9E0*BIG - END IF - DO J = 1, 3 - DO I = 1, J - 1 - G( J, I ) = G( I, J ) - END DO - END DO - DO ISIZE = 1, 2 - N = 3 - IF( ISIZE.EQ.2 ) N = NMAX - DO IUPLO = 1, 2 - UPLO = 'L' - ICOL = 3 - IF( IUPLO.EQ.2 ) THEN - UPLO = 'U' - ICOL = N - 2 - END IF - DO IMETH = 1, 4 - A = ZERO - E = ZERO - DO I = 1, N - A( I, I ) = ONE - END DO - DO J = 1, 3 - DO I = 1, 3 - II = I - JJ = J - IF( IUPLO.EQ.2 ) THEN - II = N + 1 - I - JJ = N + 1 - J - END IF - A( II, JJ ) = G( I, J ) - END DO - END DO - B( 1:N ) = A( 1:N, ICOL ) - K = 0 - DO J = 1, N - DO I = 1, N - IF( ( UPLO.EQ.'U' .AND. I.LE.J ) .OR. - $ ( UPLO.EQ.'L' .AND. I.GE.J ) ) THEN - K = K + 1 - AP( K ) = A( I, J ) - END IF - END DO - END DO - IF( IMETH.EQ.1 ) THEN - CALL SSYTRF( UPLO, N, A, NMAX, IPIV, WORK, - $ LWORK, INFO ) - ELSE IF( IMETH.EQ.2 ) THEN - CALL SSYTRF_ROOK( UPLO, N, A, NMAX, IPIV, WORK, - $ LWORK, INFO ) - ELSE IF( IMETH.EQ.3 ) THEN - CALL SSYTRF_RK( UPLO, N, A, NMAX, E, IPIV, WORK, - $ LWORK, INFO ) - ELSE - CALL SSPTRF( UPLO, N, AP, IPIV, INFO ) - END IF - BAD = INFO.NE.0 -* Confirm a 2-by-2 pivot and reject nonfinite factors -* before passing them to the solve routine. - IF( UPLO.EQ.'L' ) THEN - BAD = BAD .OR. IPIV( 1 ).GE.0 - ELSE - BAD = BAD .OR. IPIV( N ).GE.0 - END IF - DO J = 1, N - DO I = 1, N - IF( .NOT.( ABS( A( I, J ) ).LE.BIG ) ) - $ BAD = .TRUE. - END DO - END DO - DO I = 1, K - IF( .NOT.( ABS( AP( I ) ).LE.BIG ) ) - $ BAD = .TRUE. - END DO - DO I = 1, N - IF( .NOT.( ABS( E( I ) ).LE.BIG ) ) - $ BAD = .TRUE. - END DO - IF( .NOT.BAD ) THEN - IF( IMETH.EQ.1 ) THEN - CALL SSYTRS( UPLO, N, 1, A, NMAX, IPIV, B, - $ NMAX, INFO ) - ELSE IF( IMETH.EQ.2 ) THEN - CALL SSYTRS_ROOK( UPLO, N, 1, A, NMAX, IPIV, - $ B, NMAX, INFO ) - ELSE IF( IMETH.EQ.3 ) THEN - CALL SSYTRS_3( UPLO, N, 1, A, NMAX, E, IPIV, - $ B, NMAX, INFO ) - ELSE - CALL SSPTRS( UPLO, N, 1, AP, IPIV, B, NMAX, - $ INFO ) - END IF - BAD = INFO.NE.0 - B( ICOL ) = B( ICOL ) - ONE - ERR = ZERO - DO I = 1, N - IF( .NOT.( ABS( B( I ) ).LE.BIG ) ) - $ BAD = .TRUE. - ERR = MAX( ERR, ABS( B( I ) ) ) - END DO - BAD = BAD .OR. .NOT.( ERR.LE.TOL ) - END IF - NRUN = NRUN + 1 - IF( BAD ) THEN - NFAIL = NFAIL + 1 - WRITE( NOUT, 9999 ) KIND, UPLO, N, IC, - $ IMETH, INFO - END IF - END DO - END DO - END DO - END DO - END DO - CALL XLAENV( 1, NBOLD ) - RETURN - 9999 FORMAT( ' SCHKSY_2X2: ', A2, ' UPLO=', A1, ' N=', I3, - $ ' case=', I1, ' method=', I1, ' INFO=', I3 ) - END diff --git a/TESTING/LIN/zchksy.f b/TESTING/LIN/zchksy.f index edf513a0f..0c8c2c2b1 100644 --- a/TESTING/LIN/zchksy.f +++ b/TESTING/LIN/zchksy.f @@ -218,7 +218,6 @@ SUBROUTINE ZCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, EXTERNAL DGET06, ZLANSY * .. * .. External Subroutines .. - EXTERNAL ZCHKSY_2X2 EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, ZERRSY, ZGET04, $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZLATSY, ZPOT05, $ ZSYCON, ZSYRFS, ZSYT01, ZSYT02, ZSYT03, ZSYTRF, @@ -671,8 +670,6 @@ SUBROUTINE ZCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 160 CONTINUE 170 CONTINUE 180 CONTINUE -* - CALL ZCHKSY_2X2( NOUT, NFAIL, NRUN ) * * Print a summary of the results. * diff --git a/TESTING/LIN/zchksy_2x2.f b/TESTING/LIN/zchksy_2x2.f deleted file mode 100644 index 72fc89951..000000000 --- a/TESTING/LIN/zchksy_2x2.f +++ /dev/null @@ -1,287 +0,0 @@ -*> \brief \b ZCHKSY_2X2 checks extreme-scale 2-by-2 pivots. -*> -*> \par Purpose: -*> ============= -*> -*> \verbatim -*> Test factorization and solve with subnormal and near-overflow pivots, -*> using both triangles and the classic, rook, RK and packed routines. -*> Orders 3 and 130 exercise unblocked code and panels with NB = 64. -*> Each right-hand side is a column of A; the solution is a unit vector. -*> Subnormal cases are skipped if gradual underflow is unavailable. -*> Failures and test counts are added to NFAIL and NRUN, respectively. -*> \endverbatim -*> -*> \param[in] NOUT -*> Output unit for failure diagnostics. -*> \param[in,out] NFAIL -*> Number of failed tests. -*> \param[in,out] NRUN -*> Number of tests run. -*> - SUBROUTINE ZCHKSY_2X2( NOUT, NFAIL, NRUN ) - IMPLICIT NONE - INTEGER NOUT, NFAIL, NRUN -* -* .. Parameters .. - INTEGER NMAX, NB, LWORK - PARAMETER ( NMAX = 130, NB = 64, LWORK = NMAX*NB ) - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -* .. Local Scalars .. - CHARACTER UPLO - CHARACTER*2 KIND - INTEGER I, J, II, JJ, IC, IFAM, IMETH, ISIZE, - $ IUPLO, K, N, NBOLD, ICOL, INFO - LOGICAL BAD - DOUBLE PRECISION BIG, SMALL, TOL, ERR, MAG -* .. Local Arrays .. - INTEGER IPIV( NMAX ) - COMPLEX*16 G( 3, 3 ), A( NMAX, NMAX ), B( NMAX ), - $ AP( NMAX*( NMAX+1 ) / 2 ), E( NMAX ), - $ WORK( LWORK ) - COMPLEX*16 PHASE( 3 ) -* .. External Functions .. - DOUBLE PRECISION DLAMCH - INTEGER ILAENV - EXTERNAL DLAMCH, ILAENV, XLAENV - EXTERNAL ZSYTRF, ZSYTRF_ROOK, ZSYTRF_RK - EXTERNAL ZSYTRS, ZSYTRS_ROOK, ZSYTRS_3 - EXTERNAL ZHETRF, ZHETRF_ROOK, ZHETRF_RK - EXTERNAL ZHETRS, ZHETRS_ROOK, ZHETRS_3 - EXTERNAL ZSPTRF, ZSPTRS, ZHPTRF - EXTERNAL ZHPTRS -* - BIG = HUGE( ONE ) - SMALL = SCALE( TINY( ONE ), -10 ) - TOL = 128*DLAMCH( 'Epsilon' ) - NBOLD = ILAENV( 1, 'ZSYTRF', 'L', NMAX, -1, -1, -1 ) - CALL XLAENV( 1, NB ) -* - DO IFAM = 1, 2 - KIND = 'SY' - IF( IFAM.EQ.2 ) KIND = 'HE' - PHASE( 1 ) = ONE - PHASE( 2 ) = DCMPLX( ZERO, ONE ) - PHASE( 3 ) = -ONE - DO IC = 1, 7 - IF( IC.EQ.1 .AND. ( SMALL.LE.ZERO .OR. - $ SMALL.GE.TINY( ONE ) ) ) CYCLE - IF( IFAM.EQ.2 .AND. IC.GE.3 ) CYCLE - G = ZERO - IF( IC.EQ.1 ) THEN -* 1 / (4*SMALL) overflows, but the multipliers are bounded. - G( 1, 1 ) = SMALL - G( 2, 2 ) = SMALL - G( 1, 2 ) = 4*SMALL - G( 1, 3 ) = SMALL - G( 2, 3 ) = SMALL - G( 3, 3 ) = ONE - ELSE IF( IC.EQ.2 ) THEN -* T*W overflows before division by the off-diagonal pivot. - G( 1, 1 ) = 0.5D0*BIG - G( 2, 2 ) = 0.5D0*BIG - G( 1, 2 ) = BIG - G( 2, 3 ) = 0.9D0*BIG - ELSE -* The intrinsic complex division can overflow internally: -* (.53125 + .53125*i) / (-.5 - .5*i), both scaled by BIG. -* Also cover ordinary values and both reciprocal guards. - MAG = BIG - IF( IC.EQ.4 ) MAG = ONE - IF( IC.EQ.5 ) MAG = SQRT( DLAMCH( 'S' ) ) / 16 - IF( IC.EQ.6 ) MAG = 16 / SQRT( DLAMCH( 'S' ) ) - G( 1, 2 ) = DCMPLX( MAG / 8, -MAG / 8 ) - G( 1, 3 ) = DCMPLX( -MAG / 2, -MAG / 2 ) - G( 2, 3 ) = G( 1, 3 ) - G( 3, 3 ) = G( 1, 2 ) - IF( IC.EQ.7 ) THEN -* Moderate pivot, large numerator: a pivot-only guard -* would form (-1.2-.4*i)*(.9+.34*i)*BIG and overflow. - G( 1, 2 ) = DCMPLX( .75D0, -.25D0 ) - G( 1, 3 ) = DCMPLX( .4D0, .2D0 ) - G( 2, 2 ) = DCMPLX( .3D0, -.2D0 )*BIG - G( 2, 3 ) = DCMPLX( -.7D0, -.3D0 )*BIG - G( 3, 3 ) = DCMPLX( -.2D0, -.3D0 )*BIG - END IF - END IF - DO J = 1, 3 - DO I = 1, J - 1 - G( J, I ) = G( I, J ) - END DO - END DO - IF( IFAM.EQ.2 ) THEN -* Unitary diagonal scaling gives Hermitian imaginary pivots. - DO J = 1, 3 - DO I = 1, 3 - G( I, J ) = PHASE( I )*G( I, J )* - $ DCONJG( PHASE( J ) ) - END DO - END DO - END IF - DO ISIZE = 1, 2 - N = 3 - IF( ISIZE.EQ.2 ) N = NMAX - DO IUPLO = 1, 2 - UPLO = 'L' - ICOL = 3 - IF( IUPLO.EQ.2 ) THEN - UPLO = 'U' - ICOL = N - 2 - END IF - DO IMETH = 1, 4 - IF( IC.EQ.7 .AND. - $ ( IMETH.EQ.2 .OR. IMETH.EQ.3 ) ) CYCLE - A = ZERO - E = ZERO - DO I = 1, N - A( I, I ) = ONE - END DO - DO J = 1, 3 - DO I = 1, 3 - II = I - JJ = J - IF( IUPLO.EQ.2 ) THEN - II = N + 1 - I - JJ = N + 1 - J - END IF - A( II, JJ ) = G( I, J ) - END DO - END DO - B( 1:N ) = A( 1:N, ICOL ) - K = 0 - DO J = 1, N - DO I = 1, N - IF( ( UPLO.EQ.'U' .AND. I.LE.J ) .OR. - $ ( UPLO.EQ.'L' .AND. I.GE.J ) ) THEN - K = K + 1 - AP( K ) = A( I, J ) - END IF - END DO - END DO - IF( IFAM.EQ.1 ) THEN - IF( IMETH.EQ.1 ) THEN - CALL ZSYTRF( UPLO, N, A, NMAX, IPIV, WORK, - $ LWORK, INFO ) - ELSE IF( IMETH.EQ.2 ) THEN - CALL ZSYTRF_ROOK( UPLO, N, A, NMAX, IPIV, - $ WORK, LWORK, INFO ) - ELSE IF( IMETH.EQ.3 ) THEN - CALL ZSYTRF_RK( UPLO, N, A, NMAX, E, IPIV, - $ WORK, LWORK, INFO ) - ELSE - CALL ZSPTRF( UPLO, N, AP, IPIV, INFO ) - END IF - ELSE - IF( IMETH.EQ.1 ) THEN - CALL ZHETRF( UPLO, N, A, NMAX, IPIV, WORK, - $ LWORK, INFO ) - ELSE IF( IMETH.EQ.2 ) THEN - CALL ZHETRF_ROOK( UPLO, N, A, NMAX, IPIV, - $ WORK, LWORK, INFO ) - ELSE IF( IMETH.EQ.3 ) THEN - CALL ZHETRF_RK( UPLO, N, A, NMAX, E, IPIV, - $ WORK, LWORK, INFO ) - ELSE - CALL ZHPTRF( UPLO, N, AP, IPIV, INFO ) - END IF - END IF - BAD = INFO.NE.0 -* Confirm a 2-by-2 pivot and reject nonfinite factors -* before passing them to the solve routine. - IF( UPLO.EQ.'L' ) THEN - BAD = BAD .OR. IPIV( 1 ).GE.0 - ELSE - BAD = BAD .OR. IPIV( N ).GE.0 - END IF - DO J = 1, N - DO I = 1, N - IF( .NOT.( ABS( DBLE( A( I, J ) ) ).LE. - $ BIG .AND. ABS( DIMAG( A( I, J ) ) ).LE. - $ BIG ) ) BAD = .TRUE. - END DO - END DO - DO I = 1, K - IF( .NOT.( ABS( DBLE( AP( I ) ) ).LE. - $ BIG .AND. ABS( DIMAG( AP( I ) ) ).LE. - $ BIG ) ) BAD = .TRUE. - END DO - DO I = 1, N - IF( .NOT.( ABS( DBLE( E( I ) ) ).LE. - $ BIG .AND. ABS( DIMAG( E( I ) ) ).LE. - $ BIG ) ) BAD = .TRUE. - END DO - IF( IC.EQ.7 .AND. .NOT.BAD ) THEN -* This matrix is ill-conditioned; check the known -* multiplier instead of a forward solve error. - II = 3 - JJ = 1 - K = 3 - IF( UPLO.EQ.'U' ) THEN - II = N - 2 - JJ = N - K = N*( N-1 ) / 2 + N - 2 - END IF - WORK( 1 ) = A( II, JJ ) / BIG - IF( IMETH.EQ.4 ) WORK( 1 ) = AP( K ) / BIG - ERR = ABS( WORK( 1 )- - $ DCMPLX( -.944D0, -.768D0 ) ) - BAD = .NOT.( ERR.LE.TOL ) - END IF - IF( .NOT.BAD .AND. IC.NE.7 ) THEN - IF( IFAM.EQ.1 ) THEN - IF( IMETH.EQ.1 ) THEN - CALL ZSYTRS( UPLO, N, 1, A, NMAX, IPIV, B, - $ NMAX, INFO ) - ELSE IF( IMETH.EQ.2 ) THEN - CALL ZSYTRS_ROOK( UPLO, N, 1, A, NMAX, - $ IPIV, B, NMAX, INFO ) - ELSE IF( IMETH.EQ.3 ) THEN - CALL ZSYTRS_3( UPLO, N, 1, A, NMAX, E, - $ IPIV, B, NMAX, INFO ) - ELSE - CALL ZSPTRS( UPLO, N, 1, AP, IPIV, B, - $ NMAX, INFO ) - END IF - ELSE - IF( IMETH.EQ.1 ) THEN - CALL ZHETRS( UPLO, N, 1, A, NMAX, IPIV, B, - $ NMAX, INFO ) - ELSE IF( IMETH.EQ.2 ) THEN - CALL ZHETRS_ROOK( UPLO, N, 1, A, NMAX, - $ IPIV, B, NMAX, INFO ) - ELSE IF( IMETH.EQ.3 ) THEN - CALL ZHETRS_3( UPLO, N, 1, A, NMAX, E, - $ IPIV, B, NMAX, INFO ) - ELSE - CALL ZHPTRS( UPLO, N, 1, AP, IPIV, B, - $ NMAX, INFO ) - END IF - END IF - BAD = INFO.NE.0 - B( ICOL ) = B( ICOL ) - ONE - ERR = ZERO - DO I = 1, N - IF( .NOT.( ABS( DBLE( B( I ) ) ).LE. - $ BIG .AND. ABS( DIMAG( B( I ) ) ).LE. - $ BIG ) ) BAD = .TRUE. - ERR = MAX( ERR, ABS( B( I ) ) ) - END DO - BAD = BAD .OR. .NOT.( ERR.LE.TOL ) - END IF - NRUN = NRUN + 1 - IF( BAD ) THEN - NFAIL = NFAIL + 1 - WRITE( NOUT, 9999 ) KIND, UPLO, N, IC, - $ IMETH, INFO - END IF - END DO - END DO - END DO - END DO - END DO - CALL XLAENV( 1, NBOLD ) - RETURN - 9999 FORMAT( ' ZCHKSY_2X2: ', A2, ' UPLO=', A1, ' N=', I3, - $ ' case=', I1, ' method=', I1, ' INFO=', I3 ) - END From 6b2ba55f539cfb393569586d4e237b1c9622076d Mon Sep 17 00:00:00 2001 From: Rasmus Munk Larsen Date: Mon, 7 Sep 2026 21:39:09 -0700 Subject: [PATCH 4/4] Add a subnormal 2x2 pivot block to the symmetric-indefinite tests The matrix generator scales what it produces to the requested norm and xLATB4 asks for at most 1/(SFMIN/EPS), so no type of the SY path holds a 2x2 pivot block whose off-diagonal entry is subnormal, which is what the hoisted reciprocal T/d21 overflows on. Type 11 of xCHKSY takes the type 2 matrix, scales two adjacent rows and columns into the subnormal range, and gives them a 2 by 2 block with d11 = d22 = s and d21 = 4 s: the pivot test then chooses that block, and it sits at the end the factorization starts from, the last two indices for 'U' and the first two for 'L'. The reconstruction residual of xSYTRF is the test; on the parent commit it is a NaN for 24 of the shapes per precision, and a NaN is not .GE. THRESH, so the comparison that prints a failure now tests for one. Such a matrix is at the edge of the representable range, so only the factorization is meaningful: its inverse overflows whatever the pivot inversion does, and the reciprocal of its norm is not a condition estimate. The type therefore sets TRFCON, which is how the path already skips those tests, and skips the condition estimate as well. The complex full-storage path takes the same code with a complex d21, where the division computes |d21|^2 and returns before the reciprocal overflows, so the type is added for the real precisions only; the sweep in the pull request covers the packed and Hermitian routines. The test files declare the new xSCAL calls EXTERNAL: the extended-API build renames only the routines a file declares, so without the declaration xlintsts_64 and xlintstd_64 failed to link against the 64-bit BLAS. Co-Authored-By: Claude Fable 5.1 --- TESTING/LIN/alahd.f | 17 ++++++++++++++++- TESTING/LIN/dchkaa.F | 2 +- TESTING/LIN/dchksy.f | 43 ++++++++++++++++++++++++++++++++++++++---- TESTING/LIN/schkaa.F | 2 +- TESTING/LIN/schksy.f | 45 +++++++++++++++++++++++++++++++++++++++----- TESTING/dtest.in | 2 +- TESTING/stest.in | 2 +- 7 files changed, 99 insertions(+), 14 deletions(-) diff --git a/TESTING/LIN/alahd.f b/TESTING/LIN/alahd.f index b04a3f796..880effbeb 100644 --- a/TESTING/LIN/alahd.f +++ b/TESTING/LIN/alahd.f @@ -300,7 +300,7 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) END IF WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) IF( SORD ) THEN - WRITE( IOUNIT, FMT = 9972 ) + WRITE( IOUNIT, FMT = 7972 ) ELSE WRITE( IOUNIT, FMT = 9971 ) END IF @@ -913,6 +913,21 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) $ 'TRF, no test ratios are computed)' ) * * SSY, SSR, SSP, CHE, CHR, CHP matrix types +* +* +* SSY matrix types +* + 7972 FORMAT( 4X, '1. Diagonal', 24X, + $ '6. Last n/2 rows and columns zero', / 4X, + $ '2. Random, CNDNUM = 2', 14X, + $ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, + $ '3. First row and column zero', 7X, + $ '8. Random, CNDNUM = 0.1/EPS', / 4X, + $ '4. Last row and column zero', 8X, + $ '9. Scaled near underflow', / 4X, + $ '5. Middle row and column zero', 5X, + $ '10. Scaled near overflow', / 39X, + $ '11. Subnormal 2 by 2 pivot block' ) * 9972 FORMAT( 4X, '1. Diagonal', 24X, $ '6. Last n/2 rows and columns zero', / 4X, diff --git a/TESTING/LIN/dchkaa.F b/TESTING/LIN/dchkaa.F index d0f7dbcb4..ed5c7ab90 100644 --- a/TESTING/LIN/dchkaa.F +++ b/TESTING/LIN/dchkaa.F @@ -671,7 +671,7 @@ PROGRAM DCHKAA * SY: symmetric indefinite matrices, * with partial (Bunch-Kaufman) pivoting algorithm * - NTYPES = 10 + NTYPES = 11 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN diff --git a/TESTING/LIN/dchksy.f b/TESTING/LIN/dchksy.f index 4d9789e74..cf4fc5e4d 100644 --- a/TESTING/LIN/dchksy.f +++ b/TESTING/LIN/dchksy.f @@ -177,6 +177,7 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, LOGICAL TSTERR INTEGER NMAX, NN, NNB, NNS, NOUT DOUBLE PRECISION THRESH + DOUBLE PRECISION SUBNRM * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) @@ -190,8 +191,10 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) + DOUBLE PRECISION FOUR + PARAMETER ( FOUR = 4.0D+0 ) INTEGER NTYPES - PARAMETER ( NTYPES = 10 ) + PARAMETER ( NTYPES = 11 ) INTEGER NTESTS PARAMETER ( NTESTS = 9 ) * .. @@ -210,13 +213,16 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, DOUBLE PRECISION RESULT( NTESTS ) * .. * .. External Functions .. + LOGICAL DISNAN + DOUBLE PRECISION DLAMCH DOUBLE PRECISION DGET06, DLANSY EXTERNAL DGET06, DLANSY + EXTERNAL DISNAN, DLAMCH * .. * .. External Subroutines .. EXTERNAL ALAERH, ALAHD, ALASUM, DERRSY, DGET04, DLACPY, $ DLARHS, DLATB4, DLATMS, DPOT02, DPOT03, DPOT05, - $ DSYCON, DSYRFS, DSYT01, DSYTRF, + $ DSCAL, DSYCON, DSYRFS, DSYT01, DSYTRF, $ DSYTRI2, DSYTRS, DSYTRS2, XLAENV * .. * .. Intrinsic Functions .. @@ -387,6 +393,32 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, IZERO = 0 END IF * +* Type 11: scale two adjacent rows and columns into the +* subnormal range and give them a 2 by 2 pivot block whose +* off-diagonal entry is four times its diagonal, at the +* end the factorization starts from. Inverting that pivot +* through the reciprocal of the off-diagonal entry +* overflows. +* + IF( IMAT.EQ.11 .AND. N.GE.2 ) THEN + SUBNRM = DLAMCH( 'Safe minimum' ) / 512 + IF( IUPLO.EQ.1 ) THEN + I1 = N - 1 + ELSE + I1 = 1 + END IF + I2 = I1 + 1 + CALL DSCAL( N, SUBNRM, A( I1 ), LDA ) + CALL DSCAL( N, SUBNRM, A( I2 ), LDA ) + CALL DSCAL( N, SUBNRM, A( ( I1-1 )*LDA+1 ), 1 ) + CALL DSCAL( N, SUBNRM, A( ( I2-1 )*LDA+1 ), 1 ) + A( ( I1-1 )*LDA+I1 ) = SUBNRM + A( ( I2-1 )*LDA+I2 ) = SUBNRM + A( ( I2-1 )*LDA+I1 ) = FOUR*SUBNRM + A( ( I1-1 )*LDA+I2 ) = FOUR*SUBNRM + IZERO = 0 + END IF +* * End generate the test matrix A. * * Do for each value of NB in NBVAL @@ -440,7 +472,7 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * * Set the condition estimate flag if the INFO is not 0. * - IF( INFO.NE.0 ) THEN + IF( INFO.NE.0 .OR. IMAT.EQ.11 ) THEN TRFCON = .TRUE. ELSE TRFCON = .FALSE. @@ -485,7 +517,8 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * the threshold. * DO 110 K = 1, NT - IF( RESULT( K ).GE.THRESH ) THEN + IF( RESULT( K ).GE.THRESH .OR. + $ DISNAN( RESULT( K ) ) ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, @@ -624,6 +657,8 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * Get an estimate of RCOND = 1/CNDNUM. * 140 CONTINUE + IF( IMAT.EQ.11 ) + $ GO TO 150 ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK ) SRNAMT = 'DSYCON' CALL DSYCON( UPLO, N, AFAC, LDA, IWORK, ANORM, RCOND, diff --git a/TESTING/LIN/schkaa.F b/TESTING/LIN/schkaa.F index dd3f8de4b..bb5b0af2c 100644 --- a/TESTING/LIN/schkaa.F +++ b/TESTING/LIN/schkaa.F @@ -667,7 +667,7 @@ PROGRAM SCHKAA * SY: symmetric indefinite matrices, * with partial (Bunch-Kaufman) pivoting algorithm * - NTYPES = 10 + NTYPES = 11 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN diff --git a/TESTING/LIN/schksy.f b/TESTING/LIN/schksy.f index a8de72ca6..12f416df9 100644 --- a/TESTING/LIN/schksy.f +++ b/TESTING/LIN/schksy.f @@ -177,6 +177,7 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, LOGICAL TSTERR INTEGER NMAX, NN, NNB, NNS, NOUT REAL THRESH + REAL SUBNRM * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) @@ -190,8 +191,10 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) + REAL FOUR + PARAMETER ( FOUR = 4.0E+0 ) INTEGER NTYPES - PARAMETER ( NTYPES = 10 ) + PARAMETER ( NTYPES = 11 ) INTEGER NTESTS PARAMETER ( NTESTS = 9 ) * .. @@ -210,14 +213,17 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, REAL RESULT( NTESTS ) * .. * .. External Functions .. + LOGICAL SISNAN + REAL SLAMCH REAL SGET06, SLANSY EXTERNAL SGET06, SLANSY + EXTERNAL SISNAN, SLAMCH * .. * .. External Subroutines .. EXTERNAL ALAERH, ALAHD, ALASUM, SERRSY, SGET04, SLACPY, $ SLARHS, SLATB4, SLATMS, SPOT02, SPOT03, SPOT05, - $ SSYCON, SSYRFS, SSYT01, SSYTRF, SSYTRI2, - $ SSYTRS, SSYTRS2, XLAENV + $ SSCAL, SSYCON, SSYRFS, SSYT01, SSYTRF, + $ SSYTRI2, SSYTRS, SSYTRS2, XLAENV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -386,6 +392,32 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, IZERO = 0 END IF * +* Type 11: scale two adjacent rows and columns into the +* subnormal range and give them a 2 by 2 pivot block whose +* off-diagonal entry is four times its diagonal, at the +* end the factorization starts from. Inverting that pivot +* through the reciprocal of the off-diagonal entry +* overflows. +* + IF( IMAT.EQ.11 .AND. N.GE.2 ) THEN + SUBNRM = SLAMCH( 'Safe minimum' ) / 512 + IF( IUPLO.EQ.1 ) THEN + I1 = N - 1 + ELSE + I1 = 1 + END IF + I2 = I1 + 1 + CALL SSCAL( N, SUBNRM, A( I1 ), LDA ) + CALL SSCAL( N, SUBNRM, A( I2 ), LDA ) + CALL SSCAL( N, SUBNRM, A( ( I1-1 )*LDA+1 ), 1 ) + CALL SSCAL( N, SUBNRM, A( ( I2-1 )*LDA+1 ), 1 ) + A( ( I1-1 )*LDA+I1 ) = SUBNRM + A( ( I2-1 )*LDA+I2 ) = SUBNRM + A( ( I2-1 )*LDA+I1 ) = FOUR*SUBNRM + A( ( I1-1 )*LDA+I2 ) = FOUR*SUBNRM + IZERO = 0 + END IF +* * End generate the test matrix A. * * @@ -440,7 +472,7 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * * Set the condition estimate flag if the INFO is not 0. * - IF( INFO.NE.0 ) THEN + IF( INFO.NE.0 .OR. IMAT.EQ.11 ) THEN TRFCON = .TRUE. ELSE TRFCON = .FALSE. @@ -485,7 +517,8 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * the threshold. * DO 110 K = 1, NT - IF( RESULT( K ).GE.THRESH ) THEN + IF( RESULT( K ).GE.THRESH .OR. + $ SISNAN( RESULT( K ) ) ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, @@ -623,6 +656,8 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * Get an estimate of RCOND = 1/CNDNUM. * 140 CONTINUE + IF( IMAT.EQ.11 ) + $ GO TO 150 ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK ) SRNAMT = 'SSYCON' CALL SSYCON( UPLO, N, AFAC, LDA, IWORK, ANORM, RCOND, diff --git a/TESTING/dtest.in b/TESTING/dtest.in index cde62db50..34a6dd14b 100644 --- a/TESTING/dtest.in +++ b/TESTING/dtest.in @@ -22,7 +22,7 @@ DPS 9 List types on next line if 0 < NTYPES < 9 DPP 9 List types on next line if 0 < NTYPES < 9 DPB 8 List types on next line if 0 < NTYPES < 8 DPT 12 List types on next line if 0 < NTYPES < 12 -DSY 10 List types on next line if 0 < NTYPES < 10 +DSY 11 List types on next line if 0 < NTYPES < 11 DSR 10 List types on next line if 0 < NTYPES < 10 DSK 10 List types on next line if 0 < NTYPES < 10 DSA 10 List types on next line if 0 < NTYPES < 10 diff --git a/TESTING/stest.in b/TESTING/stest.in index abfd639fd..b95b4ed32 100644 --- a/TESTING/stest.in +++ b/TESTING/stest.in @@ -22,7 +22,7 @@ SPS 9 List types on next line if 0 < NTYPES < 9 SPP 9 List types on next line if 0 < NTYPES < 9 SPB 8 List types on next line if 0 < NTYPES < 8 SPT 12 List types on next line if 0 < NTYPES < 12 -SSY 10 List types on next line if 0 < NTYPES < 10 +SSY 11 List types on next line if 0 < NTYPES < 11 SSR 10 List types on next line if 0 < NTYPES < 10 SSK 10 List types on next line if 0 < NTYPES < 10 SSA 10 List types on next line if 0 < NTYPES < 10