150 INTEGER nn, nout, nrhs
156 REAL a( * ), b( * ), d( * ), e( * ), rwork( * ),
157 $ work( * ), x( * ), xact( * )
164 parameter ( one = 1.0e+0, zero = 0.0e+0 )
166 parameter ( ntypes = 12 )
168 parameter ( ntests = 6 )
172 CHARACTER dist, fact, type
174 INTEGER i, ia, ifact, imat, in, info, ix, izero, j, k,
175 $ k1, kl, ku, lda, mode, n, nerrs, nfail, nimat,
177 REAL ainvnm, anorm, cond, dmax, rcond, rcondc
180 INTEGER iseed( 4 ), iseedy( 4 )
181 REAL result( ntests ), z( 3 )
203 COMMON / infoc / infot, nunit, ok, lerr
204 COMMON / srnamc / srnamt
207 DATA iseedy / 0, 0, 0, 1 /
211 path( 1: 1 ) =
'Single precision'
217 iseed( i ) = iseedy( i )
223 $
CALL serrvx( path, nout )
236 DO 110 imat = 1, nimat
240 IF( n.GT.0 .AND. .NOT.dotype( imat ) )
245 CALL slatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
248 zerot = imat.GE.8 .AND. imat.LE.10
255 CALL slatms( n, n, dist, iseed,
TYPE, rwork, mode, cond,
256 $ anorm, kl, ku,
'B', a, 2, work, info )
261 CALL alaerh( path,
'SLATMS', info, 0,
' ', n, n, kl,
262 $ ku, -1, imat, nfail, nerrs, nout )
282 IF( .NOT.zerot .OR. .NOT.dotype( 7 ) )
THEN
286 CALL slarnv( 2, iseed, n, d )
287 CALL slarnv( 2, iseed, n-1, e )
292 d( 1 ) = abs( d( 1 ) )
294 d( 1 ) = abs( d( 1 ) ) + abs( e( 1 ) )
295 d( n ) = abs( d( n ) ) + abs( e( n-1 ) )
297 d( i ) = abs( d( i ) ) + abs( e( i ) ) +
306 CALL sscal( n, anorm / dmax, d, 1 )
308 $
CALL sscal( n-1, anorm / dmax, e, 1 )
310 ELSE IF( izero.GT.0 )
THEN
315 IF( izero.EQ.1 )
THEN
319 ELSE IF( izero.EQ.n )
THEN
323 e( izero-1 ) = z( 1 )
341 ELSE IF( imat.EQ.9 )
THEN
349 ELSE IF( imat.EQ.10 )
THEN
351 IF( izero.GT.1 )
THEN
352 z( 1 ) = e( izero-1 )
366 CALL slarnv( 2, iseed, n, xact( ix ) )
372 CALL slaptm( n, nrhs, one, d, e, xact, lda, zero, b, lda )
375 IF( ifact.EQ.1 )
THEN
389 ELSE IF( ifact.EQ.1 )
THEN
393 anorm =
slanst(
'1', n, d, e )
395 CALL scopy( n, d, 1, d( n+1 ), 1 )
397 $
CALL scopy( n-1, e, 1, e( n+1 ), 1 )
401 CALL spttrf( n, d( n+1 ), e( n+1 ), info )
412 CALL spttrs( n, 1, d( n+1 ), e( n+1 ), x, lda,
414 ainvnm = max( ainvnm,
sasum( n, x, 1 ) )
419 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
422 rcondc = ( one / anorm ) / ainvnm
426 IF( ifact.EQ.2 )
THEN
430 CALL scopy( n, d, 1, d( n+1 ), 1 )
432 $
CALL scopy( n-1, e, 1, e( n+1 ), 1 )
433 CALL slacpy(
'Full', n, nrhs, b, lda, x, lda )
438 CALL sptsv( n, nrhs, d( n+1 ), e( n+1 ), x, lda,
444 $
CALL alaerh( path,
'SPTSV ', info, izero,
' ', n,
445 $ n, 1, 1, nrhs, imat, nfail, nerrs,
448 IF( izero.EQ.0 )
THEN
453 CALL sptt01( n, d, e, d( n+1 ), e( n+1 ), work,
458 CALL slacpy(
'Full', n, nrhs, b, lda, work, lda )
459 CALL sptt02( n, nrhs, d, e, x, lda, work, lda,
464 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
473 IF( result( k ).GE.thresh )
THEN
474 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
475 $
CALL aladhd( nout, path )
476 WRITE( nout, fmt = 9999 )
'SPTSV ', n, imat, k,
486 IF( ifact.GT.1 )
THEN
498 CALL slaset(
'Full', n, nrhs, zero, zero, x, lda )
504 CALL sptsvx( fact, n, nrhs, d, e, d( n+1 ), e( n+1 ), b,
505 $ lda, x, lda, rcond, rwork, rwork( nrhs+1 ),
511 $
CALL alaerh( path,
'SPTSVX', info, izero, fact, n, n,
512 $ 1, 1, nrhs, imat, nfail, nerrs, nout )
513 IF( izero.EQ.0 )
THEN
514 IF( ifact.EQ.2 )
THEN
520 CALL sptt01( n, d, e, d( n+1 ), e( n+1 ), work,
528 CALL slacpy(
'Full', n, nrhs, b, lda, work, lda )
529 CALL sptt02( n, nrhs, d, e, x, lda, work, lda,
534 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
539 CALL sptt05( n, nrhs, d, e, b, lda, x, lda, xact, lda,
540 $ rwork, rwork( nrhs+1 ), result( 4 ) )
547 result( 6 ) =
sget06( rcond, rcondc )
553 IF( result( k ).GE.thresh )
THEN
554 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
555 $
CALL aladhd( nout, path )
556 WRITE( nout, fmt = 9998 )
'SPTSVX', fact, n, imat,
568 CALL alasvm( path, nout, nfail, nrun, nerrs )
570 9999
FORMAT( 1x, a,
', N =', i5,
', type ', i2,
', test ', i2,
571 $
', ratio = ', g12.5 )
572 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', N =', i5,
', type ', i2,
573 $
', test ', i2,
', ratio = ', g12.5 )
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine sptt01(N, D, E, DF, EF, WORK, RESID)
SPTT01
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
subroutine sptsv(N, NRHS, D, E, B, LDB, INFO)
SPTSV computes the solution to system of linear equations A * X = B for PT matrices ...
real function sget06(RCOND, RCONDC)
SGET06
integer function isamax(N, SX, INCX)
ISAMAX
subroutine sptt02(N, NRHS, D, E, X, LDX, B, LDB, RESID)
SPTT02
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine sptsvx(FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, INFO)
SPTSVX computes the solution to system of linear equations A * X = B for PT matrices ...
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
real function sasum(N, SX, INCX)
SASUM
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 aladhd(IOUNIT, PATH)
ALADHD
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine serrvx(PATH, NUNIT)
SERRVX
subroutine sptt05(N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPTT05
subroutine slaptm(N, NRHS, ALPHA, D, E, X, LDX, BETA, B, LDB)
SLAPTM
subroutine spttrf(N, D, E, INFO)
SPTTRF
subroutine sscal(N, SA, SX, INCX)
SSCAL
subroutine spttrs(N, NRHS, D, E, B, LDB, INFO)
SPTTRS
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
real function slanst(NORM, N, D, E)
SLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix.
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY