Skip to content

fix rfp test for DIAG = U #796

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 1 commit into from
Feb 14, 2023
Merged

fix rfp test for DIAG = U #796

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
56 changes: 43 additions & 13 deletions TESTING/LIN/cdrvrf3.f
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -156,9 +156,10 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
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
Expand Down Expand Up @@ -222,9 +223,9 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
*
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 )
Expand Down Expand Up @@ -263,7 +264,7 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
*
DO J = 1, NA
DO I = 1, NA
A( I, J) = CLARND( 4, ISEED )
A( I, J ) = CLARND( 4, ISEED )
END DO
END DO
*
Expand All @@ -276,6 +277,20 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
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'
Expand All @@ -285,6 +300,20 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
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
Expand All @@ -293,7 +322,8 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
* 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).
Expand All @@ -307,8 +337,8 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
*
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
*
Expand All @@ -331,24 +361,24 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
*
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
*
Expand Down
53 changes: 41 additions & 12 deletions TESTING/LIN/ddrvrf3.f
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -153,8 +153,9 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
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
Expand Down Expand Up @@ -218,9 +219,9 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
*
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 )
Expand Down Expand Up @@ -259,7 +260,7 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
*
DO J = 1, NA
DO I = 1, NA
A( I, J) = DLARND( 2, ISEED )
A( I, J ) = DLARND( 2, ISEED )
END DO
END DO
*
Expand All @@ -272,6 +273,20 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
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'
Expand All @@ -281,6 +296,20 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
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).
Expand All @@ -294,8 +323,8 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
*
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
*
Expand All @@ -318,24 +347,24 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
*
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
*
Expand Down
53 changes: 41 additions & 12 deletions TESTING/LIN/sdrvrf3.f
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -153,8 +153,9 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
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
Expand Down Expand Up @@ -218,9 +219,9 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
*
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 )
Expand Down Expand Up @@ -259,7 +260,7 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
*
DO J = 1, NA
DO I = 1, NA
A( I, J) = SLARND( 2, ISEED )
A( I, J ) = SLARND( 2, ISEED )
END DO
END DO
*
Expand All @@ -272,6 +273,20 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
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'
Expand All @@ -281,6 +296,20 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
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).
Expand All @@ -294,8 +323,8 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
*
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
*
Expand All @@ -318,24 +347,24 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
*
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
*
Expand Down
Loading