156 INTEGER nn, nns, nout
157 DOUBLE PRECISION thresh
161 INTEGER iwork( * ), nsval( * ), nval( * )
162 DOUBLE PRECISION a( * ), af( * ), b( * ), rwork( * ), work( * ),
169 DOUBLE PRECISION one, zero
170 parameter ( one = 1.0d+0, zero = 0.0d+0 )
172 parameter ( ntypes = 12 )
174 parameter ( ntests = 7 )
177 LOGICAL trfcon, zerot
178 CHARACTER dist, norm, trans, type
180 INTEGER i, imat, in, info, irhs, itran, ix, izero, j,
181 $ k, kl, koff, ku, lda, m, mode, n, nerrs, nfail,
183 DOUBLE PRECISION ainvnm, anorm, cond, rcond, rcondc, rcondi,
187 CHARACTER transs( 3 )
188 INTEGER iseed( 4 ), iseedy( 4 )
189 DOUBLE PRECISION result( ntests ), z( 3 )
210 COMMON / infoc / infot, nunit, ok, lerr
211 COMMON / srnamc / srnamt
214 DATA iseedy / 0, 0, 0, 1 / , transs /
'N',
'T',
219 path( 1: 1 ) =
'Double precision'
225 iseed( i ) = iseedy( i )
231 $
CALL derrge( path, nout )
245 DO 100 imat = 1, nimat
249 IF( .NOT.dotype( imat ) )
254 CALL dlatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
257 zerot = imat.GE.8 .AND. imat.LE.10
262 koff = max( 2-ku, 3-max( 1, n ) )
264 CALL dlatms( n, n, dist, iseed,
TYPE, rwork, mode, cond,
265 $ anorm, kl, ku,
'Z', af( koff ), 3, work,
271 CALL alaerh( path,
'DLATMS', info, 0,
' ', n, n, kl,
272 $ ku, -1, imat, nfail, nerrs, nout )
278 CALL dcopy( n-1, af( 4 ), 3, a, 1 )
279 CALL dcopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
281 CALL dcopy( n, af( 2 ), 3, a( m+1 ), 1 )
287 IF( .NOT.zerot .OR. .NOT.dotype( 7 ) )
THEN
291 CALL dlarnv( 2, iseed, n+2*m, a )
293 $
CALL dscal( n+2*m, anorm, a, 1 )
294 ELSE IF( izero.GT.0 )
THEN
299 IF( izero.EQ.1 )
THEN
303 ELSE IF( izero.EQ.n )
THEN
307 a( 2*n-2+izero ) = z( 1 )
308 a( n-1+izero ) = z( 2 )
315 IF( .NOT.zerot )
THEN
317 ELSE IF( imat.EQ.8 )
THEN
325 ELSE IF( imat.EQ.9 )
THEN
333 DO 20 i = izero, n - 1
347 CALL dcopy( n+2*m, a, 1, af, 1 )
349 CALL dgttrf( n, af, af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
355 $
CALL alaerh( path,
'DGTTRF', info, izero,
' ', n, n, 1,
356 $ 1, -1, imat, nfail, nerrs, nout )
359 CALL dgtt01( n, a, a( m+1 ), a( n+m+1 ), af, af( m+1 ),
360 $ af( n+m+1 ), af( n+2*m+1 ), iwork, work, lda,
361 $ rwork, result( 1 ) )
365 IF( result( 1 ).GE.thresh )
THEN
366 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
367 $
CALL alahd( nout, path )
368 WRITE( nout, fmt = 9999 )n, imat, 1, result( 1 )
374 trans = transs( itran )
375 IF( itran.EQ.1 )
THEN
380 anorm =
dlangt( norm, n, a, a( m+1 ), a( n+m+1 ) )
382 IF( .NOT.trfcon )
THEN
394 CALL dgttrs( trans, n, 1, af, af( m+1 ),
395 $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
397 ainvnm = max( ainvnm,
dasum( n, x, 1 ) )
402 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
405 rcondc = ( one / anorm ) / ainvnm
407 IF( itran.EQ.1 )
THEN
421 CALL dgtcon( norm, n, af, af( m+1 ), af( n+m+1 ),
422 $ af( n+2*m+1 ), iwork, anorm, rcond, work,
423 $ iwork( n+1 ), info )
428 $
CALL alaerh( path,
'DGTCON', info, 0, norm, n, n, -1,
429 $ -1, -1, imat, nfail, nerrs, nout )
431 result( 7 ) =
dget06( rcond, rcondc )
435 IF( result( 7 ).GE.thresh )
THEN
436 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
437 $
CALL alahd( nout, path )
438 WRITE( nout, fmt = 9997 )norm, n, imat, 7,
457 CALL dlarnv( 2, iseed, n, xact( ix ) )
462 trans = transs( itran )
463 IF( itran.EQ.1 )
THEN
471 CALL dlagtm( trans, n, nrhs, one, a, a( m+1 ),
472 $ a( n+m+1 ), xact, lda, zero, b, lda )
477 CALL dlacpy(
'Full', n, nrhs, b, lda, x, lda )
479 CALL dgttrs( trans, n, nrhs, af, af( m+1 ),
480 $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
486 $
CALL alaerh( path,
'DGTTRS', info, 0, trans, n, n,
487 $ -1, -1, nrhs, imat, nfail, nerrs,
490 CALL dlacpy(
'Full', n, nrhs, b, lda, work, lda )
491 CALL dgtt02( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
492 $ x, lda, work, lda, result( 2 ) )
497 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
504 CALL dgtrfs( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
505 $ af, af( m+1 ), af( n+m+1 ),
506 $ af( n+2*m+1 ), iwork, b, lda, x, lda,
507 $ rwork, rwork( nrhs+1 ), work,
508 $ iwork( n+1 ), info )
513 $
CALL alaerh( path,
'DGTRFS', info, 0, trans, n, n,
514 $ -1, -1, nrhs, imat, nfail, nerrs,
517 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
519 CALL dgtt05( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
520 $ b, lda, x, lda, xact, lda, rwork,
521 $ rwork( nrhs+1 ), result( 5 ) )
527 IF( result( k ).GE.thresh )
THEN
528 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
529 $
CALL alahd( nout, path )
530 WRITE( nout, fmt = 9998 )trans, n, nrhs, imat,
544 CALL alasum( path, nout, nfail, nrun, nerrs )
546 9999
FORMAT( 12x,
'N =', i5,
',', 10x,
' type ', i2,
', test(', i2,
548 9998
FORMAT(
' TRANS=''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
549 $ i2,
', test(', i2,
') = ', g12.5 )
550 9997
FORMAT(
' NORM =''', a1,
''', N =', i5,
',', 10x,
' type ', i2,
551 $
', test(', i2,
') = ', g12.5 )
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dgtt05(TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DGTT05
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 dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine derrge(PATH, NUNIT)
DERRGE
subroutine dgtrfs(TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DGTRFS
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
subroutine dscal(N, DA, DX, INCX)
DSCAL
double precision function dasum(N, DX, INCX)
DASUM
subroutine dgttrs(TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO)
DGTTRS
double precision function dget06(RCOND, RCONDC)
DGET06
subroutine dgttrf(N, DL, D, DU, DU2, IPIV, INFO)
DGTTRF
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine dgtt02(TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB, RESID)
DGTT02
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 dgtcon(NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
DGTCON
subroutine dlarnv(IDIST, ISEED, N, X)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine dgtt01(N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK, LDWORK, RWORK, RESID)
DGTT01