171 SUBROUTINE sdrvgb( 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
187 INTEGER iwork( * ), nval( * )
188 REAL a( * ), afb( * ), asav( * ),
b( * ), bsav( * ),
189 $ rwork( * ), s( * ), work( * ), x( * ),
197 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL 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 ) =
'Single precision'
261 iseed( i ) = iseedy( i )
267 $ CALL
serrvx( 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
slatb4( path, imat, n, n, type, kl, ku, anorm,
362 $ mode, cndnum, dist )
363 rcondc = one / cndnum
366 CALL
slatms( n, n, dist, iseed, type, rwork, mode,
367 $ cndnum, anorm, kl, ku,
'Z', a, lda, work,
373 CALL
alaerh( path,
'SLATMS', 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
slacpy(
'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
slacpy(
'Full', kl+ku+1, n, asav, lda,
440 $ afb( kl+1 ), ldafb )
441 IF( equil .OR. iequed.GT.1 )
THEN
446 CALL
sgbequ( 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
slaqgb( n, n, kl, ku, afb( kl+1 ),
464 $ ldafb, s, s( n+1 ),
465 $ rowcnd, colcnd, amax,
480 anormo =
slangb(
'1', n, kl, ku, afb( kl+1 ),
482 anormi =
slangb(
'I', n, kl, ku, afb( kl+1 ),
487 CALL
sgbtrf( n, n, kl, ku, afb, ldafb, iwork,
492 CALL
slaset(
'Full', n, n, zero, one, work,
495 CALL
sgbtrs(
'No transpose', n, kl, ku, n,
496 $ afb, ldafb, iwork, work, ldb,
501 ainvnm =
slange(
'1', n, n, work, ldb,
503 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
506 rcondo = ( one / anormo ) / ainvnm
512 ainvnm =
slange(
'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
slacpy(
'Full', kl+ku+1, n, asav, lda,
541 CALL
slarhs( path, xtype,
'Full', trans, n,
542 $ n, kl, ku, nrhs, a, lda, xact,
543 $ ldb,
b, ldb, iseed, info )
545 CALL
slacpy(
'Full', n, nrhs,
b, ldb, bsav,
548 IF( nofact .AND. itran.EQ.1 )
THEN
555 CALL
slacpy(
'Full', kl+ku+1, n, a, lda,
556 $ afb( kl+1 ), ldafb )
557 CALL
slacpy(
'Full', n, nrhs,
b, ldb, x,
561 CALL
sgbsv( n, kl, ku, nrhs, afb, ldafb,
562 $ iwork, x, ldb, info )
567 $ CALL
alaerh( path,
'SGBSV ', info,
568 $ izero,
' ', n, n, kl, ku,
569 $ nrhs, imat, nfail, nerrs,
575 CALL
sgbt01( n, n, kl, ku, a, lda, afb,
576 $ ldafb, iwork, work,
579 IF( izero.EQ.0 )
THEN
584 CALL
slacpy(
'Full', n, nrhs,
b, ldb,
586 CALL
sgbt02(
'No transpose', n, n, kl,
587 $ ku, nrhs, a, lda, x, ldb,
588 $ work, ldb, result( 2 ) )
593 CALL
sget04( 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 )
'SGBSV ',
606 $ n, kl, ku, imat, k, result( k )
616 $ CALL
slaset(
'Full', 2*kl+ku+1, n, zero,
618 CALL
slaset(
'Full', n, nrhs, zero, zero, x,
620 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
625 CALL
slaqgb( n, n, kl, ku, a, lda, s,
626 $ s( n+1 ), rowcnd, colcnd,
634 CALL
sgbsvx( 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,
'SGBSVX', 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 =
slantb(
'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 =
slantb(
'M',
'U',
'N', n, kl+ku,
672 IF( rpvgrw.EQ.zero )
THEN
675 rpvgrw =
slangb(
'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
sgbt01( n, n, kl, ku, a, lda, afb,
689 $ ldafb, iwork, work,
701 CALL
slacpy(
'Full', n, nrhs, bsav, ldb,
703 CALL
sgbt02( 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
sget04( n, nrhs, x, ldb, xact,
713 $ ldb, rcondc, result( 3 ) )
715 IF( itran.EQ.1 )
THEN
720 CALL
sget04( n, nrhs, x, ldb, xact,
721 $ ldb, roldc, result( 3 ) )
727 CALL
sgbt05( trans, n, kl, ku, nrhs, asav,
728 $ lda,
b, ldb, x, ldb, xact,
729 $ ldb, rwork, rwork( nrhs+1 ),
738 result( 6 ) =
sget06( 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 $
'SGBSVX', fact, trans, n, kl,
751 $ ku, equed, imat, k,
754 WRITE( nout, fmt = 9996 )
755 $
'SGBSVX', 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 )
'SGBSVX',
769 $ fact, trans, n, kl, ku, equed,
770 $ imat, 1, result( 1 )
772 WRITE( nout, fmt = 9996 )
'SGBSVX',
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 )
'SGBSVX',
784 $ fact, trans, n, kl, ku, equed,
785 $ imat, 6, result( 6 )
787 WRITE( nout, fmt = 9996 )
'SGBSVX',
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 )
'SGBSVX',
799 $ fact, trans, n, kl, ku, equed,
800 $ imat, 7, result( 7 )
802 WRITE( nout, fmt = 9996 )
'SGBSVX',
803 $ fact, trans, n, kl, ku, imat, 7,
821 CALL
alasvm( path, nout, nfail, nrun, nerrs )
823 9999
FORMAT(
' *** In SDRVGB, LA=', i5,
' is too small for N=', i5,
824 $
', KU=', i5,
', KL=', i5, /
' ==> Increase LA to at least ',
826 9998
FORMAT(
' *** In SDRVGB, 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 slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
real function slantb(NORM, UPLO, DIAG, N, K, AB, LDAB, WORK)
SLANTB 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 alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine sgbt02(TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, RESID)
SGBT02
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine sgbequ(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO)
SGBEQU
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
real function sget06(RCOND, RCONDC)
SGET06
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine sdrvgb(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
SDRVGB
subroutine sgbsvx(FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
SGBSVX computes the solution to system of linear equations A * X = B for GB matrices ...
subroutine sgbtrf(M, N, KL, KU, AB, LDAB, IPIV, INFO)
SGBTRF
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine slaqgb(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED)
SLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ...
logical function lsame(CA, CB)
LSAME
real function slangb(NORM, N, KL, KU, AB, LDAB, WORK)
SLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine sgbsv(N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
SGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver) ...
subroutine sgbt05(TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SGBT05
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
real function slamch(CMACH)
SLAMCH
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine aladhd(IOUNIT, PATH)
ALADHD
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine sgbt01(M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, RESID)
SGBT01
subroutine serrvx(PATH, NUNIT)
SERRVX
subroutine sgbtrs(TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
SGBTRS
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4