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 = 14 )
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 )
248 REAL SASUM, SLAMCH, SQRT12, SQRT14, SQRT17
249 EXTERNAL sasum, slamch, sqrt12, sqrt14, sqrt17
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 )
284 eps = slamch(
'Epsilon' )
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 )
445 CALL xlaenv( 3, nxval( inb ) )
462 lwlsy = max( 1, mnmin+2*n+nb*( n+1 ),
465 CALL slacpy(
'Full', m, n, copya, lda, a, lda )
466 CALL slacpy(
'Full', m, nrhs, copyb, ldb, b,
470 CALL sgelsy( m, n, nrhs, a, lda, b, ldb, iwork,
471 $ rcond, crank, work, lwlsy, info )
473 $
CALL alaerh( path,
'SGELSY', info, 0,
' ', m,
474 $ n, nrhs, -1, nb, itype, nfail,
480 result( 3 ) = sqrt12( crank, crank, a, lda,
481 $ copys, work, lwork )
486 CALL slacpy(
'Full', m, nrhs, copyb, ldb, work,
488 CALL sqrt16(
'No transpose', m, n, nrhs, copya,
489 $ lda, b, ldb, work, ldwork,
490 $ work( m*nrhs+1 ), result( 4 ) )
497 $ result( 5 ) = sqrt17(
'No transpose', 1, m,
498 $ n, nrhs, copya, lda, b, ldb,
499 $ copyb, ldb, c, work, lwork )
507 $ result( 6 ) = sqrt14(
'No transpose', m, n,
508 $ nrhs, copya, lda, b, ldb,
517 CALL slacpy(
'Full', m, n, copya, lda, a, lda )
518 CALL slacpy(
'Full', m, nrhs, copyb, ldb, b,
521 CALL sgelss( m, n, nrhs, a, lda, b, ldb, s,
522 $ rcond, crank, work, lwork, info )
524 $
CALL alaerh( path,
'SGELSS', info, 0,
' ', m,
525 $ n, nrhs, -1, nb, itype, nfail,
534 CALL saxpy( mnmin, -one, copys, 1, s, 1 )
535 result( 7 ) = sasum( mnmin, s, 1 ) /
536 $ sasum( mnmin, copys, 1 ) /
537 $ ( eps*
REAL( MNMIN ) )
544 CALL slacpy(
'Full', m, nrhs, copyb, ldb, work,
546 CALL sqrt16(
'No transpose', m, n, nrhs, copya,
547 $ lda, b, ldb, work, ldwork,
548 $ work( m*nrhs+1 ), result( 8 ) )
554 $ result( 9 ) = sqrt17(
'No transpose', 1, m,
555 $ n, nrhs, copya, lda, b, ldb,
556 $ copyb, ldb, c, work, lwork )
562 $ result( 10 ) = sqrt14(
'No transpose', m, n,
563 $ nrhs, copya, lda, b, ldb,
578 CALL slacpy(
'Full', m, n, copya, lda, a, lda )
579 CALL slacpy(
'Full', m, nrhs, copyb, ldb, b,
583 CALL sgelsd( m, n, nrhs, a, lda, b, ldb, s,
584 $ rcond, crank, work, lwork, iwork,
587 $
CALL alaerh( path,
'SGELSD', info, 0,
' ', m,
588 $ n, nrhs, -1, nb, itype, nfail,
594 CALL saxpy( mnmin, -one, copys, 1, s, 1 )
595 result( 11 ) = sasum( mnmin, s, 1 ) /
596 $ sasum( mnmin, copys, 1 ) /
597 $ ( eps*
REAL( MNMIN ) )
604 CALL slacpy(
'Full', m, nrhs, copyb, ldb, work,
606 CALL sqrt16(
'No transpose', m, n, nrhs, copya,
607 $ lda, b, ldb, work, ldwork,
608 $ work( m*nrhs+1 ), result( 12 ) )
614 $ result( 13 ) = sqrt17(
'No transpose', 1, m,
615 $ n, nrhs, copya, lda, b, ldb,
616 $ copyb, ldb, c, work, lwork )
622 $ result( 14 ) = sqrt14(
'No transpose', m, n,
623 $ nrhs, copya, lda, b, ldb,
630 IF( result( k ).GE.thresh )
THEN
631 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
632 $
CALL alahd( nout, path )
633 WRITE( nout, fmt = 9998 )m, n, nrhs, nb,
634 $ itype, k, result( k )
649 CALL alasvm( path, nout, nfail, nrun, nerrs )
651 9999
FORMAT(
' TRANS=''', a1,
''', M=', i5,
', N=', i5,
', NRHS=', i4,
652 $
', NB=', i4,
', type', i2,
', test(', i2,
')=', g12.5 )
653 9998
FORMAT(
' M=', i5,
', N=', i5,
', NRHS=', i4,
', NB=', i4,
654 $
', type', i2,
', test(', i2,
')=', g12.5 )
subroutine sqrt15(SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, RANK, NORMA, NORMB, ISEED, WORK, LWORK)
SQRT15
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
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 ...
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine sqrt16(TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SQRT16
subroutine sgels(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
SGELS solves overdetermined or underdetermined systems for GE matrices
subroutine sqrt13(SCALE, M, N, A, LDA, NORMA, ISEED)
SQRT13
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 saxpy(N, SA, SX, INCX, SY, INCY)
SAXPY
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 sscal(N, SA, SX, INCX)
SSCAL
subroutine serrls(PATH, NUNIT)
SERRLS