159 INTEGER nmax, nn, nns, nout
160 DOUBLE PRECISION thresh
164 INTEGER nsval( * ), nval( * )
165 DOUBLE PRECISION rwork( * )
166 COMPLEX*16 ab( * ), ainv( * ), b( * ), work( * ), x( * ),
173 INTEGER ntype1, ntypes
174 parameter ( ntype1 = 9, ntypes = 17 )
176 parameter ( ntests = 8 )
178 parameter ( ntran = 3 )
179 DOUBLE PRECISION one, zero
180 parameter ( one = 1.0d+0, zero = 0.0d+0 )
183 CHARACTER diag, norm, trans, uplo, xtype
185 INTEGER i, idiag, ik, imat, in, info, irhs, itran,
186 $ iuplo, j, k, kd, lda, ldab, n, nerrs, nfail,
187 $ nimat, nimat2, nk, nrhs, nrun
188 DOUBLE PRECISION ainvnm, anorm, rcond, rcondc, rcondi, rcondo,
192 CHARACTER transs( ntran ), uplos( 2 )
193 INTEGER iseed( 4 ), iseedy( 4 )
194 DOUBLE PRECISION result( ntests )
210 INTEGER infot, iounit
213 COMMON / infoc / infot, iounit, ok, lerr
214 COMMON / srnamc / srnamt
217 INTRINSIC dcmplx, max, min
220 DATA iseedy / 1988, 1989, 1990, 1991 /
221 DATA uplos /
'U',
'L' / , transs /
'N',
'T',
'C' /
227 path( 1: 1 ) =
'Zomplex precision'
233 iseed( i ) = iseedy( i )
239 $
CALL zerrtr( path, nout )
264 ELSE IF( ik.EQ.2 )
THEN
266 ELSE IF( ik.EQ.3 )
THEN
268 ELSE IF( ik.EQ.4 )
THEN
273 DO 90 imat = 1, nimat
277 IF( .NOT.dotype( imat ) )
284 uplo = uplos( iuplo )
289 CALL zlattb( imat, uplo,
'No transpose', diag, iseed,
290 $ n, kd, ab, ldab, x, work, rwork, info )
294 IF(
lsame( diag,
'N' ) )
THEN
303 CALL zlaset(
'Full', n, n, dcmplx( zero ),
304 $ dcmplx( one ), ainv, lda )
305 IF(
lsame( uplo,
'U' ) )
THEN
307 CALL ztbsv( uplo,
'No transpose', diag, j, kd,
308 $ ab, ldab, ainv( ( j-1 )*lda+1 ), 1 )
312 CALL ztbsv( uplo,
'No transpose', diag, n-j+1,
313 $ kd, ab( ( j-1 )*ldab+1 ), ldab,
314 $ ainv( ( j-1 )*lda+j ), 1 )
320 anorm =
zlantb(
'1', uplo, diag, n, kd, ab, ldab,
322 ainvnm =
zlantr(
'1', uplo, diag, n, n, ainv, lda,
324 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
327 rcondo = ( one / anorm ) / ainvnm
332 anorm =
zlantb(
'I', uplo, diag, n, kd, ab, ldab,
334 ainvnm =
zlantr(
'I', uplo, diag, n, n, ainv, lda,
336 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
339 rcondi = ( one / anorm ) / ainvnm
346 DO 50 itran = 1, ntran
350 trans = transs( itran )
351 IF( itran.EQ.1 )
THEN
363 CALL zlarhs( path, xtype, uplo, trans, n, n, kd,
364 $ idiag, nrhs, ab, ldab, xact, lda,
365 $ b, lda, iseed, info )
367 CALL zlacpy(
'Full', n, nrhs, b, lda, x, lda )
370 CALL ztbtrs( uplo, trans, diag, n, kd, nrhs, ab,
371 $ ldab, x, lda, info )
376 $
CALL alaerh( path,
'ZTBTRS', info, 0,
377 $ uplo // trans // diag, n, n, kd,
378 $ kd, nrhs, imat, nfail, nerrs,
381 CALL ztbt02( uplo, trans, diag, n, kd, nrhs, ab,
382 $ ldab, x, lda, b, lda, work, rwork,
388 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
396 CALL ztbrfs( uplo, trans, diag, n, kd, nrhs, ab,
397 $ ldab, b, lda, x, lda, rwork,
398 $ rwork( nrhs+1 ), work,
399 $ rwork( 2*nrhs+1 ), info )
404 $
CALL alaerh( path,
'ZTBRFS', info, 0,
405 $ uplo // trans // diag, n, n, kd,
406 $ kd, nrhs, imat, nfail, nerrs,
409 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
411 CALL ztbt05( uplo, trans, diag, n, kd, nrhs, ab,
412 $ ldab, b, lda, x, lda, xact, lda,
413 $ rwork, rwork( nrhs+1 ),
420 IF( result( k ).GE.thresh )
THEN
421 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
422 $
CALL alahd( nout, path )
423 WRITE( nout, fmt = 9999 )uplo, trans,
424 $ diag, n, kd, nrhs, imat, k, result( k )
436 IF( itran.EQ.1 )
THEN
444 CALL ztbcon( norm, uplo, diag, n, kd, ab, ldab,
445 $ rcond, work, rwork, info )
450 $
CALL alaerh( path,
'ZTBCON', info, 0,
451 $ norm // uplo // diag, n, n, kd, kd,
452 $ -1, imat, nfail, nerrs, nout )
454 CALL ztbt06( rcond, rcondc, uplo, diag, n, kd, ab,
455 $ ldab, rwork, result( 6 ) )
459 IF( result( 6 ).GE.thresh )
THEN
460 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
461 $
CALL alahd( nout, path )
462 WRITE( nout, fmt = 9998 )
'ZTBCON', norm, uplo,
463 $ diag, n, kd, imat, 6, result( 6 )
473 DO 120 imat = ntype1 + 1, nimat2
477 IF( .NOT.dotype( imat ) )
484 uplo = uplos( iuplo )
485 DO 100 itran = 1, ntran
489 trans = transs( itran )
494 CALL zlattb( imat, uplo, trans, diag, iseed, n, kd,
495 $ ab, ldab, x, work, rwork, info )
501 CALL zcopy( n, x, 1, b, 1 )
502 CALL zlatbs( uplo, trans, diag,
'N', n, kd, ab,
503 $ ldab, b, scale, rwork, info )
508 $
CALL alaerh( path,
'ZLATBS', info, 0,
509 $ uplo // trans // diag //
'N', n, n,
510 $ kd, kd, -1, imat, nfail, nerrs,
513 CALL ztbt03( uplo, trans, diag, n, kd, 1, ab, ldab,
514 $ scale, rwork, one, b, lda, x, lda,
515 $ work, result( 7 ) )
520 CALL zcopy( n, x, 1, b, 1 )
521 CALL zlatbs( uplo, trans, diag,
'Y', n, kd, ab,
522 $ ldab, b, scale, rwork, info )
527 $
CALL alaerh( path,
'ZLATBS', info, 0,
528 $ uplo // trans // diag //
'Y', n, n,
529 $ kd, kd, -1, imat, nfail, nerrs,
532 CALL ztbt03( uplo, trans, diag, n, kd, 1, ab, ldab,
533 $ scale, rwork, one, b, lda, x, lda,
534 $ work, result( 8 ) )
539 IF( result( 7 ).GE.thresh )
THEN
540 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
541 $
CALL alahd( nout, path )
542 WRITE( nout, fmt = 9997 )
'ZLATBS', uplo, trans,
543 $ diag,
'N', n, kd, imat, 7, result( 7 )
546 IF( result( 8 ).GE.thresh )
THEN
547 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
548 $
CALL alahd( nout, path )
549 WRITE( nout, fmt = 9997 )
'ZLATBS', uplo, trans,
550 $ diag,
'Y', n, kd, imat, 8, result( 8 )
562 CALL alasum( path, nout, nfail, nrun, nerrs )
564 9999
FORMAT(
' UPLO=''', a1,
''', TRANS=''', a1,
''',
565 $ DIAG=''', a1,
''', N=', i5,
', KD=', i5,
', NRHS=', i5,
566 $
', type ', i2,
', test(', i2,
')=', g12.5 )
567 9998
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ''', a1,
''',',
568 $ i5,
',', i5,
', ... ), type ', i2,
', test(', i2,
')=',
570 9997
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ''', a1,
''', ''',
571 $ a1,
''',', i5,
',', i5,
', ... ), type ', i2,
', test(',
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine zerrtr(PATH, NUNIT)
ZERRTR
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine ztbt02(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X, LDX, B, LDB, WORK, RWORK, RESID)
ZTBT02
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
subroutine ztbcon(NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, RWORK, INFO)
ZTBCON
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
double precision function zlantr(NORM, UPLO, DIAG, M, N, A, LDA, WORK)
ZLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a trapezoidal or triangular matrix.
subroutine ztbt05(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
ZTBT05
subroutine zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
double precision function zlantb(NORM, UPLO, DIAG, N, K, AB, LDAB, WORK)
ZLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular band matrix.
subroutine zlatbs(UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO)
ZLATBS solves a triangular banded system of equations.
subroutine zlattb(IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, LDAB, B, WORK, RWORK, INFO)
ZLATTB
subroutine ztbt06(RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB, RWORK, RAT)
ZTBT06
subroutine ztbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
ZTBSV
subroutine ztbt03(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
ZTBT03
subroutine ztbrfs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZTBRFS
subroutine ztbtrs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
ZTBTRS
logical function lsame(CA, CB)
LSAME
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM