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 )
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 )