174 INTEGER nmax, nn, nout, nrhs
179 INTEGER iwork( * ), nval( * )
180 REAL a( * ), afac( * ), asav( * ), b( * ),
181 $ bsav( * ), rwork( * ), s( * ), work( * ),
189 parameter ( one = 1.0e+0, zero = 0.0e+0 )
190 INTEGER ntypes, ntests
191 parameter ( ntypes = 8, ntests = 6 )
193 parameter ( nbw = 4 )
196 LOGICAL equil, nofact, prefac, zerot
197 CHARACTER dist, equed, fact, packit,
TYPE, uplo, xtype
199 INTEGER i, i1, i2, iequed, ifact, ikd, imat, in, info,
200 $ ioff, iuplo, iw, izero, k, k1, kd, kl, koff,
201 $ ku, lda, ldab, mode, n, nb, nbmin, nerrs,
202 $ nfact, nfail, nimat, nkd, nrun, nt
203 REAL ainvnm, amax, anorm, cndnum, rcond, rcondc,
207 CHARACTER equeds( 2 ), facts( 3 )
208 INTEGER iseed( 4 ), iseedy( 4 ), kdval( nbw )
209 REAL result( ntests )
231 COMMON / infoc / infot, nunit, ok, lerr
232 COMMON / srnamc / srnamt
235 DATA iseedy / 1988, 1989, 1990, 1991 /
236 DATA facts /
'F',
'N',
'E' /
237 DATA equeds /
'N',
'Y' /
243 path( 1: 1 ) =
'Single precision'
249 iseed( i ) = iseedy( i )
255 $
CALL serrvx( path, nout )
275 nkd = max( 1, min( n, 4 ) )
280 kdval( 2 ) = n + ( n+1 ) / 4
281 kdval( 3 ) = ( 3*n-1 ) / 4
282 kdval( 4 ) = ( n+1 ) / 4
297 IF( iuplo.EQ.1 )
THEN
300 koff = max( 1, kd+2-n )
306 DO 80 imat = 1, nimat
310 IF( .NOT.dotype( imat ) )
315 zerot = imat.GE.2 .AND. imat.LE.4
316 IF( zerot .AND. n.LT.imat-1 )
319 IF( .NOT.zerot .OR. .NOT.dotype( 1 ) )
THEN
324 CALL slatb4( path, imat, n, n,
TYPE, kl, ku, anorm,
325 $ mode, cndnum, dist )
328 CALL slatms( n, n, dist, iseed,
TYPE, rwork, mode,
329 $ cndnum, anorm, kd, kd, packit,
330 $ a( koff ), ldab, work, info )
335 CALL alaerh( path,
'SLATMS', info, 0, uplo, n,
336 $ n, -1, -1, -1, imat, nfail, nerrs,
340 ELSE IF( izero.GT.0 )
THEN
346 IF( iuplo.EQ.1 )
THEN
347 ioff = ( izero-1 )*ldab + kd + 1
348 CALL scopy( izero-i1, work( iw ), 1,
349 $ a( ioff-izero+i1 ), 1 )
351 CALL scopy( i2-izero+1, work( iw ), 1,
352 $ a( ioff ), max( ldab-1, 1 ) )
354 ioff = ( i1-1 )*ldab + 1
355 CALL scopy( izero-i1, work( iw ), 1,
356 $ a( ioff+izero-i1 ),
358 ioff = ( izero-1 )*ldab + 1
360 CALL scopy( i2-izero+1, work( iw ), 1,
372 ELSE IF( imat.EQ.3 )
THEN
381 DO 20 i = 1, min( 2*kd+1, n )
385 i1 = max( izero-kd, 1 )
386 i2 = min( izero+kd, n )
388 IF( iuplo.EQ.1 )
THEN
389 ioff = ( izero-1 )*ldab + kd + 1
390 CALL sswap( izero-i1, a( ioff-izero+i1 ), 1,
393 CALL sswap( i2-izero+1, a( ioff ),
394 $ max( ldab-1, 1 ), work( iw ), 1 )
396 ioff = ( i1-1 )*ldab + 1
397 CALL sswap( izero-i1, a( ioff+izero-i1 ),
398 $ max( ldab-1, 1 ), work( iw ), 1 )
399 ioff = ( izero-1 )*ldab + 1
401 CALL sswap( i2-izero+1, a( ioff ), 1,
408 CALL slacpy(
'Full', kd+1, n, a, ldab, asav, ldab )
411 equed = equeds( iequed )
412 IF( iequed.EQ.1 )
THEN
418 DO 60 ifact = 1, nfact
419 fact = facts( ifact )
420 prefac =
lsame( fact,
'F' )
421 nofact =
lsame( fact,
'N' )
422 equil =
lsame( fact,
'E' )
429 ELSE IF( .NOT.
lsame( fact,
'N' ) )
THEN
436 CALL slacpy(
'Full', kd+1, n, asav, ldab,
438 IF( equil .OR. iequed.GT.1 )
THEN
443 CALL spbequ( uplo, n, kd, afac, ldab, s,
444 $ scond, amax, info )
445 IF( info.EQ.0 .AND. n.GT.0 )
THEN
451 CALL slaqsb( uplo, n, kd, afac, ldab,
452 $ s, scond, amax, equed )
464 anorm =
slansb(
'1', uplo, n, kd, afac, ldab,
469 CALL spbtrf( uplo, n, kd, afac, ldab, info )
473 CALL slaset(
'Full', n, n, zero, one, a,
476 CALL spbtrs( uplo, n, kd, n, afac, ldab, a,
481 ainvnm =
slange(
'1', n, n, a, lda, rwork )
482 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
485 rcondc = ( one / anorm ) / ainvnm
491 CALL slacpy(
'Full', kd+1, n, asav, ldab, a,
498 CALL slarhs( path, xtype, uplo,
' ', n, n, kd,
499 $ kd, nrhs, a, ldab, xact, lda, b,
502 CALL slacpy(
'Full', n, nrhs, b, lda, bsav,
512 CALL slacpy(
'Full', kd+1, n, a, ldab, afac,
514 CALL slacpy(
'Full', n, nrhs, b, lda, x,
518 CALL spbsv( uplo, n, kd, nrhs, afac, ldab, x,
523 IF( info.NE.izero )
THEN
524 CALL alaerh( path,
'SPBSV ', info, izero,
525 $ uplo, n, n, kd, kd, nrhs,
526 $ imat, nfail, nerrs, nout )
528 ELSE IF( info.NE.0 )
THEN
535 CALL spbt01( uplo, n, kd, a, ldab, afac,
536 $ ldab, rwork, result( 1 ) )
540 CALL slacpy(
'Full', n, nrhs, b, lda, work,
542 CALL spbt02( uplo, n, kd, nrhs, a, ldab, x,
543 $ lda, work, lda, rwork,
548 CALL sget04( n, nrhs, x, lda, xact, lda,
549 $ rcondc, result( 3 ) )
556 IF( result( k ).GE.thresh )
THEN
557 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
558 $
CALL aladhd( nout, path )
559 WRITE( nout, fmt = 9999 )
'SPBSV ',
560 $ uplo, n, kd, imat, k, result( k )
571 $
CALL slaset(
'Full', kd+1, n, zero, zero,
573 CALL slaset(
'Full', n, nrhs, zero, zero, x,
575 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
580 CALL slaqsb( uplo, n, kd, a, ldab, s, scond,
588 CALL spbsvx( fact, uplo, n, kd, nrhs, a, ldab,
589 $ afac, ldab, equed, s, b, lda, x,
590 $ lda, rcond, rwork, rwork( nrhs+1 ),
591 $ work, iwork, info )
595 IF( info.NE.izero )
THEN
596 CALL alaerh( path,
'SPBSVX', info, izero,
597 $ fact // uplo, n, n, kd, kd,
598 $ nrhs, imat, nfail, nerrs, nout )
603 IF( .NOT.prefac )
THEN
608 CALL spbt01( uplo, n, kd, a, ldab, afac,
609 $ ldab, rwork( 2*nrhs+1 ),
618 CALL slacpy(
'Full', n, nrhs, bsav, lda,
620 CALL spbt02( uplo, n, kd, nrhs, asav, ldab,
622 $ rwork( 2*nrhs+1 ), result( 2 ) )
626 IF( nofact .OR. ( prefac .AND.
lsame( equed,
628 CALL sget04( n, nrhs, x, lda, xact, lda,
629 $ rcondc, result( 3 ) )
631 CALL sget04( n, nrhs, x, lda, xact, lda,
632 $ roldc, result( 3 ) )
638 CALL spbt05( uplo, n, kd, nrhs, asav, ldab,
639 $ b, lda, x, lda, xact, lda,
640 $ rwork, rwork( nrhs+1 ),
649 result( 6 ) =
sget06( rcond, rcondc )
655 IF( result( k ).GE.thresh )
THEN
656 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
657 $
CALL aladhd( nout, path )
659 WRITE( nout, fmt = 9997 )
'SPBSVX',
660 $ fact, uplo, n, kd, equed, imat, k,
663 WRITE( nout, fmt = 9998 )
'SPBSVX',
664 $ fact, uplo, n, kd, imat, k,
680 CALL alasvm( path, nout, nfail, nrun, nerrs )
682 9999
FORMAT( 1x, a,
', UPLO=''', a1,
''', N =', i5,
', KD =', i5,
683 $
', type ', i1,
', test(', i1,
')=', g12.5 )
684 9998
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ', i5,
', ', i5,
685 $
', ... ), type ', i1,
', test(', i1,
')=', g12.5 )
686 9997
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ', i5,
', ', i5,
687 $
', ... ), EQUED=''', a1,
''', type ', i1,
', test(', i1,
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine spbequ(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO)
SPBEQU
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
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
subroutine spbsvx(FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
SPBSVX computes the solution to system of linear equations A * X = B for OTHER matrices ...
real function sget06(RCOND, RCONDC)
SGET06
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine spbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
SPBTRS
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
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...
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.
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 spbtrf(UPLO, N, KD, AB, LDAB, INFO)
SPBTRF
subroutine slaqsb(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED)
SLAQSB scales a symmetric/Hermitian band matrix, using scaling factors computed by spbequ...
subroutine spbsv(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
SPBSV computes the solution to system of linear equations A * X = B for OTHER matrices ...
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine spbt05(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPBT05
subroutine serrvx(PATH, NUNIT)
SERRVX
subroutine spbt01(UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, RESID)
SPBT01
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
logical function lsame(CA, CB)
LSAME
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY