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 )
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 )
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
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 ...
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
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
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.
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.
subroutine sqrt13(SCALE, M, N, A, LDA, NORMA, ISEED)
SQRT13
subroutine sscal(N, SA, SX, INCX)
SSCAL