Skip to content

Commit 85a0367

Browse files
martin-frbgmartin-frbg
authored
Fix ill-conditioned test matrix for DIAG=U in LIN testsuite test_rfp (LAPACK 678/796)
1 parent fa3bc57 commit 85a0367

4 files changed

Lines changed: 168 additions & 50 deletions

File tree

‎lapack-netlib/TESTING/LIN/cdrvrf3.f‎

Lines changed: 43 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -156,9 +156,10 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
156156
REAL RESULT( NTESTS )
157157
* ..
158158
* .. External Functions ..
159+
LOGICAL LSAME
159160
REAL SLAMCH, CLANGE
160161
COMPLEX CLARND
161-
EXTERNAL SLAMCH, CLARND, CLANGE
162+
EXTERNAL SLAMCH, CLARND, CLANGE, LSAME
162163
* ..
163164
* .. External Subroutines ..
164165
EXTERNAL CTRTTF, CGEQRF, CGEQLF, CTFSM, CTRSM
@@ -222,9 +223,9 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
222223
*
223224
DO 100 IALPHA = 1, 3
224225
*
225-
IF ( IALPHA.EQ. 1) THEN
226+
IF ( IALPHA.EQ.1 ) THEN
226227
ALPHA = ZERO
227-
ELSE IF ( IALPHA.EQ. 2) THEN
228+
ELSE IF ( IALPHA.EQ.2 ) THEN
228229
ALPHA = ONE
229230
ELSE
230231
ALPHA = CLARND( 4, ISEED )
@@ -263,7 +264,7 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
263264
*
264265
DO J = 1, NA
265266
DO I = 1, NA
266-
A( I, J) = CLARND( 4, ISEED )
267+
A( I, J ) = CLARND( 4, ISEED )
267268
END DO
268269
END DO
269270
*
@@ -276,6 +277,20 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
276277
CALL CGEQRF( NA, NA, A, LDA, TAU,
277278
+ C_WORK_CGEQRF, LDA,
278279
+ INFO )
280+
*
281+
* Forcing main diagonal of test matrix to
282+
* be unit makes it ill-conditioned for
283+
* some test cases
284+
*
285+
IF ( LSAME( DIAG, 'U' ) ) THEN
286+
DO J = 1, NA
287+
DO I = 1, J
288+
A( I, J ) = A( I, J ) /
289+
+ ( 2.0 * A( J, J ) )
290+
END DO
291+
END DO
292+
END IF
293+
*
279294
ELSE
280295
*
281296
* The case IUPLO.EQ.2 is when SIDE.EQ.'L'
@@ -285,6 +300,20 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
285300
CALL CGELQF( NA, NA, A, LDA, TAU,
286301
+ C_WORK_CGEQRF, LDA,
287302
+ INFO )
303+
*
304+
* Forcing main diagonal of test matrix to
305+
* be unit makes it ill-conditioned for
306+
* some test cases
307+
*
308+
IF ( LSAME( DIAG, 'U' ) ) THEN
309+
DO I = 1, NA
310+
DO J = 1, I
311+
A( I, J ) = A( I, J ) /
312+
+ ( 2.0 * A( I, I ) )
313+
END DO
314+
END DO
315+
END IF
316+
*
288317
END IF
289318
*
290319
* After the QR factorization, the diagonal
@@ -293,7 +322,8 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
293322
* value 1.0E+00.
294323
*
295324
DO J = 1, NA
296-
A( J, J) = A(J,J) * CLARND( 5, ISEED )
325+
A( J, J ) = A( J, J ) *
326+
+ CLARND( 5, ISEED )
297327
END DO
298328
*
299329
* Store a copy of A in RFP format (in ARF).
@@ -307,8 +337,8 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
307337
*
308338
DO J = 1, N
309339
DO I = 1, M
310-
B1( I, J) = CLARND( 4, ISEED )
311-
B2( I, J) = B1( I, J)
340+
B1( I, J ) = CLARND( 4, ISEED )
341+
B2( I, J ) = B1( I, J )
312342
END DO
313343
END DO
314344
*
@@ -331,24 +361,24 @@ SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
331361
*
332362
DO J = 1, N
333363
DO I = 1, M
334-
B1( I, J) = B2( I, J ) - B1( I, J )
364+
B1( I, J ) = B2( I, J ) - B1( I, J )
335365
END DO
336366
END DO
337367
*
338-
RESULT(1) = CLANGE( 'I', M, N, B1, LDA,
368+
RESULT( 1 ) = CLANGE( 'I', M, N, B1, LDA,
339369
+ S_WORK_CLANGE )
340370
*
341-
RESULT(1) = RESULT(1) / SQRT( EPS )
342-
+ / MAX ( MAX( M, N), 1 )
371+
RESULT( 1 ) = RESULT( 1 ) / SQRT( EPS )
372+
+ / MAX ( MAX( M, N ), 1 )
343373
*
344-
IF( RESULT(1).GE.THRESH ) THEN
374+
IF( RESULT( 1 ).GE.THRESH ) THEN
345375
IF( NFAIL.EQ.0 ) THEN
346376
WRITE( NOUT, * )
347377
WRITE( NOUT, FMT = 9999 )
348378
END IF
349379
WRITE( NOUT, FMT = 9997 ) 'CTFSM',
350380
+ CFORM, SIDE, UPLO, TRANS, DIAG, M,
351-
+ N, RESULT(1)
381+
+ N, RESULT( 1 )
352382
NFAIL = NFAIL + 1
353383
END IF
354384
*

‎lapack-netlib/TESTING/LIN/ddrvrf3.f‎

Lines changed: 41 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -153,8 +153,9 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
153153
DOUBLE PRECISION RESULT( NTESTS )
154154
* ..
155155
* .. External Functions ..
156+
LOGICAL LSAME
156157
DOUBLE PRECISION DLAMCH, DLANGE, DLARND
157-
EXTERNAL DLAMCH, DLANGE, DLARND
158+
EXTERNAL DLAMCH, DLANGE, DLARND, LSAME
158159
* ..
159160
* .. External Subroutines ..
160161
EXTERNAL DTRTTF, DGEQRF, DGEQLF, DTFSM, DTRSM
@@ -218,9 +219,9 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
218219
*
219220
DO 100 IALPHA = 1, 3
220221
*
221-
IF ( IALPHA.EQ. 1) THEN
222+
IF ( IALPHA.EQ.1 ) THEN
222223
ALPHA = ZERO
223-
ELSE IF ( IALPHA.EQ. 2) THEN
224+
ELSE IF ( IALPHA.EQ.2 ) THEN
224225
ALPHA = ONE
225226
ELSE
226227
ALPHA = DLARND( 2, ISEED )
@@ -259,7 +260,7 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
259260
*
260261
DO J = 1, NA
261262
DO I = 1, NA
262-
A( I, J) = DLARND( 2, ISEED )
263+
A( I, J ) = DLARND( 2, ISEED )
263264
END DO
264265
END DO
265266
*
@@ -272,6 +273,20 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
272273
CALL DGEQRF( NA, NA, A, LDA, TAU,
273274
+ D_WORK_DGEQRF, LDA,
274275
+ INFO )
276+
*
277+
* Forcing main diagonal of test matrix to
278+
* be unit makes it ill-conditioned for
279+
* some test cases
280+
*
281+
IF ( LSAME( DIAG, 'U' ) ) THEN
282+
DO J = 1, NA
283+
DO I = 1, J
284+
A( I, J ) = A( I, J ) /
285+
+ ( 2.0 * A( J, J ) )
286+
END DO
287+
END DO
288+
END IF
289+
*
275290
ELSE
276291
*
277292
* The case IUPLO.EQ.2 is when SIDE.EQ.'L'
@@ -281,6 +296,20 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
281296
CALL DGELQF( NA, NA, A, LDA, TAU,
282297
+ D_WORK_DGEQRF, LDA,
283298
+ INFO )
299+
*
300+
* Forcing main diagonal of test matrix to
301+
* be unit makes it ill-conditioned for
302+
* some test cases
303+
*
304+
IF ( LSAME( DIAG, 'U' ) ) THEN
305+
DO I = 1, NA
306+
DO J = 1, I
307+
A( I, J ) = A( I, J ) /
308+
+ ( 2.0 * A( I, I ) )
309+
END DO
310+
END DO
311+
END IF
312+
*
284313
END IF
285314
*
286315
* Store a copy of A in RFP format (in ARF).
@@ -294,8 +323,8 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
294323
*
295324
DO J = 1, N
296325
DO I = 1, M
297-
B1( I, J) = DLARND( 2, ISEED )
298-
B2( I, J) = B1( I, J)
326+
B1( I, J ) = DLARND( 2, ISEED )
327+
B2( I, J ) = B1( I, J )
299328
END DO
300329
END DO
301330
*
@@ -318,24 +347,24 @@ SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
318347
*
319348
DO J = 1, N
320349
DO I = 1, M
321-
B1( I, J) = B2( I, J ) - B1( I, J )
350+
B1( I, J ) = B2( I, J ) - B1( I, J )
322351
END DO
323352
END DO
324353
*
325-
RESULT(1) = DLANGE( 'I', M, N, B1, LDA,
354+
RESULT( 1 ) = DLANGE( 'I', M, N, B1, LDA,
326355
+ D_WORK_DLANGE )
327356
*
328-
RESULT(1) = RESULT(1) / SQRT( EPS )
329-
+ / MAX ( MAX( M, N), 1 )
357+
RESULT( 1 ) = RESULT( 1 ) / SQRT( EPS )
358+
+ / MAX ( MAX( M, N ), 1 )
330359
*
331-
IF( RESULT(1).GE.THRESH ) THEN
360+
IF( RESULT( 1 ).GE.THRESH ) THEN
332361
IF( NFAIL.EQ.0 ) THEN
333362
WRITE( NOUT, * )
334363
WRITE( NOUT, FMT = 9999 )
335364
END IF
336365
WRITE( NOUT, FMT = 9997 ) 'DTFSM',
337366
+ CFORM, SIDE, UPLO, TRANS, DIAG, M,
338-
+ N, RESULT(1)
367+
+ N, RESULT( 1 )
339368
NFAIL = NFAIL + 1
340369
END IF
341370
*

‎lapack-netlib/TESTING/LIN/sdrvrf3.f‎

Lines changed: 41 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -153,8 +153,9 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
153153
REAL RESULT( NTESTS )
154154
* ..
155155
* .. External Functions ..
156+
LOGICAL LSAME
156157
REAL SLAMCH, SLANGE, SLARND
157-
EXTERNAL SLAMCH, SLANGE, SLARND
158+
EXTERNAL SLAMCH, SLANGE, SLARND, LSAME
158159
* ..
159160
* .. External Subroutines ..
160161
EXTERNAL STRTTF, SGEQRF, SGEQLF, STFSM, STRSM
@@ -218,9 +219,9 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
218219
*
219220
DO 100 IALPHA = 1, 3
220221
*
221-
IF ( IALPHA.EQ. 1) THEN
222+
IF ( IALPHA.EQ.1 ) THEN
222223
ALPHA = ZERO
223-
ELSE IF ( IALPHA.EQ. 2) THEN
224+
ELSE IF ( IALPHA.EQ.2 ) THEN
224225
ALPHA = ONE
225226
ELSE
226227
ALPHA = SLARND( 2, ISEED )
@@ -259,7 +260,7 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
259260
*
260261
DO J = 1, NA
261262
DO I = 1, NA
262-
A( I, J) = SLARND( 2, ISEED )
263+
A( I, J ) = SLARND( 2, ISEED )
263264
END DO
264265
END DO
265266
*
@@ -272,6 +273,20 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
272273
CALL SGEQRF( NA, NA, A, LDA, TAU,
273274
+ S_WORK_SGEQRF, LDA,
274275
+ INFO )
276+
*
277+
* Forcing main diagonal of test matrix to
278+
* be unit makes it ill-conditioned for
279+
* some test cases
280+
*
281+
IF ( LSAME( DIAG, 'U' ) ) THEN
282+
DO J = 1, NA
283+
DO I = 1, J
284+
A( I, J ) = A( I, J ) /
285+
+ ( 2.0 * A( J, J ) )
286+
END DO
287+
END DO
288+
END IF
289+
*
275290
ELSE
276291
*
277292
* The case IUPLO.EQ.2 is when SIDE.EQ.'L'
@@ -281,6 +296,20 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
281296
CALL SGELQF( NA, NA, A, LDA, TAU,
282297
+ S_WORK_SGEQRF, LDA,
283298
+ INFO )
299+
*
300+
* Forcing main diagonal of test matrix to
301+
* be unit makes it ill-conditioned for
302+
* some test cases
303+
*
304+
IF ( LSAME( DIAG, 'U' ) ) THEN
305+
DO I = 1, NA
306+
DO J = 1, I
307+
A( I, J ) = A( I, J ) /
308+
+ ( 2.0 * A( I, I ) )
309+
END DO
310+
END DO
311+
END IF
312+
*
284313
END IF
285314
*
286315
* Store a copy of A in RFP format (in ARF).
@@ -294,8 +323,8 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
294323
*
295324
DO J = 1, N
296325
DO I = 1, M
297-
B1( I, J) = SLARND( 2, ISEED )
298-
B2( I, J) = B1( I, J)
326+
B1( I, J ) = SLARND( 2, ISEED )
327+
B2( I, J ) = B1( I, J )
299328
END DO
300329
END DO
301330
*
@@ -318,24 +347,24 @@ SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
318347
*
319348
DO J = 1, N
320349
DO I = 1, M
321-
B1( I, J) = B2( I, J ) - B1( I, J )
350+
B1( I, J ) = B2( I, J ) - B1( I, J )
322351
END DO
323352
END DO
324353
*
325-
RESULT(1) = SLANGE( 'I', M, N, B1, LDA,
354+
RESULT( 1 ) = SLANGE( 'I', M, N, B1, LDA,
326355
+ S_WORK_SLANGE )
327356
*
328-
RESULT(1) = RESULT(1) / SQRT( EPS )
329-
+ / MAX ( MAX( M, N), 1 )
357+
RESULT( 1 ) = RESULT( 1 ) / SQRT( EPS )
358+
+ / MAX ( MAX( M, N ), 1 )
330359
*
331-
IF( RESULT(1).GE.THRESH ) THEN
360+
IF( RESULT( 1 ).GE.THRESH ) THEN
332361
IF( NFAIL.EQ.0 ) THEN
333362
WRITE( NOUT, * )
334363
WRITE( NOUT, FMT = 9999 )
335364
END IF
336365
WRITE( NOUT, FMT = 9997 ) 'STFSM',
337366
+ CFORM, SIDE, UPLO, TRANS, DIAG, M,
338-
+ N, RESULT(1)
367+
+ N, RESULT( 1 )
339368
NFAIL = NFAIL + 1
340369
END IF
341370
*

0 commit comments

Comments
 (0)