190 SUBROUTINE cchkgb( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS,
191 $ nsval, thresh, tsterr, a, la, afac, lafac,
b,
192 $
x, xact, work, rwork, iwork, nout )
201 INTEGER la, lafac, nm, nn, nnb, nns, nout
206 INTEGER iwork( * ), mval( * ), nbval( * ), nsval( * ),
209 COMPLEX a( * ), afac( * ),
b( * ), work( * ),
x( * ),
217 parameter( one = 1.0e+0, zero = 0.0e+0 )
218 INTEGER ntypes, ntests
219 parameter( ntypes = 8, ntests = 7 )
221 parameter( nbw = 4, ntran = 3 )
224 LOGICAL trfcon, zerot
225 CHARACTER dist, norm, trans, type, xtype
227 INTEGER i, i1, i2, ikl, iku, im, imat, in, inb, info,
228 $ ioff, irhs, itran, izero,
j, k, kl, koff, ku,
229 $ lda, ldafac, ldb, m, mode, n, nb, nerrs, nfail,
230 $ nimat, nkl, nku, nrhs, nrun
231 REAL ainvnm, anorm, anormi, anormo, cndnum, rcond,
232 $ rcondc, rcondi, rcondo
235 CHARACTER transs( ntran )
236 INTEGER iseed( 4 ), iseedy( 4 ), klval( nbw ),
238 REAL result( ntests )
251 INTRINSIC cmplx, max, min
259 COMMON / infoc / infot, nunit, ok, lerr
260 COMMON / srnamc / srnamt
263 DATA iseedy / 1988, 1989, 1990, 1991 / ,
264 $ transs /
'N',
'T',
'C' /
270 path( 1: 1 ) =
'Complex precision'
276 iseed( i ) = iseedy( i )
282 $ CALL
cerrge( path, nout )
297 klval( 2 ) = m + ( m+1 ) / 4
301 klval( 3 ) = ( 3*m-1 ) / 4
302 klval( 4 ) = ( m+1 ) / 4
312 kuval( 2 ) = n + ( n+1 ) / 4
316 kuval( 3 ) = ( 3*n-1 ) / 4
317 kuval( 4 ) = ( n+1 ) / 4
328 IF( m.LE.0 .OR. n.LE.0 )
350 ldafac = 2*kl + ku + 1
351 IF( ( lda*n ).GT.la .OR. ( ldafac*n ).GT.lafac )
THEN
352 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
353 $ CALL
alahd( nout, path )
354 IF( n*( kl+ku+1 ).GT.la )
THEN
355 WRITE( nout, fmt = 9999 )la, m, n, kl, ku,
359 IF( n*( 2*kl+ku+1 ).GT.lafac )
THEN
360 WRITE( nout, fmt = 9998 )lafac, m, n, kl, ku,
367 DO 120 imat = 1, nimat
371 IF( .NOT.dotype( imat ) )
377 zerot = imat.GE.2 .AND. imat.LE.4
378 IF( zerot .AND. n.LT.imat-1 )
381 IF( .NOT.zerot .OR. .NOT.dotype( 1 ) )
THEN
386 CALL
clatb4( path, imat, m, n, type, kl, ku,
387 $ anorm, mode, cndnum, dist )
389 koff = max( 1, ku+2-n )
390 DO 20 i = 1, koff - 1
394 CALL
clatms( m, n, dist, iseed, type, rwork,
395 $ mode, cndnum, anorm, kl, ku,
'Z',
396 $ a( koff ), lda, work, info )
401 CALL
alaerh( path,
'CLATMS', info, 0,
' ', m,
402 $ n, kl, ku, -1, imat, nfail,
406 ELSE IF( izero.GT.0 )
THEN
411 CALL
ccopy( i2-i1+1,
b, 1, a( ioff+i1 ), 1 )
421 ELSE IF( imat.EQ.3 )
THEN
424 izero = min( m, n ) / 2 + 1
426 ioff = ( izero-1 )*lda
431 i1 = max( 1, ku+2-izero )
432 i2 = min( kl+ku+1, ku+1+( m-izero ) )
433 CALL
ccopy( i2-i1+1, a( ioff+i1 ), 1,
b, 1 )
440 DO 40 i = max( 1, ku+2-
j ),
441 $ min( kl+ku+1, ku+1+( m-
j ) )
464 IF( m.GT.0 .AND. n.GT.0 )
465 $ CALL
clacpy(
'Full', kl+ku+1, n, a, lda,
466 $ afac( kl+1 ), ldafac )
468 CALL
cgbtrf( m, n, kl, ku, afac, ldafac, iwork,
474 $ CALL
alaerh( path,
'CGBTRF', info, izero,
475 $
' ', m, n, kl, ku, nb, imat,
476 $ nfail, nerrs, nout )
483 CALL
cgbt01( m, n, kl, ku, a, lda, afac, ldafac,
484 $ iwork, work, result( 1 ) )
489 IF( result( 1 ).GE.thresh )
THEN
490 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
491 $ CALL
alahd( nout, path )
492 WRITE( nout, fmt = 9997 )m, n, kl, ku, nb,
493 $ imat, 1, result( 1 )
501 IF( inb.GT.1 .OR. m.NE.n )
504 anormo =
clangb(
'O', n, kl, ku, a, lda, rwork )
505 anormi =
clangb(
'I', n, kl, ku, a, lda, rwork )
513 CALL
claset(
'Full', n, n, cmplx( zero ),
514 $ cmplx( one ), work, ldb )
516 CALL
cgbtrs(
'No transpose', n, kl, ku, n,
517 $ afac, ldafac, iwork, work, ldb,
522 ainvnm =
clange(
'O', n, n, work, ldb,
524 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
527 rcondo = ( one / anormo ) / ainvnm
533 ainvnm =
clange(
'I', n, n, work, ldb,
535 IF( anormi.LE.zero .OR. ainvnm.LE.zero )
THEN
538 rcondi = ( one / anormi ) / ainvnm
558 DO 70 itran = 1, ntran
559 trans = transs( itran )
560 IF( itran.EQ.1 )
THEN
572 CALL
clarhs( path, xtype,
' ', trans, n,
573 $ n, kl, ku, nrhs, a, lda,
574 $ xact, ldb,
b, ldb, iseed,
577 CALL
clacpy(
'Full', n, nrhs,
b, ldb,
x,
581 CALL
cgbtrs( trans, n, kl, ku, nrhs, afac,
582 $ ldafac, iwork,
x, ldb, info )
587 $ CALL
alaerh( path,
'CGBTRS', info, 0,
588 $ trans, n, n, kl, ku, -1,
589 $ imat, nfail, nerrs, nout )
591 CALL
clacpy(
'Full', n, nrhs,
b, ldb,
593 CALL
cgbt02( trans, m, n, kl, ku, nrhs, a,
594 $ lda,
x, ldb, work, ldb,
601 CALL
cget04( n, nrhs,
x, ldb, xact, ldb,
602 $ rcondc, result( 3 ) )
609 CALL
cgbrfs( trans, n, kl, ku, nrhs, a,
610 $ lda, afac, ldafac, iwork,
b,
611 $ ldb,
x, ldb, rwork,
612 $ rwork( nrhs+1 ), work,
613 $ rwork( 2*nrhs+1 ), info )
618 $ CALL
alaerh( path,
'CGBRFS', info, 0,
619 $ trans, n, n, kl, ku, nrhs,
620 $ imat, nfail, nerrs, nout )
622 CALL
cget04( n, nrhs,
x, ldb, xact, ldb,
623 $ rcondc, result( 4 ) )
624 CALL
cgbt05( trans, n, kl, ku, nrhs, a,
625 $ lda,
b, ldb,
x, ldb, xact,
626 $ ldb, rwork, rwork( nrhs+1 ),
633 IF( result( k ).GE.thresh )
THEN
634 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
635 $ CALL
alahd( nout, path )
636 WRITE( nout, fmt = 9996 )trans, n,
637 $ kl, ku, nrhs, imat, k,
651 IF( itran.EQ.1 )
THEN
661 CALL
cgbcon( norm, n, kl, ku, afac, ldafac,
662 $ iwork, anorm, rcond, work,
668 $ CALL
alaerh( path,
'CGBCON', info, 0,
669 $ norm, n, n, kl, ku, -1, imat,
670 $ nfail, nerrs, nout )
672 result( 7 ) =
sget06( rcond, rcondc )
677 IF( result( 7 ).GE.thresh )
THEN
678 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
679 $ CALL
alahd( nout, path )
680 WRITE( nout, fmt = 9995 )norm, n, kl, ku,
681 $ imat, 7, result( 7 )
695 CALL
alasum( path, nout, nfail, nrun, nerrs )
697 9999
FORMAT(
' *** In CCHKGB, LA=', i5,
' is too small for M=', i5,
698 $
', N=', i5,
', KL=', i4,
', KU=', i4,
699 $ /
' ==> Increase LA to at least ', i5 )
700 9998
FORMAT(
' *** In CCHKGB, LAFAC=', i5,
' is too small for M=', i5,
701 $
', N=', i5,
', KL=', i4,
', KU=', i4,
702 $ /
' ==> Increase LAFAC to at least ', i5 )
703 9997
FORMAT(
' M =', i5,
', N =', i5,
', KL=', i5,
', KU=', i5,
704 $
', NB =', i4,
', type ', i1,
', test(', i1,
')=', g12.5 )
705 9996
FORMAT(
' TRANS=''', a1,
''', N=', i5,
', KL=', i5,
', KU=', i5,
706 $
', NRHS=', i3,
', type ', i1,
', test(', i1,
')=', g12.5 )
707 9995
FORMAT(
' NORM =''', a1,
''', N=', i5,
', KL=', i5,
', KU=', i5,
708 $
',', 10
x,
' type ', i1,
', test(', i1,
')=', 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 cgbt05(TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CGBT05
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 cchkgb(DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, A, LA, AFAC, LAFAC, B, X, XACT, WORK, RWORK, IWORK, NOUT)
CCHKGB
subroutine cerrge(PATH, NUNIT)
CERRGE
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
REAL function sget06(RCOND, RCONDC)
SGET06
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
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 cgbt01(M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, RESID)
CGBT01
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
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine cgbcon(NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, RWORK, INFO)
CGBCON
REAL function clangb(NORM, N, KL, KU, AB, LDAB, WORK)
CLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine cgbtrs(TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
CGBTRS
subroutine cgbtrf(M, N, KL, KU, AB, LDAB, IPIV, INFO)
CGBTRF
subroutine cgbrfs(TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CGBRFS
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
subroutine cgbt02(TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, RESID)
CGBT02