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 )
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 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,
',', 10x,
584 $
' type ', i2,
', test(', i2,
') = ', g12.5 )
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
subroutine spbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
SPBTRS
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 spbt02(UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SPBT02
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
real function sget06(RCOND, RCONDC)
SGET06
subroutine spbcon(UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, IWORK, INFO)
SPBCON
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
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 sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
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 spbtrf(UPLO, N, KD, AB, LDAB, INFO)
SPBTRF
subroutine spbt05(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPBT05
subroutine spbt01(UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, RESID)
SPBT01
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
subroutine spbrfs(UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
SPBRFS
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine serrpo(PATH, NUNIT)
SERRPO
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM