202 SUBROUTINE sdrvls( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
203 $ nbval, nxval, thresh, tsterr, a, copya, b,
204 $ copyb, c, s, copys, work, iwork, nout )
213 INTEGER nm, nn, nnb, nns, nout
218 INTEGER iwork( * ), mval( * ), nbval( * ), nsval( * ),
219 $ nval( * ), nxval( * )
220 REAL a( * ), b( * ), c( * ), copya( * ), copyb( * ),
221 $ copys( * ), s( * ), work( * )
228 parameter( ntests = 18 )
230 parameter( smlsiz = 25 )
232 parameter( one = 1.0e0, two = 2.0e0, zero = 0.0e0 )
237 INTEGER crank, i, im, in, inb, info, ins, irank,
238 $ iscale, itran, itype, j, k, lda, ldb, ldwork,
239 $ lwlsy, lwork, m, mnmin, n, nb, ncols, nerrs,
240 $ nfail, nlvl, nrhs, nrows, nrun, rank
241 REAL eps, norma, normb, rcond
244 INTEGER iseed( 4 ), iseedy( 4 )
245 REAL result( ntests )
258 INTRINSIC int, log, max, min,
REAL, sqrt
263 INTEGER infot, iounit
266 common / infoc / infot, iounit, ok, lerr
267 common / srnamc / srnamt
270 DATA iseedy / 1988, 1989, 1990, 1991 /
276 path( 1: 1 ) =
'Single precision'
282 iseed( i ) = iseedy( i )
288 rcond = sqrt( eps ) - ( sqrt( eps )-eps ) / 2
295 $ CALL
serrls( path, nout )
299 IF( ( nm.EQ.0 .OR. nn.EQ.0 ) .AND. thresh.EQ.zero )
300 $ CALL
alahd( nout, path )
314 nlvl = max( int( log( max( one,
REAL( MNMIN ) ) /
315 $
REAL( SMLSIZ+1 ) ) / log( two ) ) + 1, 0 )
316 lwork = max( 1, ( m+nrhs )*( n+2 ), ( n+nrhs )*( m+2 ),
317 $ m*n+4*mnmin+max( m, n ), 12*mnmin+2*mnmin*smlsiz+
318 $ 8*mnmin*nlvl+mnmin*nrhs+(smlsiz+1)**2 )
322 itype = ( irank-1 )*3 + iscale
323 IF( .NOT.dotype( itype ) )
326 IF( irank.EQ.1 )
THEN
332 CALL
sqrt13( iscale, m, n, copya, lda, norma,
337 CALL
xlaenv( 3, nxval( inb ) )
340 IF( itran.EQ.1 )
THEN
349 ldwork = max( 1, ncols )
353 IF( ncols.GT.0 )
THEN
354 CALL
slarnv( 2, iseed, ncols*nrhs,
356 CALL
sscal( ncols*nrhs,
357 $ one /
REAL( NCOLS ), work,
360 CALL
sgemm( trans,
'No transpose', nrows,
361 $ nrhs, ncols, one, copya, lda,
362 $ work, ldwork, zero, b, ldb )
363 CALL
slacpy(
'Full', nrows, nrhs, b, ldb,
368 IF( m.GT.0 .AND. n.GT.0 )
THEN
369 CALL
slacpy(
'Full', m, n, copya, lda,
371 CALL
slacpy(
'Full', nrows, nrhs,
372 $ copyb, ldb, b, ldb )
375 CALL
sgels( trans, m, n, nrhs, a, lda, b,
376 $ ldb, work, lwork, info )
378 $ CALL
alaerh( path,
'SGELS ', info, 0,
379 $ trans, m, n, nrhs, -1, nb,
380 $ itype, nfail, nerrs,
385 ldwork = max( 1, nrows )
386 IF( nrows.GT.0 .AND. nrhs.GT.0 )
387 $ CALL
slacpy(
'Full', nrows, nrhs,
388 $ copyb, ldb, c, ldb )
389 CALL
sqrt16( trans, m, n, nrhs, copya,
390 $ lda, b, ldb, c, ldb, work,
393 IF( ( itran.EQ.1 .AND. m.GE.n ) .OR.
394 $ ( itran.EQ.2 .AND. m.LT.n ) )
THEN
398 result( 2 ) =
sqrt17( trans, 1, m, n,
399 $ nrhs, copya, lda, b, ldb,
400 $ copyb, ldb, c, work,
406 result( 2 ) =
sqrt14( trans, m, n,
407 $ nrhs, copya, lda, b, ldb,
415 IF( result( k ).GE.thresh )
THEN
416 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
417 $ CALL
alahd( nout, path )
418 WRITE( nout, fmt = 9999 )trans, m,
419 $ n, nrhs, nb, itype, k,
432 CALL
sqrt15( iscale, irank, m, n, nrhs, copya, lda,
433 $ copyb, ldb, copys, rank, norma, normb,
434 $ iseed, work, lwork )
451 CALL
slacpy(
'Full', m, n, copya, lda, a, lda )
452 CALL
slacpy(
'Full', m, nrhs, copyb, ldb, b, ldb )
455 CALL
sgelsx( m, n, nrhs, a, lda, b, ldb, iwork,
456 $ rcond, crank, work, info )
458 $ CALL
alaerh( path,
'SGELSX', info, 0,
' ', m, n,
459 $ nrhs, -1, nb, itype, nfail, nerrs,
467 result( 3 ) =
sqrt12( crank, crank, a, lda, copys,
473 CALL
slacpy(
'Full', m, nrhs, copyb, ldb, work,
475 CALL
sqrt16(
'No transpose', m, n, nrhs, copya,
476 $ lda, b, ldb, work, ldwork,
477 $ work( m*nrhs+1 ), result( 4 ) )
484 $ result( 5 ) =
sqrt17(
'No transpose', 1, m, n,
485 $ nrhs, copya, lda, b, ldb, copyb,
486 $ ldb, c, work, lwork )
494 $ result( 6 ) =
sqrt14(
'No transpose', m, n,
495 $ nrhs, copya, lda, b, ldb, work,
502 IF( result( k ).GE.thresh )
THEN
503 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
504 $ CALL
alahd( nout, path )
505 WRITE( nout, fmt = 9998 )m, n, nrhs, nb,
506 $ itype, k, result( k )
517 CALL
xlaenv( 3, nxval( inb ) )
534 lwlsy = max( 1, mnmin+2*n+nb*( n+1 ),
537 CALL
slacpy(
'Full', m, n, copya, lda, a, lda )
538 CALL
slacpy(
'Full', m, nrhs, copyb, ldb, b,
542 CALL
sgelsy( m, n, nrhs, a, lda, b, ldb, iwork,
543 $ rcond, crank, work, lwlsy, info )
545 $ CALL
alaerh( path,
'SGELSY', info, 0,
' ', m,
546 $ n, nrhs, -1, nb, itype, nfail,
552 result( 7 ) =
sqrt12( crank, crank, a, lda,
553 $ copys, work, lwork )
558 CALL
slacpy(
'Full', m, nrhs, copyb, ldb, work,
560 CALL
sqrt16(
'No transpose', m, n, nrhs, copya,
561 $ lda, b, ldb, work, ldwork,
562 $ work( m*nrhs+1 ), result( 8 ) )
569 $ result( 9 ) =
sqrt17(
'No transpose', 1, m,
570 $ n, nrhs, copya, lda, b, ldb,
571 $ copyb, ldb, c, work, lwork )
579 $ result( 10 ) =
sqrt14(
'No transpose', m, n,
580 $ nrhs, copya, lda, b, ldb,
589 CALL
slacpy(
'Full', m, n, copya, lda, a, lda )
590 CALL
slacpy(
'Full', m, nrhs, copyb, ldb, b,
593 CALL
sgelss( m, n, nrhs, a, lda, b, ldb, s,
594 $ rcond, crank, work, lwork, info )
596 $ CALL
alaerh( path,
'SGELSS', info, 0,
' ', m,
597 $ n, nrhs, -1, nb, itype, nfail,
606 CALL
saxpy( mnmin, -one, copys, 1, s, 1 )
607 result( 11 ) =
sasum( mnmin, s, 1 ) /
608 $
sasum( mnmin, copys, 1 ) /
609 $ ( eps*
REAL( MNMIN ) )
616 CALL
slacpy(
'Full', m, nrhs, copyb, ldb, work,
618 CALL
sqrt16(
'No transpose', m, n, nrhs, copya,
619 $ lda, b, ldb, work, ldwork,
620 $ work( m*nrhs+1 ), result( 12 ) )
626 $ result( 13 ) =
sqrt17(
'No transpose', 1, m,
627 $ n, nrhs, copya, lda, b, ldb,
628 $ copyb, ldb, c, work, lwork )
634 $ result( 14 ) =
sqrt14(
'No transpose', m, n,
635 $ nrhs, copya, lda, b, ldb,
650 CALL
slacpy(
'Full', m, n, copya, lda, a, lda )
651 CALL
slacpy(
'Full', m, nrhs, copyb, ldb, b,
655 CALL
sgelsd( m, n, nrhs, a, lda, b, ldb, s,
656 $ rcond, crank, work, lwork, iwork,
659 $ CALL
alaerh( path,
'SGELSD', info, 0,
' ', m,
660 $ n, nrhs, -1, nb, itype, nfail,
666 CALL
saxpy( mnmin, -one, copys, 1, s, 1 )
667 result( 15 ) =
sasum( mnmin, s, 1 ) /
668 $
sasum( mnmin, copys, 1 ) /
669 $ ( eps*
REAL( MNMIN ) )
676 CALL
slacpy(
'Full', m, nrhs, copyb, ldb, work,
678 CALL
sqrt16(
'No transpose', m, n, nrhs, copya,
679 $ lda, b, ldb, work, ldwork,
680 $ work( m*nrhs+1 ), result( 16 ) )
686 $ result( 17 ) =
sqrt17(
'No transpose', 1, m,
687 $ n, nrhs, copya, lda, b, ldb,
688 $ copyb, ldb, c, work, lwork )
694 $ result( 18 ) =
sqrt14(
'No transpose', m, n,
695 $ nrhs, copya, lda, b, ldb,
702 IF( result( k ).GE.thresh )
THEN
703 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
704 $ CALL
alahd( nout, path )
705 WRITE( nout, fmt = 9998 )m, n, nrhs, nb,
706 $ itype, k, result( k )
721 CALL
alasvm( path, nout, nfail, nrun, nerrs )
723 9999 format(
' TRANS=''', a1,
''', M=', i5,
', N=', i5,
', NRHS=', i4,
724 $
', NB=', i4,
', type', i2,
', test(', i2,
')=', g12.5 )
725 9998 format(
' M=', i5,
', N=', i5,
', NRHS=', i4,
', NB=', i4,
726 $
', type', i2,
', test(', i2,
')=', g12.5 )