201 INTEGER la, lafac, nm, nn, nnb, nns, nout
202 DOUBLE PRECISION thresh
206 INTEGER iwork( * ), mval( * ), nbval( * ), nsval( * ),
208 DOUBLE PRECISION a( * ), afac( * ), b( * ), rwork( * ),
209 $ work( * ), x( * ), xact( * )
215 DOUBLE PRECISION one, zero
216 parameter( one = 1.0d+0, zero = 0.0d+0 )
217 INTEGER ntypes, ntests
218 parameter( ntypes = 8, ntests = 7 )
220 parameter( nbw = 4, ntran = 3 )
223 LOGICAL trfcon, zerot
224 CHARACTER dist, norm, trans,
TYPE, xtype
226 INTEGER i, i1, i2, ikl, iku, im, imat, in, inb, info,
227 $ ioff, irhs, itran, izero, j, k, kl, koff, ku,
228 $ lda, ldafac, ldb, m, mode, n, nb, nerrs, nfail,
229 $ nimat, nkl, nku, nrhs, nrun
230 DOUBLE PRECISION ainvnm, anorm, anormi, anormo, cndnum, rcond,
231 $ rcondc, rcondi, rcondo
234 CHARACTER transs( ntran )
235 INTEGER iseed( 4 ), iseedy( 4 ), klval( nbw ),
237 DOUBLE PRECISION result( ntests )
258 COMMON / infoc / infot, nunit, ok, lerr
259 COMMON / srnamc / srnamt
262 DATA iseedy / 1988, 1989, 1990, 1991 / ,
263 $ transs /
'N',
'T',
'C' /
269 path( 1: 1 ) =
'Double precision' 275 iseed( i ) = iseedy( i )
281 $
CALL derrge( path, nout )
297 klval( 2 ) = m + ( m+1 ) / 4
301 klval( 3 ) = ( 3*m-1 ) / 4
302 klval( 4 ) = ( m+1 ) / 4
312 kuval( 2 ) = n + ( n+1 ) / 4
316 kuval( 3 ) = ( 3*n-1 ) / 4
317 kuval( 4 ) = ( n+1 ) / 4
328 IF( m.LE.0 .OR. n.LE.0 )
350 ldafac = 2*kl + ku + 1
351 IF( ( lda*n ).GT.la .OR. ( ldafac*n ).GT.lafac )
THEN 352 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
353 $
CALL alahd( nout, path )
354 IF( n*( kl+ku+1 ).GT.la )
THEN 355 WRITE( nout, fmt = 9999 )la, m, n, kl, ku,
359 IF( n*( 2*kl+ku+1 ).GT.lafac )
THEN 360 WRITE( nout, fmt = 9998 )lafac, m, n, kl, ku,
367 DO 120 imat = 1, nimat
371 IF( .NOT.dotype( imat ) )
377 zerot = imat.GE.2 .AND. imat.LE.4
378 IF( zerot .AND. n.LT.imat-1 )
381 IF( .NOT.zerot .OR. .NOT.dotype( 1 ) )
THEN 386 CALL dlatb4( path, imat, m, n,
TYPE, kl, ku,
387 $ anorm, mode, cndnum, dist )
389 koff = max( 1, ku+2-n )
390 DO 20 i = 1, koff - 1
394 CALL dlatms( m, n, dist, iseed,
TYPE, rwork,
395 $ mode, cndnum, anorm, kl, ku,
'Z',
396 $ a( koff ), lda, work, info )
401 CALL alaerh( path,
'DLATMS', info, 0,
' ', m,
402 $ n, kl, ku, -1, imat, nfail,
406 ELSE IF( izero.GT.0 )
THEN 411 CALL dcopy( i2-i1+1, b, 1, a( ioff+i1 ), 1 )
421 ELSE IF( imat.EQ.3 )
THEN 424 izero = min( m, n ) / 2 + 1
426 ioff = ( izero-1 )*lda
431 i1 = max( 1, ku+2-izero )
432 i2 = min( kl+ku+1, ku+1+( m-izero ) )
433 CALL dcopy( i2-i1+1, a( ioff+i1 ), 1, b, 1 )
440 DO 40 i = max( 1, ku+2-j ),
441 $ min( kl+ku+1, ku+1+( m-j ) )
464 IF( m.GT.0 .AND. n.GT.0 )
465 $
CALL dlacpy(
'Full', kl+ku+1, n, a, lda,
466 $ afac( kl+1 ), ldafac )
468 CALL dgbtrf( m, n, kl, ku, afac, ldafac, iwork,
474 $
CALL alaerh( path,
'DGBTRF', info, izero,
475 $
' ', m, n, kl, ku, nb, imat,
476 $ nfail, nerrs, nout )
483 CALL dgbt01( m, n, kl, ku, a, lda, afac, ldafac,
484 $ iwork, work, result( 1 ) )
489 IF( result( 1 ).GE.thresh )
THEN 490 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
491 $
CALL alahd( nout, path )
492 WRITE( nout, fmt = 9997 )m, n, kl, ku, nb,
493 $ imat, 1, result( 1 )
501 IF( inb.GT.1 .OR. m.NE.n )
504 anormo =
dlangb(
'O', n, kl, ku, a, lda, rwork )
505 anormi =
dlangb(
'I', n, kl, ku, a, lda, rwork )
513 CALL dlaset(
'Full', n, n, zero, one, work,
516 CALL dgbtrs(
'No transpose', n, kl, ku, n,
517 $ afac, ldafac, iwork, work, ldb,
522 ainvnm =
dlange(
'O', n, n, work, ldb,
524 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN 527 rcondo = ( one / anormo ) / ainvnm
533 ainvnm =
dlange(
'I', n, n, work, ldb,
535 IF( anormi.LE.zero .OR. ainvnm.LE.zero )
THEN 538 rcondi = ( one / anormi ) / ainvnm
558 DO 70 itran = 1, ntran
559 trans = transs( itran )
560 IF( itran.EQ.1 )
THEN 572 CALL dlarhs( path, xtype,
' ', trans, n,
573 $ n, kl, ku, nrhs, a, lda,
574 $ xact, ldb, b, ldb, iseed,
577 CALL dlacpy(
'Full', n, nrhs, b, ldb, x,
581 CALL dgbtrs( trans, n, kl, ku, nrhs, afac,
582 $ ldafac, iwork, x, ldb, info )
587 $
CALL alaerh( path,
'DGBTRS', info, 0,
588 $ trans, n, n, kl, ku, -1,
589 $ imat, nfail, nerrs, nout )
591 CALL dlacpy(
'Full', n, nrhs, b, ldb,
593 CALL dgbt02( trans, m, n, kl, ku, nrhs, a,
594 $ lda, x, ldb, work, ldb,
601 CALL dget04( n, nrhs, x, ldb, xact, ldb,
602 $ rcondc, result( 3 ) )
609 CALL dgbrfs( trans, n, kl, ku, nrhs, a,
610 $ lda, afac, ldafac, iwork, b,
611 $ ldb, x, ldb, rwork,
612 $ rwork( nrhs+1 ), work,
613 $ iwork( n+1 ), info )
618 $
CALL alaerh( path,
'DGBRFS', info, 0,
619 $ trans, n, n, kl, ku, nrhs,
620 $ imat, nfail, nerrs, nout )
622 CALL dget04( n, nrhs, x, ldb, xact, ldb,
623 $ rcondc, result( 4 ) )
624 CALL dgbt05( trans, n, kl, ku, nrhs, a,
625 $ lda, b, ldb, x, ldb, xact,
626 $ ldb, rwork, rwork( nrhs+1 ),
629 IF( result( k ).GE.thresh )
THEN 630 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
631 $
CALL alahd( nout, path )
632 WRITE( nout, fmt = 9996 )trans, n,
633 $ kl, ku, nrhs, imat, k,
647 IF( itran.EQ.1 )
THEN 657 CALL dgbcon( norm, n, kl, ku, afac, ldafac,
658 $ iwork, anorm, rcond, work,
659 $ iwork( n+1 ), info )
664 $
CALL alaerh( path,
'DGBCON', info, 0,
665 $ norm, n, n, kl, ku, -1, imat,
666 $ nfail, nerrs, nout )
668 result( 7 ) =
dget06( rcond, rcondc )
673 IF( result( 7 ).GE.thresh )
THEN 674 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
675 $
CALL alahd( nout, path )
676 WRITE( nout, fmt = 9995 )norm, n, kl, ku,
677 $ imat, 7, result( 7 )
692 CALL alasum( path, nout, nfail, nrun, nerrs )
694 9999
FORMAT(
' *** In DCHKGB, LA=', i5,
' is too small for M=', i5,
695 $
', N=', i5,
', KL=', i4,
', KU=', i4,
696 $ /
' ==> Increase LA to at least ', i5 )
697 9998
FORMAT(
' *** In DCHKGB, LAFAC=', i5,
' is too small for M=', i5,
698 $
', N=', i5,
', KL=', i4,
', KU=', i4,
699 $ /
' ==> Increase LAFAC to at least ', i5 )
700 9997
FORMAT(
' M =', i5,
', N =', i5,
', KL=', i5,
', KU=', i5,
701 $
', NB =', i4,
', type ', i1,
', test(', i1,
')=', g12.5 )
702 9996
FORMAT(
' TRANS=''', a1,
''', N=', i5,
', KL=', i5,
', KU=', i5,
703 $
', NRHS=', i3,
', type ', i1,
', test(', i1,
')=', g12.5 )
704 9995
FORMAT(
' NORM =''', a1,
''', N=', i5,
', KL=', i5,
', KU=', i5,
705 $
',', 10x,
' type ', i1,
', test(', i1,
')=', g12.5 )
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dgbt05(TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DGBT05
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
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 ...
subroutine dlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
DLARHS
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
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 derrge(PATH, NUNIT)
DERRGE
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
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 ...
subroutine dgbtrf(M, N, KL, KU, AB, LDAB, IPIV, INFO)
DGBTRF
subroutine dgbt02(TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, RESID)
DGBT02
subroutine dgbtrs(TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
DGBTRS
subroutine dgbt01(M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, RESID)
DGBT01
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
double precision function dget06(RCOND, RCONDC)
DGET06
subroutine dgbcon(NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
DGBCON
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine dgbrfs(TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DGBRFS