171 SUBROUTINE dchkpb( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
172 $ thresh, tsterr, nmax, a, afac, ainv, b, x,
173 $ xact, work, rwork, iwork, nout )
182 INTEGER NMAX, NN, NNB, NNS, NOUT
183 DOUBLE PRECISION THRESH
187 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
188 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
189 $ rwork( * ), work( * ), x( * ), xact( * )
195 DOUBLE PRECISION ONE, ZERO
196 parameter ( one = 1.0d+0, zero = 0.0d+0 )
197 INTEGER NTYPES, NTESTS
198 parameter ( ntypes = 8, ntests = 7 )
200 parameter ( nbw = 4 )
204 CHARACTER DIST, PACKIT,
TYPE, UPLO, XTYPE
206 INTEGER I, I1, I2, IKD, IMAT, IN, INB, INFO, IOFF,
207 $ irhs, iuplo, iw, izero, k, kd, kl, koff, ku,
208 $ lda, ldab, mode, n, nb, nerrs, nfail, nimat,
210 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC
213 INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( nbw )
214 DOUBLE PRECISION RESULT( ntests )
217 DOUBLE PRECISION DGET06, DLANGE, DLANSB
218 EXTERNAL dget06, dlange, dlansb
235 COMMON / infoc / infot, nunit, ok, lerr
236 COMMON / srnamc / srnamt
239 DATA iseedy / 1988, 1989, 1990, 1991 /
245 path( 1: 1 ) =
'Double precision'
251 iseed( i ) = iseedy( i )
257 $
CALL derrpo( path, nout )
271 nkd = max( 1, min( n, 4 ) )
276 kdval( 2 ) = n + ( n+1 ) / 4
277 kdval( 3 ) = ( 3*n-1 ) / 4
278 kdval( 4 ) = ( n+1 ) / 4
293 IF( iuplo.EQ.1 )
THEN
295 koff = max( 1, kd+2-n )
302 DO 60 imat = 1, nimat
306 IF( .NOT.dotype( imat ) )
311 zerot = imat.GE.2 .AND. imat.LE.4
312 IF( zerot .AND. n.LT.imat-1 )
315 IF( .NOT.zerot .OR. .NOT.dotype( 1 ) )
THEN
320 CALL dlatb4( path, imat, n, n,
TYPE, KL, KU, ANORM,
321 $ mode, cndnum, dist )
324 CALL dlatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
325 $ cndnum, anorm, kd, kd, packit,
326 $ a( koff ), ldab, work, info )
331 CALL alaerh( path,
'DLATMS', info, 0, uplo, n,
332 $ n, kd, kd, -1, imat, nfail, nerrs,
336 ELSE IF( izero.GT.0 )
THEN
342 IF( iuplo.EQ.1 )
THEN
343 ioff = ( izero-1 )*ldab + kd + 1
344 CALL dcopy( izero-i1, work( iw ), 1,
345 $ a( ioff-izero+i1 ), 1 )
347 CALL dcopy( i2-izero+1, work( iw ), 1,
348 $ a( ioff ), max( ldab-1, 1 ) )
350 ioff = ( i1-1 )*ldab + 1
351 CALL dcopy( izero-i1, work( iw ), 1,
352 $ a( ioff+izero-i1 ),
354 ioff = ( izero-1 )*ldab + 1
356 CALL dcopy( i2-izero+1, work( iw ), 1,
368 ELSE IF( imat.EQ.3 )
THEN
377 DO 20 i = 1, min( 2*kd+1, n )
381 i1 = max( izero-kd, 1 )
382 i2 = min( izero+kd, n )
384 IF( iuplo.EQ.1 )
THEN
385 ioff = ( izero-1 )*ldab + kd + 1
386 CALL dswap( izero-i1, a( ioff-izero+i1 ), 1,
389 CALL dswap( i2-izero+1, a( ioff ),
390 $ max( ldab-1, 1 ), work( iw ), 1 )
392 ioff = ( i1-1 )*ldab + 1
393 CALL dswap( izero-i1, a( ioff+izero-i1 ),
394 $ max( ldab-1, 1 ), work( iw ), 1 )
395 ioff = ( izero-1 )*ldab + 1
397 CALL dswap( i2-izero+1, a( ioff ), 1,
411 CALL dlacpy(
'Full', kd+1, n, a, ldab, afac, ldab )
413 CALL dpbtrf( uplo, n, kd, afac, ldab, info )
417 IF( info.NE.izero )
THEN
418 CALL alaerh( path,
'DPBTRF', info, izero, uplo,
419 $ n, n, kd, kd, nb, imat, nfail,
433 CALL dlacpy(
'Full', kd+1, n, afac, ldab, ainv,
435 CALL dpbt01( uplo, n, kd, a, ldab, ainv, ldab,
436 $ rwork, result( 1 ) )
440 IF( result( 1 ).GE.thresh )
THEN
441 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
442 $
CALL alahd( nout, path )
443 WRITE( nout, fmt = 9999 )uplo, n, kd, nb, imat,
457 CALL dlaset(
'Full', n, n, zero, one, ainv, lda )
459 CALL dpbtrs( uplo, n, kd, n, afac, ldab, ainv, lda,
464 anorm = dlansb(
'1', uplo, n, kd, a, ldab, rwork )
465 ainvnm = dlange(
'1', n, n, ainv, lda, rwork )
466 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
469 rcondc = ( one / anorm ) / ainvnm
479 CALL dlarhs( path, xtype, uplo,
' ', n, n, kd,
480 $ kd, nrhs, a, ldab, xact, lda, b,
482 CALL dlacpy(
'Full', n, nrhs, b, lda, x, lda )
485 CALL dpbtrs( uplo, n, kd, nrhs, afac, ldab, x,
491 $
CALL alaerh( path,
'DPBTRS', info, 0, uplo,
492 $ n, n, kd, kd, nrhs, imat, nfail,
495 CALL dlacpy(
'Full', n, nrhs, b, lda, work,
497 CALL dpbt02( uplo, n, kd, nrhs, a, ldab, x, lda,
498 $ work, lda, rwork, result( 2 ) )
503 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
510 CALL dpbrfs( uplo, n, kd, nrhs, a, ldab, afac,
511 $ ldab, b, lda, x, lda, rwork,
512 $ rwork( nrhs+1 ), work, iwork,
518 $
CALL alaerh( path,
'DPBRFS', info, 0, uplo,
519 $ n, n, kd, kd, nrhs, imat, nfail,
522 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
524 CALL dpbt05( uplo, n, kd, nrhs, a, ldab, b, lda,
525 $ x, lda, xact, lda, rwork,
526 $ rwork( nrhs+1 ), result( 5 ) )
532 IF( result( k ).GE.thresh )
THEN
533 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
534 $
CALL alahd( nout, path )
535 WRITE( nout, fmt = 9998 )uplo, n, kd,
536 $ nrhs, imat, k, result( k )
547 CALL dpbcon( uplo, n, kd, afac, ldab, anorm, rcond,
548 $ work, iwork, info )
553 $
CALL alaerh( path,
'DPBCON', info, 0, uplo, n,
554 $ n, kd, kd, -1, imat, nfail, nerrs,
557 result( 7 ) = dget06( rcond, rcondc )
561 IF( result( 7 ).GE.thresh )
THEN
562 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
563 $
CALL alahd( nout, path )
564 WRITE( nout, fmt = 9997 )uplo, n, kd, imat, 7,
577 CALL alasum( path, nout, nfail, nrun, nerrs )
579 9999
FORMAT(
' UPLO=''', a1,
''', N=', i5,
', KD=', i5,
', NB=', i4,
580 $
', type ', i2,
', test ', i2,
', ratio= ', g12.5 )
581 9998
FORMAT(
' UPLO=''', a1,
''', N=', i5,
', KD=', i5,
', NRHS=', i3,
582 $
', type ', i2,
', test(', i2,
') = ', g12.5 )
583 9997
FORMAT(
' UPLO=''', a1,
''', N=', i5,
', KD=', i5,
',', 10x,
584 $
' type ', i2,
', test(', i2,
') = ', g12.5 )
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 alahd(IOUNIT, PATH)
ALAHD
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 dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dpbcon(UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, IWORK, INFO)
DPBCON
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dswap(N, DX, INCX, DY, INCY)
DSWAP
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine dpbt01(UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, RESID)
DPBT01
subroutine dpbtrf(UPLO, N, KD, AB, LDAB, INFO)
DPBTRF
subroutine dchkpb(DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
DCHKPB
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
subroutine dpbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
DPBTRS
subroutine dpbt05(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DPBT05
subroutine dpbrfs(UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DPBRFS
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine dpbt02(UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
DPBT02
subroutine derrpo(PATH, NUNIT)
DERRPO