140 SUBROUTINE ddrvpt( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, D,
141 $ e,
b, x, xact, work, rwork, nout )
150 INTEGER nn, nout, nrhs
151 DOUBLE PRECISION thresh
156 DOUBLE PRECISION a( * ),
b( * ), d( * ), e( * ), rwork( * ),
157 $ work( * ), x( * ), xact( * )
163 DOUBLE PRECISION one, zero
164 parameter( one = 1.0d+0, zero = 0.0d+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 DOUBLE PRECISION ainvnm, anorm, cond, dmax, rcond, rcondc
180 INTEGER iseed( 4 ), iseedy( 4 )
181 DOUBLE PRECISION 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 ) =
'Double precision'
217 iseed( i ) = iseedy( i )
223 $ CALL
derrvx( path, nout )
236 DO 110 imat = 1, nimat
240 IF( n.GT.0 .AND. .NOT.dotype( imat ) )
245 CALL
dlatb4( path, imat, n, n, type, kl, ku, anorm, mode,
248 zerot = imat.GE.8 .AND. imat.LE.10
255 CALL
dlatms( n, n, dist, iseed, type, rwork, mode, cond,
256 $ anorm, kl, ku,
'B', a, 2, work, info )
261 CALL
alaerh( path,
'DLATMS', info, 0,
' ', n, n, kl,
262 $ ku, -1, imat, nfail, nerrs, nout )
282 IF( .NOT.zerot .OR. .NOT.dotype( 7 ) )
THEN
286 CALL
dlarnv( 2, iseed, n, d )
287 CALL
dlarnv( 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
dscal( n, anorm / dmax, d, 1 )
308 $ CALL
dscal( 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
dlarnv( 2, iseed, n, xact( ix ) )
372 CALL
dlaptm( 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 =
dlanst(
'1', n, d, e )
395 CALL
dcopy( n, d, 1, d( n+1 ), 1 )
397 $ CALL
dcopy( n-1, e, 1, e( n+1 ), 1 )
401 CALL
dpttrf( n, d( n+1 ), e( n+1 ), info )
412 CALL
dpttrs( n, 1, d( n+1 ), e( n+1 ), x, lda,
414 ainvnm = max( ainvnm,
dasum( 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
dcopy( n, d, 1, d( n+1 ), 1 )
432 $ CALL
dcopy( n-1, e, 1, e( n+1 ), 1 )
433 CALL
dlacpy(
'Full', n, nrhs,
b, lda, x, lda )
438 CALL
dptsv( n, nrhs, d( n+1 ), e( n+1 ), x, lda,
444 $ CALL
alaerh( path,
'DPTSV ', info, izero,
' ', n,
445 $ n, 1, 1, nrhs, imat, nfail, nerrs,
448 IF( izero.EQ.0 )
THEN
453 CALL
dptt01( n, d, e, d( n+1 ), e( n+1 ), work,
458 CALL
dlacpy(
'Full', n, nrhs,
b, lda, work, lda )
459 CALL
dptt02( n, nrhs, d, e, x, lda, work, lda,
464 CALL
dget04( 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 )
'DPTSV ', n, imat, k,
486 IF( ifact.GT.1 )
THEN
498 CALL
dlaset(
'Full', n, nrhs, zero, zero, x, lda )
504 CALL
dptsvx( 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,
'DPTSVX', 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
dptt01( n, d, e, d( n+1 ), e( n+1 ), work,
528 CALL
dlacpy(
'Full', n, nrhs,
b, lda, work, lda )
529 CALL
dptt02( n, nrhs, d, e, x, lda, work, lda,
534 CALL
dget04( n, nrhs, x, lda, xact, lda, rcondc,
539 CALL
dptt05( n, nrhs, d, e,
b, lda, x, lda, xact, lda,
540 $ rwork, rwork( nrhs+1 ), result( 4 ) )
547 result( 6 ) =
dget06( 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 )
'DPTSVX', 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 dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine dpttrf(N, D, E, INFO)
DPTTRF
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine derrvx(PATH, NUNIT)
DERRVX
subroutine dptt01(N, D, E, DF, EF, WORK, RESID)
DPTT01
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine ddrvpt(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, D, E, B, X, XACT, WORK, RWORK, NOUT)
DDRVPT
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine dlarnv(IDIST, ISEED, N, X)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
subroutine dptsvx(FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, INFO)
DPTSVX computes the solution to system of linear equations A * X = B for PT matrices ...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine dscal(N, DA, DX, INCX)
DSCAL
double precision function dget06(RCOND, RCONDC)
DGET06
subroutine dptt02(N, NRHS, D, E, X, LDX, B, LDB, RESID)
DPTT02
subroutine dpttrs(N, NRHS, D, E, B, LDB, INFO)
DPTTRS
double precision function dlanst(NORM, N, D, E)
DLANST 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 aladhd(IOUNIT, PATH)
ALADHD
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
integer function idamax(N, DX, INCX)
IDAMAX
subroutine dptt05(N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DPTT05
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
double precision function dasum(N, DX, INCX)
DASUM
subroutine dlaptm(N, NRHS, ALPHA, D, E, X, LDX, BETA, B, LDB)
DLAPTM
subroutine dptsv(N, NRHS, D, E, B, LDB, INFO)
DPTSV computes the solution to system of linear equations A * X = B for PT matrices ...