173 INTEGER nmax, nn, nnb, nns, nout
174 DOUBLE PRECISION thresh
178 INTEGER nbval( * ), nsval( * ), nval( * )
179 DOUBLE PRECISION rwork( * )
180 COMPLEX*16 a( * ), ainv( * ), b( * ), work( * ), x( * ),
187 INTEGER ntype1, ntypes
188 parameter( ntype1 = 10, ntypes = 18 )
190 parameter( ntests = 9 )
192 parameter( ntran = 3 )
193 DOUBLE PRECISION one, zero
194 parameter( one = 1.0d0, zero = 0.0d0 )
197 CHARACTER diag, norm, trans, uplo, xtype
199 INTEGER i, idiag, imat, in, inb, info, irhs, itran,
200 $ iuplo, k, lda, n, nb, nerrs, nfail, nrhs, nrun
201 DOUBLE PRECISION ainvnm, anorm, dummy, rcond, rcondc, rcondi,
205 CHARACTER transs( ntran ), uplos( 2 )
206 INTEGER iseed( 4 ), iseedy( 4 )
207 DOUBLE PRECISION result( ntests )
223 INTEGER infot, iounit
226 COMMON / infoc / infot, iounit, ok, lerr
227 COMMON / srnamc / srnamt
233 DATA iseedy / 1988, 1989, 1990, 1991 /
234 DATA uplos /
'U',
'L' / , transs /
'N',
'T',
'C' /
240 path( 1: 1 ) =
'Zomplex precision'
246 iseed( i ) = iseedy( i )
252 $
CALL zerrtr( path, nout )
263 DO 80 imat = 1, ntype1
267 IF( .NOT.dotype( imat ) )
274 uplo = uplos( iuplo )
279 CALL zlattr( imat, uplo,
'No transpose', diag, iseed, n,
280 $ a, lda, x, work, rwork, info )
284 IF(
lsame( diag,
'N' ) )
THEN
300 CALL zlacpy( uplo, n, n, a, lda, ainv, lda )
302 CALL ztrtri( uplo, diag, n, ainv, lda, info )
307 $
CALL alaerh( path,
'ZTRTRI', info, 0, uplo // diag,
308 $ n, n, -1, -1, nb, imat, nfail, nerrs,
313 anorm =
zlantr(
'I', uplo, diag, n, n, a, lda, rwork )
314 ainvnm =
zlantr(
'I', uplo, diag, n, n, ainv, lda,
316 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
319 rcondi = ( one / anorm ) / ainvnm
326 CALL ztrt01( uplo, diag, n, a, lda, ainv, lda, rcondo,
327 $ rwork, result( 1 ) )
330 IF( result( 1 ).GE.thresh )
THEN
331 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
332 $
CALL alahd( nout, path )
333 WRITE( nout, fmt = 9999 )uplo, diag, n, nb, imat,
348 DO 30 itran = 1, ntran
352 trans = transs( itran )
353 IF( itran.EQ.1 )
THEN
365 CALL zlarhs( path, xtype, uplo, trans, n, n, 0,
366 $ idiag, nrhs, a, lda, xact, lda, b,
369 CALL zlacpy(
'Full', n, nrhs, b, lda, x, lda )
372 CALL ztrtrs( uplo, trans, diag, n, nrhs, a, lda,
378 $
CALL alaerh( path,
'ZTRTRS', info, 0,
379 $ uplo // trans // diag, n, n, -1,
380 $ -1, nrhs, imat, nfail, nerrs,
388 CALL ztrt02( uplo, trans, diag, n, nrhs, a, lda,
389 $ x, lda, b, lda, work, rwork,
395 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
403 CALL ztrrfs( uplo, trans, diag, n, nrhs, a, lda,
404 $ b, lda, x, lda, rwork,
405 $ rwork( nrhs+1 ), work,
406 $ rwork( 2*nrhs+1 ), info )
411 $
CALL alaerh( path,
'ZTRRFS', info, 0,
412 $ uplo // trans // diag, n, n, -1,
413 $ -1, nrhs, imat, nfail, nerrs,
416 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
418 CALL ztrt05( uplo, trans, diag, n, nrhs, a, lda,
419 $ b, lda, x, lda, xact, lda, rwork,
420 $ rwork( nrhs+1 ), result( 5 ) )
426 IF( result( k ).GE.thresh )
THEN
427 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
428 $
CALL alahd( nout, path )
429 WRITE( nout, fmt = 9998 )uplo, trans,
430 $ diag, n, nrhs, imat, k, result( k )
442 IF( itran.EQ.1 )
THEN
450 CALL ztrcon( norm, uplo, diag, n, a, lda, rcond,
451 $ work, rwork, info )
456 $
CALL alaerh( path,
'ZTRCON', info, 0,
457 $ norm // uplo // diag, n, n, -1, -1,
458 $ -1, imat, nfail, nerrs, nout )
460 CALL ztrt06( rcond, rcondc, uplo, diag, n, a, lda,
461 $ rwork, result( 7 ) )
465 IF( result( 7 ).GE.thresh )
THEN
466 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
467 $
CALL alahd( nout, path )
468 WRITE( nout, fmt = 9997 )norm, uplo, n, imat,
480 DO 110 imat = ntype1 + 1, ntypes
484 IF( .NOT.dotype( imat ) )
491 uplo = uplos( iuplo )
492 DO 90 itran = 1, ntran
496 trans = transs( itran )
501 CALL zlattr( imat, uplo, trans, diag, iseed, n, a,
502 $ lda, x, work, rwork, info )
508 CALL zcopy( n, x, 1, b, 1 )
509 CALL zlatrs( uplo, trans, diag,
'N', n, a, lda, b,
510 $ scale, rwork, info )
515 $
CALL alaerh( path,
'ZLATRS', info, 0,
516 $ uplo // trans // diag //
'N', n, n,
517 $ -1, -1, -1, imat, nfail, nerrs, nout )
519 CALL ztrt03( uplo, trans, diag, n, 1, a, lda, scale,
520 $ rwork, one, b, lda, x, lda, work,
526 CALL zcopy( n, x, 1, b( n+1 ), 1 )
527 CALL zlatrs( uplo, trans, diag,
'Y', n, a, lda,
528 $ b( n+1 ), scale, rwork, info )
533 $
CALL alaerh( path,
'ZLATRS', info, 0,
534 $ uplo // trans // diag //
'Y', n, n,
535 $ -1, -1, -1, imat, nfail, nerrs, nout )
537 CALL ztrt03( uplo, trans, diag, n, 1, a, lda, scale,
538 $ rwork, one, b( n+1 ), lda, x, lda, work,
544 IF( result( 8 ).GE.thresh )
THEN
545 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
546 $
CALL alahd( nout, path )
547 WRITE( nout, fmt = 9996 )
'ZLATRS', uplo, trans,
548 $ diag,
'N', n, imat, 8, result( 8 )
551 IF( result( 9 ).GE.thresh )
THEN
552 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
553 $
CALL alahd( nout, path )
554 WRITE( nout, fmt = 9996 )
'ZLATRS', uplo, trans,
555 $ diag,
'Y', n, imat, 9, result( 9 )
566 CALL alasum( path, nout, nfail, nrun, nerrs )
568 9999
FORMAT(
' UPLO=''', a1,
''', DIAG=''', a1,
''', N=', i5,
', NB=',
569 $ i4,
', type ', i2,
', test(', i2,
')= ', g12.5 )
570 9998
FORMAT(
' UPLO=''', a1,
''', TRANS=''', a1,
''', DIAG=''', a1,
571 $
''', N=', i5,
', NB=', i4,
', type ', i2,
',
572 $ test(', i2,
')= ', g12.5 )
573 9997
FORMAT(
' NORM=''', a1,
''', UPLO =''', a1,
''', N=', i5,
',',
574 $ 11x,
' type ', i2,
', test(', i2,
')=', g12.5 )
575 9996
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ''', a1,
''', ''',
576 $ a1,
''',', i5,
', ... ), type ', i2,
', test(', i2,
')=',
subroutine zerrtr(PATH, NUNIT)
ZERRTR
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine ztrrfs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZTRRFS
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 alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine ztrt01(UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND, RWORK, RESID)
ZTRT01
subroutine ztrcon(NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, RWORK, INFO)
ZTRCON
subroutine zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
subroutine ztrt02(UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B, LDB, WORK, RWORK, RESID)
ZTRT02
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
logical function lsame(CA, CB)
LSAME
subroutine ztrt05(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
ZTRT05
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine ztrtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
ZTRTRS
subroutine ztrt03(UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
ZTRT03
subroutine zlatrs(UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO)
ZLATRS solves a triangular system of equations with the scale factor set to prevent overflow...
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine ztrtri(UPLO, DIAG, N, A, LDA, INFO)
ZTRTRI
subroutine ztrt06(RCOND, RCONDC, UPLO, DIAG, N, A, LDA, RWORK, RAT)
ZTRT06
subroutine zlattr(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, WORK, RWORK, INFO)
ZLATTR