139 SUBROUTINE ddrvgt( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF,
140 $
b,
x, xact, work, rwork, iwork, nout )
149 INTEGER nn, nout, nrhs
150 DOUBLE PRECISION thresh
154 INTEGER iwork( * ), nval( * )
155 DOUBLE PRECISION a( * ), af( * ),
b( * ), rwork( * ), work( * ),
162 DOUBLE PRECISION one, zero
163 parameter( one = 1.0d+0, zero = 0.0d+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 DOUBLE PRECISION ainvnm, anorm, anormi, anormo, cond, rcond,
177 $ rcondc, rcondi, rcondo
180 CHARACTER transs( 3 )
181 INTEGER iseed( 4 ), iseedy( 4 )
182 DOUBLE PRECISION 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 ) =
'Double precision'
218 iseed( i ) = iseedy( i )
224 $ CALL
derrvx( path, nout )
238 DO 130 imat = 1, nimat
242 IF( .NOT.dotype( imat ) )
247 CALL
dlatb4( 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
dlatms( n, n, dist, iseed, type, rwork, mode, cond,
258 $ anorm, kl, ku,
'Z', af( koff ), 3, work,
264 CALL
alaerh( path,
'DLATMS', info, 0,
' ', n, n, kl,
265 $ ku, -1, imat, nfail, nerrs, nout )
271 CALL
dcopy( n-1, af( 4 ), 3, a, 1 )
272 CALL
dcopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
274 CALL
dcopy( n, af( 2 ), 3, a( m+1 ), 1 )
280 IF( .NOT.zerot .OR. .NOT.dotype( 7 ) )
THEN
284 CALL
dlarnv( 2, iseed, n+2*m, a )
286 $ CALL
dscal( 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
dcopy( n+2*m, a, 1, af, 1 )
357 anormo =
dlangt(
'1', n, a, a( m+1 ), a( n+m+1 ) )
358 anormi =
dlangt(
'I', n, a, a( m+1 ), a( n+m+1 ) )
362 CALL
dgttrf( n, af, af( m+1 ), af( n+m+1 ),
363 $ af( n+2*m+1 ), iwork, info )
374 CALL
dgttrs(
'No transpose', n, 1, af, af( m+1 ),
375 $ af( n+m+1 ), af( n+2*m+1 ), iwork,
x,
377 ainvnm = max( ainvnm,
dasum( n,
x, 1 ) )
382 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
385 rcondo = ( one / anormo ) / ainvnm
397 CALL
dgttrs(
'Transpose', n, 1, af, af( m+1 ),
398 $ af( n+m+1 ), af( n+2*m+1 ), iwork,
x,
400 ainvnm = max( ainvnm,
dasum( 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
dlarnv( 2, iseed, n, xact( ix ) )
430 CALL
dlagtm( 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
dcopy( n+2*m, a, 1, af, 1 )
441 CALL
dlacpy(
'Full', n, nrhs,
b, lda,
x, lda )
444 CALL
dgtsv( n, nrhs, af, af( m+1 ), af( n+m+1 ),
x,
450 $ CALL
alaerh( path,
'DGTSV ', info, izero,
' ',
451 $ n, n, 1, 1, nrhs, imat, nfail,
454 IF( izero.EQ.0 )
THEN
458 CALL
dlacpy(
'Full', n, nrhs,
b, lda, work,
460 CALL
dgtt02( trans, n, nrhs, a, a( m+1 ),
461 $ a( n+m+1 ),
x, lda, work, lda,
466 CALL
dget04( 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 )
'DGTSV ', n, imat,
488 IF( ifact.GT.1 )
THEN
496 CALL
dlaset(
'Full', n, nrhs, zero, zero,
x, lda )
502 CALL
dgtsvx( 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,
'DGTSVX', info, izero,
512 $ fact // trans, n, n, 1, 1, nrhs, imat,
513 $ nfail, nerrs, nout )
515 IF( ifact.GE.2 )
THEN
520 CALL
dgtt01( 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
dlacpy(
'Full', n, nrhs,
b, lda, work, lda )
534 CALL
dgtt02( trans, n, nrhs, a, a( m+1 ),
535 $ a( n+m+1 ),
x, lda, work, lda,
540 CALL
dget04( n, nrhs,
x, lda, xact, lda, rcondc,
545 CALL
dgtt05( 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 )
'DGTSVX', fact, trans,
559 $ n, imat, k, result( k )
566 result( 6 ) =
dget06( 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 )
'DGTSVX', 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( 1
x, a,
', N =', i5,
', type ', i2,
', test ', i2,
586 $
', ratio = ', g12.5 )
587 9998
FORMAT( 1
x, a,
', FACT=''', a1,
''', TRANS=''', a1,
''', N =',
588 $ i5,
', type ', i2,
', 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 dgtsvx(FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
DGTSVX computes the solution to system of linear equations A * X = B for GT matrices ...
subroutine dgtt02(TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB, RESID)
DGTT02
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine derrvx(PATH, NUNIT)
DERRVX
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dlagtm(TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB)
DLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix...
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 dgttrf(N, DL, D, DU, DU2, IPIV, INFO)
DGTTRF
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine dgtsv(N, NRHS, DL, D, DU, B, LDB, INFO)
DGTSV computes the solution to system of linear equations A * X = B for GT matrices ...
subroutine dscal(N, DA, DX, INCX)
DSCAL
DOUBLE PRECISION function dget06(RCOND, RCONDC)
DGET06
DOUBLE PRECISION function dlangt(NORM, N, DL, D, DU)
DLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine aladhd(IOUNIT, PATH)
ALADHD
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine dgtt05(TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DGTT05
subroutine dgtt01(N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK, LDWORK, RWORK, RESID)
DGTT01
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 dgttrs(TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO)
DGTTRS
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...
subroutine ddrvgt(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT)
DDRVGT
DOUBLE PRECISION function dasum(N, DX, INCX)
DASUM