167 SUBROUTINE cchkpb( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
168 $ thresh, tsterr, nmax, a, afac, ainv,
b, x,
169 $ xact, work, rwork, nout )
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 )
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 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 cerrpo(PATH, NUNIT)
CERRPO
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 clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine claipd(N, A, INDA, VINDA)
CLAIPD
subroutine cpbcon(UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, RWORK, INFO)
CPBCON
subroutine cpbt02(UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CPBT02
real function sget06(RCOND, RCONDC)
SGET06
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine cpbrfs(UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CPBRFS
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 cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine cpbtrf(UPLO, N, KD, AB, LDAB, INFO)
CPBTRF
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
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
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 cpbt01(UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK, RESID)
CPBT01
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine cchkpb(DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, NOUT)
CCHKPB
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
subroutine cpbt05(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPBT05