158 SUBROUTINE cdrvpb( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
159 $ a, afac, asav,
b, bsav,
x, xact, s, work,
169 INTEGER nmax, nn, nout, nrhs
175 REAL rwork( * ), s( * )
176 COMPLEX a( * ), afac( * ), asav( * ),
b( * ),
177 $ bsav( * ), work( * ),
x( * ), xact( * )
184 parameter( one = 1.0e+0, zero = 0.0e+0 )
185 INTEGER ntypes, ntests
186 parameter( ntypes = 8, ntests = 6 )
191 LOGICAL equil, nofact, prefac, zerot
192 CHARACTER dist, equed, fact, packit, type, uplo, xtype
194 INTEGER i, i1, i2, iequed, ifact, ikd, imat, in, info,
195 $ ioff, iuplo, iw, izero, k, k1, kd, kl, koff,
196 $ ku, lda, ldab, mode, n, nb, nbmin, nerrs,
197 $ nfact, nfail, nimat, nkd, nrun, nt
198 REAL ainvnm, amax, anorm, cndnum, rcond, rcondc,
202 CHARACTER equeds( 2 ), facts( 3 )
203 INTEGER iseed( 4 ), iseedy( 4 ), kdval( nbw )
204 REAL result( ntests )
218 INTRINSIC cmplx, max, min
226 COMMON / infoc / infot, nunit, ok, lerr
227 COMMON / srnamc / srnamt
230 DATA iseedy / 1988, 1989, 1990, 1991 /
231 DATA facts /
'F',
'N',
'E' / , equeds /
'N',
'Y' /
237 path( 1: 1 ) =
'Complex precision'
243 iseed( i ) = iseedy( i )
249 $ CALL
cerrvx( path, nout )
269 nkd = max( 1, min( n, 4 ) )
274 kdval( 2 ) = n + ( n+1 ) / 4
275 kdval( 3 ) = ( 3*n-1 ) / 4
276 kdval( 4 ) = ( n+1 ) / 4
291 IF( iuplo.EQ.1 )
THEN
294 koff = max( 1, kd+2-n )
300 DO 80 imat = 1, nimat
304 IF( .NOT.dotype( imat ) )
309 zerot = imat.GE.2 .AND. imat.LE.4
310 IF( zerot .AND. n.LT.imat-1 )
313 IF( .NOT.zerot .OR. .NOT.dotype( 1 ) )
THEN
318 CALL
clatb4( path, imat, n, n, type, kl, ku, anorm,
319 $ mode, cndnum, dist )
322 CALL
clatms( n, n, dist, iseed, type, rwork, mode,
323 $ cndnum, anorm, kd, kd, packit,
324 $ a( koff ), ldab, work, info )
329 CALL
alaerh( path,
'CLATMS', info, 0, uplo, n,
330 $ n, -1, -1, -1, imat, nfail, nerrs,
334 ELSE IF( izero.GT.0 )
THEN
340 IF( iuplo.EQ.1 )
THEN
341 ioff = ( izero-1 )*ldab + kd + 1
342 CALL
ccopy( izero-i1, work( iw ), 1,
343 $ a( ioff-izero+i1 ), 1 )
345 CALL
ccopy( i2-izero+1, work( iw ), 1,
346 $ a( ioff ), max( ldab-1, 1 ) )
348 ioff = ( i1-1 )*ldab + 1
349 CALL
ccopy( izero-i1, work( iw ), 1,
350 $ a( ioff+izero-i1 ),
352 ioff = ( izero-1 )*ldab + 1
354 CALL
ccopy( i2-izero+1, work( iw ), 1,
366 ELSE IF( imat.EQ.3 )
THEN
375 DO 20 i = 1, min( 2*kd+1, n )
379 i1 = max( izero-kd, 1 )
380 i2 = min( izero+kd, n )
382 IF( iuplo.EQ.1 )
THEN
383 ioff = ( izero-1 )*ldab + kd + 1
384 CALL
cswap( izero-i1, a( ioff-izero+i1 ), 1,
387 CALL
cswap( i2-izero+1, a( ioff ),
388 $ max( ldab-1, 1 ), work( iw ), 1 )
390 ioff = ( i1-1 )*ldab + 1
391 CALL
cswap( izero-i1, a( ioff+izero-i1 ),
392 $ max( ldab-1, 1 ), work( iw ), 1 )
393 ioff = ( izero-1 )*ldab + 1
395 CALL
cswap( i2-izero+1, a( ioff ), 1,
402 IF( iuplo.EQ.1 )
THEN
403 CALL
claipd( n, a( kd+1 ), ldab, 0 )
405 CALL
claipd( n, a( 1 ), ldab, 0 )
410 CALL
clacpy(
'Full', kd+1, n, a, ldab, asav, ldab )
413 equed = equeds( iequed )
414 IF( iequed.EQ.1 )
THEN
420 DO 60 ifact = 1, nfact
421 fact = facts( ifact )
422 prefac =
lsame( fact,
'F' )
423 nofact =
lsame( fact,
'N' )
424 equil =
lsame( fact,
'E' )
431 ELSE IF( .NOT.
lsame( fact,
'N' ) )
THEN
438 CALL
clacpy(
'Full', kd+1, n, asav, ldab,
440 IF( equil .OR. iequed.GT.1 )
THEN
445 CALL
cpbequ( uplo, n, kd, afac, ldab, s,
446 $ scond, amax, info )
447 IF( info.EQ.0 .AND. n.GT.0 )
THEN
453 CALL
claqhb( uplo, n, kd, afac, ldab,
454 $ s, scond, amax, equed )
466 anorm =
clanhb(
'1', uplo, n, kd, afac, ldab,
471 CALL
cpbtrf( uplo, n, kd, afac, ldab, info )
475 CALL
claset(
'Full', n, n, cmplx( zero ),
476 $ cmplx( one ), a, lda )
478 CALL
cpbtrs( uplo, n, kd, n, afac, ldab, a,
483 ainvnm =
clange(
'1', n, n, a, lda, rwork )
484 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
487 rcondc = ( one / anorm ) / ainvnm
493 CALL
clacpy(
'Full', kd+1, n, asav, ldab, a,
500 CALL
clarhs( path, xtype, uplo,
' ', n, n, kd,
501 $ kd, nrhs, a, ldab, xact, lda,
b,
504 CALL
clacpy(
'Full', n, nrhs,
b, lda, bsav,
514 CALL
clacpy(
'Full', kd+1, n, a, ldab, afac,
516 CALL
clacpy(
'Full', n, nrhs,
b, lda,
x,
520 CALL
cpbsv( uplo, n, kd, nrhs, afac, ldab,
x,
525 IF( info.NE.izero )
THEN
526 CALL
alaerh( path,
'CPBSV ', info, izero,
527 $ uplo, n, n, kd, kd, nrhs,
528 $ imat, nfail, nerrs, nout )
530 ELSE IF( info.NE.0 )
THEN
537 CALL
cpbt01( uplo, n, kd, a, ldab, afac,
538 $ ldab, rwork, result( 1 ) )
542 CALL
clacpy(
'Full', n, nrhs,
b, lda, work,
544 CALL
cpbt02( uplo, n, kd, nrhs, a, ldab,
x,
545 $ lda, work, lda, rwork,
550 CALL
cget04( n, nrhs,
x, lda, xact, lda,
551 $ rcondc, result( 3 ) )
558 IF( result( k ).GE.thresh )
THEN
559 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
560 $ CALL
aladhd( nout, path )
561 WRITE( nout, fmt = 9999 )
'CPBSV ',
562 $ uplo, n, kd, imat, k, result( k )
573 $ CALL
claset(
'Full', kd+1, n, cmplx( zero ),
574 $ cmplx( zero ), afac, ldab )
575 CALL
claset(
'Full', n, nrhs, cmplx( zero ),
576 $ cmplx( zero ),
x, lda )
577 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
582 CALL
claqhb( uplo, n, kd, a, ldab, s, scond,
590 CALL
cpbsvx( fact, uplo, n, kd, nrhs, a, ldab,
591 $ afac, ldab, equed, s,
b, lda,
x,
592 $ lda, rcond, rwork, rwork( nrhs+1 ),
593 $ work, rwork( 2*nrhs+1 ), info )
597 IF( info.NE.izero )
THEN
598 CALL
alaerh( path,
'CPBSVX', info, izero,
599 $ fact // uplo, n, n, kd, kd,
600 $ nrhs, imat, nfail, nerrs, nout )
605 IF( .NOT.prefac )
THEN
610 CALL
cpbt01( uplo, n, kd, a, ldab, afac,
611 $ ldab, rwork( 2*nrhs+1 ),
620 CALL
clacpy(
'Full', n, nrhs, bsav, lda,
622 CALL
cpbt02( uplo, n, kd, nrhs, asav, ldab,
624 $ rwork( 2*nrhs+1 ), result( 2 ) )
628 IF( nofact .OR. ( prefac .AND.
lsame( equed,
630 CALL
cget04( n, nrhs,
x, lda, xact, lda,
631 $ rcondc, result( 3 ) )
633 CALL
cget04( n, nrhs,
x, lda, xact, lda,
634 $ roldc, result( 3 ) )
640 CALL
cpbt05( uplo, n, kd, nrhs, asav, ldab,
641 $
b, lda,
x, lda, xact, lda,
642 $ rwork, rwork( nrhs+1 ),
651 result( 6 ) =
sget06( rcond, rcondc )
657 IF( result( k ).GE.thresh )
THEN
658 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
659 $ CALL
aladhd( nout, path )
661 WRITE( nout, fmt = 9997 )
'CPBSVX',
662 $ fact, uplo, n, kd, equed, imat, k,
665 WRITE( nout, fmt = 9998 )
'CPBSVX',
666 $ fact, uplo, n, kd, imat, k,
682 CALL
alasvm( path, nout, nfail, nrun, nerrs )
684 9999
FORMAT( 1
x, a,
', UPLO=''', a1,
''', N =', i5,
', KD =', i5,
685 $
', type ', i1,
', test(', i1,
')=', g12.5 )
686 9998
FORMAT( 1
x, a,
'( ''', a1,
''', ''', a1,
''', ', i5,
', ', i5,
687 $
', ... ), type ', i1,
', test(', i1,
')=', g12.5 )
688 9997
FORMAT( 1
x, a,
'( ''', a1,
''', ''', a1,
''', ', i5,
', ', i5,
689 $
', ... ), EQUED=''', a1,
''', type ', i1,
', test(', i1,
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
LOGICAL function lsame(CA, CB)
LSAME
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine claipd(N, A, INDA, VINDA)
CLAIPD
subroutine claqhb(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED)
CLAQHB scales a Hermitian band matrix, using scaling factors computed by cpbequ.
subroutine cpbt02(UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CPBT02
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
REAL function sget06(RCOND, RCONDC)
SGET06
subroutine cpbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
CPBTRS
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine cpbequ(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO)
CPBEQU
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine cpbtrf(UPLO, N, KD, AB, LDAB, INFO)
CPBTRF
subroutine cpbsvx(FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
CPBSVX computes the solution to system of linear equations A * X = B for OTHER matrices ...
REAL function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine cpbt01(UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, RESID)
CPBT01
subroutine cerrvx(PATH, NUNIT)
CERRVX
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine cdrvpb(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, NOUT)
CDRVPB
REAL function clanhb(NORM, UPLO, N, K, AB, LDAB, WORK)
CLANHB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a Hermitian band matrix.
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
subroutine cpbsv(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
CPBSV computes the solution to system of linear equations A * X = B for OTHER matrices ...
subroutine cpbt05(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPBT05