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 )
213 DOUBLE PRECISION DGET06, DLANGE, DLANSB
214 EXTERNAL lsame, dget06, dlange, dlansb
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 dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine dpbtrf(UPLO, N, KD, AB, LDAB, INFO)
DPBTRF
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
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 alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
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 dlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
DLARHS
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 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 dswap(N, DX, INCX, DY, INCY)
DSWAP
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
subroutine dpbt02(UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
DPBT02
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine dpbequ(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO)
DPBEQU
subroutine derrvx(PATH, NUNIT)
DERRVX
subroutine dpbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
DPBTRS
subroutine dpbt01(UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, RESID)
DPBT01
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 dpbt05(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DPBT05