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 )
188 parameter ( nbw = 4 )
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( 1x, a,
', UPLO=''', a1,
''', N =', i5,
', KD =', i5,
685 $
', type ', i1,
', test(', i1,
')=', g12.5 )
686 9998
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ', i5,
', ', i5,
687 $
', ... ), type ', i1,
', test(', i1,
')=', g12.5 )
688 9997
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ', i5,
', ', i5,
689 $
', ... ), EQUED=''', a1,
''', type ', i1,
', test(', i1,
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
subroutine claipd(N, A, INDA, VINDA)
CLAIPD
subroutine cpbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
CPBTRS
subroutine claqhb(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED)
CLAQHB scales a Hermitian band matrix, using scaling factors computed by cpbequ.
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 cerrvx(PATH, NUNIT)
CERRVX
subroutine cpbt05(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPBT05
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 ...
real function sget06(RCOND, RCONDC)
SGET06
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 xlaenv(ISPEC, NVALUE)
XLAENV
subroutine cpbequ(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO)
CPBEQU
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
subroutine aladhd(IOUNIT, PATH)
ALADHD
logical function lsame(CA, CB)
LSAME
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine cpbt01(UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, RESID)
CPBT01
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine cpbt02(UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CPBT02
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 ...
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
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 cpbtrf(UPLO, N, KD, AB, LDAB, INFO)
CPBTRF
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04