178 INTEGER nmax, nn, nnb, nns, nout
183 INTEGER nbval( * ), nsval( * ), nval( * )
185 COMPLEX a( * ), afac( * ), ainv( * ), b( * ),
186 $ work( * ), x( * ), xact( * )
193 parameter ( one = 1.0e+0, zero = 0.0e+0 )
194 INTEGER ntypes, ntests
195 parameter ( ntypes = 8, ntests = 7 )
197 parameter ( nbw = 4 )
201 CHARACTER dist, packit,
TYPE, uplo, xtype
203 INTEGER i, i1, i2, ikd, imat, in, inb, info, ioff,
204 $ irhs, iuplo, iw, izero, k, kd, kl, koff, ku,
205 $ lda, ldab, mode, n, nb, nerrs, nfail, nimat,
207 REAL ainvnm, anorm, cndnum, rcond, rcondc
210 INTEGER iseed( 4 ), iseedy( 4 ), kdval( nbw )
211 REAL result( ntests )
224 INTRINSIC cmplx, max, min
232 COMMON / infoc / infot, nunit, ok, lerr
233 COMMON / srnamc / srnamt
236 DATA iseedy / 1988, 1989, 1990, 1991 /
242 path( 1: 1 ) =
'Complex precision'
248 iseed( i ) = iseedy( i )
254 $
CALL cerrpo( path, nout )
267 nkd = max( 1, min( n, 4 ) )
272 kdval( 2 ) = n + ( n+1 ) / 4
273 kdval( 3 ) = ( 3*n-1 ) / 4
274 kdval( 4 ) = ( n+1 ) / 4
289 IF( iuplo.EQ.1 )
THEN
291 koff = max( 1, kd+2-n )
298 DO 60 imat = 1, nimat
302 IF( .NOT.dotype( imat ) )
307 zerot = imat.GE.2 .AND. imat.LE.4
308 IF( zerot .AND. n.LT.imat-1 )
311 IF( .NOT.zerot .OR. .NOT.dotype( 1 ) )
THEN
316 CALL clatb4( path, imat, n, n,
TYPE, kl, ku, anorm,
317 $ mode, cndnum, dist )
320 CALL clatms( n, n, dist, iseed,
TYPE, rwork, mode,
321 $ cndnum, anorm, kd, kd, packit,
322 $ a( koff ), ldab, work, info )
327 CALL alaerh( path,
'CLATMS', info, 0, uplo, n,
328 $ n, kd, kd, -1, imat, nfail, nerrs,
332 ELSE IF( izero.GT.0 )
THEN
338 IF( iuplo.EQ.1 )
THEN
339 ioff = ( izero-1 )*ldab + kd + 1
340 CALL ccopy( izero-i1, work( iw ), 1,
341 $ a( ioff-izero+i1 ), 1 )
343 CALL ccopy( i2-izero+1, work( iw ), 1,
344 $ a( ioff ), max( ldab-1, 1 ) )
346 ioff = ( i1-1 )*ldab + 1
347 CALL ccopy( izero-i1, work( iw ), 1,
348 $ a( ioff+izero-i1 ),
350 ioff = ( izero-1 )*ldab + 1
352 CALL ccopy( i2-izero+1, work( iw ), 1,
364 ELSE IF( imat.EQ.3 )
THEN
373 DO 20 i = 1, min( 2*kd+1, n )
377 i1 = max( izero-kd, 1 )
378 i2 = min( izero+kd, n )
380 IF( iuplo.EQ.1 )
THEN
381 ioff = ( izero-1 )*ldab + kd + 1
382 CALL cswap( izero-i1, a( ioff-izero+i1 ), 1,
385 CALL cswap( i2-izero+1, a( ioff ),
386 $ max( ldab-1, 1 ), work( iw ), 1 )
388 ioff = ( i1-1 )*ldab + 1
389 CALL cswap( izero-i1, a( ioff+izero-i1 ),
390 $ max( ldab-1, 1 ), work( iw ), 1 )
391 ioff = ( izero-1 )*ldab + 1
393 CALL cswap( i2-izero+1, a( ioff ), 1,
400 IF( iuplo.EQ.1 )
THEN
401 CALL claipd( n, a( kd+1 ), ldab, 0 )
403 CALL claipd( n, a( 1 ), ldab, 0 )
415 CALL clacpy(
'Full', kd+1, n, a, ldab, afac, ldab )
417 CALL cpbtrf( uplo, n, kd, afac, ldab, info )
421 IF( info.NE.izero )
THEN
422 CALL alaerh( path,
'CPBTRF', info, izero, uplo,
423 $ n, n, kd, kd, nb, imat, nfail,
437 CALL clacpy(
'Full', kd+1, n, afac, ldab, ainv,
439 CALL cpbt01( uplo, n, kd, a, ldab, ainv, ldab,
440 $ rwork, result( 1 ) )
444 IF( result( 1 ).GE.thresh )
THEN
445 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
446 $
CALL alahd( nout, path )
447 WRITE( nout, fmt = 9999 )uplo, n, kd, nb, imat,
461 CALL claset(
'Full', n, n, cmplx( zero ),
462 $ cmplx( one ), ainv, lda )
464 CALL cpbtrs( uplo, n, kd, n, afac, ldab, ainv, lda,
469 anorm =
clanhb(
'1', uplo, n, kd, a, ldab, rwork )
470 ainvnm =
clange(
'1', n, n, ainv, lda, rwork )
471 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
474 rcondc = ( one / anorm ) / ainvnm
484 CALL clarhs( path, xtype, uplo,
' ', n, n, kd,
485 $ kd, nrhs, a, ldab, xact, lda, b,
487 CALL clacpy(
'Full', n, nrhs, b, lda, x, lda )
490 CALL cpbtrs( uplo, n, kd, nrhs, afac, ldab, x,
496 $
CALL alaerh( path,
'CPBTRS', info, 0, uplo,
497 $ n, n, kd, kd, nrhs, imat, nfail,
500 CALL clacpy(
'Full', n, nrhs, b, lda, work,
502 CALL cpbt02( uplo, n, kd, nrhs, a, ldab, x, lda,
503 $ work, lda, rwork, result( 2 ) )
508 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
515 CALL cpbrfs( uplo, n, kd, nrhs, a, ldab, afac,
516 $ ldab, b, lda, x, lda, rwork,
517 $ rwork( nrhs+1 ), work,
518 $ rwork( 2*nrhs+1 ), info )
523 $
CALL alaerh( path,
'CPBRFS', info, 0, uplo,
524 $ n, n, kd, kd, nrhs, imat, nfail,
527 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
529 CALL cpbt05( uplo, n, kd, nrhs, a, ldab, b, lda,
530 $ x, lda, xact, lda, rwork,
531 $ rwork( nrhs+1 ), result( 5 ) )
537 IF( result( k ).GE.thresh )
THEN
538 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
539 $
CALL alahd( nout, path )
540 WRITE( nout, fmt = 9998 )uplo, n, kd,
541 $ nrhs, imat, k, result( k )
552 CALL cpbcon( uplo, n, kd, afac, ldab, anorm, rcond,
553 $ work, rwork, info )
558 $
CALL alaerh( path,
'CPBCON', info, 0, uplo, n,
559 $ n, kd, kd, -1, imat, nfail, nerrs,
562 result( 7 ) =
sget06( rcond, rcondc )
566 IF( result( 7 ).GE.thresh )
THEN
567 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
568 $
CALL alahd( nout, path )
569 WRITE( nout, fmt = 9997 )uplo, n, kd, imat, 7,
582 CALL alasum( path, nout, nfail, nrun, nerrs )
584 9999
FORMAT(
' UPLO=''', a1,
''', N=', i5,
', KD=', i5,
', NB=', i4,
585 $
', type ', i2,
', test ', i2,
', ratio= ', g12.5 )
586 9998
FORMAT(
' UPLO=''', a1,
''', N=', i5,
', KD=', i5,
', NRHS=', i3,
587 $
', type ', i2,
', test(', i2,
') = ', g12.5 )
588 9997
FORMAT(
' UPLO=''', a1,
''', N=', i5,
', KD=', i5,
',', 10x,
589 $
' type ', i2,
', test(', i2,
') = ', g12.5 )
subroutine alahd(IOUNIT, PATH)
ALAHD
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 cpbcon(UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, RWORK, INFO)
CPBCON
subroutine claipd(N, A, INDA, VINDA)
CLAIPD
subroutine cpbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
CPBTRS
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 cpbt05(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPBT05
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 clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
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 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
subroutine cpbrfs(UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CPBRFS
subroutine cerrpo(PATH, NUNIT)
CERRPO
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM