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 )
subroutine alahd(IOUNIT, PATH)
ALAHD
REAL function sqrt12(M, N, A, LDA, S, WORK, LWORK)
SQRT12
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine sgelsd(M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, IWORK, INFO)
SGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices ...
REAL function slamch(CMACH)
SLAMCH
subroutine sqrt16(TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SQRT16
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine sgelss(M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, INFO)
SGELSS solves overdetermined or underdetermined systems for GE matrices
subroutine sgels(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
SGELS solves overdetermined or underdetermined systems for GE matrices
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine sqrt15(SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, RANK, NORMA, NORMB, ISEED, WORK, LWORK)
SQRT15
subroutine saxpy(N, SA, SX, INCX, SY, INCY)
SAXPY
REAL function sqrt14(TRANS, M, N, NRHS, A, LDA, X, LDX, WORK, LWORK)
SQRT14
subroutine sdrvls(DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, COPYB, C, S, COPYS, WORK, IWORK, NOUT)
SDRVLS
subroutine sgelsy(M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, INFO)
SGELSY solves overdetermined or underdetermined systems for GE matrices
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
REAL function sqrt17(TRANS, IRESID, M, N, NRHS, A, LDA, X, LDX, B, LDB, C, WORK, LWORK)
SQRT17
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
subroutine sgelsx(M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, INFO)
SGELSX solves overdetermined or underdetermined systems for GE matrices
subroutine serrls(PATH, NUNIT)
SERRLS
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
REAL function sasum(N, SX, INCX)
SASUM
subroutine sqrt13(SCALE, M, N, A, LDA, NORMA, ISEED)
SQRT13
subroutine sscal(N, SA, SX, INCX)
SSCAL