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 $
',', 10x,
' type ', i1,
', test(', i1,
')=', g12.5 )