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 )
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 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 alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
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...
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.
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 dcopy(N, DX, INCX, DY, INCY)
DCOPY
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 dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dpbequ(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO)
DPBEQU
subroutine dswap(N, DX, INCX, DY, INCY)
DSWAP
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine dpbt01(UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, RESID)
DPBT01
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 dpbtrf(UPLO, N, KD, AB, LDAB, INFO)
DPBTRF
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 dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
subroutine aladhd(IOUNIT, PATH)
ALADHD
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 derrvx(PATH, NUNIT)
DERRVX
subroutine dpbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
DPBTRS
double precision function dget06(RCOND, RCONDC)
DGET06
subroutine dpbt05(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DPBT05
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
logical function lsame(CA, CB)
LSAME
subroutine dpbt02(UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
DPBT02