floraachy
/
OpenBLAS
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add a BLAS3-based triangular Sylvester equation solver (Reference-LAPACK PR 651)

This commit is contained in:
Martin Kroeker 2022-11-13 23:18:09 +01:00 committed by GitHub
parent 92174725d9
commit 13f3bbece1
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
8 changed files with 358 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
lapack-netlib/TESTING/LIN/cchktr.f
View File

@ -31,7 +31,7 @@
*> *>
*> \verbatim *> \verbatim
*> *>
*> CCHKTR tests CTRTRI, -TRS, -RFS, and -CON, and CLATRS *> CCHKTR tests CTRTRI, -TRS, -RFS, and -CON, and CLATRS(3)
*> \endverbatim *> \endverbatim
* *
* Arguments: * Arguments:
@ -184,7 +184,7 @@
INTEGER NTYPE1, NTYPES INTEGER NTYPE1, NTYPES
PARAMETER ( NTYPE1 = 10, NTYPES = 18 ) PARAMETER ( NTYPE1 = 10, NTYPES = 18 )
INTEGER NTESTS INTEGER NTESTS
PARAMETER ( NTESTS = 9 ) PARAMETER ( NTESTS = 10 )
INTEGER NTRAN INTEGER NTRAN
PARAMETER ( NTRAN = 3 ) PARAMETER ( NTRAN = 3 )
REAL ONE, ZERO REAL ONE, ZERO
@ -195,13 +195,13 @@
CHARACTER*3 PATH CHARACTER*3 PATH
INTEGER I, IDIAG, IMAT, IN, INB, INFO, IRHS, ITRAN, INTEGER I, IDIAG, IMAT, IN, INB, INFO, IRHS, ITRAN,
$ IUPLO, K, LDA, N, NB, NERRS, NFAIL, NRHS, NRUN $ IUPLO, K, LDA, N, NB, NERRS, NFAIL, NRHS, NRUN
REAL AINVNM, ANORM, DUMMY, RCOND, RCONDC, RCONDI, REAL AINVNM, ANORM, BIGNUM, DUMMY, RCOND, RCONDC,
$ RCONDO, SCALE $ RCONDI, RCONDO, RES, SCALE, SLAMCH
* .. * ..
* .. Local Arrays .. * .. Local Arrays ..
CHARACTER TRANSS( NTRAN ), UPLOS( 2 ) CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 ) INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS ) REAL RESULT( NTESTS ), SCALE3( 2 )
* .. * ..
* .. External Functions .. * .. External Functions ..
LOGICAL LSAME LOGICAL LSAME
@ -210,9 +210,9 @@
* .. * ..
* .. External Subroutines .. * .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, CCOPY, CERRTR, CGET04, EXTERNAL ALAERH, ALAHD, ALASUM, CCOPY, CERRTR, CGET04,
$ CLACPY, CLARHS, CLATRS, CLATTR, CTRCON, CTRRFS, $ CLACPY, CLARHS, CLATRS, CLATRS3, CLATTR,
$ CTRT01, CTRT02, CTRT03, CTRT05, CTRT06, CTRTRI, $ CSSCAL, CTRCON, CTRRFS, CTRT01, CTRT02, CTRT03,
$ CTRTRS, XLAENV $ CTRT05, CTRT06, CTRTRI, CTRTRS, XLAENV, SLAMCH
* .. * ..
* .. Scalars in Common .. * .. Scalars in Common ..
LOGICAL LERR, OK LOGICAL LERR, OK
@ -236,6 +236,7 @@
* *
PATH( 1: 1 ) = 'Complex precision' PATH( 1: 1 ) = 'Complex precision'
PATH( 2: 3 ) = 'TR' PATH( 2: 3 ) = 'TR'
BIGNUM = SLAMCH('Overflow') / SLAMCH('Precision')
NRUN = 0 NRUN = 0
NFAIL = 0 NFAIL = 0
NERRS = 0 NERRS = 0
@ -380,7 +381,7 @@
* This line is needed on a Sun SPARCstation. * This line is needed on a Sun SPARCstation.
* *
IF( N.GT.0 ) IF( N.GT.0 )
$ DUMMY = A( 1 ) $ DUMMY = REAL( A( 1 ) )
* *
CALL CTRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA, CALL CTRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA,
$ X, LDA, B, LDA, WORK, RWORK, $ X, LDA, B, LDA, WORK, RWORK,
@ -535,6 +536,32 @@
$ RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK, $ RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK,
$ RESULT( 9 ) ) $ RESULT( 9 ) )
* *
*+ TEST 10
* Solve op(A)*X = B.
*
SRNAMT = 'CLATRS3'
CALL CCOPY( N, X, 1, B, 1 )
CALL CCOPY( N, X, 1, B, 1 )
CALL CSCAL( N, BIGNUM, B( N+1 ), 1 )
CALL CLATRS3( UPLO, TRANS, DIAG, 'N', N, 2, A, LDA,
$ B, MAX(1, N), SCALE3, RWORK, WORK, NMAX,
$ INFO )
*
* Check error code from CLATRS3.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'CLATRS3', INFO, 0,
$ UPLO // TRANS // DIAG // 'Y', N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
CALL CTRT03( UPLO, TRANS, DIAG, N, 1, A, LDA,
$ SCALE3( 1 ), RWORK, ONE, B( 1 ), LDA,
$ X, LDA, WORK, RESULT( 10 ) )
CALL CSSCAL( N, BIGNUM, X, 1 )
CALL CTRT03( UPLO, TRANS, DIAG, N, 1, A, LDA,
$ SCALE3( 2 ), RWORK, ONE, B( N+1 ), LDA,
$ X, LDA, WORK, RESULT( 10 ) )
RESULT( 10 ) = MAX( RESULT( 10 ), RES )
*
* Print information about the tests that did not pass * Print information about the tests that did not pass
* the threshold. * the threshold.
* *
@ -552,7 +579,14 @@
$ DIAG, 'Y', N, IMAT, 9, RESULT( 9 ) $ DIAG, 'Y', N, IMAT, 9, RESULT( 9 )
NFAIL = NFAIL + 1 NFAIL = NFAIL + 1
END IF END IF
NRUN = NRUN + 2 IF( RESULT( 10 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9996 )'CLATRS3', UPLO, TRANS,
$ DIAG, 'N', N, IMAT, 10, RESULT( 10 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 3
90 CONTINUE 90 CONTINUE
100 CONTINUE 100 CONTINUE
110 CONTINUE 110 CONTINUE

47
lapack-netlib/TESTING/LIN/cerrtr.f
View File

@ -82,9 +82,10 @@
EXTERNAL LSAMEN EXTERNAL LSAMEN
* .. * ..
* .. External Subroutines .. * .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, CLATBS, CLATPS, CLATRS, CTBCON, EXTERNAL ALAESM, CHKXER, CLATBS, CLATPS, CLATRS,
$ CTBRFS, CTBTRS, CTPCON, CTPRFS, CTPTRI, CTPTRS, $ CLATRS3, CTBCON, CTBRFS, CTBTRS, CTPCON,
$ CTRCON, CTRRFS, CTRTI2, CTRTRI, CTRTRS $ CTPRFS, CTPTRI, CTPTRS, CTRCON, CTRRFS, CTRTI2,
$ CTRTRI, CTRTRS
* .. * ..
* .. Scalars in Common .. * .. Scalars in Common ..
LOGICAL LERR, OK LOGICAL LERR, OK
@ -240,6 +241,46 @@
CALL CLATRS( 'U', 'N', 'N', 'N', 2, A, 1, X, SCALE, RW, INFO ) CALL CLATRS( 'U', 'N', 'N', 'N', 2, A, 1, X, SCALE, RW, INFO )
CALL CHKXER( 'CLATRS', INFOT, NOUT, LERR, OK ) CALL CHKXER( 'CLATRS', INFOT, NOUT, LERR, OK )
* *
* CLATRS3
*
SRNAMT = 'CLATRS3'
INFOT = 1
CALL CLATRS3( '/', 'N', 'N', 'N', 0, 0, A, 1, X, 1, SCALE, RW,
$ RW( 2 ), 1, INFO )
CALL CHKXER( 'CLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL CLATRS3( 'U', '/', 'N', 'N', 0, 0, A, 1, X, 1, SCALE, RW,
$ RW( 2 ), 1, INFO )
CALL CHKXER( 'CLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL CLATRS3( 'U', 'N', '/', 'N', 0, 0, A, 1, X, 1, SCALE, RW,
$ RW( 2 ), 1, INFO )
CALL CHKXER( 'CLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL CLATRS3( 'U', 'N', 'N', '/', 0, 0, A, 1, X, 1, SCALE, RW,
$ RW( 2 ), 1, INFO )
CALL CHKXER( 'CLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL CLATRS3( 'U', 'N', 'N', 'N', -1, 0, A, 1, X, 1, SCALE, RW,
$ RW( 2 ), 1, INFO )
CALL CHKXER( 'CLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL CLATRS3( 'U', 'N', 'N', 'N', 0, -1, A, 1, X, 1, SCALE, RW,
$ RW( 2 ), 1, INFO )
CALL CHKXER( 'CLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL CLATRS3( 'U', 'N', 'N', 'N', 2, 0, A, 1, X, 1, SCALE, RW,
$ RW( 2 ), 1, INFO )
CALL CHKXER( 'CLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL CLATRS3( 'U', 'N', 'N', 'N', 2, 0, A, 2, X, 1, SCALE, RW,
$ RW( 2 ), 1, INFO )
CALL CHKXER( 'CLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL CLATRS3( 'U', 'N', 'N', 'N', 1, 0, A, 1, X, 1, SCALE, RW,
$ RW( 2 ), 0, INFO )
CALL CHKXER( 'CLATRS3', INFOT, NOUT, LERR, OK )
*
* Test error exits for the packed triangular routines. * Test error exits for the packed triangular routines.
* *
ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN

56
lapack-netlib/TESTING/LIN/dchktr.f
View File

@ -30,7 +30,7 @@
*> *>
*> \verbatim *> \verbatim
*> *>
*> DCHKTR tests DTRTRI, -TRS, -RFS, and -CON, and DLATRS *> DCHKTR tests DTRTRI, -TRS, -RFS, and -CON, and DLATRS(3)
*> \endverbatim *> \endverbatim
* *
* Arguments: * Arguments:
@ -187,7 +187,7 @@
INTEGER NTYPE1, NTYPES INTEGER NTYPE1, NTYPES
PARAMETER ( NTYPE1 = 10, NTYPES = 18 ) PARAMETER ( NTYPE1 = 10, NTYPES = 18 )
INTEGER NTESTS INTEGER NTESTS
PARAMETER ( NTESTS = 9 ) PARAMETER ( NTESTS = 10 )
INTEGER NTRAN INTEGER NTRAN
PARAMETER ( NTRAN = 3 ) PARAMETER ( NTRAN = 3 )
DOUBLE PRECISION ONE, ZERO DOUBLE PRECISION ONE, ZERO
@ -198,13 +198,13 @@
CHARACTER*3 PATH CHARACTER*3 PATH
INTEGER I, IDIAG, IMAT, IN, INB, INFO, IRHS, ITRAN, INTEGER I, IDIAG, IMAT, IN, INB, INFO, IRHS, ITRAN,
$ IUPLO, K, LDA, N, NB, NERRS, NFAIL, NRHS, NRUN $ IUPLO, K, LDA, N, NB, NERRS, NFAIL, NRHS, NRUN
DOUBLE PRECISION AINVNM, ANORM, DUMMY, RCOND, RCONDC, RCONDI, DOUBLE PRECISION AINVNM, ANORM, BIGNUM, DLAMCH, DUMMY, RCOND,
$ RCONDO, SCALE $ RCONDC, RCONDI, RCONDO, RES, SCALE
* .. * ..
* .. Local Arrays .. * .. Local Arrays ..
CHARACTER TRANSS( NTRAN ), UPLOS( 2 ) CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 ) INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS ) DOUBLE PRECISION RESULT( NTESTS ), SCALE3( 2 )
* .. * ..
* .. External Functions .. * .. External Functions ..
LOGICAL LSAME LOGICAL LSAME
@ -213,9 +213,9 @@
* .. * ..
* .. External Subroutines .. * .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DCOPY, DERRTR, DGET04, EXTERNAL ALAERH, ALAHD, ALASUM, DCOPY, DERRTR, DGET04,
$ DLACPY, DLARHS, DLATRS, DLATTR, DTRCON, DTRRFS, $ DLACPY, DLAMCH, DSCAL, DLARHS, DLATRS, DLATRS3,
$ DTRT01, DTRT02, DTRT03, DTRT05, DTRT06, DTRTRI, $ DLATTR, DTRCON, DTRRFS, DTRT01, DTRT02, DTRT03,
$ DTRTRS, XLAENV $ DTRT05, DTRT06, DTRTRI, DTRTRS, XLAENV
* .. * ..
* .. Scalars in Common .. * .. Scalars in Common ..
LOGICAL LERR, OK LOGICAL LERR, OK
@ -239,6 +239,7 @@
* *
PATH( 1: 1 ) = 'Double precision' PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'TR' PATH( 2: 3 ) = 'TR'
BIGNUM = DLAMCH('Overflow') / DLAMCH('Precision')
NRUN = 0 NRUN = 0
NFAIL = 0 NFAIL = 0
NERRS = 0 NERRS = 0
@ -539,6 +540,32 @@
$ RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK, $ RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK,
$ RESULT( 9 ) ) $ RESULT( 9 ) )
* *
*+ TEST 10
* Solve op(A)*X = B
*
SRNAMT = 'DLATRS3'
CALL DCOPY( N, X, 1, B, 1 )
CALL DCOPY( N, X, 1, B( N+1 ), 1 )
CALL DSCAL( N, BIGNUM, B( N+1 ), 1 )
CALL DLATRS3( UPLO, TRANS, DIAG, 'N', N, 2, A, LDA,
$ B, MAX(1, N), SCALE3, RWORK, WORK, NMAX,
$ INFO )
*
* Check error code from DLATRS3.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DLATRS3', INFO, 0,
$ UPLO // TRANS // DIAG // 'N', N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
CALL DTRT03( UPLO, TRANS, DIAG, N, 1, A, LDA,
$ SCALE3( 1 ), RWORK, ONE, B( 1 ), LDA,
$ X, LDA, WORK, RESULT( 10 ) )
CALL DSCAL( N, BIGNUM, X, 1 )
CALL DTRT03( UPLO, TRANS, DIAG, N, 1, A, LDA,
$ SCALE3( 2 ), RWORK, ONE, B( N+1 ), LDA,
$ X, LDA, WORK, RES )
RESULT( 10 ) = MAX( RESULT( 10 ), RES )
*
* Print information about the tests that did not pass * Print information about the tests that did not pass
* the threshold. * the threshold.
* *
@ -556,7 +583,14 @@
$ DIAG, 'Y', N, IMAT, 9, RESULT( 9 ) $ DIAG, 'Y', N, IMAT, 9, RESULT( 9 )
NFAIL = NFAIL + 1 NFAIL = NFAIL + 1
END IF END IF
NRUN = NRUN + 2 IF( RESULT( 10 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9996 )'DLATRS3', UPLO, TRANS,
$ DIAG, 'N', N, IMAT, 10, RESULT( 10 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 3
90 CONTINUE 90 CONTINUE
100 CONTINUE 100 CONTINUE
110 CONTINUE 110 CONTINUE
@ -569,8 +603,8 @@
9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5, ', NB=', 9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5, ', NB=',
$ I4, ', type ', I2, ', test(', I2, ')= ', G12.5 ) $ I4, ', type ', I2, ', test(', I2, ')= ', G12.5 )
9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1, 9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1,
$ ''', N=', I5, ', NB=', I4, ', type ', I2, ', $ ''', N=', I5, ', NB=', I4, ', type ', I2, ', test(',
$ test(', I2, ')= ', G12.5 ) $ I2, ')= ', G12.5 )
9997 FORMAT( ' NORM=''', A1, ''', UPLO =''', A1, ''', N=', I5, ',', 9997 FORMAT( ' NORM=''', A1, ''', UPLO =''', A1, ''', N=', I5, ',',
$ 11X, ' type ', I2, ', test(', I2, ')=', G12.5 ) $ 11X, ' type ', I2, ', test(', I2, ')=', G12.5 )
9996 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''', 9996 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''',

47
lapack-netlib/TESTING/LIN/derrtr.f
View File

@ -83,9 +83,10 @@
EXTERNAL LSAMEN EXTERNAL LSAMEN
* .. * ..
* .. External Subroutines .. * .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DLATBS, DLATPS, DLATRS, DTBCON, EXTERNAL ALAESM, CHKXER, DLATBS, DLATPS, DLATRS,
$ DTBRFS, DTBTRS, DTPCON, DTPRFS, DTPTRI, DTPTRS, $ DLATRS3, DTBCON, DTBRFS, DTBTRS, DTPCON,
$ DTRCON, DTRRFS, DTRTI2, DTRTRI, DTRTRS $ DTPRFS, DTPTRI, DTPTRS, DTRCON, DTRRFS,
$ DTRTI2, DTRTRI, DTRTRS
* .. * ..
* .. Scalars in Common .. * .. Scalars in Common ..
LOGICAL LERR, OK LOGICAL LERR, OK
@ -244,6 +245,46 @@
INFOT = 7 INFOT = 7
CALL DLATRS( 'U', 'N', 'N', 'N', 2, A, 1, X, SCALE, W, INFO ) CALL DLATRS( 'U', 'N', 'N', 'N', 2, A, 1, X, SCALE, W, INFO )
CALL CHKXER( 'DLATRS', INFOT, NOUT, LERR, OK ) CALL CHKXER( 'DLATRS', INFOT, NOUT, LERR, OK )
*
* DLATRS3
*
SRNAMT = 'DLATRS3'
INFOT = 1
CALL DLATRS3( '/', 'N', 'N', 'N', 0, 0, A, 1, X, 1, SCALE, W,
$ W( 2 ), 1, INFO )
CALL CHKXER( 'DLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DLATRS3( 'U', '/', 'N', 'N', 0, 0, A, 1, X, 1, SCALE, W,
$ W( 2 ), 1, INFO )
CALL CHKXER( 'DLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DLATRS3( 'U', 'N', '/', 'N', 0, 0, A, 1, X, 1, SCALE, W,
$ W( 2 ), 1, INFO )
CALL CHKXER( 'DLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DLATRS3( 'U', 'N', 'N', '/', 0, 0, A, 1, X, 1, SCALE, W,
$ W( 2 ), 1, INFO )
CALL CHKXER( 'DLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DLATRS3( 'U', 'N', 'N', 'N', -1, 0, A, 1, X, 1, SCALE, W,
$ W( 2 ), 1, INFO )
CALL CHKXER( 'DLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DLATRS3( 'U', 'N', 'N', 'N', 0, -1, A, 1, X, 1, SCALE, W,
$ W( 2 ), 1, INFO )
CALL CHKXER( 'DLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DLATRS3( 'U', 'N', 'N', 'N', 2, 0, A, 1, X, 1, SCALE, W,
$ W( 2 ), 1, INFO )
CALL CHKXER( 'DLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DLATRS3( 'U', 'N', 'N', 'N', 2, 0, A, 2, X, 1, SCALE, W,
$ W( 2 ), 1, INFO )
CALL CHKXER( 'DLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL DLATRS3( 'U', 'N', 'N', 'N', 1, 0, A, 1, X, 1, SCALE, W,
$ W( 2 ), 0, INFO )
CALL CHKXER( 'DLATRS3', INFOT, NOUT, LERR, OK )
* *
ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
* *

57
lapack-netlib/TESTING/LIN/schktr.f
View File

@ -30,7 +30,7 @@
*> *>
*> \verbatim *> \verbatim
*> *>
*> SCHKTR tests STRTRI, -TRS, -RFS, and -CON, and SLATRS *> SCHKTR tests STRTRI, -TRS, -RFS, and -CON, and SLATRS(3)
*> \endverbatim *> \endverbatim
* *
* Arguments: * Arguments:
@ -187,7 +187,7 @@
INTEGER NTYPE1, NTYPES INTEGER NTYPE1, NTYPES
PARAMETER ( NTYPE1 = 10, NTYPES = 18 ) PARAMETER ( NTYPE1 = 10, NTYPES = 18 )
INTEGER NTESTS INTEGER NTESTS
PARAMETER ( NTESTS = 9 ) PARAMETER ( NTESTS = 10 )
INTEGER NTRAN INTEGER NTRAN
PARAMETER ( NTRAN = 3 ) PARAMETER ( NTRAN = 3 )
REAL ONE, ZERO REAL ONE, ZERO
@ -198,13 +198,13 @@
CHARACTER*3 PATH CHARACTER*3 PATH
INTEGER I, IDIAG, IMAT, IN, INB, INFO, IRHS, ITRAN, INTEGER I, IDIAG, IMAT, IN, INB, INFO, IRHS, ITRAN,
$ IUPLO, K, LDA, N, NB, NERRS, NFAIL, NRHS, NRUN $ IUPLO, K, LDA, N, NB, NERRS, NFAIL, NRHS, NRUN
REAL AINVNM, ANORM, DUMMY, RCOND, RCONDC, RCONDI, REAL AINVNM, ANORM, BIGNUM, DUMMY, RCOND, RCONDC,
$ RCONDO, SCALE $ RCONDI, RCONDO, RES, SCALE, SLAMCH
* .. * ..
* .. Local Arrays .. * .. Local Arrays ..
CHARACTER TRANSS( NTRAN ), UPLOS( 2 ) CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 ) INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS ) REAL RESULT( NTESTS ), SCALE3( 2 )
* .. * ..
* .. External Functions .. * .. External Functions ..
LOGICAL LSAME LOGICAL LSAME
@ -213,9 +213,9 @@
* .. * ..
* .. External Subroutines .. * .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRTR, SGET04, EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRTR, SGET04,
$ SLACPY, SLARHS, SLATRS, SLATTR, STRCON, STRRFS, $ SLACPY, SLARHS, SLATRS, SLATRS3, SLATTR, SSCAL,
$ STRT01, STRT02, STRT03, STRT05, STRT06, STRTRI, $ STRCON, STRRFS, STRT01, STRT02, STRT03, STRT05,
$ STRTRS, XLAENV $ STRT06, STRTRI, STRTRS, XLAENV, SLAMCH
* .. * ..
* .. Scalars in Common .. * .. Scalars in Common ..
LOGICAL LERR, OK LOGICAL LERR, OK
@ -239,6 +239,7 @@
* *
PATH( 1: 1 ) = 'Single precision' PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'TR' PATH( 2: 3 ) = 'TR'
BIGNUM = SLAMCH('Overflow') / SLAMCH('Precision')
NRUN = 0 NRUN = 0
NFAIL = 0 NFAIL = 0
NERRS = 0 NERRS = 0
@ -539,6 +540,33 @@
$ RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK, $ RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK,
$ RESULT( 9 ) ) $ RESULT( 9 ) )
* *
*+ TEST 10
* Solve op(A)*X = B
*
SRNAMT = 'SLATRS3'
CALL SCOPY( N, X, 1, B, 1 )
CALL SCOPY( N, X, 1, B( N+1 ), 1 )
CALL SSCAL( N, BIGNUM, B( N+1 ), 1 )
CALL SLATRS3( UPLO, TRANS, DIAG, 'N', N, 2, A, LDA,
$ B, MAX(1, N), SCALE3, RWORK, WORK, NMAX,
$ INFO )
*
* Check error code from SLATRS3.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SLATRS3', INFO, 0,
$ UPLO // TRANS // DIAG // 'Y', N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL STRT03( UPLO, TRANS, DIAG, N, 1, A, LDA,
$ SCALE3 ( 1 ), RWORK, ONE, B( N+1 ), LDA,
$ X, LDA, WORK, RESULT( 10 ) )
CALL SSCAL( N, BIGNUM, X, 1 )
CALL STRT03( UPLO, TRANS, DIAG, N, 1, A, LDA,
$ SCALE3( 2 ), RWORK, ONE, B( N+1 ), LDA,
$ X, LDA, WORK, RES )
RESULT( 10 ) = MAX( RESULT( 10 ), RES )
*
* Print information about the tests that did not pass * Print information about the tests that did not pass
* the threshold. * the threshold.
* *
@ -556,7 +584,14 @@
$ DIAG, 'Y', N, IMAT, 9, RESULT( 9 ) $ DIAG, 'Y', N, IMAT, 9, RESULT( 9 )
NFAIL = NFAIL + 1 NFAIL = NFAIL + 1
END IF END IF
NRUN = NRUN + 2 IF( RESULT( 10 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9996 )'SLATRS3', UPLO, TRANS,
$ DIAG, 'N', N, IMAT, 10, RESULT( 10 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 3
90 CONTINUE 90 CONTINUE
100 CONTINUE 100 CONTINUE
110 CONTINUE 110 CONTINUE
@ -569,8 +604,8 @@
9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5, ', NB=', 9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5, ', NB=',
$ I4, ', type ', I2, ', test(', I2, ')= ', G12.5 ) $ I4, ', type ', I2, ', test(', I2, ')= ', G12.5 )
9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1, 9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1,
$ ''', N=', I5, ', NB=', I4, ', type ', I2, ', $ ''', N=', I5, ', NB=', I4, ', type ', I2, ', test(',
$ test(', I2, ')= ', G12.5 ) $ I2, ')= ', G12.5 )
9997 FORMAT( ' NORM=''', A1, ''', UPLO =''', A1, ''', N=', I5, ',', 9997 FORMAT( ' NORM=''', A1, ''', UPLO =''', A1, ''', N=', I5, ',',
$ 11X, ' type ', I2, ', test(', I2, ')=', G12.5 ) $ 11X, ' type ', I2, ', test(', I2, ')=', G12.5 )
9996 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''', 9996 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''',

47
lapack-netlib/TESTING/LIN/serrtr.f
View File

@ -83,9 +83,10 @@
EXTERNAL LSAMEN EXTERNAL LSAMEN
* .. * ..
* .. External Subroutines .. * .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SLATBS, SLATPS, SLATRS, STBCON, EXTERNAL ALAESM, CHKXER, SLATBS, SLATPS, SLATRS,
$ STBRFS, STBTRS, STPCON, STPRFS, STPTRI, STPTRS, $ SLATRS3, STBCON, STBRFS, STBTRS, STPCON,
$ STRCON, STRRFS, STRTI2, STRTRI, STRTRS $ STPRFS, STPTRI, STPTRS, STRCON, STRRFS, STRTI2,
$ STRTRI, STRTRS
* .. * ..
* .. Scalars in Common .. * .. Scalars in Common ..
LOGICAL LERR, OK LOGICAL LERR, OK
@ -244,6 +245,46 @@
INFOT = 7 INFOT = 7
CALL SLATRS( 'U', 'N', 'N', 'N', 2, A, 1, X, SCALE, W, INFO ) CALL SLATRS( 'U', 'N', 'N', 'N', 2, A, 1, X, SCALE, W, INFO )
CALL CHKXER( 'SLATRS', INFOT, NOUT, LERR, OK ) CALL CHKXER( 'SLATRS', INFOT, NOUT, LERR, OK )
*
* SLATRS3
*
SRNAMT = 'SLATRS3'
INFOT = 1
CALL SLATRS3( '/', 'N', 'N', 'N', 0, 0, A, 1, X, 1, SCALE, W,
$ W( 2 ), 1, INFO )
CALL CHKXER( 'SLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SLATRS3( 'U', '/', 'N', 'N', 0, 0, A, 1, X, 1, SCALE, W,
$ W( 2 ), 1, INFO )
CALL CHKXER( 'SLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SLATRS3( 'U', 'N', '/', 'N', 0, 0, A, 1, X, 1, SCALE, W,
$ W( 2 ), 1, INFO )
CALL CHKXER( 'SLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SLATRS3( 'U', 'N', 'N', '/', 0, 0, A, 1, X, 1, SCALE, W,
$ W( 2 ), 1, INFO )
CALL CHKXER( 'SLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SLATRS3( 'U', 'N', 'N', 'N', -1, 0, A, 1, X, 1, SCALE, W,
$ W( 2 ), 1, INFO )
CALL CHKXER( 'SLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SLATRS3( 'U', 'N', 'N', 'N', 0, -1, A, 1, X, 1, SCALE, W,
$ W( 2 ), 1, INFO )
CALL CHKXER( 'SLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SLATRS3( 'U', 'N', 'N', 'N', 2, 0, A, 1, X, 1, SCALE, W,
$ W( 2 ), 1, INFO )
CALL CHKXER( 'SLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SLATRS3( 'U', 'N', 'N', 'N', 2, 0, A, 2, X, 1, SCALE, W,
$ W( 2 ), 1, INFO )
CALL CHKXER( 'SLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL SLATRS3( 'U', 'N', 'N', 'N', 1, 0, A, 1, X, 1, SCALE, W,
$ W( 2 ), 0, INFO )
CALL CHKXER( 'SLATRS3', INFOT, NOUT, LERR, OK )
* *
ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
* *

60
lapack-netlib/TESTING/LIN/zchktr.f
View File

@ -31,7 +31,7 @@
*> *>
*> \verbatim *> \verbatim
*> *>
*> ZCHKTR tests ZTRTRI, -TRS, -RFS, and -CON, and ZLATRS *> ZCHKTR tests ZTRTRI, -TRS, -RFS, and -CON, and ZLATRS(3)
*> \endverbatim *> \endverbatim
* *
* Arguments: * Arguments:
@ -184,7 +184,7 @@
INTEGER NTYPE1, NTYPES INTEGER NTYPE1, NTYPES
PARAMETER ( NTYPE1 = 10, NTYPES = 18 ) PARAMETER ( NTYPE1 = 10, NTYPES = 18 )
INTEGER NTESTS INTEGER NTESTS
PARAMETER ( NTESTS = 9 ) PARAMETER ( NTESTS = 10 )
INTEGER NTRAN INTEGER NTRAN
PARAMETER ( NTRAN = 3 ) PARAMETER ( NTRAN = 3 )
DOUBLE PRECISION ONE, ZERO DOUBLE PRECISION ONE, ZERO
@ -195,13 +195,13 @@
CHARACTER*3 PATH CHARACTER*3 PATH
INTEGER I, IDIAG, IMAT, IN, INB, INFO, IRHS, ITRAN, INTEGER I, IDIAG, IMAT, IN, INB, INFO, IRHS, ITRAN,
$ IUPLO, K, LDA, N, NB, NERRS, NFAIL, NRHS, NRUN $ IUPLO, K, LDA, N, NB, NERRS, NFAIL, NRHS, NRUN
DOUBLE PRECISION AINVNM, ANORM, DUMMY, RCOND, RCONDC, RCONDI, DOUBLE PRECISION AINVNM, ANORM, BIGNUM, DUMMY, RCOND, RCONDC,
$ RCONDO, SCALE $ RCONDI, RCONDO, RES, SCALE, DLAMCH
* .. * ..
* .. Local Arrays .. * .. Local Arrays ..
CHARACTER TRANSS( NTRAN ), UPLOS( 2 ) CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 ) INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS ) DOUBLE PRECISION RESULT( NTESTS ), SCALE3( 2 )
* .. * ..
* .. External Functions .. * .. External Functions ..
LOGICAL LSAME LOGICAL LSAME
@ -209,10 +209,10 @@
EXTERNAL LSAME, ZLANTR EXTERNAL LSAME, ZLANTR
* .. * ..
* .. External Subroutines .. * .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, ZCOPY, ZERRTR, EXTERNAL ALAERH, ALAHD, ALASUM, DLAMCH, XLAENV, ZCOPY,
$ ZGET04, ZLACPY, ZLARHS, ZLATRS, ZLATTR, ZTRCON, $ ZDSCAL, ZERRTR, ZGET04, ZLACPY, ZLARHS, ZLATRS,
$ ZTRRFS, ZTRT01, ZTRT02, ZTRT03, ZTRT05, ZTRT06, $ ZLATRS3, ZLATTR, ZTRCON, ZTRRFS, ZTRT01,
$ ZTRTRI, ZTRTRS $ ZTRT02, ZTRT03, ZTRT05, ZTRT06, ZTRTRI, ZTRTRS
* .. * ..
* .. Scalars in Common .. * .. Scalars in Common ..
LOGICAL LERR, OK LOGICAL LERR, OK
@ -236,6 +236,7 @@
* *
PATH( 1: 1 ) = 'Zomplex precision' PATH( 1: 1 ) = 'Zomplex precision'
PATH( 2: 3 ) = 'TR' PATH( 2: 3 ) = 'TR'
BIGNUM = DLAMCH('Overflow') / DLAMCH('Precision')
NRUN = 0 NRUN = 0
NFAIL = 0 NFAIL = 0
NERRS = 0 NERRS = 0
@ -380,7 +381,7 @@
* This line is needed on a Sun SPARCstation. * This line is needed on a Sun SPARCstation.
* *
IF( N.GT.0 ) IF( N.GT.0 )
$ DUMMY = A( 1 ) $ DUMMY = DBLE( A( 1 ) )
* *
CALL ZTRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA, CALL ZTRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA,
$ X, LDA, B, LDA, WORK, RWORK, $ X, LDA, B, LDA, WORK, RWORK,
@ -535,6 +536,32 @@
$ RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK, $ RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK,
$ RESULT( 9 ) ) $ RESULT( 9 ) )
* *
*+ TEST 10
* Solve op(A)*X = B
*
SRNAMT = 'ZLATRS3'
CALL ZCOPY( N, X, 1, B, 1 )
CALL ZCOPY( N, X, 1, B( N+1 ), 1 )
CALL ZDSCAL( N, BIGNUM, B( N+1 ), 1 )
CALL ZLATRS3( UPLO, TRANS, DIAG, 'N', N, 2, A, LDA,
$ B, MAX(1, N), SCALE3, RWORK, WORK, NMAX,
$ INFO )
*
* Check error code from ZLATRS3.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'ZLATRS3', INFO, 0,
$ UPLO // TRANS // DIAG // 'N', N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
CALL ZTRT03( UPLO, TRANS, DIAG, N, 1, A, LDA,
$ SCALE3( 1 ), RWORK, ONE, B( 1 ), LDA,
$ X, LDA, WORK, RESULT( 10 ) )
CALL ZDSCAL( N, BIGNUM, X, 1 )
CALL ZTRT03( UPLO, TRANS, DIAG, N, 1, A, LDA,
$ SCALE3( 2 ), RWORK, ONE, B( N+1 ), LDA,
$ X, LDA, WORK, RES )
RESULT( 10 ) = MAX( RESULT( 10 ), RES )
*
* Print information about the tests that did not pass * Print information about the tests that did not pass
* the threshold. * the threshold.
* *
@ -552,7 +579,14 @@
$ DIAG, 'Y', N, IMAT, 9, RESULT( 9 ) $ DIAG, 'Y', N, IMAT, 9, RESULT( 9 )
NFAIL = NFAIL + 1 NFAIL = NFAIL + 1
END IF END IF
NRUN = NRUN + 2 IF( RESULT( 10 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9996 )'ZLATRS3', UPLO, TRANS,
$ DIAG, 'N', N, IMAT, 10, RESULT( 10 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 3
90 CONTINUE 90 CONTINUE
100 CONTINUE 100 CONTINUE
110 CONTINUE 110 CONTINUE
@ -565,8 +599,8 @@
9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5, ', NB=', 9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5, ', NB=',
$ I4, ', type ', I2, ', test(', I2, ')= ', G12.5 ) $ I4, ', type ', I2, ', test(', I2, ')= ', G12.5 )
9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1, 9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1,
$ ''', N=', I5, ', NB=', I4, ', type ', I2, ', $ ''', N=', I5, ', NB=', I4, ', type ', I2, ', test(',
$ test(', I2, ')= ', G12.5 ) $ I2, ')= ', G12.5 )
9997 FORMAT( ' NORM=''', A1, ''', UPLO =''', A1, ''', N=', I5, ',', 9997 FORMAT( ' NORM=''', A1, ''', UPLO =''', A1, ''', N=', I5, ',',
$ 11X, ' type ', I2, ', test(', I2, ')=', G12.5 ) $ 11X, ' type ', I2, ', test(', I2, ')=', G12.5 )
9996 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''', 9996 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''',

47
lapack-netlib/TESTING/LIN/zerrtr.f
View File

@ -82,9 +82,10 @@
EXTERNAL LSAMEN EXTERNAL LSAMEN
* .. * ..
* .. External Subroutines .. * .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, ZLATBS, ZLATPS, ZLATRS, ZTBCON, EXTERNAL ALAESM, CHKXER, ZLATBS, ZLATPS, ZLATRS,
$ ZTBRFS, ZTBTRS, ZTPCON, ZTPRFS, ZTPTRI, ZTPTRS, $ ZLATRS3, ZTBCON, ZTBRFS, ZTBTRS, ZTPCON,
$ ZTRCON, ZTRRFS, ZTRTI2, ZTRTRI, ZTRTRS $ ZTPRFS, ZTPTRI, ZTPTRS, ZTRCON, ZTRRFS, ZTRTI2,
$ ZTRTRI, ZTRTRS
* .. * ..
* .. Scalars in Common .. * .. Scalars in Common ..
LOGICAL LERR, OK LOGICAL LERR, OK
@ -240,6 +241,46 @@
CALL ZLATRS( 'U', 'N', 'N', 'N', 2, A, 1, X, SCALE, RW, INFO ) CALL ZLATRS( 'U', 'N', 'N', 'N', 2, A, 1, X, SCALE, RW, INFO )
CALL CHKXER( 'ZLATRS', INFOT, NOUT, LERR, OK ) CALL CHKXER( 'ZLATRS', INFOT, NOUT, LERR, OK )
* *
* ZLATRS3
*
SRNAMT = 'ZLATRS3'
INFOT = 1
CALL ZLATRS3( '/', 'N', 'N', 'N', 0, 0, A, 1, X, 1, SCALE, RW,
$ RW( 2 ), 1, INFO )
CALL CHKXER( 'ZLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL ZLATRS3( 'U', '/', 'N', 'N', 0, 0, A, 1, X, 1, SCALE, RW,
$ RW( 2 ), 1, INFO )
CALL CHKXER( 'ZLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL ZLATRS3( 'U', 'N', '/', 'N', 0, 0, A, 1, X, 1, SCALE, RW,
$ RW( 2 ), 1, INFO )
CALL CHKXER( 'ZLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL ZLATRS3( 'U', 'N', 'N', '/', 0, 0, A, 1, X, 1, SCALE, RW,
$ RW( 2 ), 1, INFO )
CALL CHKXER( 'ZLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL ZLATRS3( 'U', 'N', 'N', 'N', -1, 0, A, 1, X, 1, SCALE, RW,
$ RW( 2 ), 1, INFO )
CALL CHKXER( 'ZLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL ZLATRS3( 'U', 'N', 'N', 'N', 0, -1, A, 1, X, 1, SCALE, RW,
$ RW( 2 ), 1, INFO )
CALL CHKXER( 'ZLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL ZLATRS3( 'U', 'N', 'N', 'N', 2, 0, A, 1, X, 1, SCALE, RW,
$ RW( 2 ), 1, INFO )
CALL CHKXER( 'ZLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL ZLATRS3( 'U', 'N', 'N', 'N', 2, 0, A, 2, X, 1, SCALE, RW,
$ RW( 2 ), 1, INFO )
CALL CHKXER( 'ZLATRS3', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL ZLATRS3( 'U', 'N', 'N', 'N', 1, 0, A, 1, X, 1, SCALE, RW,
$ RW( 2 ), 0, INFO )
CALL CHKXER( 'ZLATRS3', INFOT, NOUT, LERR, OK )
*
* Test error exits for the packed triangular routines. * Test error exits for the packed triangular routines.
* *
ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN