169 SUBROUTINE dchkpb( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
170 $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
171 $ XACT, WORK, RWORK, IWORK, NOUT )
179 INTEGER NMAX, NN, NNB, NNS, NOUT
180 DOUBLE PRECISION THRESH
184 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
185 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
186 $ rwork( * ), work( * ), x( * ), xact( * )
192 DOUBLE PRECISION ONE, ZERO
193 PARAMETER ( ONE = 1.0d+0, zero = 0.0d+0 )
194 INTEGER NTYPES, NTESTS
195 parameter( ntypes = 8, ntests = 7 )
201 CHARACTER DIST, PACKIT,
TYPE, UPLO, XTYPE
203 INTEGER I, I1, I2, IKD, IMAT, IN, INB, INFO, IOFF,
204 $ irhs, iuplo, iw, izero, k, kd, kl, koff, ku,
205 $ lda, ldab, mode, n, nb, nerrs, nfail, nimat,
207 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC
210 INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW )
211 DOUBLE PRECISION RESULT( NTESTS )
214 DOUBLE PRECISION DGET06, DLANGE, DLANSB
215 EXTERNAL DGET06, DLANGE, DLANSB
232 COMMON / infoc / infot, nunit, ok, lerr
233 COMMON / srnamc / srnamt
236 DATA iseedy / 1988, 1989, 1990, 1991 /
242 path( 1: 1 ) =
'Double precision'
248 iseed( i ) = iseedy( i )
254 $
CALL derrpo( path, nout )
268 nkd = max( 1, min( n, 4 ) )
273 kdval( 2 ) = n + ( n+1 ) / 4
274 kdval( 3 ) = ( 3*n-1 ) / 4
275 kdval( 4 ) = ( n+1 ) / 4
290 IF( iuplo.EQ.1 )
THEN
292 koff = max( 1, kd+2-n )
299 DO 60 imat = 1, nimat
303 IF( .NOT.dotype( imat ) )
308 zerot = imat.GE.2 .AND. imat.LE.4
309 IF( zerot .AND. n.LT.imat-1 )
312 IF( .NOT.zerot .OR. .NOT.dotype( 1 ) )
THEN
317 CALL dlatb4( path, imat, n, n,
TYPE, kl, ku, anorm,
318 $ mode, cndnum, dist )
321 CALL dlatms( n, n, dist, iseed,
TYPE, rwork, mode,
322 $ cndnum, anorm, kd, kd, packit,
323 $ a( koff ), ldab, work, info )
328 CALL alaerh( path,
'DLATMS', info, 0, uplo, n,
329 $ n, kd, kd, -1, imat, nfail, nerrs,
333 ELSE IF( izero.GT.0 )
THEN
339 IF( iuplo.EQ.1 )
THEN
340 ioff = ( izero-1 )*ldab + kd + 1
341 CALL dcopy( izero-i1, work( iw ), 1,
342 $ a( ioff-izero+i1 ), 1 )
344 CALL dcopy( i2-izero+1, work( iw ), 1,
345 $ a( ioff ), max( ldab-1, 1 ) )
347 ioff = ( i1-1 )*ldab + 1
348 CALL dcopy( izero-i1, work( iw ), 1,
349 $ a( ioff+izero-i1 ),
351 ioff = ( izero-1 )*ldab + 1
353 CALL dcopy( i2-izero+1, work( iw ), 1,
365 ELSE IF( imat.EQ.3 )
THEN
374 DO 20 i = 1, min( 2*kd+1, n )
378 i1 = max( izero-kd, 1 )
379 i2 = min( izero+kd, n )
381 IF( iuplo.EQ.1 )
THEN
382 ioff = ( izero-1 )*ldab + kd + 1
383 CALL dswap( izero-i1, a( ioff-izero+i1 ), 1,
386 CALL dswap( i2-izero+1, a( ioff ),
387 $ max( ldab-1, 1 ), work( iw ), 1 )
389 ioff = ( i1-1 )*ldab + 1
390 CALL dswap( izero-i1, a( ioff+izero-i1 ),
391 $ max( ldab-1, 1 ), work( iw ), 1 )
392 ioff = ( izero-1 )*ldab + 1
394 CALL dswap( i2-izero+1, a( ioff ), 1,
408 CALL dlacpy(
'Full', kd+1, n, a, ldab, afac, ldab )
410 CALL dpbtrf( uplo, n, kd, afac, ldab, info )
414 IF( info.NE.izero )
THEN
415 CALL alaerh( path,
'DPBTRF', info, izero, uplo,
416 $ n, n, kd, kd, nb, imat, nfail,
430 CALL dlacpy(
'Full', kd+1, n, afac, ldab, ainv,
432 CALL dpbt01( uplo, n, kd, a, ldab, ainv, ldab,
433 $ rwork, result( 1 ) )
437 IF( result( 1 ).GE.thresh )
THEN
438 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
439 $
CALL alahd( nout, path )
440 WRITE( nout, fmt = 9999 )uplo, n, kd, nb, imat,
454 CALL dlaset(
'Full', n, n, zero, one, ainv, lda )
456 CALL dpbtrs( uplo, n, kd, n, afac, ldab, ainv, lda,
461 anorm = dlansb(
'1', uplo, n, kd, a, ldab, rwork )
462 ainvnm = dlange(
'1', n, n, ainv, lda, rwork )
463 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
466 rcondc = ( one / anorm ) / ainvnm
476 CALL dlarhs( path, xtype, uplo,
' ', n, n, kd,
477 $ kd, nrhs, a, ldab, xact, lda, b,
479 CALL dlacpy(
'Full', n, nrhs, b, lda, x, lda )
482 CALL dpbtrs( uplo, n, kd, nrhs, afac, ldab, x,
488 $
CALL alaerh( path,
'DPBTRS', info, 0, uplo,
489 $ n, n, kd, kd, nrhs, imat, nfail,
492 CALL dlacpy(
'Full', n, nrhs, b, lda, work,
494 CALL dpbt02( uplo, n, kd, nrhs, a, ldab, x, lda,
495 $ work, lda, rwork, result( 2 ) )
500 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
507 CALL dpbrfs( uplo, n, kd, nrhs, a, ldab, afac,
508 $ ldab, b, lda, x, lda, rwork,
509 $ rwork( nrhs+1 ), work, iwork,
515 $
CALL alaerh( path,
'DPBRFS', info, 0, uplo,
516 $ n, n, kd, kd, nrhs, imat, nfail,
519 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
521 CALL dpbt05( uplo, n, kd, nrhs, a, ldab, b, lda,
522 $ x, lda, xact, lda, rwork,
523 $ rwork( nrhs+1 ), result( 5 ) )
529 IF( result( k ).GE.thresh )
THEN
530 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
531 $
CALL alahd( nout, path )
532 WRITE( nout, fmt = 9998 )uplo, n, kd,
533 $ nrhs, imat, k, result( k )
544 CALL dpbcon( uplo, n, kd, afac, ldab, anorm, rcond,
545 $ work, iwork, info )
550 $
CALL alaerh( path,
'DPBCON', info, 0, uplo, n,
551 $ n, kd, kd, -1, imat, nfail, nerrs,
554 result( 7 ) = dget06( rcond, rcondc )
558 IF( result( 7 ).GE.thresh )
THEN
559 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
560 $
CALL alahd( nout, path )
561 WRITE( nout, fmt = 9997 )uplo, n, kd, imat, 7,
574 CALL alasum( path, nout, nfail, nrun, nerrs )
576 9999
FORMAT(
' UPLO=''', a1,
''', N=', i5,
', KD=', i5,
', NB=', i4,
577 $
', type ', i2,
', test ', i2,
', ratio= ', g12.5 )
578 9998
FORMAT(
' UPLO=''', a1,
''', N=', i5,
', KD=', i5,
', NRHS=', i3,
579 $
', type ', i2,
', test(', i2,
') = ', g12.5 )
580 9997
FORMAT(
' UPLO=''', a1,
''', N=', i5,
', KD=', i5,
',', 10x,
581 $
' type ', i2,
', test(', i2,
') = ', 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 dchkpb(dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
DCHKPB
subroutine derrpo(path, nunit)
DERRPO
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 dpbt01(uplo, n, kd, a, lda, afac, ldafac, rwork, resid)
DPBT01
subroutine dpbt02(uplo, n, kd, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
DPBT02
subroutine dpbt05(uplo, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
DPBT05
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
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.
subroutine dpbcon(uplo, n, kd, ab, ldab, anorm, rcond, work, iwork, info)
DPBCON
subroutine dpbrfs(uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x, ldx, ferr, berr, work, iwork, info)
DPBRFS
subroutine dpbtrf(uplo, n, kd, ab, ldab, info)
DPBTRF
subroutine dpbtrs(uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
DPBTRS
subroutine dswap(n, dx, incx, dy, incy)
DSWAP