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 )
761 nrun = nrun + ntests - k1 + 1
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 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 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 zgbtrs(TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
ZGBTRS
subroutine zgbt02(TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, RESID)
ZGBT02
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
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 zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zgbequ(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO)
ZGBEQU
subroutine zgbt01(M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, RESID)
ZGBT01
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
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 zgbtrf(M, N, KL, KU, AB, LDAB, IPIV, INFO)
ZGBTRF
subroutine zlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
ZLATB4
subroutine aladhd(IOUNIT, PATH)
ALADHD
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 zdrvgb(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
ZDRVGB
subroutine zerrvx(PATH, NUNIT)
ZERRVX
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
subroutine zgbt05(TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
ZGBT05