163 SUBROUTINE sdrvpb( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
164 $ a, afac, asav,
b, bsav,
x, xact, s, work,
165 $ rwork, iwork, nout )
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 )
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( 1
x, a,
', UPLO=''', a1,
''', N =', i5,
', KD =', i5,
683 $
', type ', i1,
', test(', i1,
')=', g12.5 )
684 9998
FORMAT( 1
x, a,
'( ''', a1,
''', ''', a1,
''', ', i5,
', ', i5,
685 $
', ... ), type ', i1,
', test(', i1,
')=', g12.5 )
686 9997
FORMAT( 1
x, a,
'( ''', a1,
''', ''', a1,
''', ', i5,
', ', i5,
687 $
', ... ), EQUED=''', a1,
''', type ', i1,
', test(', i1,
subroutine spbequ(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO)
SPBEQU
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...
LOGICAL function lsame(CA, CB)
LSAME
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
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 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.
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 slaqsb(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED)
SLAQSB scales a symmetric/Hermitian band matrix, using scaling factors computed by spbequ...
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 aladhd(IOUNIT, PATH)
ALADHD
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 sdrvpb(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
SDRVPB
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 ...
subroutine serrvx(PATH, NUNIT)
SERRVX
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4