190 SUBROUTINE schkgb( 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( * ),
208 REAL a( * ), afac( * ), b( * ), rwork( * ),
209 $ work( * ), x( * ), xact( * )
216 parameter( one = 1.0e+0, zero = 0.0e+0 )
217 INTEGER ntypes, ntests
218 parameter( ntypes = 8, ntests = 7 )
220 parameter( nbw = 4, ntran = 3 )
223 LOGICAL trfcon, zerot
224 CHARACTER dist, norm, trans, type, xtype
226 INTEGER i, i1, i2, ikl, iku, im, imat, in, inb, info,
227 $ ioff, irhs, itran, izero, j, k, kl, koff, ku,
228 $ lda, ldafac, ldb, m, mode, n, nb, nerrs, nfail,
229 $ nimat, nkl, nku, nrhs, nrun
230 REAL ainvnm, anorm, anormi, anormo, cndnum, rcond,
231 $ rcondc, rcondi, rcondo
234 CHARACTER transs( ntran )
235 INTEGER iseed( 4 ), iseedy( 4 ), klval( nbw ),
237 REAL result( ntests )
258 common / infoc / infot, nunit, ok, lerr
259 common / srnamc / srnamt
262 DATA iseedy / 1988, 1989, 1990, 1991 / ,
263 $ transs /
'N',
'T',
'C' /
269 path( 1: 1 ) =
'Single precision'
275 iseed( i ) = iseedy( i )
281 $ CALL
serrge( 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
slatb4( 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
slatms( m, n, dist, iseed, type, rwork,
395 $ mode, cndnum, anorm, kl, ku,
'Z',
396 $ a( koff ), lda, work, info )
401 CALL
alaerh( path,
'SLATMS', info, 0,
' ', m,
402 $ n, kl, ku, -1, imat, nfail,
406 ELSE IF( izero.GT.0 )
THEN
411 CALL
scopy( 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
scopy( 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
slacpy(
'Full', kl+ku+1, n, a, lda,
466 $ afac( kl+1 ), ldafac )
468 CALL
sgbtrf( m, n, kl, ku, afac, ldafac, iwork,
474 $ CALL
alaerh( path,
'SGBTRF', info, izero,
475 $
' ', m, n, kl, ku, nb, imat,
476 $ nfail, nerrs, nout )
483 CALL
sgbt01( 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 =
slangb(
'O', n, kl, ku, a, lda, rwork )
505 anormi =
slangb(
'I', n, kl, ku, a, lda, rwork )
513 CALL
slaset(
'Full', n, n, zero, one, work,
516 CALL
sgbtrs(
'No transpose', n, kl, ku, n,
517 $ afac, ldafac, iwork, work, ldb,
522 ainvnm =
slange(
'O', n, n, work, ldb,
524 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
527 rcondo = ( one / anormo ) / ainvnm
533 ainvnm =
slange(
'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
slarhs( path, xtype,
' ', trans, n,
573 $ n, kl, ku, nrhs, a, lda,
574 $ xact, ldb, b, ldb, iseed,
577 CALL
slacpy(
'Full', n, nrhs, b, ldb, x,
581 CALL
sgbtrs( trans, n, kl, ku, nrhs, afac,
582 $ ldafac, iwork, x, ldb, info )
587 $ CALL
alaerh( path,
'SGBTRS', info, 0,
588 $ trans, n, n, kl, ku, -1,
589 $ imat, nfail, nerrs, nout )
591 CALL
slacpy(
'Full', n, nrhs, b, ldb,
593 CALL
sgbt02( trans, m, n, kl, ku, nrhs, a,
594 $ lda, x, ldb, work, ldb,
601 CALL
sget04( n, nrhs, x, ldb, xact, ldb,
602 $ rcondc, result( 3 ) )
609 CALL
sgbrfs( trans, n, kl, ku, nrhs, a,
610 $ lda, afac, ldafac, iwork, b,
611 $ ldb, x, ldb, rwork,
612 $ rwork( nrhs+1 ), work,
613 $ iwork( n+1 ), info )
618 $ CALL
alaerh( path,
'SGBRFS', info, 0,
619 $ trans, n, n, kl, ku, nrhs,
620 $ imat, nfail, nerrs, nout )
622 CALL
sget04( n, nrhs, x, ldb, xact, ldb,
623 $ rcondc, result( 4 ) )
624 CALL
sgbt05( trans, n, kl, ku, nrhs, a,
625 $ lda, b, ldb, x, ldb, xact,
626 $ ldb, rwork, rwork( nrhs+1 ),
629 IF( result( k ).GE.thresh )
THEN
630 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
631 $ CALL
alahd( nout, path )
632 WRITE( nout, fmt = 9996 )trans, n,
633 $ kl, ku, nrhs, imat, k,
647 IF( itran.EQ.1 )
THEN
657 CALL
sgbcon( norm, n, kl, ku, afac, ldafac,
658 $ iwork, anorm, rcond, work,
659 $ iwork( n+1 ), info )
664 $ CALL
alaerh( path,
'SGBCON', info, 0,
665 $ norm, n, n, kl, ku, -1, imat,
666 $ nfail, nerrs, nout )
668 result( 7 ) =
sget06( rcond, rcondc )
673 IF( result( 7 ).GE.thresh )
THEN
674 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
675 $ CALL
alahd( nout, path )
676 WRITE( nout, fmt = 9995 )norm, n, kl, ku,
677 $ imat, 7, result( 7 )
692 CALL
alasum( path, nout, nfail, nrun, nerrs )
694 9999 format(
' *** In SCHKGB, LA=', i5,
' is too small for M=', i5,
695 $
', N=', i5,
', KL=', i4,
', KU=', i4,
696 $ /
' ==> Increase LA to at least ', i5 )
697 9998 format(
' *** In SCHKGB, LAFAC=', i5,
' is too small for M=', i5,
698 $
', N=', i5,
', KL=', i4,
', KU=', i4,
699 $ /
' ==> Increase LAFAC to at least ', i5 )
700 9997 format(
' M =', i5,
', N =', i5,
', KL=', i5,
', KU=', i5,
701 $
', NB =', i4,
', type ', i1,
', test(', i1,
')=', g12.5 )
702 9996 format(
' TRANS=''', a1,
''', N=', i5,
', KL=', i5,
', KU=', i5,
703 $
', NRHS=', i3,
', type ', i1,
', test(', i1,
')=', g12.5 )
704 9995 format(
' NORM =''', a1,
''', N=', i5,
', KL=', i5,
', KU=', i5,
705 $
',', 10x,
' type ', i1,
', test(', i1,
')=', g12.5 )