171 SUBROUTINE zdrvgb( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA,
172 $ afb, lafb, asav, b, bsav, x, xact, s, work,
173 $ rwork, iwork, nout )
182 INTEGER LA, LAFB, NN, NOUT, NRHS
183 DOUBLE PRECISION THRESH
187 INTEGER IWORK( * ), NVAL( * )
188 DOUBLE PRECISION RWORK( * ), S( * )
189 COMPLEX*16 A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
190 $ work( * ), x( * ), xact( * )
196 DOUBLE PRECISION ONE, ZERO
197 parameter( one = 1.0d+0, zero = 0.0d+0 )
199 parameter( ntypes = 8 )
201 parameter( ntests = 7 )
203 parameter( ntran = 3 )
206 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
207 CHARACTER DIST, EQUED, FACT, TRANS,
TYPE, XTYPE
209 INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN,
210 $ info, ioff, itran, izero, j, k, k1, kl, ku,
211 $ lda, ldafb, ldb, mode, n, nb, nbmin, nerrs,
212 $ nfact, nfail, nimat, nkl, nku, nrun, nt
213 DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV,
214 $ cndnum, colcnd, rcond, rcondc, rcondi, rcondo,
215 $ roldc, roldi, roldo, rowcnd, rpvgrw
218 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( ntran )
219 INTEGER ISEED( 4 ), ISEEDY( 4 )
220 DOUBLE PRECISION RDUM( 1 ), RESULT( ntests )
224 DOUBLE PRECISION DGET06, DLAMCH, ZLANGB, ZLANGE, ZLANTB
225 EXTERNAL lsame, dget06, dlamch, zlangb, zlange, zlantb
234 INTRINSIC abs, dcmplx, max, min
242 COMMON / infoc / infot, nunit, ok, lerr
243 COMMON / srnamc / srnamt
246 DATA iseedy / 1988, 1989, 1990, 1991 /
247 DATA transs /
'N',
'T',
'C' /
248 DATA facts /
'F',
'N',
'E' /
249 DATA equeds /
'N',
'R',
'C',
'B' /
255 path( 1: 1 ) =
'Zomplex precision'
261 iseed( i ) = iseedy( i )
267 $ CALL
zerrvx( path, nout )
286 nkl = max( 1, min( n, 4 ) )
301 ELSE IF( ikl.EQ.2 )
THEN
303 ELSE IF( ikl.EQ.3 )
THEN
305 ELSE IF( ikl.EQ.4 )
THEN
316 ELSE IF( iku.EQ.2 )
THEN
318 ELSE IF( iku.EQ.3 )
THEN
320 ELSE IF( iku.EQ.4 )
THEN
328 ldafb = 2*kl + ku + 1
329 IF( lda*n.GT.la .OR. ldafb*n.GT.lafb )
THEN
330 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
331 $ CALL
aladhd( nout, path )
332 IF( lda*n.GT.la )
THEN
333 WRITE( nout, fmt = 9999 )la, n, kl, ku,
337 IF( ldafb*n.GT.lafb )
THEN
338 WRITE( nout, fmt = 9998 )lafb, n, kl, ku,
345 DO 120 imat = 1, nimat
349 IF( .NOT.dotype( imat ) )
354 zerot = imat.GE.2 .AND. imat.LE.4
355 IF( zerot .AND. n.LT.imat-1 )
361 CALL
zlatb4( path, imat, n, n,
TYPE, KL, KU, ANORM,
362 $ mode, cndnum, dist )
363 rcondc = one / cndnum
366 CALL
zlatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
367 $ cndnum, anorm, kl, ku,
'Z', a, lda, work,
373 CALL
alaerh( path,
'ZLATMS', info, 0,
' ', n, n,
374 $ kl, ku, -1, imat, nfail, nerrs, nout )
385 ELSE IF( imat.EQ.3 )
THEN
390 ioff = ( izero-1 )*lda
392 i1 = max( 1, ku+2-izero )
393 i2 = min( kl+ku+1, ku+1+( n-izero ) )
399 DO 30 i = max( 1, ku+2-j ),
400 $ min( kl+ku+1, ku+1+( n-j ) )
410 CALL
zlacpy(
'Full', kl+ku+1, n, a, lda, asav, lda )
413 equed = equeds( iequed )
414 IF( iequed.EQ.1 )
THEN
420 DO 100 ifact = 1, nfact
421 fact = facts( ifact )
422 prefac = lsame( fact,
'F' )
423 nofact = lsame( fact,
'N' )
424 equil = lsame( fact,
'E' )
432 ELSE IF( .NOT.nofact )
THEN
439 CALL
zlacpy(
'Full', kl+ku+1, n, asav, lda,
440 $ afb( kl+1 ), ldafb )
441 IF( equil .OR. iequed.GT.1 )
THEN
446 CALL
zgbequ( n, n, kl, ku, afb( kl+1 ),
447 $ ldafb, s, s( n+1 ), rowcnd,
448 $ colcnd, amax, info )
449 IF( info.EQ.0 .AND. n.GT.0 )
THEN
450 IF( lsame( equed,
'R' ) )
THEN
453 ELSE IF( lsame( equed,
'C' ) )
THEN
456 ELSE IF( lsame( equed,
'B' ) )
THEN
463 CALL
zlaqgb( n, n, kl, ku, afb( kl+1 ),
464 $ ldafb, s, s( n+1 ),
465 $ rowcnd, colcnd, amax,
480 anormo = zlangb(
'1', n, kl, ku, afb( kl+1 ),
482 anormi = zlangb(
'I', n, kl, ku, afb( kl+1 ),
487 CALL
zgbtrf( n, n, kl, ku, afb, ldafb, iwork,
492 CALL
zlaset(
'Full', n, n, dcmplx( zero ),
493 $ dcmplx( one ), work, ldb )
495 CALL
zgbtrs(
'No transpose', n, kl, ku, n,
496 $ afb, ldafb, iwork, work, ldb,
501 ainvnm = zlange(
'1', n, n, work, ldb,
503 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
506 rcondo = ( one / anormo ) / ainvnm
512 ainvnm = zlange(
'I', n, n, work, ldb,
514 IF( anormi.LE.zero .OR. ainvnm.LE.zero )
THEN
517 rcondi = ( one / anormi ) / ainvnm
521 DO 90 itran = 1, ntran
525 trans = transs( itran )
526 IF( itran.EQ.1 )
THEN
534 CALL
zlacpy(
'Full', kl+ku+1, n, asav, lda,
541 CALL
zlarhs( path, xtype,
'Full', trans, n,
542 $ n, kl, ku, nrhs, a, lda, xact,
543 $ ldb, b, ldb, iseed, info )
545 CALL
zlacpy(
'Full', n, nrhs, b, ldb, bsav,
548 IF( nofact .AND. itran.EQ.1 )
THEN
555 CALL
zlacpy(
'Full', kl+ku+1, n, a, lda,
556 $ afb( kl+1 ), ldafb )
557 CALL
zlacpy(
'Full', n, nrhs, b, ldb, x,
561 CALL
zgbsv( n, kl, ku, nrhs, afb, ldafb,
562 $ iwork, x, ldb, info )
567 $ CALL
alaerh( path,
'ZGBSV ', info,
568 $ izero,
' ', n, n, kl, ku,
569 $ nrhs, imat, nfail, nerrs,
575 CALL
zgbt01( n, n, kl, ku, a, lda, afb,
576 $ ldafb, iwork, work,
579 IF( izero.EQ.0 )
THEN
584 CALL
zlacpy(
'Full', n, nrhs, b, ldb,
586 CALL
zgbt02(
'No transpose', n, n, kl,
587 $ ku, nrhs, a, lda, x, ldb,
588 $ work, ldb, result( 2 ) )
593 CALL
zget04( n, nrhs, x, ldb, xact,
594 $ ldb, rcondc, result( 3 ) )
602 IF( result( k ).GE.thresh )
THEN
603 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
604 $ CALL
aladhd( nout, path )
605 WRITE( nout, fmt = 9997 )
'ZGBSV ',
606 $ n, kl, ku, imat, k, result( k )
616 $ CALL
zlaset(
'Full', 2*kl+ku+1, n,
618 $ dcmplx( zero ), afb, ldafb )
619 CALL
zlaset(
'Full', n, nrhs, dcmplx( zero ),
620 $ dcmplx( zero ), x, ldb )
621 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
626 CALL
zlaqgb( n, n, kl, ku, a, lda, s,
627 $ s( n+1 ), rowcnd, colcnd,
635 CALL
zgbsvx( fact, trans, n, kl, ku, nrhs, a,
636 $ lda, afb, ldafb, iwork, equed,
637 $ s, s( ldb+1 ), b, ldb, x, ldb,
638 $ rcond, rwork, rwork( nrhs+1 ),
639 $ work, rwork( 2*nrhs+1 ), info )
644 $ CALL
alaerh( path,
'ZGBSVX', info, izero,
645 $ fact // trans, n, n, kl, ku,
646 $ nrhs, imat, nfail, nerrs,
651 IF( info.NE.0 .AND. info.LE.n)
THEN
654 DO 60 i = max( ku+2-j, 1 ),
655 $ min( n+ku+1-j, kl+ku+1 )
656 anrmpv = max( anrmpv,
657 $ abs( a( i+( j-1 )*lda ) ) )
660 rpvgrw = zlantb(
'M',
'U',
'N', info,
661 $ min( info-1, kl+ku ),
662 $ afb( max( 1, kl+ku+2-info ) ),
664 IF( rpvgrw.EQ.zero )
THEN
667 rpvgrw = anrmpv / rpvgrw
670 rpvgrw = zlantb(
'M',
'U',
'N', n, kl+ku,
672 IF( rpvgrw.EQ.zero )
THEN
675 rpvgrw = zlangb(
'M', n, kl, ku, a,
676 $ lda, rdum ) / rpvgrw
679 result( 7 ) = abs( rpvgrw-rwork( 2*nrhs+1 ) )
680 $ / max( rwork( 2*nrhs+1 ),
681 $ rpvgrw ) / dlamch(
'E' )
683 IF( .NOT.prefac )
THEN
688 CALL
zgbt01( n, n, kl, ku, a, lda, afb,
689 $ ldafb, iwork, work,
701 CALL
zlacpy(
'Full', n, nrhs, bsav, ldb,
703 CALL
zgbt02( trans, n, n, kl, ku, nrhs,
704 $ asav, lda, x, ldb, work, ldb,
710 IF( nofact .OR. ( prefac .AND.
711 $ lsame( equed,
'N' ) ) )
THEN
712 CALL
zget04( n, nrhs, x, ldb, xact,
713 $ ldb, rcondc, result( 3 ) )
715 IF( itran.EQ.1 )
THEN
720 CALL
zget04( n, nrhs, x, ldb, xact,
721 $ ldb, roldc, result( 3 ) )
727 CALL
zgbt05( trans, n, kl, ku, nrhs, asav,
728 $ lda, bsav, ldb, x, ldb, xact,
729 $ ldb, rwork, rwork( nrhs+1 ),
738 result( 6 ) = dget06( rcond, rcondc )
743 IF( .NOT.trfcon )
THEN
745 IF( result( k ).GE.thresh )
THEN
746 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
747 $ CALL
aladhd( nout, path )
749 WRITE( nout, fmt = 9995 )
750 $
'ZGBSVX', fact, trans, n, kl,
751 $ ku, equed, imat, k,
754 WRITE( nout, fmt = 9996 )
755 $
'ZGBSVX', fact, trans, n, kl,
756 $ ku, imat, k, result( k )
763 IF( result( 1 ).GE.thresh .AND. .NOT.
765 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
766 $ CALL
aladhd( nout, path )
768 WRITE( nout, fmt = 9995 )
'ZGBSVX',
769 $ fact, trans, n, kl, ku, equed,
770 $ imat, 1, result( 1 )
772 WRITE( nout, fmt = 9996 )
'ZGBSVX',
773 $ fact, trans, n, kl, ku, imat, 1,
779 IF( result( 6 ).GE.thresh )
THEN
780 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
781 $ CALL
aladhd( nout, path )
783 WRITE( nout, fmt = 9995 )
'ZGBSVX',
784 $ fact, trans, n, kl, ku, equed,
785 $ imat, 6, result( 6 )
787 WRITE( nout, fmt = 9996 )
'ZGBSVX',
788 $ fact, trans, n, kl, ku, imat, 6,
794 IF( result( 7 ).GE.thresh )
THEN
795 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
796 $ CALL
aladhd( nout, path )
798 WRITE( nout, fmt = 9995 )
'ZGBSVX',
799 $ fact, trans, n, kl, ku, equed,
800 $ imat, 7, result( 7 )
802 WRITE( nout, fmt = 9996 )
'ZGBSVX',
803 $ fact, trans, n, kl, ku, imat, 7,
820 CALL
alasvm( path, nout, nfail, nrun, nerrs )
822 9999
FORMAT(
' *** In ZDRVGB, LA=', i5,
' is too small for N=', i5,
823 $
', KU=', i5,
', KL=', i5, /
' ==> Increase LA to at least ',
825 9998
FORMAT(
' *** In ZDRVGB, LAFB=', i5,
' is too small for N=', i5,
826 $
', KU=', i5,
', KL=', i5, /
827 $
' ==> Increase LAFB to at least ', i5 )
828 9997
FORMAT( 1x, a,
', N=', i5,
', KL=', i5,
', KU=', i5,
', type ',
829 $ i1,
', test(', i1,
')=', g12.5 )
830 9996
FORMAT( 1x, a,
'( ''', a1,
''',''', a1,
''',', i5,
',', i5,
',',
831 $ i5,
',...), type ', i1,
', test(', i1,
')=', g12.5 )
832 9995
FORMAT( 1x, a,
'( ''', a1,
''',''', a1,
''',', i5,
',', i5,
',',
833 $ i5,
',...), EQUED=''', a1,
''', type ', i1,
', test(', i1,
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 alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
subroutine zlaqgb(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED)
ZLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ...
subroutine zgbt01(M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, RESID)
ZGBT01
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 zgbt02(TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, RESID)
ZGBT02
subroutine zgbt05(TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
ZGBT05
subroutine zgbtrs(TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
ZGBTRS
subroutine zgbequ(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO)
ZGBEQU
subroutine zdrvgb(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
ZDRVGB
subroutine zgbsv(N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
ZGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver) ...
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine zerrvx(PATH, NUNIT)
ZERRVX
subroutine zgbsvx(FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
ZGBSVX computes the solution to system of linear equations A * X = B for GB matrices ...
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
subroutine zgbtrf(M, N, KL, KU, AB, LDAB, IPIV, INFO)
ZGBTRF
subroutine zlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
ZLATB4