139 SUBROUTINE sdrvgt( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF,
140 $ B, X, XACT, WORK, RWORK, IWORK, NOUT )
149 INTEGER nn, nout, nrhs
154 INTEGER IWORK( * ), NVAL( * )
155 REAL A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ),
163 parameter( one = 1.0e+0, zero = 0.0e+0 )
165 parameter( ntypes = 12 )
167 parameter( ntests = 6 )
170 LOGICAL TRFCON, ZEROT
171 CHARACTER DIST, FACT, TRANS, TYPE
173 INTEGER I, IFACT, IMAT, IN, INFO, ITRAN, IX, IZERO, J,
174 $ k, k1, kl, koff, ku, lda, m, mode, n, nerrs,
175 $ nfail, nimat, nrun, nt
176 REAL AINVNM, ANORM, ANORMI, ANORMO, COND, RCOND,
177 $ rcondc, rcondi, rcondo
180 CHARACTER TRANSS( 3 )
181 INTEGER ISEED( 4 ), ISEEDY( 4 )
182 REAL RESULT( NTESTS ), Z( 3 )
185 REAL SASUM, SGET06, SLANGT
186 EXTERNAL sasum, sget06, slangt
203 COMMON / infoc / infot, nunit, ok, lerr
204 COMMON / srnamc / srnamt
207 DATA iseedy / 0, 0, 0, 1 / , transs /
'N',
'T',
212 path( 1: 1 ) =
'Single precision'
218 iseed( i ) = iseedy( i )
224 $
CALL serrvx( path, nout )
238 DO 130 imat = 1, nimat
242 IF( .NOT.dotype( imat ) )
247 CALL slatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
250 zerot = imat.GE.8 .AND. imat.LE.10
255 koff = max( 2-ku, 3-max( 1, n ) )
257 CALL slatms( n, n, dist, iseed,
TYPE, rwork, mode, cond,
258 $ anorm, kl, ku,
'Z', af( koff ), 3, work,
264 CALL alaerh( path,
'SLATMS', info, 0,
' ', n, n, kl,
265 $ ku, -1, imat, nfail, nerrs, nout )
271 CALL scopy( n-1, af( 4 ), 3, a, 1 )
272 CALL scopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
274 CALL scopy( n, af( 2 ), 3, a( m+1 ), 1 )
280 IF( .NOT.zerot .OR. .NOT.dotype( 7 ) )
THEN
284 CALL slarnv( 2, iseed, n+2*m, a )
286 $
CALL sscal( n+2*m, anorm, a, 1 )
287 ELSE IF( izero.GT.0 )
THEN
292 IF( izero.EQ.1 )
THEN
296 ELSE IF( izero.EQ.n )
THEN
300 a( 2*n-2+izero ) = z( 1 )
301 a( n-1+izero ) = z( 2 )
308 IF( .NOT.zerot )
THEN
310 ELSE IF( imat.EQ.8 )
THEN
318 ELSE IF( imat.EQ.9 )
THEN
326 DO 20 i = izero, n - 1
337 IF( ifact.EQ.1 )
THEN
352 ELSE IF( ifact.EQ.1 )
THEN
353 CALL scopy( n+2*m, a, 1, af, 1 )
357 anormo = slangt(
'1', n, a, a( m+1 ), a( n+m+1 ) )
358 anormi = slangt(
'I', n, a, a( m+1 ), a( n+m+1 ) )
362 CALL sgttrf( n, af, af( m+1 ), af( n+m+1 ),
363 $ af( n+2*m+1 ), iwork, info )
374 CALL sgttrs(
'No transpose', n, 1, af, af( m+1 ),
375 $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
377 ainvnm = max( ainvnm, sasum( n, x, 1 ) )
382 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
385 rcondo = ( one / anormo ) / ainvnm
397 CALL sgttrs(
'Transpose', n, 1, af, af( m+1 ),
398 $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
400 ainvnm = max( ainvnm, sasum( n, x, 1 ) )
405 IF( anormi.LE.zero .OR. ainvnm.LE.zero )
THEN
408 rcondi = ( one / anormi ) / ainvnm
413 trans = transs( itran )
414 IF( itran.EQ.1 )
THEN
424 CALL slarnv( 2, iseed, n, xact( ix ) )
430 CALL slagtm( trans, n, nrhs, one, a, a( m+1 ),
431 $ a( n+m+1 ), xact, lda, zero, b, lda )
433 IF( ifact.EQ.2 .AND. itran.EQ.1 )
THEN
440 CALL scopy( n+2*m, a, 1, af, 1 )
441 CALL slacpy(
'Full', n, nrhs, b, lda, x, lda )
444 CALL sgtsv( n, nrhs, af, af( m+1 ), af( n+m+1 ), x,
450 $
CALL alaerh( path,
'SGTSV ', info, izero,
' ',
451 $ n, n, 1, 1, nrhs, imat, nfail,
454 IF( izero.EQ.0 )
THEN
458 CALL slacpy(
'Full', n, nrhs, b, lda, work,
460 CALL sgtt02( trans, n, nrhs, a, a( m+1 ),
461 $ a( n+m+1 ), x, lda, work, lda,
466 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
475 IF( result( k ).GE.thresh )
THEN
476 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
477 $
CALL aladhd( nout, path )
478 WRITE( nout, fmt = 9999 )
'SGTSV ', n, imat,
488 IF( ifact.GT.1 )
THEN
496 CALL slaset(
'Full', n, nrhs, zero, zero, x, lda )
502 CALL sgtsvx( fact, trans, n, nrhs, a, a( m+1 ),
503 $ a( n+m+1 ), af, af( m+1 ), af( n+m+1 ),
504 $ af( n+2*m+1 ), iwork, b, lda, x, lda,
505 $ rcond, rwork, rwork( nrhs+1 ), work,
506 $ iwork( n+1 ), info )
511 $
CALL alaerh( path,
'SGTSVX', info, izero,
512 $ fact // trans, n, n, 1, 1, nrhs, imat,
513 $ nfail, nerrs, nout )
515 IF( ifact.GE.2 )
THEN
520 CALL sgtt01( n, a, a( m+1 ), a( n+m+1 ), af,
521 $ af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
522 $ iwork, work, lda, rwork, result( 1 ) )
533 CALL slacpy(
'Full', n, nrhs, b, lda, work, lda )
534 CALL sgtt02( trans, n, nrhs, a, a( m+1 ),
535 $ a( n+m+1 ), x, lda, work, lda,
540 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
545 CALL sgtt05( trans, n, nrhs, a, a( m+1 ),
546 $ a( n+m+1 ), b, lda, x, lda, xact, lda,
547 $ rwork, rwork( nrhs+1 ), result( 4 ) )
555 IF( result( k ).GE.thresh )
THEN
556 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
557 $
CALL aladhd( nout, path )
558 WRITE( nout, fmt = 9998 )
'SGTSVX', fact, trans,
559 $ n, imat, k, result( k )
566 result( 6 ) = sget06( rcond, rcondc )
567 IF( result( 6 ).GE.thresh )
THEN
568 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
569 $
CALL aladhd( nout, path )
570 WRITE( nout, fmt = 9998 )
'SGTSVX', fact, trans, n,
571 $ imat, k, result( k )
574 nrun = nrun + nt - k1 + 2
583 CALL alasvm( path, nout, nfail, nrun, nerrs )
585 9999
FORMAT( 1x, a,
', N =', i5,
', type ', i2,
', test ', i2,
586 $
', ratio = ', g12.5 )
587 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', TRANS=''', a1,
''', N =',
588 $ i5,
', type ', i2,
', test ', i2,
', ratio = ', g12.5 )