171 SUBROUTINE ddrvgb( 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 a( * ), afb( * ), asav( * ),
b( * ), bsav( * ),
189 $ rwork( * ), s( * ), work( * ), x( * ),
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 result( ntests )
234 INTRINSIC abs, 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 ) =
'Double precision'
261 iseed( i ) = iseedy( i )
267 $ CALL
derrvx( 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
dlatb4( path, imat, n, n, type, kl, ku, anorm,
362 $ mode, cndnum, dist )
363 rcondc = one / cndnum
366 CALL
dlatms( n, n, dist, iseed, type, rwork, mode,
367 $ cndnum, anorm, kl, ku,
'Z', a, lda, work,
373 CALL
alaerh( path,
'DLATMS', 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
dlacpy(
'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
dlacpy(
'Full', kl+ku+1, n, asav, lda,
440 $ afb( kl+1 ), ldafb )
441 IF( equil .OR. iequed.GT.1 )
THEN
446 CALL
dgbequ( 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
dlaqgb( n, n, kl, ku, afb( kl+1 ),
464 $ ldafb, s, s( n+1 ),
465 $ rowcnd, colcnd, amax,
480 anormo =
dlangb(
'1', n, kl, ku, afb( kl+1 ),
482 anormi =
dlangb(
'I', n, kl, ku, afb( kl+1 ),
487 CALL
dgbtrf( n, n, kl, ku, afb, ldafb, iwork,
492 CALL
dlaset(
'Full', n, n, zero, one, work,
495 CALL
dgbtrs(
'No transpose', n, kl, ku, n,
496 $ afb, ldafb, iwork, work, ldb,
501 ainvnm =
dlange(
'1', n, n, work, ldb,
503 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
506 rcondo = ( one / anormo ) / ainvnm
512 ainvnm =
dlange(
'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
dlacpy(
'Full', kl+ku+1, n, asav, lda,
541 CALL
dlarhs( path, xtype,
'Full', trans, n,
542 $ n, kl, ku, nrhs, a, lda, xact,
543 $ ldb,
b, ldb, iseed, info )
545 CALL
dlacpy(
'Full', n, nrhs,
b, ldb, bsav,
548 IF( nofact .AND. itran.EQ.1 )
THEN
555 CALL
dlacpy(
'Full', kl+ku+1, n, a, lda,
556 $ afb( kl+1 ), ldafb )
557 CALL
dlacpy(
'Full', n, nrhs,
b, ldb, x,
561 CALL
dgbsv( n, kl, ku, nrhs, afb, ldafb,
562 $ iwork, x, ldb, info )
567 $ CALL
alaerh( path,
'DGBSV ', info,
568 $ izero,
' ', n, n, kl, ku,
569 $ nrhs, imat, nfail, nerrs,
575 CALL
dgbt01( n, n, kl, ku, a, lda, afb,
576 $ ldafb, iwork, work,
579 IF( izero.EQ.0 )
THEN
584 CALL
dlacpy(
'Full', n, nrhs,
b, ldb,
586 CALL
dgbt02(
'No transpose', n, n, kl,
587 $ ku, nrhs, a, lda, x, ldb,
588 $ work, ldb, result( 2 ) )
593 CALL
dget04( 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 )
'DGBSV ',
606 $ n, kl, ku, imat, k, result( k )
616 $ CALL
dlaset(
'Full', 2*kl+ku+1, n, zero,
618 CALL
dlaset(
'Full', n, nrhs, zero, zero, x,
620 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
625 CALL
dlaqgb( n, n, kl, ku, a, lda, s,
626 $ s( n+1 ), rowcnd, colcnd,
634 CALL
dgbsvx( fact, trans, n, kl, ku, nrhs, a,
635 $ lda, afb, ldafb, iwork, equed,
636 $ s, s( n+1 ),
b, ldb, x, ldb,
637 $ rcond, rwork, rwork( nrhs+1 ),
638 $ work, iwork( n+1 ), info )
643 $ CALL
alaerh( path,
'DGBSVX', info, izero,
644 $ fact // trans, n, n, kl, ku,
645 $ 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 =
dlantb(
'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 =
dlantb(
'M',
'U',
'N', n, kl+ku,
672 IF( rpvgrw.EQ.zero )
THEN
675 rpvgrw =
dlangb(
'M', n, kl, ku, a,
676 $ lda, work ) / rpvgrw
679 result( 7 ) = abs( rpvgrw-work( 1 ) ) /
680 $ max( work( 1 ), rpvgrw ) /
683 IF( .NOT.prefac )
THEN
688 CALL
dgbt01( n, n, kl, ku, a, lda, afb,
689 $ ldafb, iwork, work,
701 CALL
dlacpy(
'Full', n, nrhs, bsav, ldb,
703 CALL
dgbt02( 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
dget04( n, nrhs, x, ldb, xact,
713 $ ldb, rcondc, result( 3 ) )
715 IF( itran.EQ.1 )
THEN
720 CALL
dget04( n, nrhs, x, ldb, xact,
721 $ ldb, roldc, result( 3 ) )
727 CALL
dgbt05( trans, n, kl, ku, nrhs, asav,
728 $ lda,
b, 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 $
'DGBSVX', fact, trans, n, kl,
751 $ ku, equed, imat, k,
754 WRITE( nout, fmt = 9996 )
755 $
'DGBSVX', 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 )
'DGBSVX',
769 $ fact, trans, n, kl, ku, equed,
770 $ imat, 1, result( 1 )
772 WRITE( nout, fmt = 9996 )
'DGBSVX',
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 )
'DGBSVX',
784 $ fact, trans, n, kl, ku, equed,
785 $ imat, 6, result( 6 )
787 WRITE( nout, fmt = 9996 )
'DGBSVX',
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 )
'DGBSVX',
799 $ fact, trans, n, kl, ku, equed,
800 $ imat, 7, result( 7 )
802 WRITE( nout, fmt = 9996 )
'DGBSVX',
803 $ fact, trans, n, kl, ku, imat, 7,
821 CALL
alasvm( path, nout, nfail, nrun, nerrs )
823 9999
FORMAT(
' *** In DDRVGB, LA=', i5,
' is too small for N=', i5,
824 $
', KU=', i5,
', KL=', i5, /
' ==> Increase LA to at least ',
826 9998
FORMAT(
' *** In DDRVGB, LAFB=', i5,
' is too small for N=', i5,
827 $
', KU=', i5,
', KL=', i5, /
828 $
' ==> Increase LAFB to at least ', i5 )
829 9997
FORMAT( 1x, a,
', N=', i5,
', KL=', i5,
', KU=', i5,
', type ',
830 $ i1,
', test(', i1,
')=', g12.5 )
831 9996
FORMAT( 1x, a,
'( ''', a1,
''',''', a1,
''',', i5,
',', i5,
',',
832 $ i5,
',...), type ', i1,
', test(', i1,
')=', g12.5 )
833 9995
FORMAT( 1x, a,
'( ''', a1,
''',''', a1,
''',', i5,
',', i5,
',',
834 $ i5,
',...), EQUED=''', a1,
''', type ', i1,
', test(', i1,
subroutine dgbt01(M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, RESID)
DGBT01
subroutine dgbsv(N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
DGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver) ...
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine derrvx(PATH, NUNIT)
DERRVX
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine dlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
DLARHS
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine dgbtrf(M, N, KL, KU, AB, LDAB, IPIV, INFO)
DGBTRF
double precision function dlangb(NORM, N, KL, KU, AB, LDAB, WORK)
DLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
logical function lsame(CA, CB)
LSAME
subroutine ddrvgb(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
DDRVGB
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
double precision function dlantb(NORM, UPLO, DIAG, N, K, AB, LDAB, WORK)
DLANTB 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 dgbsvx(FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
DGBSVX computes the solution to system of linear equations A * X = B for GB matrices ...
subroutine dlaqgb(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED)
DLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ...
double precision function dget06(RCOND, RCONDC)
DGET06
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine dgbtrs(TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
DGBTRS
subroutine dgbequ(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO)
DGBEQU
subroutine aladhd(IOUNIT, PATH)
ALADHD
double precision function dlamch(CMACH)
DLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dgbt05(TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DGBT05
subroutine dgbt02(TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, RESID)
DGBT02