149 SUBROUTINE zchktb( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
150 $ nmax, ab, ainv,
b, x, xact, work, rwork, nout )
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 zerrtr(PATH, NUNIT)
ZERRTR
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
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 zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine ztbt05(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
ZTBT05
subroutine zlattb(IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, LDAB, B, WORK, RWORK, INFO)
ZLATTB
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 ztbt03(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
ZTBT03
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine ztbt02(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X, LDX, B, LDB, WORK, RWORK, RESID)
ZTBT02
subroutine ztbt06(RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB, RWORK, RAT)
ZTBT06
subroutine zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
logical function lsame(CA, CB)
LSAME
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...
subroutine ztbcon(NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, RWORK, INFO)
ZTBCON
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine ztbrfs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZTBRFS
subroutine zlatbs(UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO)
ZLATBS solves a triangular banded system of equations.
subroutine ztbtrs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
ZTBTRS
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine ztbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
ZTBSV
subroutine zchktb(DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, AB, AINV, B, X, XACT, WORK, RWORK, NOUT)
ZCHKTB