From 3c263ddc269a4fcd2e69253aabf0841f33a4b738 Mon Sep 17 00:00:00 2001 From: Rasmus Munk Larsen Date: Mon, 7 Sep 2026 20:54:13 -0700 Subject: [PATCH 1/3] Guard against a NaN pivot in the packed, banded and tridiagonal Cholesky factorizations xPOTF2, xPOTRF2 and xPSTF2 reject a pivot with IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN Their packed, banded and tridiagonal counterparts xPPTRF, xPBTF2 and xPTTRF test AJJ.LE.ZERO (or D( I ).LE.ZERO) alone. A NaN is not .LE.ZERO, so a matrix containing one is factored into a NaN factor and returned with INFO = 0, and the drivers xPPSV, xPBSV and xPTSV return a NaN solution as success, where xPOSV reports the column. xPBTRF is also inconsistent with itself: for KD <= 64 ILAENV selects the unblocked xPBTF2 and the NaN passes; for KD > 64 the blocked path factors the diagonal blocks with xPOTF2 and catches it. No index depends on this test, so unlike the packed Bunch-Kaufman case (#1378) the routines stay in bounds; the defect is the silent INFO = 0. Add the DISNAN / SISNAN term at both sites of xPPTRF and xPBTF2 and at the six sites of xPTTRF, in all four precisions. The three test paths get a matrix type for it: PT 13, PP 10 and PB 9, each the generated matrix of the preceding type with a NaN written on its last diagonal entry and IZERO set to N, so that the existing check of INFO against IZERO covers it. That check reached ALAERH, which returns without a message when INFO is zero, so the case it has to report was the one it dropped; the three checkers now report an unexpected INFO = 0 themselves and leave the rest to ALAERH. On the parent commit the new types give 6 failures per precision for PT, 12 for PP and 88 for PB. Behavior is unchanged on matrices that contain no NaN: over a sweep of 6864 (precision, format, UPLO, KD, n, NaN position) cases the 528 finite-input factors are bit-identical to the parent commit, and INFO now agrees with xPOTRF on the same matrix in every NaN case, where before 5808 of 6336 disagreed. The full LAPACK test suite passes: 5441925 LAPACK and 315872 BLAS tests, 0 numerical errors, 0 other errors, 24 tests more than the parent commit from the new PT type. Co-Authored-By: Claude Fable 5.1 --- CMAKE/LAPACKTestHelpers.cmake | 8 +++---- SRC/cpbtf2.f | 8 +++---- SRC/cpptrf.f | 8 +++---- SRC/cpttrf.f | 16 ++++++++----- SRC/dpbtf2.f | 8 +++---- SRC/dpptrf.f | 8 +++---- SRC/dpttrf.f | 16 ++++++++----- SRC/spbtf2.f | 8 +++---- SRC/spptrf.f | 8 +++---- SRC/spttrf.f | 16 ++++++++----- SRC/zpbtf2.f | 8 +++---- SRC/zpptrf.f | 8 +++---- SRC/zpttrf.f | 16 ++++++++----- TESTING/LIN/CMakeLists.txt | 3 ++- TESTING/LIN/alahd.f | 7 ++++-- TESTING/LIN/cchkaa.F | 6 ++--- TESTING/LIN/cchkpb.f | 42 ++++++++++++++++++++++++++++++----- TESTING/LIN/cchkpp.f | 40 +++++++++++++++++++++++++++------ TESTING/LIN/cchkpt.f | 32 +++++++++++++++++++++----- TESTING/LIN/dchkaa.F | 6 ++--- TESTING/LIN/dchkpb.f | 42 ++++++++++++++++++++++++++++++----- TESTING/LIN/dchkpp.f | 40 +++++++++++++++++++++++++++------ TESTING/LIN/dchkpt.f | 32 +++++++++++++++++++++----- TESTING/LIN/schkaa.F | 6 ++--- TESTING/LIN/schkpb.f | 42 ++++++++++++++++++++++++++++++----- TESTING/LIN/schkpp.f | 40 +++++++++++++++++++++++++++------ TESTING/LIN/schkpt.f | 32 +++++++++++++++++++++----- TESTING/LIN/zchkaa.F | 6 ++--- TESTING/LIN/zchkpb.f | 42 ++++++++++++++++++++++++++++++----- TESTING/LIN/zchkpp.f | 40 +++++++++++++++++++++++++++------ TESTING/LIN/zchkpt.f | 32 +++++++++++++++++++++----- TESTING/ctest.in | 6 ++--- TESTING/dtest.in | 6 ++--- TESTING/stest.in | 6 ++--- TESTING/ztest.in | 6 ++--- 35 files changed, 491 insertions(+), 159 deletions(-) diff --git a/CMAKE/LAPACKTestHelpers.cmake b/CMAKE/LAPACKTestHelpers.cmake index 609f32045..5f44981c0 100644 --- a/CMAKE/LAPACKTestHelpers.cmake +++ b/CMAKE/LAPACKTestHelpers.cmake @@ -44,9 +44,9 @@ function(lapack_no_constant_propagation_flag out_var) endif() endfunction() -# Disable it for the ?errcxx drivers among ARGN, which manufacture their NaN -# with SQRT( -ONE ). Call this with every source list such a driver is built -# from: the generated _64 and _TEST copies need it as much as the originals. +# Disable it for the CXX error-exit and tridiagonal Cholesky tests among +# ARGN, which manufacture NaNs. Call this with every source list: the +# generated _64 and _TEST copies need it as much as the originals. function(lapack_nag_disable_constant_propagation) lapack_no_constant_propagation_flag(flag) if(NOT flag) @@ -54,7 +54,7 @@ function(lapack_nag_disable_constant_propagation) endif() foreach(source IN LISTS ARGN) get_filename_component(name "${source}" NAME) - if(name MATCHES "^[scdz]errcxx(_[A-Za-z0-9]+)*\\.f$") + if(name MATCHES "^[scdz](errcxx|chkpt)(_[A-Za-z0-9]+)*\\.f$") set_source_files_properties("${source}" PROPERTIES COMPILE_OPTIONS "${flag}") endif() diff --git a/SRC/cpbtf2.f b/SRC/cpbtf2.f index dbc399f70..4d135db8e 100644 --- a/SRC/cpbtf2.f +++ b/SRC/cpbtf2.f @@ -163,8 +163,8 @@ SUBROUTINE CPBTF2( UPLO, N, KD, AB, LDAB, INFO ) REAL AJJ * .. * .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME + LOGICAL LSAME, SISNAN + EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. EXTERNAL CHER, CLACGV, CSSCAL, XERBLA @@ -208,7 +208,7 @@ SUBROUTINE CPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * Compute U(J,J) and test for non-positive-definiteness. * AJJ = REAL( AB( KD+1, J ) ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.SISNAN( AJJ ) ) THEN AB( KD+1, J ) = AJJ GO TO 30 END IF @@ -236,7 +236,7 @@ SUBROUTINE CPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * Compute L(J,J) and test for non-positive-definiteness. * AJJ = REAL( AB( 1, J ) ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.SISNAN( AJJ ) ) THEN AB( 1, J ) = AJJ GO TO 30 END IF diff --git a/SRC/cpptrf.f b/SRC/cpptrf.f index 04a206bb0..7f8c28698 100644 --- a/SRC/cpptrf.f +++ b/SRC/cpptrf.f @@ -140,9 +140,9 @@ SUBROUTINE CPPTRF( UPLO, N, AP, INFO ) REAL AJJ * .. * .. External Functions .. - LOGICAL LSAME + LOGICAL LSAME, SISNAN COMPLEX CDOTC - EXTERNAL LSAME, CDOTC + EXTERNAL LSAME, CDOTC, SISNAN * .. * .. External Subroutines .. EXTERNAL CHPR, CSSCAL, CTPSV, XERBLA @@ -191,7 +191,7 @@ SUBROUTINE CPPTRF( UPLO, N, AP, INFO ) * AJJ = REAL( REAL( AP( JJ ) ) - CDOTC( J-1, $ AP( JC ), 1, AP( JC ), 1 ) ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.SISNAN( AJJ ) ) THEN AP( JJ ) = AJJ GO TO 30 END IF @@ -207,7 +207,7 @@ SUBROUTINE CPPTRF( UPLO, N, AP, INFO ) * Compute L(J,J) and test for non-positive-definiteness. * AJJ = REAL( AP( JJ ) ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.SISNAN( AJJ ) ) THEN AP( JJ ) = AJJ GO TO 30 END IF diff --git a/SRC/cpttrf.f b/SRC/cpttrf.f index 1d0da1199..ac46a50f3 100644 --- a/SRC/cpttrf.f +++ b/SRC/cpttrf.f @@ -111,6 +111,10 @@ SUBROUTINE CPTTRF( N, D, E, INFO ) INTEGER I, I4 REAL EII, EIR, F, G * .. +* .. External Functions .. + LOGICAL SISNAN + EXTERNAL SISNAN +* .. * .. External Subroutines .. EXTERNAL XERBLA * .. @@ -137,7 +141,7 @@ SUBROUTINE CPTTRF( N, D, E, INFO ) * I4 = MOD( N-1, 4 ) DO 10 I = 1, I4 - IF( D( I ).LE.ZERO ) THEN + IF( D( I ).LE.ZERO.OR.SISNAN( D( I ) ) ) THEN INFO = I GO TO 20 END IF @@ -154,7 +158,7 @@ SUBROUTINE CPTTRF( N, D, E, INFO ) * Drop out of the loop if d(i) <= 0: the matrix is not positive * definite. * - IF( D( I ).LE.ZERO ) THEN + IF( D( I ).LE.ZERO.OR.SISNAN( D( I ) ) ) THEN INFO = I GO TO 20 END IF @@ -168,7 +172,7 @@ SUBROUTINE CPTTRF( N, D, E, INFO ) E( I ) = CMPLX( F, G ) D( I+1 ) = D( I+1 ) - F*EIR - G*EII * - IF( D( I+1 ).LE.ZERO ) THEN + IF( D( I+1 ).LE.ZERO.OR.SISNAN( D( I+1 ) ) ) THEN INFO = I+1 GO TO 20 END IF @@ -182,7 +186,7 @@ SUBROUTINE CPTTRF( N, D, E, INFO ) E( I+1 ) = CMPLX( F, G ) D( I+2 ) = D( I+2 ) - F*EIR - G*EII * - IF( D( I+2 ).LE.ZERO ) THEN + IF( D( I+2 ).LE.ZERO.OR.SISNAN( D( I+2 ) ) ) THEN INFO = I+2 GO TO 20 END IF @@ -196,7 +200,7 @@ SUBROUTINE CPTTRF( N, D, E, INFO ) E( I+2 ) = CMPLX( F, G ) D( I+3 ) = D( I+3 ) - F*EIR - G*EII * - IF( D( I+3 ).LE.ZERO ) THEN + IF( D( I+3 ).LE.ZERO.OR.SISNAN( D( I+3 ) ) ) THEN INFO = I+3 GO TO 20 END IF @@ -213,7 +217,7 @@ SUBROUTINE CPTTRF( N, D, E, INFO ) * * Check d(n) for positive definiteness. * - IF( D( N ).LE.ZERO ) + IF( D( N ).LE.ZERO.OR.SISNAN( D( N ) ) ) $ INFO = N * 20 CONTINUE diff --git a/SRC/dpbtf2.f b/SRC/dpbtf2.f index 9a477228a..31d55d3c2 100644 --- a/SRC/dpbtf2.f +++ b/SRC/dpbtf2.f @@ -163,8 +163,8 @@ SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) DOUBLE PRECISION AJJ * .. * .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME + LOGICAL LSAME, DISNAN + EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. EXTERNAL DSCAL, DSYR, XERBLA @@ -208,7 +208,7 @@ SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * Compute U(J,J) and test for non-positive-definiteness. * AJJ = AB( KD+1, J ) - IF( AJJ.LE.ZERO ) + IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) $ GO TO 30 AJJ = SQRT( AJJ ) AB( KD+1, J ) = AJJ @@ -232,7 +232,7 @@ SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * Compute L(J,J) and test for non-positive-definiteness. * AJJ = AB( 1, J ) - IF( AJJ.LE.ZERO ) + IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) $ GO TO 30 AJJ = SQRT( AJJ ) AB( 1, J ) = AJJ diff --git a/SRC/dpptrf.f b/SRC/dpptrf.f index c606a7a9d..6f6fd6dd0 100644 --- a/SRC/dpptrf.f +++ b/SRC/dpptrf.f @@ -140,9 +140,9 @@ SUBROUTINE DPPTRF( UPLO, N, AP, INFO ) DOUBLE PRECISION AJJ * .. * .. External Functions .. - LOGICAL LSAME + LOGICAL LSAME, DISNAN DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT + EXTERNAL LSAME, DDOT, DISNAN * .. * .. External Subroutines .. EXTERNAL DSCAL, DSPR, DTPSV, XERBLA @@ -189,7 +189,7 @@ SUBROUTINE DPPTRF( UPLO, N, AP, INFO ) * Compute U(J,J) and test for non-positive-definiteness. * AJJ = AP( JJ ) - DDOT( J-1, AP( JC ), 1, AP( JC ), 1 ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN AP( JJ ) = AJJ GO TO 30 END IF @@ -205,7 +205,7 @@ SUBROUTINE DPPTRF( UPLO, N, AP, INFO ) * Compute L(J,J) and test for non-positive-definiteness. * AJJ = AP( JJ ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN AP( JJ ) = AJJ GO TO 30 END IF diff --git a/SRC/dpttrf.f b/SRC/dpttrf.f index 59dd4b57b..9a01fbe30 100644 --- a/SRC/dpttrf.f +++ b/SRC/dpttrf.f @@ -109,6 +109,10 @@ SUBROUTINE DPTTRF( N, D, E, INFO ) INTEGER I, I4 DOUBLE PRECISION EI * .. +* .. External Functions .. + LOGICAL DISNAN + EXTERNAL DISNAN +* .. * .. External Subroutines .. EXTERNAL XERBLA * .. @@ -135,7 +139,7 @@ SUBROUTINE DPTTRF( N, D, E, INFO ) * I4 = MOD( N-1, 4 ) DO 10 I = 1, I4 - IF( D( I ).LE.ZERO ) THEN + IF( D( I ).LE.ZERO.OR.DISNAN( D( I ) ) ) THEN INFO = I GO TO 30 END IF @@ -149,7 +153,7 @@ SUBROUTINE DPTTRF( N, D, E, INFO ) * Drop out of the loop if d(i) <= 0: the matrix is not positive * definite. * - IF( D( I ).LE.ZERO ) THEN + IF( D( I ).LE.ZERO.OR.DISNAN( D( I ) ) ) THEN INFO = I GO TO 30 END IF @@ -160,7 +164,7 @@ SUBROUTINE DPTTRF( N, D, E, INFO ) E( I ) = EI / D( I ) D( I+1 ) = D( I+1 ) - E( I )*EI * - IF( D( I+1 ).LE.ZERO ) THEN + IF( D( I+1 ).LE.ZERO.OR.DISNAN( D( I+1 ) ) ) THEN INFO = I + 1 GO TO 30 END IF @@ -171,7 +175,7 @@ SUBROUTINE DPTTRF( N, D, E, INFO ) E( I+1 ) = EI / D( I+1 ) D( I+2 ) = D( I+2 ) - E( I+1 )*EI * - IF( D( I+2 ).LE.ZERO ) THEN + IF( D( I+2 ).LE.ZERO.OR.DISNAN( D( I+2 ) ) ) THEN INFO = I + 2 GO TO 30 END IF @@ -182,7 +186,7 @@ SUBROUTINE DPTTRF( N, D, E, INFO ) E( I+2 ) = EI / D( I+2 ) D( I+3 ) = D( I+3 ) - E( I+2 )*EI * - IF( D( I+3 ).LE.ZERO ) THEN + IF( D( I+3 ).LE.ZERO.OR.DISNAN( D( I+3 ) ) ) THEN INFO = I + 3 GO TO 30 END IF @@ -196,7 +200,7 @@ SUBROUTINE DPTTRF( N, D, E, INFO ) * * Check d(n) for positive definiteness. * - IF( D( N ).LE.ZERO ) + IF( D( N ).LE.ZERO.OR.DISNAN( D( N ) ) ) $ INFO = N * 30 CONTINUE diff --git a/SRC/spbtf2.f b/SRC/spbtf2.f index 2dffd522f..9dd6c61c6 100644 --- a/SRC/spbtf2.f +++ b/SRC/spbtf2.f @@ -163,8 +163,8 @@ SUBROUTINE SPBTF2( UPLO, N, KD, AB, LDAB, INFO ) REAL AJJ * .. * .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME + LOGICAL LSAME, SISNAN + EXTERNAL LSAME, SISNAN * .. * .. External Subroutines .. EXTERNAL SSCAL, SSYR, XERBLA @@ -208,7 +208,7 @@ SUBROUTINE SPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * Compute U(J,J) and test for non-positive-definiteness. * AJJ = AB( KD+1, J ) - IF( AJJ.LE.ZERO ) + IF( AJJ.LE.ZERO.OR.SISNAN( AJJ ) ) $ GO TO 30 AJJ = SQRT( AJJ ) AB( KD+1, J ) = AJJ @@ -232,7 +232,7 @@ SUBROUTINE SPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * Compute L(J,J) and test for non-positive-definiteness. * AJJ = AB( 1, J ) - IF( AJJ.LE.ZERO ) + IF( AJJ.LE.ZERO.OR.SISNAN( AJJ ) ) $ GO TO 30 AJJ = SQRT( AJJ ) AB( 1, J ) = AJJ diff --git a/SRC/spptrf.f b/SRC/spptrf.f index 89646f06d..1b333e725 100644 --- a/SRC/spptrf.f +++ b/SRC/spptrf.f @@ -140,9 +140,9 @@ SUBROUTINE SPPTRF( UPLO, N, AP, INFO ) REAL AJJ * .. * .. External Functions .. - LOGICAL LSAME + LOGICAL LSAME, SISNAN REAL SDOT - EXTERNAL LSAME, SDOT + EXTERNAL LSAME, SDOT, SISNAN * .. * .. External Subroutines .. EXTERNAL SSCAL, SSPR, STPSV, XERBLA @@ -189,7 +189,7 @@ SUBROUTINE SPPTRF( UPLO, N, AP, INFO ) * Compute U(J,J) and test for non-positive-definiteness. * AJJ = AP( JJ ) - SDOT( J-1, AP( JC ), 1, AP( JC ), 1 ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.SISNAN( AJJ ) ) THEN AP( JJ ) = AJJ GO TO 30 END IF @@ -205,7 +205,7 @@ SUBROUTINE SPPTRF( UPLO, N, AP, INFO ) * Compute L(J,J) and test for non-positive-definiteness. * AJJ = AP( JJ ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.SISNAN( AJJ ) ) THEN AP( JJ ) = AJJ GO TO 30 END IF diff --git a/SRC/spttrf.f b/SRC/spttrf.f index da2d0a6b1..10751bc0e 100644 --- a/SRC/spttrf.f +++ b/SRC/spttrf.f @@ -109,6 +109,10 @@ SUBROUTINE SPTTRF( N, D, E, INFO ) INTEGER I, I4 REAL EI * .. +* .. External Functions .. + LOGICAL SISNAN + EXTERNAL SISNAN +* .. * .. External Subroutines .. EXTERNAL XERBLA * .. @@ -135,7 +139,7 @@ SUBROUTINE SPTTRF( N, D, E, INFO ) * I4 = MOD( N-1, 4 ) DO 10 I = 1, I4 - IF( D( I ).LE.ZERO ) THEN + IF( D( I ).LE.ZERO.OR.SISNAN( D( I ) ) ) THEN INFO = I GO TO 30 END IF @@ -149,7 +153,7 @@ SUBROUTINE SPTTRF( N, D, E, INFO ) * Drop out of the loop if d(i) <= 0: the matrix is not positive * definite. * - IF( D( I ).LE.ZERO ) THEN + IF( D( I ).LE.ZERO.OR.SISNAN( D( I ) ) ) THEN INFO = I GO TO 30 END IF @@ -160,7 +164,7 @@ SUBROUTINE SPTTRF( N, D, E, INFO ) E( I ) = EI / D( I ) D( I+1 ) = D( I+1 ) - E( I )*EI * - IF( D( I+1 ).LE.ZERO ) THEN + IF( D( I+1 ).LE.ZERO.OR.SISNAN( D( I+1 ) ) ) THEN INFO = I + 1 GO TO 30 END IF @@ -171,7 +175,7 @@ SUBROUTINE SPTTRF( N, D, E, INFO ) E( I+1 ) = EI / D( I+1 ) D( I+2 ) = D( I+2 ) - E( I+1 )*EI * - IF( D( I+2 ).LE.ZERO ) THEN + IF( D( I+2 ).LE.ZERO.OR.SISNAN( D( I+2 ) ) ) THEN INFO = I + 2 GO TO 30 END IF @@ -182,7 +186,7 @@ SUBROUTINE SPTTRF( N, D, E, INFO ) E( I+2 ) = EI / D( I+2 ) D( I+3 ) = D( I+3 ) - E( I+2 )*EI * - IF( D( I+3 ).LE.ZERO ) THEN + IF( D( I+3 ).LE.ZERO.OR.SISNAN( D( I+3 ) ) ) THEN INFO = I + 3 GO TO 30 END IF @@ -196,7 +200,7 @@ SUBROUTINE SPTTRF( N, D, E, INFO ) * * Check d(n) for positive definiteness. * - IF( D( N ).LE.ZERO ) + IF( D( N ).LE.ZERO.OR.SISNAN( D( N ) ) ) $ INFO = N * 30 CONTINUE diff --git a/SRC/zpbtf2.f b/SRC/zpbtf2.f index 7002eb549..67d664278 100644 --- a/SRC/zpbtf2.f +++ b/SRC/zpbtf2.f @@ -163,8 +163,8 @@ SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO ) DOUBLE PRECISION AJJ * .. * .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME + LOGICAL LSAME, DISNAN + EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDSCAL, ZHER, ZLACGV @@ -208,7 +208,7 @@ SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * Compute U(J,J) and test for non-positive-definiteness. * AJJ = DBLE( AB( KD+1, J ) ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN AB( KD+1, J ) = AJJ GO TO 30 END IF @@ -236,7 +236,7 @@ SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * Compute L(J,J) and test for non-positive-definiteness. * AJJ = DBLE( AB( 1, J ) ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN AB( 1, J ) = AJJ GO TO 30 END IF diff --git a/SRC/zpptrf.f b/SRC/zpptrf.f index e40af1e57..aae5905d6 100644 --- a/SRC/zpptrf.f +++ b/SRC/zpptrf.f @@ -140,9 +140,9 @@ SUBROUTINE ZPPTRF( UPLO, N, AP, INFO ) DOUBLE PRECISION AJJ * .. * .. External Functions .. - LOGICAL LSAME + LOGICAL LSAME, DISNAN COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC + EXTERNAL LSAME, ZDOTC, DISNAN * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDSCAL, ZHPR, ZTPSV @@ -191,7 +191,7 @@ SUBROUTINE ZPPTRF( UPLO, N, AP, INFO ) * AJJ = DBLE( AP( JJ ) ) - DBLE( ZDOTC( J-1, $ AP( JC ), 1, AP( JC ), 1 ) ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN AP( JJ ) = AJJ GO TO 30 END IF @@ -207,7 +207,7 @@ SUBROUTINE ZPPTRF( UPLO, N, AP, INFO ) * Compute L(J,J) and test for non-positive-definiteness. * AJJ = DBLE( AP( JJ ) ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN AP( JJ ) = AJJ GO TO 30 END IF diff --git a/SRC/zpttrf.f b/SRC/zpttrf.f index d40c4b8ee..786122c5f 100644 --- a/SRC/zpttrf.f +++ b/SRC/zpttrf.f @@ -111,6 +111,10 @@ SUBROUTINE ZPTTRF( N, D, E, INFO ) INTEGER I, I4 DOUBLE PRECISION EII, EIR, F, G * .. +* .. External Functions .. + LOGICAL DISNAN + EXTERNAL DISNAN +* .. * .. External Subroutines .. EXTERNAL XERBLA * .. @@ -137,7 +141,7 @@ SUBROUTINE ZPTTRF( N, D, E, INFO ) * I4 = MOD( N-1, 4 ) DO 10 I = 1, I4 - IF( D( I ).LE.ZERO ) THEN + IF( D( I ).LE.ZERO.OR.DISNAN( D( I ) ) ) THEN INFO = I GO TO 30 END IF @@ -154,7 +158,7 @@ SUBROUTINE ZPTTRF( N, D, E, INFO ) * Drop out of the loop if d(i) <= 0: the matrix is not positive * definite. * - IF( D( I ).LE.ZERO ) THEN + IF( D( I ).LE.ZERO.OR.DISNAN( D( I ) ) ) THEN INFO = I GO TO 30 END IF @@ -168,7 +172,7 @@ SUBROUTINE ZPTTRF( N, D, E, INFO ) E( I ) = DCMPLX( F, G ) D( I+1 ) = D( I+1 ) - F*EIR - G*EII * - IF( D( I+1 ).LE.ZERO ) THEN + IF( D( I+1 ).LE.ZERO.OR.DISNAN( D( I+1 ) ) ) THEN INFO = I + 1 GO TO 30 END IF @@ -182,7 +186,7 @@ SUBROUTINE ZPTTRF( N, D, E, INFO ) E( I+1 ) = DCMPLX( F, G ) D( I+2 ) = D( I+2 ) - F*EIR - G*EII * - IF( D( I+2 ).LE.ZERO ) THEN + IF( D( I+2 ).LE.ZERO.OR.DISNAN( D( I+2 ) ) ) THEN INFO = I + 2 GO TO 30 END IF @@ -196,7 +200,7 @@ SUBROUTINE ZPTTRF( N, D, E, INFO ) E( I+2 ) = DCMPLX( F, G ) D( I+3 ) = D( I+3 ) - F*EIR - G*EII * - IF( D( I+3 ).LE.ZERO ) THEN + IF( D( I+3 ).LE.ZERO.OR.DISNAN( D( I+3 ) ) ) THEN INFO = I + 3 GO TO 30 END IF @@ -213,7 +217,7 @@ SUBROUTINE ZPTTRF( N, D, E, INFO ) * * Check d(n) for positive definiteness. * - IF( D( N ).LE.ZERO ) + IF( D( N ).LE.ZERO.OR.DISNAN( D( N ) ) ) $ INFO = N * 30 CONTINUE diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt index 2313fa0c4..4b0c0aa61 100644 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -222,7 +222,8 @@ else() endif() lapack_nag_disable_constant_propagation( - serrcxx.f cerrcxx.f derrcxx.f zerrcxx.f) + serrcxx.f cerrcxx.f derrcxx.f zerrcxx.f + schkpt.f cchkpt.f dchkpt.f zchkpt.f) set(DSLINTST dchkab.f ddrvab.f ddrvac.f derrab.f derrac.f dget08.f diff --git a/TESTING/LIN/alahd.f b/TESTING/LIN/alahd.f index b04a3f796..55338096c 100644 --- a/TESTING/LIN/alahd.f +++ b/TESTING/LIN/alahd.f @@ -857,7 +857,8 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) $ '10. Middle row and column zero', / 4X, $ '5. Scaled near underflow', 10X, $ '11. Scaled near underflow', / 4X, - $ '6. Scaled near overflow', 11X, '12. Scaled near overflow' ) + $ '6. Scaled near overflow', 11X, '12. Scaled near overflow', + $ / 39X, '13. Last diagonal entry a NaN' ) * * PO, PP matrix types * @@ -868,7 +869,8 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) $ '8. Scaled near underflow', / 3X, $ '*4. Last row and column zero', 8X, $ '9. Scaled near overflow', / 3X, - $ '*5. Middle row and column zero', / 3X, + $ '*5. Middle row and column zero', 6X, + $ '10. Last diagonal entry a NaN', / 3X, $ '(* - tests error exits from ', A3, $ 'TRF, no test ratios are computed)' ) * @@ -909,6 +911,7 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) $ '7. Scaled near underflow', / 3X, $ '*4. Middle row and column zero', 6X, $ '8. Scaled near overflow', / 3X, + $ '*9. Last diagonal entry a NaN', / 3X, $ '(* - tests error exits from ', A3, $ 'TRF, no test ratios are computed)' ) * diff --git a/TESTING/LIN/cchkaa.F b/TESTING/LIN/cchkaa.F index ac181df8c..59af6c3f5 100644 --- a/TESTING/LIN/cchkaa.F +++ b/TESTING/LIN/cchkaa.F @@ -601,7 +601,7 @@ PROGRAM CCHKAA * * PP: positive definite packed matrices * - NTYPES = 9 + NTYPES = 10 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN @@ -626,7 +626,7 @@ PROGRAM CCHKAA * * PB: positive definite banded matrices * - NTYPES = 8 + NTYPES = 9 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN @@ -651,7 +651,7 @@ PROGRAM CCHKAA * * PT: positive definite tridiagonal matrices * - NTYPES = 12 + NTYPES = 13 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN diff --git a/TESTING/LIN/cchkpb.f b/TESTING/LIN/cchkpb.f index 877e88d6a..53c92c2cf 100644 --- a/TESTING/LIN/cchkpb.f +++ b/TESTING/LIN/cchkpb.f @@ -190,7 +190,7 @@ SUBROUTINE CCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) INTEGER NTYPES, NTESTS - PARAMETER ( NTYPES = 8, NTESTS = 7 ) + PARAMETER ( NTYPES = 9, NTESTS = 7 ) INTEGER NBW PARAMETER ( NBW = 4 ) * .. @@ -203,6 +203,7 @@ SUBROUTINE CCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ LDA, LDAB, MODE, N, NB, NERRS, NFAIL, NIMAT, $ NKD, NRHS, NRUN REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC + REAL RNAN, RONE * .. * .. Local Arrays .. INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW ) @@ -219,7 +220,7 @@ SUBROUTINE CCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ CPBTRS, CSWAP, XLAENV * .. * .. Intrinsic Functions .. - INTRINSIC CMPLX, MAX, MIN + INTRINSIC CMPLX, MAX, MIN, SQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -401,6 +402,22 @@ SUBROUTINE CCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, CALL CLAIPD( N, A( 1 ), LDAB, 0 ) END IF * +* Type 9: put a NaN on the last diagonal entry. The +* factorization must report it like a nonpositive +* pivot. +* + IF( IMAT.EQ.9 ) THEN + IZERO = N + RONE = ONE + RNAN = SQRT( -RONE ) + IF( IUPLO.EQ.1 ) THEN + IOFF = ( N-1 )*LDAB + KD + 1 + ELSE + IOFF = ( N-1 )*LDAB + 1 + END IF + A( IOFF ) = RNAN + END IF +* * Do for each value of NB in NBVAL * DO 50 INB = 1, NNB @@ -414,12 +431,22 @@ SUBROUTINE CCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, SRNAMT = 'CPBTRF' CALL CPBTRF( UPLO, N, KD, AFAC, LDAB, INFO ) * -* Check error code from CPBTRF. +* Check error code from CPBTRF. ALAERH returns +* without a message when INFO is zero, so an +* undetected bad pivot is reported here instead. * IF( INFO.NE.IZERO ) THEN - CALL ALAERH( PATH, 'CPBTRF', INFO, IZERO, UPLO, - $ N, N, KD, KD, NB, IMAT, NFAIL, - $ NERRS, NOUT ) + IF( INFO.EQ.0 ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9996 )'CPBTRF', IZERO, + $ UPLO, N, KD, IMAT + NFAIL = NFAIL + 1 + ELSE + CALL ALAERH( PATH, 'CPBTRF', INFO, IZERO, + $ UPLO, N, N, KD, KD, NB, IMAT, + $ NFAIL, NERRS, NOUT ) + END IF GO TO 50 END IF * @@ -585,6 +612,9 @@ SUBROUTINE CCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ ', type ', I2, ', test(', I2, ') = ', G12.5 ) 9997 FORMAT( ' UPLO=''', A1, ''', N=', I5, ', KD=', I5, ',', 10X, $ ' type ', I2, ', test(', I2, ') = ', G12.5 ) + 9996 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, + $ ' for UPLO=''', A1, ''', N=', I5, ', KD=', I5, + $ ', type ', I2 ) RETURN * * End of CCHKPB diff --git a/TESTING/LIN/cchkpp.f b/TESTING/LIN/cchkpp.f index 98c108d9f..412e77ddf 100644 --- a/TESTING/LIN/cchkpp.f +++ b/TESTING/LIN/cchkpp.f @@ -178,10 +178,10 @@ SUBROUTINE CCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * ===================================================================== * * .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) INTEGER NTYPES - PARAMETER ( NTYPES = 9 ) + PARAMETER ( NTYPES = 10 ) INTEGER NTESTS PARAMETER ( NTESTS = 8 ) * .. @@ -193,6 +193,7 @@ SUBROUTINE CCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT, NPP, $ NRHS, NRUN REAL ANORM, CNDNUM, RCOND, RCONDC + REAL RNAN, RONE * .. * .. Local Arrays .. CHARACTER PACKS( 2 ), UPLOS( 2 ) @@ -219,7 +220,7 @@ SUBROUTINE CCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, COMMON / SRNAMC / SRNAMT * .. * .. Intrinsic Functions .. - INTRINSIC MAX + INTRINSIC MAX, SQRT * .. * .. Data statements .. DATA ISEEDY / 1988, 1989, 1990, 1991 / @@ -331,6 +332,18 @@ SUBROUTINE CCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, IZERO = 0 END IF * +* Type 10: put a NaN on the last diagonal entry, which is +* the last entry of the packed array for both values of +* UPLO. The factorization must report it like a +* nonpositive pivot. +* + IF( IMAT.EQ.10 ) THEN + IZERO = N + RONE = ONE + RNAN = SQRT( -RONE ) + A( N*( N+1 ) / 2 ) = RNAN + END IF +* * Set the imaginary part of the diagonals. * IF( IUPLO.EQ.1 ) THEN @@ -346,11 +359,22 @@ SUBROUTINE CCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, SRNAMT = 'CPPTRF' CALL CPPTRF( UPLO, N, AFAC, INFO ) * -* Check error code from CPPTRF. +* Check error code from CPPTRF. ALAERH returns without a +* message when INFO is zero, so an undetected bad pivot is +* reported here instead. * IF( INFO.NE.IZERO ) THEN - CALL ALAERH( PATH, 'CPPTRF', INFO, IZERO, UPLO, N, N, - $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + IF( INFO.EQ.0 ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )'CPPTRF', IZERO, UPLO, N, + $ IMAT + NFAIL = NFAIL + 1 + ELSE + CALL ALAERH( PATH, 'CPPTRF', INFO, IZERO, UPLO, N, + $ N, -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + END IF GO TO 90 END IF * @@ -502,6 +526,8 @@ SUBROUTINE CCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ I2, ', ratio =', G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, + $ ' for UPLO = ''', A1, ''', N =', I5, ', type ', I2 ) RETURN * * End of CCHKPP diff --git a/TESTING/LIN/cchkpt.f b/TESTING/LIN/cchkpt.f index 16ccca2c2..876690cef 100644 --- a/TESTING/LIN/cchkpt.f +++ b/TESTING/LIN/cchkpt.f @@ -169,7 +169,7 @@ SUBROUTINE CCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) INTEGER NTYPES - PARAMETER ( NTYPES = 12 ) + PARAMETER ( NTYPES = 13 ) INTEGER NTESTS PARAMETER ( NTESTS = 7 ) * .. @@ -181,6 +181,7 @@ SUBROUTINE CCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ J, K, KL, KU, LDA, MODE, N, NERRS, NFAIL, $ NIMAT, NRHS, NRUN REAL AINVNM, ANORM, COND, DMAX, RCOND, RCONDC + REAL RNAN, RONE * .. * .. Local Arrays .. CHARACTER UPLOS( 2 ) @@ -200,7 +201,7 @@ SUBROUTINE CCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ CSSCAL, SCOPY, SLARNV, SSCAL * .. * .. Intrinsic Functions .. - INTRINSIC ABS, MAX, REAL + INTRINSIC ABS, MAX, REAL, SQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -364,6 +365,16 @@ SUBROUTINE CCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, Z( 2 ) = D( IZERO ) D( IZERO ) = ZERO END IF +* +* Type 13: put a NaN on the last diagonal entry. The +* factorization must report it like a nonpositive pivot. +* + IF( IMAT.EQ.13 ) THEN + IZERO = N + RONE = ONE + RNAN = SQRT( -RONE ) + D( N ) = RNAN + END IF END IF * CALL SCOPY( N, D, 1, D( N+1 ), 1 ) @@ -376,11 +387,20 @@ SUBROUTINE CCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * CALL CPTTRF( N, D( N+1 ), E( N+1 ), INFO ) * -* Check error code from CPTTRF. +* Check error code from CPTTRF. ALAERH returns without a +* message when INFO is zero, so an undetected bad pivot is +* reported here instead. * IF( INFO.NE.IZERO ) THEN - CALL ALAERH( PATH, 'CPTTRF', INFO, IZERO, ' ', N, N, -1, - $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + IF( INFO.EQ.0 ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )'CPTTRF', IZERO, N, IMAT + NFAIL = NFAIL + 1 + ELSE + CALL ALAERH( PATH, 'CPTTRF', INFO, IZERO, ' ', N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + END IF GO TO 110 END IF * @@ -543,6 +563,8 @@ SUBROUTINE CCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS =', I3, $ ', type ', I2, ', test ', I2, ', ratio = ', G12.5 ) + 9997 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, + $ ' for N =', I5, ', type ', I2 ) RETURN * * End of CCHKPT diff --git a/TESTING/LIN/dchkaa.F b/TESTING/LIN/dchkaa.F index d0f7dbcb4..0a4f6fa1c 100644 --- a/TESTING/LIN/dchkaa.F +++ b/TESTING/LIN/dchkaa.F @@ -597,7 +597,7 @@ PROGRAM DCHKAA * * PP: positive definite packed matrices * - NTYPES = 9 + NTYPES = 10 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN @@ -622,7 +622,7 @@ PROGRAM DCHKAA * * PB: positive definite banded matrices * - NTYPES = 8 + NTYPES = 9 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN @@ -647,7 +647,7 @@ PROGRAM DCHKAA * * PT: positive definite tridiagonal matrices * - NTYPES = 12 + NTYPES = 13 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN diff --git a/TESTING/LIN/dchkpb.f b/TESTING/LIN/dchkpb.f index 0b9375504..485eb9b62 100644 --- a/TESTING/LIN/dchkpb.f +++ b/TESTING/LIN/dchkpb.f @@ -193,7 +193,7 @@ SUBROUTINE DCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) INTEGER NTYPES, NTESTS - PARAMETER ( NTYPES = 8, NTESTS = 7 ) + PARAMETER ( NTYPES = 9, NTESTS = 7 ) INTEGER NBW PARAMETER ( NBW = 4 ) * .. @@ -206,6 +206,7 @@ SUBROUTINE DCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ LDA, LDAB, MODE, N, NB, NERRS, NFAIL, NIMAT, $ NKD, NRHS, NRUN DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC + DOUBLE PRECISION RNAN, RONE * .. * .. Local Arrays .. INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW ) @@ -222,7 +223,7 @@ SUBROUTINE DCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ DSWAP, XLAENV * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN + INTRINSIC MAX, MIN, SQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -397,6 +398,22 @@ SUBROUTINE DCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, END IF END IF * +* Type 9: put a NaN on the last diagonal entry. The +* factorization must report it like a nonpositive +* pivot. +* + IF( IMAT.EQ.9 ) THEN + IZERO = N + RONE = ONE + RNAN = SQRT( -RONE ) + IF( IUPLO.EQ.1 ) THEN + IOFF = ( N-1 )*LDAB + KD + 1 + ELSE + IOFF = ( N-1 )*LDAB + 1 + END IF + A( IOFF ) = RNAN + END IF +* * Do for each value of NB in NBVAL * DO 50 INB = 1, NNB @@ -410,12 +427,22 @@ SUBROUTINE DCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, SRNAMT = 'DPBTRF' CALL DPBTRF( UPLO, N, KD, AFAC, LDAB, INFO ) * -* Check error code from DPBTRF. +* Check error code from DPBTRF. ALAERH returns +* without a message when INFO is zero, so an +* undetected bad pivot is reported here instead. * IF( INFO.NE.IZERO ) THEN - CALL ALAERH( PATH, 'DPBTRF', INFO, IZERO, UPLO, - $ N, N, KD, KD, NB, IMAT, NFAIL, - $ NERRS, NOUT ) + IF( INFO.EQ.0 ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9996 )'DPBTRF', IZERO, + $ UPLO, N, KD, IMAT + NFAIL = NFAIL + 1 + ELSE + CALL ALAERH( PATH, 'DPBTRF', INFO, IZERO, + $ UPLO, N, N, KD, KD, NB, IMAT, + $ NFAIL, NERRS, NOUT ) + END IF GO TO 50 END IF * @@ -580,6 +607,9 @@ SUBROUTINE DCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ ', type ', I2, ', test(', I2, ') = ', G12.5 ) 9997 FORMAT( ' UPLO=''', A1, ''', N=', I5, ', KD=', I5, ',', 10X, $ ' type ', I2, ', test(', I2, ') = ', G12.5 ) + 9996 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, + $ ' for UPLO=''', A1, ''', N=', I5, ', KD=', I5, + $ ', type ', I2 ) RETURN * * End of DCHKPB diff --git a/TESTING/LIN/dchkpp.f b/TESTING/LIN/dchkpp.f index 4338db413..3d800bbfa 100644 --- a/TESTING/LIN/dchkpp.f +++ b/TESTING/LIN/dchkpp.f @@ -181,10 +181,10 @@ SUBROUTINE DCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * ===================================================================== * * .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) INTEGER NTYPES - PARAMETER ( NTYPES = 9 ) + PARAMETER ( NTYPES = 10 ) INTEGER NTESTS PARAMETER ( NTESTS = 8 ) * .. @@ -196,6 +196,7 @@ SUBROUTINE DCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT, NPP, $ NRHS, NRUN DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC + DOUBLE PRECISION RNAN, RONE * .. * .. Local Arrays .. CHARACTER PACKS( 2 ), UPLOS( 2 ) @@ -222,7 +223,7 @@ SUBROUTINE DCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, COMMON / SRNAMC / SRNAMT * .. * .. Intrinsic Functions .. - INTRINSIC MAX + INTRINSIC MAX, SQRT * .. * .. Data statements .. DATA ISEEDY / 1988, 1989, 1990, 1991 / @@ -334,6 +335,18 @@ SUBROUTINE DCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, IZERO = 0 END IF * +* Type 10: put a NaN on the last diagonal entry, which is +* the last entry of the packed array for both values of +* UPLO. The factorization must report it like a +* nonpositive pivot. +* + IF( IMAT.EQ.10 ) THEN + IZERO = N + RONE = ONE + RNAN = SQRT( -RONE ) + A( N*( N+1 ) / 2 ) = RNAN + END IF +* * Compute the L*L' or U'*U factorization of the matrix. * NPP = N*( N+1 ) / 2 @@ -341,11 +354,22 @@ SUBROUTINE DCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, SRNAMT = 'DPPTRF' CALL DPPTRF( UPLO, N, AFAC, INFO ) * -* Check error code from DPPTRF. +* Check error code from DPPTRF. ALAERH returns without a +* message when INFO is zero, so an undetected bad pivot is +* reported here instead. * IF( INFO.NE.IZERO ) THEN - CALL ALAERH( PATH, 'DPPTRF', INFO, IZERO, UPLO, N, N, - $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + IF( INFO.EQ.0 ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )'DPPTRF', IZERO, UPLO, N, + $ IMAT + NFAIL = NFAIL + 1 + ELSE + CALL ALAERH( PATH, 'DPPTRF', INFO, IZERO, UPLO, N, + $ N, -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + END IF GO TO 90 END IF * @@ -496,6 +520,8 @@ SUBROUTINE DCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ I2, ', ratio =', G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, + $ ' for UPLO = ''', A1, ''', N =', I5, ', type ', I2 ) RETURN * * End of DCHKPP diff --git a/TESTING/LIN/dchkpt.f b/TESTING/LIN/dchkpt.f index c2df8e58e..4836ae00a 100644 --- a/TESTING/LIN/dchkpt.f +++ b/TESTING/LIN/dchkpt.f @@ -167,7 +167,7 @@ SUBROUTINE DCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) INTEGER NTYPES - PARAMETER ( NTYPES = 12 ) + PARAMETER ( NTYPES = 13 ) INTEGER NTESTS PARAMETER ( NTESTS = 7 ) * .. @@ -179,6 +179,7 @@ SUBROUTINE DCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT, $ NRHS, NRUN DOUBLE PRECISION AINVNM, ANORM, COND, DMAX, RCOND, RCONDC + DOUBLE PRECISION RNAN, RONE * .. * .. Local Arrays .. INTEGER ISEED( 4 ), ISEEDY( 4 ) @@ -196,7 +197,7 @@ SUBROUTINE DCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ DSCAL * .. * .. Intrinsic Functions .. - INTRINSIC ABS, MAX + INTRINSIC ABS, MAX, SQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -360,6 +361,16 @@ SUBROUTINE DCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, Z( 2 ) = D( IZERO ) D( IZERO ) = ZERO END IF +* +* Type 13: put a NaN on the last diagonal entry. The +* factorization must report it like a nonpositive pivot. +* + IF( IMAT.EQ.13 ) THEN + IZERO = N + RONE = ONE + RNAN = SQRT( -RONE ) + D( N ) = RNAN + END IF END IF * CALL DCOPY( N, D, 1, D( N+1 ), 1 ) @@ -372,11 +383,20 @@ SUBROUTINE DCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * CALL DPTTRF( N, D( N+1 ), E( N+1 ), INFO ) * -* Check error code from DPTTRF. +* Check error code from DPTTRF. ALAERH returns without a +* message when INFO is zero, so an undetected bad pivot is +* reported here instead. * IF( INFO.NE.IZERO ) THEN - CALL ALAERH( PATH, 'DPTTRF', INFO, IZERO, ' ', N, N, -1, - $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + IF( INFO.EQ.0 ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )'DPTTRF', IZERO, N, IMAT + NFAIL = NFAIL + 1 + ELSE + CALL ALAERH( PATH, 'DPTTRF', INFO, IZERO, ' ', N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + END IF GO TO 100 END IF * @@ -526,6 +546,8 @@ SUBROUTINE DCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ G12.5 ) 9998 FORMAT( ' N =', I5, ', NRHS=', I3, ', type ', I2, ', test(', I2, $ ') = ', G12.5 ) + 9997 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, + $ ' for N =', I5, ', type ', I2 ) RETURN * * End of DCHKPT diff --git a/TESTING/LIN/schkaa.F b/TESTING/LIN/schkaa.F index dd3f8de4b..abf057c1b 100644 --- a/TESTING/LIN/schkaa.F +++ b/TESTING/LIN/schkaa.F @@ -593,7 +593,7 @@ PROGRAM SCHKAA * * PP: positive definite packed matrices * - NTYPES = 9 + NTYPES = 10 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN @@ -618,7 +618,7 @@ PROGRAM SCHKAA * * PB: positive definite banded matrices * - NTYPES = 8 + NTYPES = 9 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN @@ -643,7 +643,7 @@ PROGRAM SCHKAA * * PT: positive definite tridiagonal matrices * - NTYPES = 12 + NTYPES = 13 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN diff --git a/TESTING/LIN/schkpb.f b/TESTING/LIN/schkpb.f index 98e23d832..ef0c79834 100644 --- a/TESTING/LIN/schkpb.f +++ b/TESTING/LIN/schkpb.f @@ -193,7 +193,7 @@ SUBROUTINE SCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) INTEGER NTYPES, NTESTS - PARAMETER ( NTYPES = 8, NTESTS = 7 ) + PARAMETER ( NTYPES = 9, NTESTS = 7 ) INTEGER NBW PARAMETER ( NBW = 4 ) * .. @@ -206,6 +206,7 @@ SUBROUTINE SCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ LDA, LDAB, MODE, N, NB, NERRS, NFAIL, NIMAT, $ NKD, NRHS, NRUN REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC + REAL RNAN, RONE * .. * .. Local Arrays .. INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW ) @@ -222,7 +223,7 @@ SUBROUTINE SCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ SSWAP, XLAENV * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN + INTRINSIC MAX, MIN, SQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -397,6 +398,22 @@ SUBROUTINE SCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, END IF END IF * +* Type 9: put a NaN on the last diagonal entry. The +* factorization must report it like a nonpositive +* pivot. +* + IF( IMAT.EQ.9 ) THEN + IZERO = N + RONE = ONE + RNAN = SQRT( -RONE ) + IF( IUPLO.EQ.1 ) THEN + IOFF = ( N-1 )*LDAB + KD + 1 + ELSE + IOFF = ( N-1 )*LDAB + 1 + END IF + A( IOFF ) = RNAN + END IF +* * Do for each value of NB in NBVAL * DO 50 INB = 1, NNB @@ -410,12 +427,22 @@ SUBROUTINE SCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, SRNAMT = 'SPBTRF' CALL SPBTRF( UPLO, N, KD, AFAC, LDAB, INFO ) * -* Check error code from SPBTRF. +* Check error code from SPBTRF. ALAERH returns +* without a message when INFO is zero, so an +* undetected bad pivot is reported here instead. * IF( INFO.NE.IZERO ) THEN - CALL ALAERH( PATH, 'SPBTRF', INFO, IZERO, UPLO, - $ N, N, KD, KD, NB, IMAT, NFAIL, - $ NERRS, NOUT ) + IF( INFO.EQ.0 ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9996 )'SPBTRF', IZERO, + $ UPLO, N, KD, IMAT + NFAIL = NFAIL + 1 + ELSE + CALL ALAERH( PATH, 'SPBTRF', INFO, IZERO, + $ UPLO, N, N, KD, KD, NB, IMAT, + $ NFAIL, NERRS, NOUT ) + END IF GO TO 50 END IF * @@ -580,6 +607,9 @@ SUBROUTINE SCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ ', type ', I2, ', test(', I2, ') = ', G12.5 ) 9997 FORMAT( ' UPLO=''', A1, ''', N=', I5, ', KD=', I5, ',', 10X, $ ' type ', I2, ', test(', I2, ') = ', G12.5 ) + 9996 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, + $ ' for UPLO=''', A1, ''', N=', I5, ', KD=', I5, + $ ', type ', I2 ) RETURN * * End of SCHKPB diff --git a/TESTING/LIN/schkpp.f b/TESTING/LIN/schkpp.f index 607c6a057..c83e3f49c 100644 --- a/TESTING/LIN/schkpp.f +++ b/TESTING/LIN/schkpp.f @@ -181,10 +181,10 @@ SUBROUTINE SCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * ===================================================================== * * .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) INTEGER NTYPES - PARAMETER ( NTYPES = 9 ) + PARAMETER ( NTYPES = 10 ) INTEGER NTESTS PARAMETER ( NTESTS = 8 ) * .. @@ -196,6 +196,7 @@ SUBROUTINE SCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT, NPP, $ NRHS, NRUN REAL ANORM, CNDNUM, RCOND, RCONDC + REAL RNAN, RONE * .. * .. Local Arrays .. CHARACTER PACKS( 2 ), UPLOS( 2 ) @@ -222,7 +223,7 @@ SUBROUTINE SCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, COMMON / SRNAMC / SRNAMT * .. * .. Intrinsic Functions .. - INTRINSIC MAX + INTRINSIC MAX, SQRT * .. * .. Data statements .. DATA ISEEDY / 1988, 1989, 1990, 1991 / @@ -334,6 +335,18 @@ SUBROUTINE SCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, IZERO = 0 END IF * +* Type 10: put a NaN on the last diagonal entry, which is +* the last entry of the packed array for both values of +* UPLO. The factorization must report it like a +* nonpositive pivot. +* + IF( IMAT.EQ.10 ) THEN + IZERO = N + RONE = ONE + RNAN = SQRT( -RONE ) + A( N*( N+1 ) / 2 ) = RNAN + END IF +* * Compute the L*L' or U'*U factorization of the matrix. * NPP = N*( N+1 ) / 2 @@ -341,11 +354,22 @@ SUBROUTINE SCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, SRNAMT = 'SPPTRF' CALL SPPTRF( UPLO, N, AFAC, INFO ) * -* Check error code from SPPTRF. +* Check error code from SPPTRF. ALAERH returns without a +* message when INFO is zero, so an undetected bad pivot is +* reported here instead. * IF( INFO.NE.IZERO ) THEN - CALL ALAERH( PATH, 'SPPTRF', INFO, IZERO, UPLO, N, N, - $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + IF( INFO.EQ.0 ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )'SPPTRF', IZERO, UPLO, N, + $ IMAT + NFAIL = NFAIL + 1 + ELSE + CALL ALAERH( PATH, 'SPPTRF', INFO, IZERO, UPLO, N, + $ N, -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + END IF GO TO 90 END IF * @@ -496,6 +520,8 @@ SUBROUTINE SCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ I2, ', ratio =', G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, + $ ' for UPLO = ''', A1, ''', N =', I5, ', type ', I2 ) RETURN * * End of SCHKPP diff --git a/TESTING/LIN/schkpt.f b/TESTING/LIN/schkpt.f index 5a356eaf3..d3bf711a3 100644 --- a/TESTING/LIN/schkpt.f +++ b/TESTING/LIN/schkpt.f @@ -167,7 +167,7 @@ SUBROUTINE SCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) INTEGER NTYPES - PARAMETER ( NTYPES = 12 ) + PARAMETER ( NTYPES = 13 ) INTEGER NTESTS PARAMETER ( NTESTS = 7 ) * .. @@ -179,6 +179,7 @@ SUBROUTINE SCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT, $ NRHS, NRUN REAL AINVNM, ANORM, COND, DMAX, RCOND, RCONDC + REAL RNAN, RONE * .. * .. Local Arrays .. INTEGER ISEED( 4 ), ISEEDY( 4 ) @@ -196,7 +197,7 @@ SUBROUTINE SCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ SSCAL * .. * .. Intrinsic Functions .. - INTRINSIC ABS, MAX + INTRINSIC ABS, MAX, SQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -360,6 +361,16 @@ SUBROUTINE SCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, Z( 2 ) = D( IZERO ) D( IZERO ) = ZERO END IF +* +* Type 13: put a NaN on the last diagonal entry. The +* factorization must report it like a nonpositive pivot. +* + IF( IMAT.EQ.13 ) THEN + IZERO = N + RONE = ONE + RNAN = SQRT( -RONE ) + D( N ) = RNAN + END IF END IF * CALL SCOPY( N, D, 1, D( N+1 ), 1 ) @@ -372,11 +383,20 @@ SUBROUTINE SCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * CALL SPTTRF( N, D( N+1 ), E( N+1 ), INFO ) * -* Check error code from SPTTRF. +* Check error code from SPTTRF. ALAERH returns without a +* message when INFO is zero, so an undetected bad pivot is +* reported here instead. * IF( INFO.NE.IZERO ) THEN - CALL ALAERH( PATH, 'SPTTRF', INFO, IZERO, ' ', N, N, -1, - $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + IF( INFO.EQ.0 ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )'SPTTRF', IZERO, N, IMAT + NFAIL = NFAIL + 1 + ELSE + CALL ALAERH( PATH, 'SPTTRF', INFO, IZERO, ' ', N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + END IF GO TO 100 END IF * @@ -526,6 +546,8 @@ SUBROUTINE SCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ G12.5 ) 9998 FORMAT( ' N =', I5, ', NRHS=', I3, ', type ', I2, ', test(', I2, $ ') = ', G12.5 ) + 9997 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, + $ ' for N =', I5, ', type ', I2 ) RETURN * * End of SCHKPT diff --git a/TESTING/LIN/zchkaa.F b/TESTING/LIN/zchkaa.F index fb1b5cd59..b98f5d213 100644 --- a/TESTING/LIN/zchkaa.F +++ b/TESTING/LIN/zchkaa.F @@ -601,7 +601,7 @@ PROGRAM ZCHKAA * * PP: positive definite packed matrices * - NTYPES = 9 + NTYPES = 10 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN @@ -626,7 +626,7 @@ PROGRAM ZCHKAA * * PB: positive definite banded matrices * - NTYPES = 8 + NTYPES = 9 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN @@ -651,7 +651,7 @@ PROGRAM ZCHKAA * * PT: positive definite tridiagonal matrices * - NTYPES = 12 + NTYPES = 13 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN diff --git a/TESTING/LIN/zchkpb.f b/TESTING/LIN/zchkpb.f index 4f3160b5c..a2a0a73b9 100644 --- a/TESTING/LIN/zchkpb.f +++ b/TESTING/LIN/zchkpb.f @@ -190,7 +190,7 @@ SUBROUTINE ZCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) INTEGER NTYPES, NTESTS - PARAMETER ( NTYPES = 8, NTESTS = 7 ) + PARAMETER ( NTYPES = 9, NTESTS = 7 ) INTEGER NBW PARAMETER ( NBW = 4 ) * .. @@ -203,6 +203,7 @@ SUBROUTINE ZCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ LDA, LDAB, MODE, N, NB, NERRS, NFAIL, NIMAT, $ NKD, NRHS, NRUN DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC + DOUBLE PRECISION RNAN, RONE * .. * .. Local Arrays .. INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW ) @@ -219,7 +220,7 @@ SUBROUTINE ZCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ ZPBTRF, ZPBTRS, ZSWAP * .. * .. Intrinsic Functions .. - INTRINSIC DCMPLX, MAX, MIN + INTRINSIC DCMPLX, MAX, MIN, SQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -401,6 +402,22 @@ SUBROUTINE ZCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, CALL ZLAIPD( N, A( 1 ), LDAB, 0 ) END IF * +* Type 9: put a NaN on the last diagonal entry. The +* factorization must report it like a nonpositive +* pivot. +* + IF( IMAT.EQ.9 ) THEN + IZERO = N + RONE = ONE + RNAN = SQRT( -RONE ) + IF( IUPLO.EQ.1 ) THEN + IOFF = ( N-1 )*LDAB + KD + 1 + ELSE + IOFF = ( N-1 )*LDAB + 1 + END IF + A( IOFF ) = RNAN + END IF +* * Do for each value of NB in NBVAL * DO 50 INB = 1, NNB @@ -414,12 +431,22 @@ SUBROUTINE ZCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, SRNAMT = 'ZPBTRF' CALL ZPBTRF( UPLO, N, KD, AFAC, LDAB, INFO ) * -* Check error code from ZPBTRF. +* Check error code from ZPBTRF. ALAERH returns +* without a message when INFO is zero, so an +* undetected bad pivot is reported here instead. * IF( INFO.NE.IZERO ) THEN - CALL ALAERH( PATH, 'ZPBTRF', INFO, IZERO, UPLO, - $ N, N, KD, KD, NB, IMAT, NFAIL, - $ NERRS, NOUT ) + IF( INFO.EQ.0 ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9996 )'ZPBTRF', IZERO, + $ UPLO, N, KD, IMAT + NFAIL = NFAIL + 1 + ELSE + CALL ALAERH( PATH, 'ZPBTRF', INFO, IZERO, + $ UPLO, N, N, KD, KD, NB, IMAT, + $ NFAIL, NERRS, NOUT ) + END IF GO TO 50 END IF * @@ -585,6 +612,9 @@ SUBROUTINE ZCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ ', type ', I2, ', test(', I2, ') = ', G12.5 ) 9997 FORMAT( ' UPLO=''', A1, ''', N=', I5, ', KD=', I5, ',', 10X, $ ' type ', I2, ', test(', I2, ') = ', G12.5 ) + 9996 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, + $ ' for UPLO=''', A1, ''', N=', I5, ', KD=', I5, + $ ', type ', I2 ) RETURN * * End of ZCHKPB diff --git a/TESTING/LIN/zchkpp.f b/TESTING/LIN/zchkpp.f index c3dcbcaff..1b2452150 100644 --- a/TESTING/LIN/zchkpp.f +++ b/TESTING/LIN/zchkpp.f @@ -178,10 +178,10 @@ SUBROUTINE ZCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * ===================================================================== * * .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) INTEGER NTYPES - PARAMETER ( NTYPES = 9 ) + PARAMETER ( NTYPES = 10 ) INTEGER NTESTS PARAMETER ( NTESTS = 8 ) * .. @@ -193,6 +193,7 @@ SUBROUTINE ZCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT, NPP, $ NRHS, NRUN DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC + DOUBLE PRECISION RNAN, RONE * .. * .. Local Arrays .. CHARACTER PACKS( 2 ), UPLOS( 2 ) @@ -219,7 +220,7 @@ SUBROUTINE ZCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, COMMON / SRNAMC / SRNAMT * .. * .. Intrinsic Functions .. - INTRINSIC MAX + INTRINSIC MAX, SQRT * .. * .. Data statements .. DATA ISEEDY / 1988, 1989, 1990, 1991 / @@ -331,6 +332,18 @@ SUBROUTINE ZCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, IZERO = 0 END IF * +* Type 10: put a NaN on the last diagonal entry, which is +* the last entry of the packed array for both values of +* UPLO. The factorization must report it like a +* nonpositive pivot. +* + IF( IMAT.EQ.10 ) THEN + IZERO = N + RONE = ONE + RNAN = SQRT( -RONE ) + A( N*( N+1 ) / 2 ) = RNAN + END IF +* * Set the imaginary part of the diagonals. * IF( IUPLO.EQ.1 ) THEN @@ -346,11 +359,22 @@ SUBROUTINE ZCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, SRNAMT = 'ZPPTRF' CALL ZPPTRF( UPLO, N, AFAC, INFO ) * -* Check error code from ZPPTRF. +* Check error code from ZPPTRF. ALAERH returns without a +* message when INFO is zero, so an undetected bad pivot is +* reported here instead. * IF( INFO.NE.IZERO ) THEN - CALL ALAERH( PATH, 'ZPPTRF', INFO, IZERO, UPLO, N, N, - $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + IF( INFO.EQ.0 ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )'ZPPTRF', IZERO, UPLO, N, + $ IMAT + NFAIL = NFAIL + 1 + ELSE + CALL ALAERH( PATH, 'ZPPTRF', INFO, IZERO, UPLO, N, + $ N, -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + END IF GO TO 90 END IF * @@ -502,6 +526,8 @@ SUBROUTINE ZCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ I2, ', ratio =', G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, + $ ' for UPLO = ''', A1, ''', N =', I5, ', type ', I2 ) RETURN * * End of ZCHKPP diff --git a/TESTING/LIN/zchkpt.f b/TESTING/LIN/zchkpt.f index b2c423864..696d810e9 100644 --- a/TESTING/LIN/zchkpt.f +++ b/TESTING/LIN/zchkpt.f @@ -169,7 +169,7 @@ SUBROUTINE ZCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) INTEGER NTYPES - PARAMETER ( NTYPES = 12 ) + PARAMETER ( NTYPES = 13 ) INTEGER NTESTS PARAMETER ( NTESTS = 7 ) * .. @@ -181,6 +181,7 @@ SUBROUTINE ZCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ J, K, KL, KU, LDA, MODE, N, NERRS, NFAIL, $ NIMAT, NRHS, NRUN DOUBLE PRECISION AINVNM, ANORM, COND, DMAX, RCOND, RCONDC + DOUBLE PRECISION RNAN, RONE * .. * .. Local Arrays .. CHARACTER UPLOS( 2 ) @@ -200,7 +201,7 @@ SUBROUTINE ZCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ ZPTT02, ZPTT05, ZPTTRF, ZPTTRS * .. * .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX + INTRINSIC ABS, DBLE, MAX, SQRT * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -364,6 +365,16 @@ SUBROUTINE ZCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, Z( 2 ) = D( IZERO ) D( IZERO ) = ZERO END IF +* +* Type 13: put a NaN on the last diagonal entry. The +* factorization must report it like a nonpositive pivot. +* + IF( IMAT.EQ.13 ) THEN + IZERO = N + RONE = ONE + RNAN = SQRT( -RONE ) + D( N ) = RNAN + END IF END IF * CALL DCOPY( N, D, 1, D( N+1 ), 1 ) @@ -376,11 +387,20 @@ SUBROUTINE ZCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * CALL ZPTTRF( N, D( N+1 ), E( N+1 ), INFO ) * -* Check error code from ZPTTRF. +* Check error code from ZPTTRF. ALAERH returns without a +* message when INFO is zero, so an undetected bad pivot is +* reported here instead. * IF( INFO.NE.IZERO ) THEN - CALL ALAERH( PATH, 'ZPTTRF', INFO, IZERO, ' ', N, N, -1, - $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + IF( INFO.EQ.0 ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )'ZPTTRF', IZERO, N, IMAT + NFAIL = NFAIL + 1 + ELSE + CALL ALAERH( PATH, 'ZPTTRF', INFO, IZERO, ' ', N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + END IF GO TO 110 END IF * @@ -543,6 +563,8 @@ SUBROUTINE ZCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS =', I3, $ ', type ', I2, ', test ', I2, ', ratio = ', G12.5 ) + 9997 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, + $ ' for N =', I5, ', type ', I2 ) RETURN * * End of ZCHKPT diff --git a/TESTING/ctest.in b/TESTING/ctest.in index 4e30224d7..9de9da956 100644 --- a/TESTING/ctest.in +++ b/TESTING/ctest.in @@ -19,9 +19,9 @@ CGB 8 List types on next line if 0 < NTYPES < 8 CGT 12 List types on next line if 0 < NTYPES < 12 CPO 9 List types on next line if 0 < NTYPES < 9 CPS 9 List types on next line if 0 < NTYPES < 9 -CPP 9 List types on next line if 0 < NTYPES < 9 -CPB 8 List types on next line if 0 < NTYPES < 8 -CPT 12 List types on next line if 0 < NTYPES < 12 +CPP 10 List types on next line if 0 < NTYPES < 10 +CPB 9 List types on next line if 0 < NTYPES < 9 +CPT 13 List types on next line if 0 < NTYPES < 13 CHE 10 List types on next line if 0 < NTYPES < 10 CHR 10 List types on next line if 0 < NTYPES < 10 CHK 10 List types on next line if 0 < NTYPES < 10 diff --git a/TESTING/dtest.in b/TESTING/dtest.in index cde62db50..d6d6dc5dc 100644 --- a/TESTING/dtest.in +++ b/TESTING/dtest.in @@ -19,9 +19,9 @@ DGB 8 List types on next line if 0 < NTYPES < 8 DGT 12 List types on next line if 0 < NTYPES < 12 DPO 9 List types on next line if 0 < NTYPES < 9 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 +DPP 10 List types on next line if 0 < NTYPES < 10 +DPB 9 List types on next line if 0 < NTYPES < 9 +DPT 13 List types on next line if 0 < NTYPES < 13 DSY 10 List types on next line if 0 < NTYPES < 10 DSR 10 List types on next line if 0 < NTYPES < 10 DSK 10 List types on next line if 0 < NTYPES < 10 diff --git a/TESTING/stest.in b/TESTING/stest.in index abfd639fd..d72f1d6bf 100644 --- a/TESTING/stest.in +++ b/TESTING/stest.in @@ -19,9 +19,9 @@ SGB 8 List types on next line if 0 < NTYPES < 8 SGT 12 List types on next line if 0 < NTYPES < 12 SPO 9 List types on next line if 0 < NTYPES < 9 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 +SPP 10 List types on next line if 0 < NTYPES < 10 +SPB 9 List types on next line if 0 < NTYPES < 9 +SPT 13 List types on next line if 0 < NTYPES < 13 SSY 10 List types on next line if 0 < NTYPES < 10 SSR 10 List types on next line if 0 < NTYPES < 10 SSK 10 List types on next line if 0 < NTYPES < 10 diff --git a/TESTING/ztest.in b/TESTING/ztest.in index bf4c9d100..6acd76f00 100644 --- a/TESTING/ztest.in +++ b/TESTING/ztest.in @@ -19,9 +19,9 @@ ZGB 8 List types on next line if 0 < NTYPES < 8 ZGT 12 List types on next line if 0 < NTYPES < 12 ZPO 9 List types on next line if 0 < NTYPES < 9 ZPS 9 List types on next line if 0 < NTYPES < 9 -ZPP 9 List types on next line if 0 < NTYPES < 9 -ZPB 8 List types on next line if 0 < NTYPES < 8 -ZPT 12 List types on next line if 0 < NTYPES < 12 +ZPP 10 List types on next line if 0 < NTYPES < 10 +ZPB 9 List types on next line if 0 < NTYPES < 9 +ZPT 13 List types on next line if 0 < NTYPES < 13 ZHE 10 List types on next line if 0 < NTYPES < 10 ZHR 10 List types on next line if 0 < NTYPES < 10 ZHK 10 List types on next line if 0 < NTYPES < 10 From 94766eacf4ea97196e22e17d2515ab82aea0d55a Mon Sep 17 00:00:00 2001 From: Rasmus Munk Larsen Date: Mon, 7 Sep 2026 22:04:07 -0700 Subject: [PATCH 2/3] Add the remaining NaN matrix types to the NAG constant-propagation list xCHKPP and xCHKPB build their NaN type the same way xCHKPT does, with SQRT of a negative variable, but only xCHKPT was listed, and the comment above the _64 branch lost its indentation. Co-Authored-By: Claude Fable 5.1 --- CMAKE/LAPACKTestHelpers.cmake | 4 ++-- TESTING/LIN/CMakeLists.txt | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/CMAKE/LAPACKTestHelpers.cmake b/CMAKE/LAPACKTestHelpers.cmake index 5f44981c0..7d25b1625 100644 --- a/CMAKE/LAPACKTestHelpers.cmake +++ b/CMAKE/LAPACKTestHelpers.cmake @@ -44,7 +44,7 @@ function(lapack_no_constant_propagation_flag out_var) endif() endfunction() -# Disable it for the CXX error-exit and tridiagonal Cholesky tests among +# Disable it for the CXX error-exit and packed, banded and tridiagonal Cholesky tests among # ARGN, which manufacture NaNs. Call this with every source list: the # generated _64 and _TEST copies need it as much as the originals. function(lapack_nag_disable_constant_propagation) @@ -54,7 +54,7 @@ function(lapack_nag_disable_constant_propagation) endif() foreach(source IN LISTS ARGN) get_filename_component(name "${source}" NAME) - if(name MATCHES "^[scdz](errcxx|chkpt)(_[A-Za-z0-9]+)*\\.f$") + if(name MATCHES "^[scdz](errcxx|chkp[tpb])(_[A-Za-z0-9]+)*\\.f$") set_source_files_properties("${source}" PROPERTIES COMPILE_OPTIONS "${flag}") endif() diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt index 4b0c0aa61..1d513bb8c 100644 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -223,7 +223,9 @@ endif() lapack_nag_disable_constant_propagation( serrcxx.f cerrcxx.f derrcxx.f zerrcxx.f - schkpt.f cchkpt.f dchkpt.f zchkpt.f) + schkpt.f cchkpt.f dchkpt.f zchkpt.f + schkpp.f cchkpp.f dchkpp.f zchkpp.f + schkpb.f cchkpb.f dchkpb.f zchkpb.f) set(DSLINTST dchkab.f ddrvab.f ddrvac.f derrab.f derrac.f dget08.f From edca5c79ccf5e9c5600db75f679513afa7a35c12 Mon Sep 17 00:00:00 2001 From: Rasmus Munk Larsen Date: Tue, 15 Sep 2026 20:29:35 -0700 Subject: [PATCH 3/3] TESTING: Report unexpected success through ALAERH Handle INFO=0 when a nonzero code was expected in the shared error reporter. Restore the twelve Cholesky checkers to their common reporting path and test unexpected success, wrong error codes, and successful calls with both integer APIs. --- TESTING/LIN/CMakeLists.txt | 11 ++++++- TESTING/LIN/alaerh.f | 4 ++- TESTING/LIN/cchkpb.f | 21 +++--------- TESTING/LIN/cchkpp.f | 19 ++--------- TESTING/LIN/cchkpt.f | 17 ++-------- TESTING/LIN/dchkpb.f | 21 +++--------- TESTING/LIN/dchkpp.f | 19 ++--------- TESTING/LIN/dchkpt.f | 17 ++-------- TESTING/LIN/schkpb.f | 21 +++--------- TESTING/LIN/schkpp.f | 19 ++--------- TESTING/LIN/schkpt.f | 17 ++-------- TESTING/LIN/test_alaerh.f90 | 66 +++++++++++++++++++++++++++++++++++++ TESTING/LIN/zchkpb.f | 21 +++--------- TESTING/LIN/zchkpp.f | 19 ++--------- TESTING/LIN/zchkpt.f | 17 ++-------- 15 files changed, 119 insertions(+), 190 deletions(-) create mode 100644 TESTING/LIN/test_alaerh.f90 diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt index 1d513bb8c..8e24908a0 100644 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -260,7 +260,7 @@ set(ZLINTSTRFP chkxer.f xerbla.f alaerh.f aladhd.f alahd.f alasvm.f) function(add_lin_executable name) - cmake_parse_arguments(PARSE_ARGV 1 LIN "" "" "SOURCES;DEFAULT_API;EXT_API") + cmake_parse_arguments(PARSE_ARGV 1 LIN "TEST" "" "SOURCES;DEFAULT_API;EXT_API") set(sources ${LIN_SOURCES} ${LIN_DEFAULT_API}) set(ext_sources ${LIN_SOURCES} ${LIN_EXT_API}) @@ -268,6 +268,9 @@ function(add_lin_executable name) add_executable(${name} ${sources}) target_link_libraries(${name} PRIVATE ${TMGLIB} ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) lapack_add_coverage(${name}) + if(LIN_TEST) + add_test(NAME LAPACK-${name} COMMAND $) + endif() endif() if(BUILD_INDEX64_EXT_API) @@ -279,6 +282,9 @@ function(add_lin_executable name) target_compile_options(${name}_64 PRIVATE ${FOPT_ILP64}) target_link_libraries(${name}_64 PRIVATE ${TMGLIB} ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) lapack_add_coverage(${name}_64) + if(LIN_TEST) + add_test(NAME LAPACK-${name}_64 COMMAND $) + endif() # Add depedency to the global codegen target. Since we reuse the same # generated source file for multiple tests, the generation could be @@ -287,6 +293,9 @@ function(add_lin_executable name) endif() endfunction() +add_lin_executable(xalaerh TEST + SOURCES test_alaerh.f90 alaerh.f aladhd.f alahd.f) + if(BUILD_SINGLE) add_lin_executable(xlintsts SOURCES ${ALINTST} ${SLINTST} ${SCLNTST} diff --git a/TESTING/LIN/alaerh.f b/TESTING/LIN/alaerh.f index 7c4f7a431..1f9bf7607 100644 --- a/TESTING/LIN/alaerh.f +++ b/TESTING/LIN/alaerh.f @@ -59,6 +59,8 @@ *> The expected error code from routine SUBNAM, if SUBNAM were *> error-free. If INFOE = 0, an error message is printed, but *> if INFOE.NE.0, we assume only the return code INFO is wrong. +*> An unexpected INFO = 0 is also reported. No message is +*> printed when both INFO and INFOE are zero. *> \endverbatim *> *> \param[in] OPTS @@ -177,7 +179,7 @@ SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, * .. * .. Executable Statements .. * - IF( INFO.EQ.0 ) + IF( INFO.EQ.0 .AND. INFOE.EQ.0 ) $ RETURN P2 = PATH( 2: 3 ) C3 = SUBNAM( 4: 6 ) diff --git a/TESTING/LIN/cchkpb.f b/TESTING/LIN/cchkpb.f index 53c92c2cf..b0d470c35 100644 --- a/TESTING/LIN/cchkpb.f +++ b/TESTING/LIN/cchkpb.f @@ -431,22 +431,12 @@ SUBROUTINE CCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, SRNAMT = 'CPBTRF' CALL CPBTRF( UPLO, N, KD, AFAC, LDAB, INFO ) * -* Check error code from CPBTRF. ALAERH returns -* without a message when INFO is zero, so an -* undetected bad pivot is reported here instead. +* Check error code from CPBTRF. * IF( INFO.NE.IZERO ) THEN - IF( INFO.EQ.0 ) THEN - IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) - $ CALL ALAHD( NOUT, PATH ) - WRITE( NOUT, FMT = 9996 )'CPBTRF', IZERO, - $ UPLO, N, KD, IMAT - NFAIL = NFAIL + 1 - ELSE - CALL ALAERH( PATH, 'CPBTRF', INFO, IZERO, - $ UPLO, N, N, KD, KD, NB, IMAT, - $ NFAIL, NERRS, NOUT ) - END IF + CALL ALAERH( PATH, 'CPBTRF', INFO, IZERO, UPLO, + $ N, N, KD, KD, NB, IMAT, NFAIL, + $ NERRS, NOUT ) GO TO 50 END IF * @@ -612,9 +602,6 @@ SUBROUTINE CCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ ', type ', I2, ', test(', I2, ') = ', G12.5 ) 9997 FORMAT( ' UPLO=''', A1, ''', N=', I5, ', KD=', I5, ',', 10X, $ ' type ', I2, ', test(', I2, ') = ', G12.5 ) - 9996 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, - $ ' for UPLO=''', A1, ''', N=', I5, ', KD=', I5, - $ ', type ', I2 ) RETURN * * End of CCHKPB diff --git a/TESTING/LIN/cchkpp.f b/TESTING/LIN/cchkpp.f index 412e77ddf..9faba093f 100644 --- a/TESTING/LIN/cchkpp.f +++ b/TESTING/LIN/cchkpp.f @@ -359,22 +359,11 @@ SUBROUTINE CCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, SRNAMT = 'CPPTRF' CALL CPPTRF( UPLO, N, AFAC, INFO ) * -* Check error code from CPPTRF. ALAERH returns without a -* message when INFO is zero, so an undetected bad pivot is -* reported here instead. +* Check error code from CPPTRF. * IF( INFO.NE.IZERO ) THEN - IF( INFO.EQ.0 ) THEN - IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) - $ CALL ALAHD( NOUT, PATH ) - WRITE( NOUT, FMT = 9997 )'CPPTRF', IZERO, UPLO, N, - $ IMAT - NFAIL = NFAIL + 1 - ELSE - CALL ALAERH( PATH, 'CPPTRF', INFO, IZERO, UPLO, N, - $ N, -1, -1, -1, IMAT, NFAIL, NERRS, - $ NOUT ) - END IF + CALL ALAERH( PATH, 'CPPTRF', INFO, IZERO, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) GO TO 90 END IF * @@ -526,8 +515,6 @@ SUBROUTINE CCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ I2, ', ratio =', G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', $ I2, ', test(', I2, ') =', G12.5 ) - 9997 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, - $ ' for UPLO = ''', A1, ''', N =', I5, ', type ', I2 ) RETURN * * End of CCHKPP diff --git a/TESTING/LIN/cchkpt.f b/TESTING/LIN/cchkpt.f index 876690cef..f7b611263 100644 --- a/TESTING/LIN/cchkpt.f +++ b/TESTING/LIN/cchkpt.f @@ -387,20 +387,11 @@ SUBROUTINE CCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * CALL CPTTRF( N, D( N+1 ), E( N+1 ), INFO ) * -* Check error code from CPTTRF. ALAERH returns without a -* message when INFO is zero, so an undetected bad pivot is -* reported here instead. +* Check error code from CPTTRF. * IF( INFO.NE.IZERO ) THEN - IF( INFO.EQ.0 ) THEN - IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) - $ CALL ALAHD( NOUT, PATH ) - WRITE( NOUT, FMT = 9997 )'CPTTRF', IZERO, N, IMAT - NFAIL = NFAIL + 1 - ELSE - CALL ALAERH( PATH, 'CPTTRF', INFO, IZERO, ' ', N, N, - $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) - END IF + CALL ALAERH( PATH, 'CPTTRF', INFO, IZERO, ' ', N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) GO TO 110 END IF * @@ -563,8 +554,6 @@ SUBROUTINE CCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS =', I3, $ ', type ', I2, ', test ', I2, ', ratio = ', G12.5 ) - 9997 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, - $ ' for N =', I5, ', type ', I2 ) RETURN * * End of CCHKPT diff --git a/TESTING/LIN/dchkpb.f b/TESTING/LIN/dchkpb.f index 485eb9b62..185ec6767 100644 --- a/TESTING/LIN/dchkpb.f +++ b/TESTING/LIN/dchkpb.f @@ -427,22 +427,12 @@ SUBROUTINE DCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, SRNAMT = 'DPBTRF' CALL DPBTRF( UPLO, N, KD, AFAC, LDAB, INFO ) * -* Check error code from DPBTRF. ALAERH returns -* without a message when INFO is zero, so an -* undetected bad pivot is reported here instead. +* Check error code from DPBTRF. * IF( INFO.NE.IZERO ) THEN - IF( INFO.EQ.0 ) THEN - IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) - $ CALL ALAHD( NOUT, PATH ) - WRITE( NOUT, FMT = 9996 )'DPBTRF', IZERO, - $ UPLO, N, KD, IMAT - NFAIL = NFAIL + 1 - ELSE - CALL ALAERH( PATH, 'DPBTRF', INFO, IZERO, - $ UPLO, N, N, KD, KD, NB, IMAT, - $ NFAIL, NERRS, NOUT ) - END IF + CALL ALAERH( PATH, 'DPBTRF', INFO, IZERO, UPLO, + $ N, N, KD, KD, NB, IMAT, NFAIL, + $ NERRS, NOUT ) GO TO 50 END IF * @@ -607,9 +597,6 @@ SUBROUTINE DCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ ', type ', I2, ', test(', I2, ') = ', G12.5 ) 9997 FORMAT( ' UPLO=''', A1, ''', N=', I5, ', KD=', I5, ',', 10X, $ ' type ', I2, ', test(', I2, ') = ', G12.5 ) - 9996 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, - $ ' for UPLO=''', A1, ''', N=', I5, ', KD=', I5, - $ ', type ', I2 ) RETURN * * End of DCHKPB diff --git a/TESTING/LIN/dchkpp.f b/TESTING/LIN/dchkpp.f index 3d800bbfa..990c35ff1 100644 --- a/TESTING/LIN/dchkpp.f +++ b/TESTING/LIN/dchkpp.f @@ -354,22 +354,11 @@ SUBROUTINE DCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, SRNAMT = 'DPPTRF' CALL DPPTRF( UPLO, N, AFAC, INFO ) * -* Check error code from DPPTRF. ALAERH returns without a -* message when INFO is zero, so an undetected bad pivot is -* reported here instead. +* Check error code from DPPTRF. * IF( INFO.NE.IZERO ) THEN - IF( INFO.EQ.0 ) THEN - IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) - $ CALL ALAHD( NOUT, PATH ) - WRITE( NOUT, FMT = 9997 )'DPPTRF', IZERO, UPLO, N, - $ IMAT - NFAIL = NFAIL + 1 - ELSE - CALL ALAERH( PATH, 'DPPTRF', INFO, IZERO, UPLO, N, - $ N, -1, -1, -1, IMAT, NFAIL, NERRS, - $ NOUT ) - END IF + CALL ALAERH( PATH, 'DPPTRF', INFO, IZERO, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) GO TO 90 END IF * @@ -520,8 +509,6 @@ SUBROUTINE DCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ I2, ', ratio =', G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', $ I2, ', test(', I2, ') =', G12.5 ) - 9997 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, - $ ' for UPLO = ''', A1, ''', N =', I5, ', type ', I2 ) RETURN * * End of DCHKPP diff --git a/TESTING/LIN/dchkpt.f b/TESTING/LIN/dchkpt.f index 4836ae00a..e6dd3174c 100644 --- a/TESTING/LIN/dchkpt.f +++ b/TESTING/LIN/dchkpt.f @@ -383,20 +383,11 @@ SUBROUTINE DCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * CALL DPTTRF( N, D( N+1 ), E( N+1 ), INFO ) * -* Check error code from DPTTRF. ALAERH returns without a -* message when INFO is zero, so an undetected bad pivot is -* reported here instead. +* Check error code from DPTTRF. * IF( INFO.NE.IZERO ) THEN - IF( INFO.EQ.0 ) THEN - IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) - $ CALL ALAHD( NOUT, PATH ) - WRITE( NOUT, FMT = 9997 )'DPTTRF', IZERO, N, IMAT - NFAIL = NFAIL + 1 - ELSE - CALL ALAERH( PATH, 'DPTTRF', INFO, IZERO, ' ', N, N, - $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) - END IF + CALL ALAERH( PATH, 'DPTTRF', INFO, IZERO, ' ', N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) GO TO 100 END IF * @@ -546,8 +537,6 @@ SUBROUTINE DCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ G12.5 ) 9998 FORMAT( ' N =', I5, ', NRHS=', I3, ', type ', I2, ', test(', I2, $ ') = ', G12.5 ) - 9997 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, - $ ' for N =', I5, ', type ', I2 ) RETURN * * End of DCHKPT diff --git a/TESTING/LIN/schkpb.f b/TESTING/LIN/schkpb.f index ef0c79834..1dfd4df1c 100644 --- a/TESTING/LIN/schkpb.f +++ b/TESTING/LIN/schkpb.f @@ -427,22 +427,12 @@ SUBROUTINE SCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, SRNAMT = 'SPBTRF' CALL SPBTRF( UPLO, N, KD, AFAC, LDAB, INFO ) * -* Check error code from SPBTRF. ALAERH returns -* without a message when INFO is zero, so an -* undetected bad pivot is reported here instead. +* Check error code from SPBTRF. * IF( INFO.NE.IZERO ) THEN - IF( INFO.EQ.0 ) THEN - IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) - $ CALL ALAHD( NOUT, PATH ) - WRITE( NOUT, FMT = 9996 )'SPBTRF', IZERO, - $ UPLO, N, KD, IMAT - NFAIL = NFAIL + 1 - ELSE - CALL ALAERH( PATH, 'SPBTRF', INFO, IZERO, - $ UPLO, N, N, KD, KD, NB, IMAT, - $ NFAIL, NERRS, NOUT ) - END IF + CALL ALAERH( PATH, 'SPBTRF', INFO, IZERO, UPLO, + $ N, N, KD, KD, NB, IMAT, NFAIL, + $ NERRS, NOUT ) GO TO 50 END IF * @@ -607,9 +597,6 @@ SUBROUTINE SCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ ', type ', I2, ', test(', I2, ') = ', G12.5 ) 9997 FORMAT( ' UPLO=''', A1, ''', N=', I5, ', KD=', I5, ',', 10X, $ ' type ', I2, ', test(', I2, ') = ', G12.5 ) - 9996 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, - $ ' for UPLO=''', A1, ''', N=', I5, ', KD=', I5, - $ ', type ', I2 ) RETURN * * End of SCHKPB diff --git a/TESTING/LIN/schkpp.f b/TESTING/LIN/schkpp.f index c83e3f49c..39dd5ff61 100644 --- a/TESTING/LIN/schkpp.f +++ b/TESTING/LIN/schkpp.f @@ -354,22 +354,11 @@ SUBROUTINE SCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, SRNAMT = 'SPPTRF' CALL SPPTRF( UPLO, N, AFAC, INFO ) * -* Check error code from SPPTRF. ALAERH returns without a -* message when INFO is zero, so an undetected bad pivot is -* reported here instead. +* Check error code from SPPTRF. * IF( INFO.NE.IZERO ) THEN - IF( INFO.EQ.0 ) THEN - IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) - $ CALL ALAHD( NOUT, PATH ) - WRITE( NOUT, FMT = 9997 )'SPPTRF', IZERO, UPLO, N, - $ IMAT - NFAIL = NFAIL + 1 - ELSE - CALL ALAERH( PATH, 'SPPTRF', INFO, IZERO, UPLO, N, - $ N, -1, -1, -1, IMAT, NFAIL, NERRS, - $ NOUT ) - END IF + CALL ALAERH( PATH, 'SPPTRF', INFO, IZERO, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) GO TO 90 END IF * @@ -520,8 +509,6 @@ SUBROUTINE SCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ I2, ', ratio =', G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', $ I2, ', test(', I2, ') =', G12.5 ) - 9997 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, - $ ' for UPLO = ''', A1, ''', N =', I5, ', type ', I2 ) RETURN * * End of SCHKPP diff --git a/TESTING/LIN/schkpt.f b/TESTING/LIN/schkpt.f index d3bf711a3..5e7e83324 100644 --- a/TESTING/LIN/schkpt.f +++ b/TESTING/LIN/schkpt.f @@ -383,20 +383,11 @@ SUBROUTINE SCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * CALL SPTTRF( N, D( N+1 ), E( N+1 ), INFO ) * -* Check error code from SPTTRF. ALAERH returns without a -* message when INFO is zero, so an undetected bad pivot is -* reported here instead. +* Check error code from SPTTRF. * IF( INFO.NE.IZERO ) THEN - IF( INFO.EQ.0 ) THEN - IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) - $ CALL ALAHD( NOUT, PATH ) - WRITE( NOUT, FMT = 9997 )'SPTTRF', IZERO, N, IMAT - NFAIL = NFAIL + 1 - ELSE - CALL ALAERH( PATH, 'SPTTRF', INFO, IZERO, ' ', N, N, - $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) - END IF + CALL ALAERH( PATH, 'SPTTRF', INFO, IZERO, ' ', N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) GO TO 100 END IF * @@ -546,8 +537,6 @@ SUBROUTINE SCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ G12.5 ) 9998 FORMAT( ' N =', I5, ', NRHS=', I3, ', type ', I2, ', test(', I2, $ ') = ', G12.5 ) - 9997 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, - $ ' for N =', I5, ', type ', I2 ) RETURN * * End of SCHKPT diff --git a/TESTING/LIN/test_alaerh.f90 b/TESTING/LIN/test_alaerh.f90 new file mode 100644 index 000000000..7f4dd788e --- /dev/null +++ b/TESTING/LIN/test_alaerh.f90 @@ -0,0 +1,66 @@ +! SPDX-FileCopyrightText: The LAPACK Authors +! SPDX-License-Identifier: BSD-3-Clause +! +! Unexpected success must be diagnosed like any other wrong INFO. +program test_alaerh + implicit none + character :: precision(4) = ['S', 'D', 'C', 'Z'] + character(2) :: storage(3) = ['PB', 'PP', 'PT'] + character(3) :: path + character(6) :: subnam + integer :: p, s + + do p = 1, size(precision) + do s = 1, size(storage) + path = precision(p)//storage(s) + subnam = path//'TRF' + call check(0, 3, 0) + call check(2, 3, 1) + call check(2, 0, 1) + call check(2, 2, 1) + call check(0, 0, 0) + end do + end do + +contains + + subroutine check(info, infoe, prior_errors) + integer, intent(in) :: info, infoe, prior_errors + integer :: unit, nerrs, nfail, status, lines, diagnostics + character(256) :: line + character(5) :: actual + character(2) :: expected + external :: alaerh + + nfail = 0 + nerrs = prior_errors + open(newunit=unit, status='scratch', action='readwrite') + call alaerh(path, subnam, info, infoe, 'U', 5, 5, 1, 1, 1, & + 9, nfail, nerrs, unit) + if (nfail /= 0) stop 1 + rewind(unit) + lines = 0 + diagnostics = 0 + write(actual, '(I5)') info + write(expected, '(I2)') infoe + do + read(unit, '(A)', iostat=status) line + if (status < 0) exit + if (status /= 0) stop 2 + lines = lines + 1 + if (index(line, subnam) == 0) cycle + if (index(line, ' *** ') == 0) cycle + diagnostics = diagnostics + 1 + if (index(line, '='//actual) == 0) stop 3 + if (info /= infoe .and. infoe /= 0) then + if (index(line, 'instead of '//expected) == 0) stop 4 + end if + end do + close(unit) + if (info == 0 .and. infoe == 0) then + if (nerrs /= prior_errors .or. lines /= 0) stop 5 + else + if (nerrs /= prior_errors+1 .or. diagnostics /= 1) stop 6 + end if + end subroutine +end program diff --git a/TESTING/LIN/zchkpb.f b/TESTING/LIN/zchkpb.f index a2a0a73b9..3751da587 100644 --- a/TESTING/LIN/zchkpb.f +++ b/TESTING/LIN/zchkpb.f @@ -431,22 +431,12 @@ SUBROUTINE ZCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, SRNAMT = 'ZPBTRF' CALL ZPBTRF( UPLO, N, KD, AFAC, LDAB, INFO ) * -* Check error code from ZPBTRF. ALAERH returns -* without a message when INFO is zero, so an -* undetected bad pivot is reported here instead. +* Check error code from ZPBTRF. * IF( INFO.NE.IZERO ) THEN - IF( INFO.EQ.0 ) THEN - IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) - $ CALL ALAHD( NOUT, PATH ) - WRITE( NOUT, FMT = 9996 )'ZPBTRF', IZERO, - $ UPLO, N, KD, IMAT - NFAIL = NFAIL + 1 - ELSE - CALL ALAERH( PATH, 'ZPBTRF', INFO, IZERO, - $ UPLO, N, N, KD, KD, NB, IMAT, - $ NFAIL, NERRS, NOUT ) - END IF + CALL ALAERH( PATH, 'ZPBTRF', INFO, IZERO, UPLO, + $ N, N, KD, KD, NB, IMAT, NFAIL, + $ NERRS, NOUT ) GO TO 50 END IF * @@ -612,9 +602,6 @@ SUBROUTINE ZCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ ', type ', I2, ', test(', I2, ') = ', G12.5 ) 9997 FORMAT( ' UPLO=''', A1, ''', N=', I5, ', KD=', I5, ',', 10X, $ ' type ', I2, ', test(', I2, ') = ', G12.5 ) - 9996 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, - $ ' for UPLO=''', A1, ''', N=', I5, ', KD=', I5, - $ ', type ', I2 ) RETURN * * End of ZCHKPB diff --git a/TESTING/LIN/zchkpp.f b/TESTING/LIN/zchkpp.f index 1b2452150..8b679b8ac 100644 --- a/TESTING/LIN/zchkpp.f +++ b/TESTING/LIN/zchkpp.f @@ -359,22 +359,11 @@ SUBROUTINE ZCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, SRNAMT = 'ZPPTRF' CALL ZPPTRF( UPLO, N, AFAC, INFO ) * -* Check error code from ZPPTRF. ALAERH returns without a -* message when INFO is zero, so an undetected bad pivot is -* reported here instead. +* Check error code from ZPPTRF. * IF( INFO.NE.IZERO ) THEN - IF( INFO.EQ.0 ) THEN - IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) - $ CALL ALAHD( NOUT, PATH ) - WRITE( NOUT, FMT = 9997 )'ZPPTRF', IZERO, UPLO, N, - $ IMAT - NFAIL = NFAIL + 1 - ELSE - CALL ALAERH( PATH, 'ZPPTRF', INFO, IZERO, UPLO, N, - $ N, -1, -1, -1, IMAT, NFAIL, NERRS, - $ NOUT ) - END IF + CALL ALAERH( PATH, 'ZPPTRF', INFO, IZERO, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) GO TO 90 END IF * @@ -526,8 +515,6 @@ SUBROUTINE ZCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ I2, ', ratio =', G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', $ I2, ', test(', I2, ') =', G12.5 ) - 9997 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, - $ ' for UPLO = ''', A1, ''', N =', I5, ', type ', I2 ) RETURN * * End of ZCHKPP diff --git a/TESTING/LIN/zchkpt.f b/TESTING/LIN/zchkpt.f index 696d810e9..3c6b75728 100644 --- a/TESTING/LIN/zchkpt.f +++ b/TESTING/LIN/zchkpt.f @@ -387,20 +387,11 @@ SUBROUTINE ZCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, * CALL ZPTTRF( N, D( N+1 ), E( N+1 ), INFO ) * -* Check error code from ZPTTRF. ALAERH returns without a -* message when INFO is zero, so an undetected bad pivot is -* reported here instead. +* Check error code from ZPTTRF. * IF( INFO.NE.IZERO ) THEN - IF( INFO.EQ.0 ) THEN - IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) - $ CALL ALAHD( NOUT, PATH ) - WRITE( NOUT, FMT = 9997 )'ZPTTRF', IZERO, N, IMAT - NFAIL = NFAIL + 1 - ELSE - CALL ALAERH( PATH, 'ZPTTRF', INFO, IZERO, ' ', N, N, - $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) - END IF + CALL ALAERH( PATH, 'ZPTTRF', INFO, IZERO, ' ', N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) GO TO 110 END IF * @@ -563,8 +554,6 @@ SUBROUTINE ZCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, $ G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS =', I3, $ ', type ', I2, ', test ', I2, ', ratio = ', G12.5 ) - 9997 FORMAT( ' *** ', A, ' returned INFO = 0 instead of ', I5, - $ ' for N =', I5, ', type ', I2 ) RETURN * * End of ZCHKPT