139 SUBROUTINE sdrvgt( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF,
140 $
b, x, xact, work, rwork, iwork, nout )
149 INTEGER nn, nout, nrhs
154 INTEGER iwork( * ), nval( * )
155 REAL a( * ), af( * ),
b( * ), rwork( * ), work( * ),
163 parameter( one = 1.0e+0, zero = 0.0e+0 )
165 parameter( ntypes = 12 )
167 parameter( ntests = 6 )
170 LOGICAL trfcon, zerot
171 CHARACTER dist, fact, trans, type
173 INTEGER i, ifact, imat, in, info, itran, ix, izero,
j,
174 $ k, k1, kl, koff, ku, lda, m, mode, n, nerrs,
175 $ nfail, nimat, nrun, nt
176 REAL ainvnm, anorm, anormi, anormo, cond, rcond,
177 $ rcondc, rcondi, rcondo
180 CHARACTER transs( 3 )
181 INTEGER iseed( 4 ), iseedy( 4 )
182 REAL result( ntests ), z( 3 )
203 COMMON / infoc / infot, nunit, ok, lerr
204 COMMON / srnamc / srnamt
207 DATA iseedy / 0, 0, 0, 1 / , transs /
'N',
'T',
212 path( 1: 1 ) =
'Single precision'
218 iseed( i ) = iseedy( i )
224 $ CALL
serrvx( path, nout )
238 DO 130 imat = 1, nimat
242 IF( .NOT.dotype( imat ) )
247 CALL
slatb4( path, imat, n, n, type, kl, ku, anorm, mode,
250 zerot = imat.GE.8 .AND. imat.LE.10
255 koff = max( 2-ku, 3-max( 1, n ) )
257 CALL
slatms( n, n, dist, iseed, type, rwork, mode, cond,
258 $ anorm, kl, ku,
'Z', af( koff ), 3, work,
264 CALL
alaerh( path,
'SLATMS', info, 0,
' ', n, n, kl,
265 $ ku, -1, imat, nfail, nerrs, nout )
271 CALL
scopy( n-1, af( 4 ), 3, a, 1 )
272 CALL
scopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
274 CALL
scopy( n, af( 2 ), 3, a( m+1 ), 1 )
280 IF( .NOT.zerot .OR. .NOT.dotype( 7 ) )
THEN
284 CALL
slarnv( 2, iseed, n+2*m, a )
286 $ CALL
sscal( n+2*m, anorm, a, 1 )
287 ELSE IF( izero.GT.0 )
THEN
292 IF( izero.EQ.1 )
THEN
296 ELSE IF( izero.EQ.n )
THEN
300 a( 2*n-2+izero ) = z( 1 )
301 a( n-1+izero ) = z( 2 )
308 IF( .NOT.zerot )
THEN
310 ELSE IF( imat.EQ.8 )
THEN
318 ELSE IF( imat.EQ.9 )
THEN
326 DO 20 i = izero, n - 1
337 IF( ifact.EQ.1 )
THEN
352 ELSE IF( ifact.EQ.1 )
THEN
353 CALL
scopy( n+2*m, a, 1, af, 1 )
357 anormo =
slangt(
'1', n, a, a( m+1 ), a( n+m+1 ) )
358 anormi =
slangt(
'I', n, a, a( m+1 ), a( n+m+1 ) )
362 CALL
sgttrf( n, af, af( m+1 ), af( n+m+1 ),
363 $ af( n+2*m+1 ), iwork, info )
374 CALL
sgttrs(
'No transpose', n, 1, af, af( m+1 ),
375 $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
377 ainvnm = max( ainvnm,
sasum( n, x, 1 ) )
382 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
385 rcondo = ( one / anormo ) / ainvnm
397 CALL
sgttrs(
'Transpose', n, 1, af, af( m+1 ),
398 $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
400 ainvnm = max( ainvnm,
sasum( n, x, 1 ) )
405 IF( anormi.LE.zero .OR. ainvnm.LE.zero )
THEN
408 rcondi = ( one / anormi ) / ainvnm
413 trans = transs( itran )
414 IF( itran.EQ.1 )
THEN
424 CALL
slarnv( 2, iseed, n, xact( ix ) )
430 CALL
slagtm( trans, n, nrhs, one, a, a( m+1 ),
431 $ a( n+m+1 ), xact, lda, zero,
b, lda )
433 IF( ifact.EQ.2 .AND. itran.EQ.1 )
THEN
440 CALL
scopy( n+2*m, a, 1, af, 1 )
441 CALL
slacpy(
'Full', n, nrhs,
b, lda, x, lda )
444 CALL
sgtsv( n, nrhs, af, af( m+1 ), af( n+m+1 ), x,
450 $ CALL
alaerh( path,
'SGTSV ', info, izero,
' ',
451 $ n, n, 1, 1, nrhs, imat, nfail,
454 IF( izero.EQ.0 )
THEN
458 CALL
slacpy(
'Full', n, nrhs,
b, lda, work,
460 CALL
sgtt02( trans, n, nrhs, a, a( m+1 ),
461 $ a( n+m+1 ), x, lda, work, lda,
466 CALL
sget04( n, nrhs, x, lda, xact, lda, rcondc,
475 IF( result( k ).GE.thresh )
THEN
476 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
477 $ CALL
aladhd( nout, path )
478 WRITE( nout, fmt = 9999 )
'SGTSV ', n, imat,
488 IF( ifact.GT.1 )
THEN
496 CALL
slaset(
'Full', n, nrhs, zero, zero, x, lda )
502 CALL
sgtsvx( fact, trans, n, nrhs, a, a( m+1 ),
503 $ a( n+m+1 ), af, af( m+1 ), af( n+m+1 ),
504 $ af( n+2*m+1 ), iwork,
b, lda, x, lda,
505 $ rcond, rwork, rwork( nrhs+1 ), work,
506 $ iwork( n+1 ), info )
511 $ CALL
alaerh( path,
'SGTSVX', info, izero,
512 $ fact // trans, n, n, 1, 1, nrhs, imat,
513 $ nfail, nerrs, nout )
515 IF( ifact.GE.2 )
THEN
520 CALL
sgtt01( n, a, a( m+1 ), a( n+m+1 ), af,
521 $ af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
522 $ iwork, work, lda, rwork, result( 1 ) )
533 CALL
slacpy(
'Full', n, nrhs,
b, lda, work, lda )
534 CALL
sgtt02( trans, n, nrhs, a, a( m+1 ),
535 $ a( n+m+1 ), x, lda, work, lda,
540 CALL
sget04( n, nrhs, x, lda, xact, lda, rcondc,
545 CALL
sgtt05( trans, n, nrhs, a, a( m+1 ),
546 $ a( n+m+1 ),
b, lda, x, lda, xact, lda,
547 $ rwork, rwork( nrhs+1 ), result( 4 ) )
555 IF( result( k ).GE.thresh )
THEN
556 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
557 $ CALL
aladhd( nout, path )
558 WRITE( nout, fmt = 9998 )
'SGTSVX', fact, trans,
559 $ n, imat, k, result( k )
566 result( 6 ) =
sget06( rcond, rcondc )
567 IF( result( 6 ).GE.thresh )
THEN
568 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
569 $ CALL
aladhd( nout, path )
570 WRITE( nout, fmt = 9998 )
'SGTSVX', fact, trans, n,
571 $ imat, k, result( k )
574 nrun = nrun + nt - k1 + 2
583 CALL
alasvm( path, nout, nfail, nrun, nerrs )
585 9999
FORMAT( 1x, a,
', N =', i5,
', type ', i2,
', test ', i2,
586 $
', ratio = ', g12.5 )
587 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', TRANS=''', a1,
''', N =',
588 $ i5,
', type ', i2,
', test ', i2,
', ratio = ', g12.5 )
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine sgtsv(N, NRHS, DL, D, DU, B, LDB, INFO)
SGTSV computes the solution to system of linear equations A * X = B for GT matrices ...
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine sgtt05(TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SGTT05
real function sasum(N, SX, INCX)
SASUM
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
subroutine sgtt01(N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK, LDWORK, RWORK, RESID)
SGTT01
real function sget06(RCOND, RCONDC)
SGET06
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine sgttrf(N, DL, D, DU, DU2, IPIV, INFO)
SGTTRF
real function slangt(NORM, N, DL, D, DU)
SLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine sgttrs(TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO)
SGTTRS
subroutine sdrvgt(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT)
SDRVGT
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine aladhd(IOUNIT, PATH)
ALADHD
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine sgtsvx(FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
SGTSVX computes the solution to system of linear equations A * X = B for GT matrices ...
subroutine sgtt02(TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB, RESID)
SGTT02
subroutine slagtm(TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB)
SLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix...
subroutine serrvx(PATH, NUNIT)
SERRVX
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
subroutine sscal(N, SA, SX, INCX)
SSCAL