From 85a03675f6e23683542cdef3cb5b2d18acc0c069 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 15 Feb 2023 08:24:47 +0100 Subject: [PATCH] Fix ill-conditioned test matrix for DIAG=U in LIN testsuite test_rfp (LAPACK 678/796) --- lapack-netlib/TESTING/LIN/cdrvrf3.f | 56 ++++++++++++++++++++++------- lapack-netlib/TESTING/LIN/ddrvrf3.f | 53 ++++++++++++++++++++------- lapack-netlib/TESTING/LIN/sdrvrf3.f | 53 ++++++++++++++++++++------- lapack-netlib/TESTING/LIN/zdrvrf3.f | 56 ++++++++++++++++++++++------- 4 files changed, 168 insertions(+), 50 deletions(-) diff --git a/lapack-netlib/TESTING/LIN/cdrvrf3.f b/lapack-netlib/TESTING/LIN/cdrvrf3.f index 1ca816979..d0edf75e1 100644 --- a/lapack-netlib/TESTING/LIN/cdrvrf3.f +++ b/lapack-netlib/TESTING/LIN/cdrvrf3.f @@ -156,9 +156,10 @@ REAL RESULT( NTESTS ) * .. * .. External Functions .. + LOGICAL LSAME REAL SLAMCH, CLANGE COMPLEX CLARND - EXTERNAL SLAMCH, CLARND, CLANGE + EXTERNAL SLAMCH, CLARND, CLANGE, LSAME * .. * .. External Subroutines .. EXTERNAL CTRTTF, CGEQRF, CGEQLF, CTFSM, CTRSM @@ -222,9 +223,9 @@ * DO 100 IALPHA = 1, 3 * - IF ( IALPHA.EQ. 1) THEN + IF ( IALPHA.EQ.1 ) THEN ALPHA = ZERO - ELSE IF ( IALPHA.EQ. 2) THEN + ELSE IF ( IALPHA.EQ.2 ) THEN ALPHA = ONE ELSE ALPHA = CLARND( 4, ISEED ) @@ -263,7 +264,7 @@ * DO J = 1, NA DO I = 1, NA - A( I, J) = CLARND( 4, ISEED ) + A( I, J ) = CLARND( 4, ISEED ) END DO END DO * @@ -276,6 +277,20 @@ CALL CGEQRF( NA, NA, A, LDA, TAU, + C_WORK_CGEQRF, LDA, + INFO ) +* +* Forcing main diagonal of test matrix to +* be unit makes it ill-conditioned for +* some test cases +* + IF ( LSAME( DIAG, 'U' ) ) THEN + DO J = 1, NA + DO I = 1, J + A( I, J ) = A( I, J ) / + + ( 2.0 * A( J, J ) ) + END DO + END DO + END IF +* ELSE * * The case IUPLO.EQ.2 is when SIDE.EQ.'L' @@ -285,6 +300,20 @@ CALL CGELQF( NA, NA, A, LDA, TAU, + C_WORK_CGEQRF, LDA, + INFO ) +* +* Forcing main diagonal of test matrix to +* be unit makes it ill-conditioned for +* some test cases +* + IF ( LSAME( DIAG, 'U' ) ) THEN + DO I = 1, NA + DO J = 1, I + A( I, J ) = A( I, J ) / + + ( 2.0 * A( I, I ) ) + END DO + END DO + END IF +* END IF * * After the QR factorization, the diagonal @@ -293,7 +322,8 @@ * value 1.0E+00. * DO J = 1, NA - A( J, J) = A(J,J) * CLARND( 5, ISEED ) + A( J, J ) = A( J, J ) * + + CLARND( 5, ISEED ) END DO * * Store a copy of A in RFP format (in ARF). @@ -307,8 +337,8 @@ * DO J = 1, N DO I = 1, M - B1( I, J) = CLARND( 4, ISEED ) - B2( I, J) = B1( I, J) + B1( I, J ) = CLARND( 4, ISEED ) + B2( I, J ) = B1( I, J ) END DO END DO * @@ -331,24 +361,24 @@ * DO J = 1, N DO I = 1, M - B1( I, J) = B2( I, J ) - B1( I, J ) + B1( I, J ) = B2( I, J ) - B1( I, J ) END DO END DO * - RESULT(1) = CLANGE( 'I', M, N, B1, LDA, + RESULT( 1 ) = CLANGE( 'I', M, N, B1, LDA, + S_WORK_CLANGE ) * - RESULT(1) = RESULT(1) / SQRT( EPS ) - + / MAX ( MAX( M, N), 1 ) + RESULT( 1 ) = RESULT( 1 ) / SQRT( EPS ) + + / MAX ( MAX( M, N ), 1 ) * - IF( RESULT(1).GE.THRESH ) THEN + IF( RESULT( 1 ).GE.THRESH ) THEN IF( NFAIL.EQ.0 ) THEN WRITE( NOUT, * ) WRITE( NOUT, FMT = 9999 ) END IF WRITE( NOUT, FMT = 9997 ) 'CTFSM', + CFORM, SIDE, UPLO, TRANS, DIAG, M, - + N, RESULT(1) + + N, RESULT( 1 ) NFAIL = NFAIL + 1 END IF * diff --git a/lapack-netlib/TESTING/LIN/ddrvrf3.f b/lapack-netlib/TESTING/LIN/ddrvrf3.f index 1c5d74aea..ef823c2e7 100644 --- a/lapack-netlib/TESTING/LIN/ddrvrf3.f +++ b/lapack-netlib/TESTING/LIN/ddrvrf3.f @@ -153,8 +153,9 @@ DOUBLE PRECISION RESULT( NTESTS ) * .. * .. External Functions .. + LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE, DLARND - EXTERNAL DLAMCH, DLANGE, DLARND + EXTERNAL DLAMCH, DLANGE, DLARND, LSAME * .. * .. External Subroutines .. EXTERNAL DTRTTF, DGEQRF, DGEQLF, DTFSM, DTRSM @@ -218,9 +219,9 @@ * DO 100 IALPHA = 1, 3 * - IF ( IALPHA.EQ. 1) THEN + IF ( IALPHA.EQ.1 ) THEN ALPHA = ZERO - ELSE IF ( IALPHA.EQ. 2) THEN + ELSE IF ( IALPHA.EQ.2 ) THEN ALPHA = ONE ELSE ALPHA = DLARND( 2, ISEED ) @@ -259,7 +260,7 @@ * DO J = 1, NA DO I = 1, NA - A( I, J) = DLARND( 2, ISEED ) + A( I, J ) = DLARND( 2, ISEED ) END DO END DO * @@ -272,6 +273,20 @@ CALL DGEQRF( NA, NA, A, LDA, TAU, + D_WORK_DGEQRF, LDA, + INFO ) +* +* Forcing main diagonal of test matrix to +* be unit makes it ill-conditioned for +* some test cases +* + IF ( LSAME( DIAG, 'U' ) ) THEN + DO J = 1, NA + DO I = 1, J + A( I, J ) = A( I, J ) / + + ( 2.0 * A( J, J ) ) + END DO + END DO + END IF +* ELSE * * The case IUPLO.EQ.2 is when SIDE.EQ.'L' @@ -281,6 +296,20 @@ CALL DGELQF( NA, NA, A, LDA, TAU, + D_WORK_DGEQRF, LDA, + INFO ) +* +* Forcing main diagonal of test matrix to +* be unit makes it ill-conditioned for +* some test cases +* + IF ( LSAME( DIAG, 'U' ) ) THEN + DO I = 1, NA + DO J = 1, I + A( I, J ) = A( I, J ) / + + ( 2.0 * A( I, I ) ) + END DO + END DO + END IF +* END IF * * Store a copy of A in RFP format (in ARF). @@ -294,8 +323,8 @@ * DO J = 1, N DO I = 1, M - B1( I, J) = DLARND( 2, ISEED ) - B2( I, J) = B1( I, J) + B1( I, J ) = DLARND( 2, ISEED ) + B2( I, J ) = B1( I, J ) END DO END DO * @@ -318,24 +347,24 @@ * DO J = 1, N DO I = 1, M - B1( I, J) = B2( I, J ) - B1( I, J ) + B1( I, J ) = B2( I, J ) - B1( I, J ) END DO END DO * - RESULT(1) = DLANGE( 'I', M, N, B1, LDA, + RESULT( 1 ) = DLANGE( 'I', M, N, B1, LDA, + D_WORK_DLANGE ) * - RESULT(1) = RESULT(1) / SQRT( EPS ) - + / MAX ( MAX( M, N), 1 ) + RESULT( 1 ) = RESULT( 1 ) / SQRT( EPS ) + + / MAX ( MAX( M, N ), 1 ) * - IF( RESULT(1).GE.THRESH ) THEN + IF( RESULT( 1 ).GE.THRESH ) THEN IF( NFAIL.EQ.0 ) THEN WRITE( NOUT, * ) WRITE( NOUT, FMT = 9999 ) END IF WRITE( NOUT, FMT = 9997 ) 'DTFSM', + CFORM, SIDE, UPLO, TRANS, DIAG, M, - + N, RESULT(1) + + N, RESULT( 1 ) NFAIL = NFAIL + 1 END IF * diff --git a/lapack-netlib/TESTING/LIN/sdrvrf3.f b/lapack-netlib/TESTING/LIN/sdrvrf3.f index 5faae2733..bc01d8473 100644 --- a/lapack-netlib/TESTING/LIN/sdrvrf3.f +++ b/lapack-netlib/TESTING/LIN/sdrvrf3.f @@ -153,8 +153,9 @@ REAL RESULT( NTESTS ) * .. * .. External Functions .. + LOGICAL LSAME REAL SLAMCH, SLANGE, SLARND - EXTERNAL SLAMCH, SLANGE, SLARND + EXTERNAL SLAMCH, SLANGE, SLARND, LSAME * .. * .. External Subroutines .. EXTERNAL STRTTF, SGEQRF, SGEQLF, STFSM, STRSM @@ -218,9 +219,9 @@ * DO 100 IALPHA = 1, 3 * - IF ( IALPHA.EQ. 1) THEN + IF ( IALPHA.EQ.1 ) THEN ALPHA = ZERO - ELSE IF ( IALPHA.EQ. 2) THEN + ELSE IF ( IALPHA.EQ.2 ) THEN ALPHA = ONE ELSE ALPHA = SLARND( 2, ISEED ) @@ -259,7 +260,7 @@ * DO J = 1, NA DO I = 1, NA - A( I, J) = SLARND( 2, ISEED ) + A( I, J ) = SLARND( 2, ISEED ) END DO END DO * @@ -272,6 +273,20 @@ CALL SGEQRF( NA, NA, A, LDA, TAU, + S_WORK_SGEQRF, LDA, + INFO ) +* +* Forcing main diagonal of test matrix to +* be unit makes it ill-conditioned for +* some test cases +* + IF ( LSAME( DIAG, 'U' ) ) THEN + DO J = 1, NA + DO I = 1, J + A( I, J ) = A( I, J ) / + + ( 2.0 * A( J, J ) ) + END DO + END DO + END IF +* ELSE * * The case IUPLO.EQ.2 is when SIDE.EQ.'L' @@ -281,6 +296,20 @@ CALL SGELQF( NA, NA, A, LDA, TAU, + S_WORK_SGEQRF, LDA, + INFO ) +* +* Forcing main diagonal of test matrix to +* be unit makes it ill-conditioned for +* some test cases +* + IF ( LSAME( DIAG, 'U' ) ) THEN + DO I = 1, NA + DO J = 1, I + A( I, J ) = A( I, J ) / + + ( 2.0 * A( I, I ) ) + END DO + END DO + END IF +* END IF * * Store a copy of A in RFP format (in ARF). @@ -294,8 +323,8 @@ * DO J = 1, N DO I = 1, M - B1( I, J) = SLARND( 2, ISEED ) - B2( I, J) = B1( I, J) + B1( I, J ) = SLARND( 2, ISEED ) + B2( I, J ) = B1( I, J ) END DO END DO * @@ -318,24 +347,24 @@ * DO J = 1, N DO I = 1, M - B1( I, J) = B2( I, J ) - B1( I, J ) + B1( I, J ) = B2( I, J ) - B1( I, J ) END DO END DO * - RESULT(1) = SLANGE( 'I', M, N, B1, LDA, + RESULT( 1 ) = SLANGE( 'I', M, N, B1, LDA, + S_WORK_SLANGE ) * - RESULT(1) = RESULT(1) / SQRT( EPS ) - + / MAX ( MAX( M, N), 1 ) + RESULT( 1 ) = RESULT( 1 ) / SQRT( EPS ) + + / MAX ( MAX( M, N ), 1 ) * - IF( RESULT(1).GE.THRESH ) THEN + IF( RESULT( 1 ).GE.THRESH ) THEN IF( NFAIL.EQ.0 ) THEN WRITE( NOUT, * ) WRITE( NOUT, FMT = 9999 ) END IF WRITE( NOUT, FMT = 9997 ) 'STFSM', + CFORM, SIDE, UPLO, TRANS, DIAG, M, - + N, RESULT(1) + + N, RESULT( 1 ) NFAIL = NFAIL + 1 END IF * diff --git a/lapack-netlib/TESTING/LIN/zdrvrf3.f b/lapack-netlib/TESTING/LIN/zdrvrf3.f index 7a44dba29..4e55b03ef 100644 --- a/lapack-netlib/TESTING/LIN/zdrvrf3.f +++ b/lapack-netlib/TESTING/LIN/zdrvrf3.f @@ -156,9 +156,10 @@ DOUBLE PRECISION RESULT( NTESTS ) * .. * .. External Functions .. + LOGICAL LSAME DOUBLE PRECISION DLAMCH, ZLANGE COMPLEX*16 ZLARND - EXTERNAL DLAMCH, ZLARND, ZLANGE + EXTERNAL DLAMCH, ZLARND, ZLANGE, LSAME * .. * .. External Subroutines .. EXTERNAL ZTRTTF, ZGEQRF, ZGEQLF, ZTFSM, ZTRSM @@ -222,9 +223,9 @@ * DO 100 IALPHA = 1, 3 * - IF ( IALPHA.EQ. 1) THEN + IF ( IALPHA.EQ.1 ) THEN ALPHA = ZERO - ELSE IF ( IALPHA.EQ. 2) THEN + ELSE IF ( IALPHA.EQ.2 ) THEN ALPHA = ONE ELSE ALPHA = ZLARND( 4, ISEED ) @@ -263,7 +264,7 @@ * DO J = 1, NA DO I = 1, NA - A( I, J) = ZLARND( 4, ISEED ) + A( I, J ) = ZLARND( 4, ISEED ) END DO END DO * @@ -276,6 +277,20 @@ CALL ZGEQRF( NA, NA, A, LDA, TAU, + Z_WORK_ZGEQRF, LDA, + INFO ) +* +* Forcing main diagonal of test matrix to +* be unit makes it ill-conditioned for +* some test cases +* + IF ( LSAME( DIAG, 'U' ) ) THEN + DO J = 1, NA + DO I = 1, J + A( I, J ) = A( I, J ) / + + ( 2.0 * A( J, J ) ) + END DO + END DO + END IF +* ELSE * * The case IUPLO.EQ.2 is when SIDE.EQ.'L' @@ -285,6 +300,20 @@ CALL ZGELQF( NA, NA, A, LDA, TAU, + Z_WORK_ZGEQRF, LDA, + INFO ) +* +* Forcing main diagonal of test matrix to +* be unit makes it ill-conditioned for +* some test cases +* + IF ( LSAME( DIAG, 'U' ) ) THEN + DO I = 1, NA + DO J = 1, I + A( I, J ) = A( I, J ) / + + ( 2.0 * A( I, I ) ) + END DO + END DO + END IF +* END IF * * After the QR factorization, the diagonal @@ -293,7 +322,8 @@ * value 1.0E+00. * DO J = 1, NA - A( J, J) = A(J,J) * ZLARND( 5, ISEED ) + A( J, J ) = A( J, J ) * + + ZLARND( 5, ISEED ) END DO * * Store a copy of A in RFP format (in ARF). @@ -307,8 +337,8 @@ * DO J = 1, N DO I = 1, M - B1( I, J) = ZLARND( 4, ISEED ) - B2( I, J) = B1( I, J) + B1( I, J ) = ZLARND( 4, ISEED ) + B2( I, J ) = B1( I, J ) END DO END DO * @@ -331,24 +361,24 @@ * DO J = 1, N DO I = 1, M - B1( I, J) = B2( I, J ) - B1( I, J ) + B1( I, J ) = B2( I, J ) - B1( I, J ) END DO END DO * - RESULT(1) = ZLANGE( 'I', M, N, B1, LDA, + RESULT( 1 ) = ZLANGE( 'I', M, N, B1, LDA, + D_WORK_ZLANGE ) * - RESULT(1) = RESULT(1) / SQRT( EPS ) - + / MAX ( MAX( M, N), 1 ) + RESULT( 1 ) = RESULT( 1 ) / SQRT( EPS ) + + / MAX ( MAX( M, N ), 1 ) * - IF( RESULT(1).GE.THRESH ) THEN + IF( RESULT( 1 ).GE.THRESH ) THEN IF( NFAIL.EQ.0 ) THEN WRITE( NOUT, * ) WRITE( NOUT, FMT = 9999 ) END IF WRITE( NOUT, FMT = 9997 ) 'ZTFSM', + CFORM, SIDE, UPLO, TRANS, DIAG, M, - + N, RESULT(1) + + N, RESULT( 1 ) NFAIL = NFAIL + 1 END IF *