171 SUBROUTINE schkpb( 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
187 INTEGER iwork( * ), nbval( * ), nsval( * ), nval( * )
188 REAL a( * ), afac( * ), ainv( * ),
b( * ),
189 $ rwork( * ), work( * ),
x( * ), xact( * )
196 parameter( one = 1.0e+0, zero = 0.0e+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 REAL ainvnm, anorm, cndnum, rcond, rcondc
213 INTEGER iseed( 4 ), iseedy( 4 ), kdval( nbw )
214 REAL result( ntests )
235 COMMON / infoc / infot, nunit, ok, lerr
236 COMMON / srnamc / srnamt
239 DATA iseedy / 1988, 1989, 1990, 1991 /
245 path( 1: 1 ) =
'Single precision'
251 iseed( i ) = iseedy( i )
257 $ CALL
serrpo( 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
slatb4( path, imat, n, n, type, kl, ku, anorm,
321 $ mode, cndnum, dist )
324 CALL
slatms( n, n, dist, iseed, type, rwork, mode,
325 $ cndnum, anorm, kd, kd, packit,
326 $ a( koff ), ldab, work, info )
331 CALL
alaerh( path,
'SLATMS', 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
scopy( izero-i1, work( iw ), 1,
345 $ a( ioff-izero+i1 ), 1 )
347 CALL
scopy( i2-izero+1, work( iw ), 1,
348 $ a( ioff ), max( ldab-1, 1 ) )
350 ioff = ( i1-1 )*ldab + 1
351 CALL
scopy( izero-i1, work( iw ), 1,
352 $ a( ioff+izero-i1 ),
354 ioff = ( izero-1 )*ldab + 1
356 CALL
scopy( 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
sswap( izero-i1, a( ioff-izero+i1 ), 1,
389 CALL
sswap( i2-izero+1, a( ioff ),
390 $ max( ldab-1, 1 ), work( iw ), 1 )
392 ioff = ( i1-1 )*ldab + 1
393 CALL
sswap( izero-i1, a( ioff+izero-i1 ),
394 $ max( ldab-1, 1 ), work( iw ), 1 )
395 ioff = ( izero-1 )*ldab + 1
397 CALL
sswap( i2-izero+1, a( ioff ), 1,
411 CALL
slacpy(
'Full', kd+1, n, a, ldab, afac, ldab )
413 CALL
spbtrf( uplo, n, kd, afac, ldab, info )
417 IF( info.NE.izero )
THEN
418 CALL
alaerh( path,
'SPBTRF', info, izero, uplo,
419 $ n, n, kd, kd, nb, imat, nfail,
433 CALL
slacpy(
'Full', kd+1, n, afac, ldab, ainv,
435 CALL
spbt01( 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
slaset(
'Full', n, n, zero, one, ainv, lda )
459 CALL
spbtrs( uplo, n, kd, n, afac, ldab, ainv, lda,
464 anorm =
slansb(
'1', uplo, n, kd, a, ldab, rwork )
465 ainvnm =
slange(
'1', n, n, ainv, lda, rwork )
466 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
469 rcondc = ( one / anorm ) / ainvnm
479 CALL
slarhs( path, xtype, uplo,
' ', n, n, kd,
480 $ kd, nrhs, a, ldab, xact, lda,
b,
482 CALL
slacpy(
'Full', n, nrhs,
b, lda,
x, lda )
485 CALL
spbtrs( uplo, n, kd, nrhs, afac, ldab,
x,
491 $ CALL
alaerh( path,
'SPBTRS', info, 0, uplo,
492 $ n, n, kd, kd, nrhs, imat, nfail,
495 CALL
slacpy(
'Full', n, nrhs,
b, lda, work,
497 CALL
spbt02( uplo, n, kd, nrhs, a, ldab,
x, lda,
498 $ work, lda, rwork, result( 2 ) )
503 CALL
sget04( n, nrhs,
x, lda, xact, lda, rcondc,
510 CALL
spbrfs( uplo, n, kd, nrhs, a, ldab, afac,
511 $ ldab,
b, lda,
x, lda, rwork,
512 $ rwork( nrhs+1 ), work, iwork,
518 $ CALL
alaerh( path,
'SPBRFS', info, 0, uplo,
519 $ n, n, kd, kd, nrhs, imat, nfail,
522 CALL
sget04( n, nrhs,
x, lda, xact, lda, rcondc,
524 CALL
spbt05( 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
spbcon( uplo, n, kd, afac, ldab, anorm, rcond,
548 $ work, iwork, info )
553 $ CALL
alaerh( path,
'SPBCON', info, 0, uplo, n,
554 $ n, kd, kd, -1, imat, nfail, nerrs,
557 result( 7 ) =
sget06( 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,
',', 10
x,
584 $
' type ', i2,
', test(', i2,
') = ', g12.5 )
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
subroutine spbcon(UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, IWORK, INFO)
SPBCON
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine spbt01(UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, RESID)
SPBT01
REAL function sget06(RCOND, RCONDC)
SGET06
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
REAL function slansb(NORM, UPLO, N, K, AB, LDAB, WORK)
SLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric band matrix.
subroutine schkpb(DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
SCHKPB
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine serrpo(PATH, NUNIT)
SERRPO
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
REAL function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine spbtrf(UPLO, N, KD, AB, LDAB, INFO)
SPBTRF
subroutine spbt02(UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SPBT02
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine spbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
SPBTRS
subroutine spbt05(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPBT05
subroutine spbrfs(UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
SPBRFS
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4