188 SUBROUTINE dchkgb( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS,
189 $ NSVAL, THRESH, TSTERR, A, LA, AFAC, LAFAC, B,
190 $ X, XACT, WORK, RWORK, IWORK, NOUT )
198 INTEGER LA, LAFAC, NM, NN, NNB, NNS, NOUT
199 DOUBLE PRECISION THRESH
203 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
205 DOUBLE PRECISION A( * ), AFAC( * ), B( * ), RWORK( * ),
206 $ WORK( * ), X( * ), XACT( * )
212 DOUBLE PRECISION ONE, ZERO
213 PARAMETER ( ONE = 1.0d+0, zero = 0.0d+0 )
214 INTEGER NTYPES, NTESTS
215 parameter( ntypes = 8, ntests = 7 )
217 parameter( nbw = 4, ntran = 3 )
220 LOGICAL TRFCON, ZEROT
221 CHARACTER DIST, NORM, TRANS,
TYPE, XTYPE
223 INTEGER I, I1, I2, IKL, IKU, IM, IMAT, IN, INB, INFO,
224 $ ioff, irhs, itran, izero, j, k, kl, koff, ku,
225 $ lda, ldafac, ldb, m, mode, n, nb, nerrs, nfail,
226 $ nimat, nkl, nku, nrhs, nrun
227 DOUBLE PRECISION AINVNM, ANORM, ANORMI, ANORMO, CNDNUM, RCOND,
228 $ RCONDC, RCONDI, RCONDO
231 CHARACTER TRANSS( NTRAN )
232 INTEGER ISEED( 4 ), ISEEDY( 4 ), KLVAL( NBW ),
234 DOUBLE PRECISION RESULT( NTESTS )
237 DOUBLE PRECISION DGET06, DLANGB, DLANGE
238 EXTERNAL DGET06, DLANGB, DLANGE
255 COMMON / infoc / infot, nunit, ok, lerr
256 COMMON / srnamc / srnamt
259 DATA iseedy / 1988, 1989, 1990, 1991 / ,
260 $ transs /
'N',
'T',
'C' /
266 path( 1: 1 ) =
'Double precision'
272 iseed( i ) = iseedy( i )
278 $
CALL derrge( path, nout )
294 klval( 2 ) = m + ( m+1 ) / 4
298 klval( 3 ) = ( 3*m-1 ) / 4
299 klval( 4 ) = ( m+1 ) / 4
309 kuval( 2 ) = n + ( n+1 ) / 4
313 kuval( 3 ) = ( 3*n-1 ) / 4
314 kuval( 4 ) = ( n+1 ) / 4
325 IF( m.LE.0 .OR. n.LE.0 )
347 ldafac = 2*kl + ku + 1
348 IF( ( lda*n ).GT.la .OR. ( ldafac*n ).GT.lafac )
THEN
349 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
350 $
CALL alahd( nout, path )
351 IF( n*( kl+ku+1 ).GT.la )
THEN
352 WRITE( nout, fmt = 9999 )la, m, n, kl, ku,
356 IF( n*( 2*kl+ku+1 ).GT.lafac )
THEN
357 WRITE( nout, fmt = 9998 )lafac, m, n, kl, ku,
364 DO 120 imat = 1, nimat
368 IF( .NOT.dotype( imat ) )
374 zerot = imat.GE.2 .AND. imat.LE.4
375 IF( zerot .AND. n.LT.imat-1 )
378 IF( .NOT.zerot .OR. .NOT.dotype( 1 ) )
THEN
383 CALL dlatb4( path, imat, m, n,
TYPE, kl, ku,
384 $ anorm, mode, cndnum, dist )
386 koff = max( 1, ku+2-n )
387 DO 20 i = 1, koff - 1
391 CALL dlatms( m, n, dist, iseed,
TYPE, rwork,
392 $ mode, cndnum, anorm, kl, ku,
'Z',
393 $ a( koff ), lda, work, info )
398 CALL alaerh( path,
'DLATMS', info, 0,
' ', m,
399 $ n, kl, ku, -1, imat, nfail,
403 ELSE IF( izero.GT.0 )
THEN
408 CALL dcopy( i2-i1+1, b, 1, a( ioff+i1 ), 1 )
418 ELSE IF( imat.EQ.3 )
THEN
421 izero = min( m, n ) / 2 + 1
423 ioff = ( izero-1 )*lda
428 i1 = max( 1, ku+2-izero )
429 i2 = min( kl+ku+1, ku+1+( m-izero ) )
430 CALL dcopy( i2-i1+1, a( ioff+i1 ), 1, b, 1 )
437 DO 40 i = max( 1, ku+2-j ),
438 $ min( kl+ku+1, ku+1+( m-j ) )
461 IF( m.GT.0 .AND. n.GT.0 )
462 $
CALL dlacpy(
'Full', kl+ku+1, n, a, lda,
463 $ afac( kl+1 ), ldafac )
465 CALL dgbtrf( m, n, kl, ku, afac, ldafac, iwork,
471 $
CALL alaerh( path,
'DGBTRF', info, izero,
472 $
' ', m, n, kl, ku, nb, imat,
473 $ nfail, nerrs, nout )
480 CALL dgbt01( m, n, kl, ku, a, lda, afac, ldafac,
481 $ iwork, work, result( 1 ) )
486 IF( result( 1 ).GE.thresh )
THEN
487 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
488 $
CALL alahd( nout, path )
489 WRITE( nout, fmt = 9997 )m, n, kl, ku, nb,
490 $ imat, 1, result( 1 )
498 IF( inb.GT.1 .OR. m.NE.n )
501 anormo = dlangb(
'O', n, kl, ku, a, lda, rwork )
502 anormi = dlangb(
'I', n, kl, ku, a, lda, rwork )
510 CALL dlaset(
'Full', n, n, zero, one, work,
513 CALL dgbtrs(
'No transpose', n, kl, ku, n,
514 $ afac, ldafac, iwork, work, ldb,
519 ainvnm = dlange(
'O', n, n, work, ldb,
521 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
524 rcondo = ( one / anormo ) / ainvnm
530 ainvnm = dlange(
'I', n, n, work, ldb,
532 IF( anormi.LE.zero .OR. ainvnm.LE.zero )
THEN
535 rcondi = ( one / anormi ) / ainvnm
555 DO 70 itran = 1, ntran
556 trans = transs( itran )
557 IF( itran.EQ.1 )
THEN
569 CALL dlarhs( path, xtype,
' ', trans, n,
570 $ n, kl, ku, nrhs, a, lda,
571 $ xact, ldb, b, ldb, iseed,
574 CALL dlacpy(
'Full', n, nrhs, b, ldb, x,
578 CALL dgbtrs( trans, n, kl, ku, nrhs, afac,
579 $ ldafac, iwork, x, ldb, info )
584 $
CALL alaerh( path,
'DGBTRS', info, 0,
585 $ trans, n, n, kl, ku, -1,
586 $ imat, nfail, nerrs, nout )
588 CALL dlacpy(
'Full', n, nrhs, b, ldb,
590 CALL dgbt02( trans, m, n, kl, ku, nrhs, a,
591 $ lda, x, ldb, work, ldb,
592 $ rwork, result( 2 ) )
598 CALL dget04( n, nrhs, x, ldb, xact, ldb,
599 $ rcondc, result( 3 ) )
606 CALL dgbrfs( trans, n, kl, ku, nrhs, a,
607 $ lda, afac, ldafac, iwork, b,
608 $ ldb, x, ldb, rwork,
609 $ rwork( nrhs+1 ), work,
610 $ iwork( n+1 ), info )
615 $
CALL alaerh( path,
'DGBRFS', info, 0,
616 $ trans, n, n, kl, ku, nrhs,
617 $ imat, nfail, nerrs, nout )
619 CALL dget04( n, nrhs, x, ldb, xact, ldb,
620 $ rcondc, result( 4 ) )
621 CALL dgbt05( trans, n, kl, ku, nrhs, a,
622 $ lda, b, ldb, x, ldb, xact,
623 $ ldb, rwork, rwork( nrhs+1 ),
626 IF( result( k ).GE.thresh )
THEN
627 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
628 $
CALL alahd( nout, path )
629 WRITE( nout, fmt = 9996 )trans, n,
630 $ kl, ku, nrhs, imat, k,
644 IF( itran.EQ.1 )
THEN
654 CALL dgbcon( norm, n, kl, ku, afac, ldafac,
655 $ iwork, anorm, rcond, work,
656 $ iwork( n+1 ), info )
661 $
CALL alaerh( path,
'DGBCON', info, 0,
662 $ norm, n, n, kl, ku, -1, imat,
663 $ nfail, nerrs, nout )
665 result( 7 ) = dget06( rcond, rcondc )
670 IF( result( 7 ).GE.thresh )
THEN
671 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
672 $
CALL alahd( nout, path )
673 WRITE( nout, fmt = 9995 )norm, n, kl, ku,
674 $ imat, 7, result( 7 )
689 CALL alasum( path, nout, nfail, nrun, nerrs )
691 9999
FORMAT(
' *** In DCHKGB, LA=', i5,
' is too small for M=', i5,
692 $
', N=', i5,
', KL=', i4,
', KU=', i4,
693 $ /
' ==> Increase LA to at least ', i5 )
694 9998
FORMAT(
' *** In DCHKGB, LAFAC=', i5,
' is too small for M=', i5,
695 $
', N=', i5,
', KL=', i4,
', KU=', i4,
696 $ /
' ==> Increase LAFAC to at least ', i5 )
697 9997
FORMAT(
' M =', i5,
', N =', i5,
', KL=', i5,
', KU=', i5,
698 $
', NB =', i4,
', type ', i1,
', test(', i1,
')=', g12.5 )
699 9996
FORMAT(
' TRANS=''', a1,
''', N=', i5,
', KL=', i5,
', KU=', i5,
700 $
', NRHS=', i3,
', type ', i1,
', test(', i1,
')=', g12.5 )
701 9995
FORMAT(
' NORM =''', a1,
''', N=', i5,
', KL=', i5,
', KU=', i5,
702 $
',', 10x,
' type ', i1,
', test(', i1,
')=', g12.5 )
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
subroutine dlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
DLARHS
subroutine xlaenv(ispec, nvalue)
XLAENV
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
subroutine alahd(iounit, path)
ALAHD
subroutine dchkgb(dotype, nm, mval, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, a, la, afac, lafac, b, x, xact, work, rwork, iwork, nout)
DCHKGB
subroutine derrge(path, nunit)
DERRGE
subroutine dgbt01(m, n, kl, ku, a, lda, afac, ldafac, ipiv, work, resid)
DGBT01
subroutine dgbt02(trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
DGBT02
subroutine dgbt05(trans, n, kl, ku, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
DGBT05
subroutine dget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
DGET04
subroutine dlatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
DLATB4
subroutine dlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
DLATMS
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
subroutine dgbcon(norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond, work, iwork, info)
DGBCON
subroutine dgbrfs(trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
DGBRFS
subroutine dgbtrf(m, n, kl, ku, ab, ldab, ipiv, info)
DGBTRF
subroutine dgbtrs(trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
DGBTRS
subroutine dlacpy(uplo, m, n, a, lda, b, ldb)
DLACPY copies all or part of one two-dimensional array to another.
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.