163 SUBROUTINE ddrvpb( 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
175 DOUBLE PRECISION thresh
179 INTEGER iwork( * ), nval( * )
180 DOUBLE PRECISION a( * ), afac( * ), asav( * ),
b( * ),
181 $ bsav( * ), rwork( * ), s( * ), work( * ),
188 DOUBLE PRECISION one, zero
189 parameter( one = 1.0d+0, zero = 0.0d+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 DOUBLE PRECISION ainvnm, amax, anorm, cndnum, rcond, rcondc,
207 CHARACTER equeds( 2 ), facts( 3 )
208 INTEGER iseed( 4 ), iseedy( 4 ), kdval( nbw )
209 DOUBLE PRECISION 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 ) =
'Double precision'
249 iseed( i ) = iseedy( i )
255 $ CALL
derrvx( 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
dlatb4( path, imat, n, n, type, kl, ku, anorm,
325 $ mode, cndnum, dist )
328 CALL
dlatms( n, n, dist, iseed, type, rwork, mode,
329 $ cndnum, anorm, kd, kd, packit,
330 $ a( koff ), ldab, work, info )
335 CALL
alaerh( path,
'DLATMS', 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
dcopy( izero-i1, work( iw ), 1,
349 $ a( ioff-izero+i1 ), 1 )
351 CALL
dcopy( i2-izero+1, work( iw ), 1,
352 $ a( ioff ), max( ldab-1, 1 ) )
354 ioff = ( i1-1 )*ldab + 1
355 CALL
dcopy( izero-i1, work( iw ), 1,
356 $ a( ioff+izero-i1 ),
358 ioff = ( izero-1 )*ldab + 1
360 CALL
dcopy( 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
dswap( izero-i1, a( ioff-izero+i1 ), 1,
393 CALL
dswap( i2-izero+1, a( ioff ),
394 $ max( ldab-1, 1 ), work( iw ), 1 )
396 ioff = ( i1-1 )*ldab + 1
397 CALL
dswap( izero-i1, a( ioff+izero-i1 ),
398 $ max( ldab-1, 1 ), work( iw ), 1 )
399 ioff = ( izero-1 )*ldab + 1
401 CALL
dswap( i2-izero+1, a( ioff ), 1,
408 CALL
dlacpy(
'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
dlacpy(
'Full', kd+1, n, asav, ldab,
438 IF( equil .OR. iequed.GT.1 )
THEN
443 CALL
dpbequ( uplo, n, kd, afac, ldab, s,
444 $ scond, amax, info )
445 IF( info.EQ.0 .AND. n.GT.0 )
THEN
451 CALL
dlaqsb( uplo, n, kd, afac, ldab,
452 $ s, scond, amax, equed )
464 anorm =
dlansb(
'1', uplo, n, kd, afac, ldab,
469 CALL
dpbtrf( uplo, n, kd, afac, ldab, info )
473 CALL
dlaset(
'Full', n, n, zero, one, a,
476 CALL
dpbtrs( uplo, n, kd, n, afac, ldab, a,
481 ainvnm =
dlange(
'1', n, n, a, lda, rwork )
482 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
485 rcondc = ( one / anorm ) / ainvnm
491 CALL
dlacpy(
'Full', kd+1, n, asav, ldab, a,
498 CALL
dlarhs( path, xtype, uplo,
' ', n, n, kd,
499 $ kd, nrhs, a, ldab, xact, lda,
b,
502 CALL
dlacpy(
'Full', n, nrhs,
b, lda, bsav,
512 CALL
dlacpy(
'Full', kd+1, n, a, ldab, afac,
514 CALL
dlacpy(
'Full', n, nrhs,
b, lda, x,
518 CALL
dpbsv( uplo, n, kd, nrhs, afac, ldab, x,
523 IF( info.NE.izero )
THEN
524 CALL
alaerh( path,
'DPBSV ', info, izero,
525 $ uplo, n, n, kd, kd, nrhs,
526 $ imat, nfail, nerrs, nout )
528 ELSE IF( info.NE.0 )
THEN
535 CALL
dpbt01( uplo, n, kd, a, ldab, afac,
536 $ ldab, rwork, result( 1 ) )
540 CALL
dlacpy(
'Full', n, nrhs,
b, lda, work,
542 CALL
dpbt02( uplo, n, kd, nrhs, a, ldab, x,
543 $ lda, work, lda, rwork,
548 CALL
dget04( 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 )
'DPBSV ',
560 $ uplo, n, kd, imat, k, result( k )
571 $ CALL
dlaset(
'Full', kd+1, n, zero, zero,
573 CALL
dlaset(
'Full', n, nrhs, zero, zero, x,
575 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
580 CALL
dlaqsb( uplo, n, kd, a, ldab, s, scond,
588 CALL
dpbsvx( 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,
'DPBSVX', info, izero,
597 $ fact // uplo, n, n, kd, kd,
598 $ nrhs, imat, nfail, nerrs, nout )
603 IF( .NOT.prefac )
THEN
608 CALL
dpbt01( uplo, n, kd, a, ldab, afac,
609 $ ldab, rwork( 2*nrhs+1 ),
618 CALL
dlacpy(
'Full', n, nrhs, bsav, lda,
620 CALL
dpbt02( uplo, n, kd, nrhs, asav, ldab,
622 $ rwork( 2*nrhs+1 ), result( 2 ) )
626 IF( nofact .OR. ( prefac .AND.
lsame( equed,
628 CALL
dget04( n, nrhs, x, lda, xact, lda,
629 $ rcondc, result( 3 ) )
631 CALL
dget04( n, nrhs, x, lda, xact, lda,
632 $ roldc, result( 3 ) )
638 CALL
dpbt05( uplo, n, kd, nrhs, asav, ldab,
639 $
b, lda, x, lda, xact, lda,
640 $ rwork, rwork( nrhs+1 ),
649 result( 6 ) =
dget06( 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 )
'DPBSVX',
660 $ fact, uplo, n, kd, equed, imat, k,
663 WRITE( nout, fmt = 9998 )
'DPBSVX',
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 dpbsvx(FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
DPBSVX computes the solution to system of linear equations A * X = B for OTHER matrices ...
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine ddrvpb(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
DDRVPB
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine dlaqsb(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED)
DLAQSB scales a symmetric/Hermitian band matrix, using scaling factors computed by spbequ...
subroutine derrvx(PATH, NUNIT)
DERRVX
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine dlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
DLARHS
subroutine dpbt01(UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, RESID)
DPBT01
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
double precision function dlansb(NORM, UPLO, N, K, AB, LDAB, WORK)
DLANSB 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
logical function lsame(CA, CB)
LSAME
subroutine dpbtrf(UPLO, N, KD, AB, LDAB, INFO)
DPBTRF
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine dpbt05(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DPBT05
subroutine dpbt02(UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
DPBT02
double precision function dget06(RCOND, RCONDC)
DGET06
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine dpbsv(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
DPBSV computes the solution to system of linear equations A * X = B for OTHER matrices ...
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
subroutine dswap(N, DX, INCX, DY, INCY)
DSWAP
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dpbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
DPBTRS
subroutine dpbequ(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO)
DPBEQU