191 SUBROUTINE sdrvls( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
192 $ nbval, nxval, thresh, tsterr, a, copya, b,
193 $ copyb, c, s, copys, nout )
202 INTEGER NM, NN, NNB, NNS, NOUT
207 INTEGER MVAL( * ), NBVAL( * ), NSVAL( * ),
208 $ nval( * ), nxval( * )
209 REAL A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ),
217 parameter ( ntests = 16 )
219 parameter ( smlsiz = 25 )
221 parameter ( one = 1.0e0, two = 2.0e0, zero = 0.0e0 )
226 INTEGER CRANK, I, IM, IMB, IN, INB, INFO, INS, IRANK,
227 $ iscale, itran, itype, j, k, lda, ldb, ldwork,
228 $ lwlsy, lwork, m, mnmin, n, nb, ncols, nerrs,
229 $ nfail, nrhs, nrows, nrun, rank, mb,
230 $ mmax, nmax, nsmax, liwork,
231 $ lwork_sgels, lwork_sgetsls, lwork_sgelss,
232 $ lwork_sgelsy, lwork_sgelsd
233 REAL EPS, NORMA, NORMB, RCOND
236 INTEGER ISEED( 4 ), ISEEDY( 4 ), IWORKQUERY
237 REAL RESULT( ntests ), WORKQUERY
240 REAL,
ALLOCATABLE :: WORK (:)
241 INTEGER,
ALLOCATABLE :: IWORK (:)
244 REAL SASUM, SLAMCH, SQRT12, SQRT14, SQRT17
245 EXTERNAL sasum, slamch, sqrt12, sqrt14, sqrt17
254 INTRINSIC int, log, max, min,
REAL, SQRT
259 INTEGER INFOT, IOUNIT
262 COMMON / infoc / infot, iounit, ok, lerr
263 COMMON / srnamc / srnamt
266 DATA iseedy / 1988, 1989, 1990, 1991 /
272 path( 1: 1 ) =
'SINGLE PRECISION'
278 iseed( i ) = iseedy( i )
280 eps = slamch(
'Epsilon' )
284 rcond = sqrt( eps ) - ( sqrt( eps )-eps ) / 2
291 $
CALL serrls( path, nout )
295 IF( ( nm.EQ.0 .OR. nn.EQ.0 ) .AND. thresh.EQ.zero )
296 $
CALL alahd( nout, path )
307 IF ( mval( i ).GT.mmax )
THEN
312 IF ( nval( i ).GT.nmax )
THEN
317 IF ( nsval( i ).GT.nsmax )
THEN
326 mnmin = max( min( m, n ), 1 )
331 lwork = max( ( m+n )*nrhs,
332 $ ( n+nrhs )*( m+2 ), ( m+nrhs )*( n+2 ),
333 $ max( m+mnmin, nrhs*mnmin,2*n+m ),
334 $ max( m*n+4*mnmin+max(m,n), m*n+2*mnmin+4*n ) )
337 CALL sgels(
'N', m, n, nrhs, a, lda, b, ldb,
338 $ workquery, -1, info )
339 lwork_sgels = int( workquery )
341 CALL sgetsls(
'N', m, n, nrhs, a, lda, b, ldb,
342 $ workquery, -1, info )
343 lwork_sgetsls = int( workquery )
345 CALL sgelsy( m, n, nrhs, a, lda, b, ldb, iworkquery,
346 $ rcond, crank, workquery, -1, info )
347 lwork_sgelsy = int( workquery )
349 CALL sgelss( m, n, nrhs, a, lda, b, ldb, s,
350 $ rcond, crank, workquery, -1 , info )
351 lwork_sgelss = int( workquery )
353 CALL sgelsd( m, n, nrhs, a, lda, b, ldb, s,
354 $ rcond, crank, workquery, -1, iworkquery, info )
355 lwork_sgelsd = int( workquery )
357 liwork = max( 1, n, iworkquery )
359 lwork = max( 1, lwork, lwork_sgels, lwork_sgetsls, lwork_sgelsy,
360 $ lwork_sgelss, lwork_sgelsd )
363 ALLOCATE( work( lwork ) )
364 ALLOCATE( iwork( liwork ) )
372 mnmin = max(min( m, n ),1)
381 itype = ( irank-1 )*3 + iscale
382 IF( .NOT.dotype( itype ) )
385 IF( irank.EQ.1 )
THEN
391 CALL sqrt13( iscale, m, n, copya, lda, norma,
396 CALL xlaenv( 3, nxval( inb ) )
399 IF( itran.EQ.1 )
THEN
408 ldwork = max( 1, ncols )
412 IF( ncols.GT.0 )
THEN
413 CALL slarnv( 2, iseed, ncols*nrhs,
415 CALL sscal( ncols*nrhs,
416 $ one /
REAL( NCOLS ), WORK,
419 CALL sgemm( trans,
'No transpose', nrows,
420 $ nrhs, ncols, one, copya, lda,
421 $ work, ldwork, zero, b, ldb )
422 CALL slacpy(
'Full', nrows, nrhs, b, ldb,
427 IF( m.GT.0 .AND. n.GT.0 )
THEN
428 CALL slacpy(
'Full', m, n, copya, lda,
430 CALL slacpy(
'Full', nrows, nrhs,
431 $ copyb, ldb, b, ldb )
434 CALL sgels( trans, m, n, nrhs, a, lda, b,
435 $ ldb, work, lwork, info )
437 $
CALL alaerh( path,
'SGELS ', info, 0,
438 $ trans, m, n, nrhs, -1, nb,
439 $ itype, nfail, nerrs,
444 ldwork = max( 1, nrows )
445 IF( nrows.GT.0 .AND. nrhs.GT.0 )
446 $
CALL slacpy(
'Full', nrows, nrhs,
447 $ copyb, ldb, c, ldb )
448 CALL sqrt16( trans, m, n, nrhs, copya,
449 $ lda, b, ldb, c, ldb, work,
452 IF( ( itran.EQ.1 .AND. m.GE.n ) .OR.
453 $ ( itran.EQ.2 .AND. m.LT.n ) )
THEN
457 result( 2 ) = sqrt17( trans, 1, m, n,
458 $ nrhs, copya, lda, b, ldb,
459 $ copyb, ldb, c, work,
465 result( 2 ) = sqrt14( trans, m, n,
466 $ nrhs, copya, lda, b, ldb,
474 IF( result( k ).GE.thresh )
THEN
475 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
476 $
CALL alahd( nout, path )
477 WRITE( nout, fmt = 9999 )trans, m,
478 $ n, nrhs, nb, itype, k,
492 CALL sqrt13( iscale, m, n, copya, lda, norma,
502 IF( itran.EQ.1 )
THEN
511 ldwork = max( 1, ncols )
515 IF( ncols.GT.0 )
THEN
516 CALL slarnv( 2, iseed, ncols*nrhs,
518 CALL sscal( ncols*nrhs,
519 $ one /
REAL( NCOLS ), WORK,
522 CALL sgemm( trans,
'No transpose', nrows,
523 $ nrhs, ncols, one, copya, lda,
524 $ work, ldwork, zero, b, ldb )
525 CALL slacpy(
'Full', nrows, nrhs, b, ldb,
530 IF( m.GT.0 .AND. n.GT.0 )
THEN
531 CALL slacpy(
'Full', m, n, copya, lda,
533 CALL slacpy(
'Full', nrows, nrhs,
534 $ copyb, ldb, b, ldb )
537 CALL sgetsls( trans, m, n, nrhs, a,
538 $ lda, b, ldb, work, lwork, info )
540 $
CALL alaerh( path,
'SGETSLS ', info, 0,
541 $ trans, m, n, nrhs, -1, nb,
542 $ itype, nfail, nerrs,
547 ldwork = max( 1, nrows )
548 IF( nrows.GT.0 .AND. nrhs.GT.0 )
549 $
CALL slacpy(
'Full', nrows, nrhs,
550 $ copyb, ldb, c, ldb )
551 CALL sqrt16( trans, m, n, nrhs, copya,
552 $ lda, b, ldb, c, ldb, work,
555 IF( ( itran.EQ.1 .AND. m.GE.n ) .OR.
556 $ ( itran.EQ.2 .AND. m.LT.n ) )
THEN
560 result( 16 ) = sqrt17( trans, 1, m, n,
561 $ nrhs, copya, lda, b, ldb,
562 $ copyb, ldb, c, work,
568 result( 16 ) = sqrt14( trans, m, n,
569 $ nrhs, copya, lda, b, ldb,
577 IF( result( k ).GE.thresh )
THEN
578 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
579 $
CALL alahd( nout, path )
580 WRITE( nout, fmt = 9997 )trans, m,
581 $ n, nrhs, mb, nb, itype, k,
595 CALL sqrt15( iscale, irank, m, n, nrhs, copya, lda,
596 $ copyb, ldb, copys, rank, norma, normb,
597 $ iseed, work, lwork )
608 CALL xlaenv( 3, nxval( inb ) )
623 CALL slacpy(
'Full', m, n, copya, lda, a, lda )
624 CALL slacpy(
'Full', m, nrhs, copyb, ldb, b,
628 CALL sgelsy( m, n, nrhs, a, lda, b, ldb, iwork,
629 $ rcond, crank, work, lwlsy, info )
631 $
CALL alaerh( path,
'SGELSY', info, 0,
' ', m,
632 $ n, nrhs, -1, nb, itype, nfail,
638 result( 3 ) = sqrt12( crank, crank, a, lda,
639 $ copys, work, lwork )
644 CALL slacpy(
'Full', m, nrhs, copyb, ldb, work,
646 CALL sqrt16(
'No transpose', m, n, nrhs, copya,
647 $ lda, b, ldb, work, ldwork,
648 $ work( m*nrhs+1 ), result( 4 ) )
655 $ result( 5 ) = sqrt17(
'No transpose', 1, m,
656 $ n, nrhs, copya, lda, b, ldb,
657 $ copyb, ldb, c, work, lwork )
665 $ result( 6 ) = sqrt14(
'No transpose', m, n,
666 $ nrhs, copya, lda, b, ldb,
675 CALL slacpy(
'Full', m, n, copya, lda, a, lda )
676 CALL slacpy(
'Full', m, nrhs, copyb, ldb, b,
679 CALL sgelss( m, n, nrhs, a, lda, b, ldb, s,
680 $ rcond, crank, work, lwork, info )
682 $
CALL alaerh( path,
'SGELSS', info, 0,
' ', m,
683 $ n, nrhs, -1, nb, itype, nfail,
692 CALL saxpy( mnmin, -one, copys, 1, s, 1 )
693 result( 7 ) = sasum( mnmin, s, 1 ) /
694 $ sasum( mnmin, copys, 1 ) /
695 $ ( eps*
REAL( MNMIN ) )
702 CALL slacpy(
'Full', m, nrhs, copyb, ldb, work,
704 CALL sqrt16(
'No transpose', m, n, nrhs, copya,
705 $ lda, b, ldb, work, ldwork,
706 $ work( m*nrhs+1 ), result( 8 ) )
712 $ result( 9 ) = sqrt17(
'No transpose', 1, m,
713 $ n, nrhs, copya, lda, b, ldb,
714 $ copyb, ldb, c, work, lwork )
720 $ result( 10 ) = sqrt14(
'No transpose', m, n,
721 $ nrhs, copya, lda, b, ldb,
736 CALL slacpy(
'Full', m, n, copya, lda, a, lda )
737 CALL slacpy(
'Full', m, nrhs, copyb, ldb, b,
741 CALL sgelsd( m, n, nrhs, a, lda, b, ldb, s,
742 $ rcond, crank, work, lwork, iwork,
745 $
CALL alaerh( path,
'SGELSD', info, 0,
' ', m,
746 $ n, nrhs, -1, nb, itype, nfail,
752 CALL saxpy( mnmin, -one, copys, 1, s, 1 )
753 result( 11 ) = sasum( mnmin, s, 1 ) /
754 $ sasum( mnmin, copys, 1 ) /
755 $ ( eps*
REAL( MNMIN ) )
762 CALL slacpy(
'Full', m, nrhs, copyb, ldb, work,
764 CALL sqrt16(
'No transpose', m, n, nrhs, copya,
765 $ lda, b, ldb, work, ldwork,
766 $ work( m*nrhs+1 ), result( 12 ) )
772 $ result( 13 ) = sqrt17(
'No transpose', 1, m,
773 $ n, nrhs, copya, lda, b, ldb,
774 $ copyb, ldb, c, work, lwork )
780 $ result( 14 ) = sqrt14(
'No transpose', m, n,
781 $ nrhs, copya, lda, b, ldb,
788 IF( result( k ).GE.thresh )
THEN
789 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
790 $
CALL alahd( nout, path )
791 WRITE( nout, fmt = 9998 )m, n, nrhs, nb,
792 $ itype, k, result( k )
807 CALL alasvm( path, nout, nfail, nrun, nerrs )
809 9999
FORMAT(
' TRANS=''', a1,
''', M=', i5,
', N=', i5,
', NRHS=', i4,
810 $
', NB=', i4,
', type', i2,
', test(', i2,
')=', g12.5 )
811 9998
FORMAT(
' M=', i5,
', N=', i5,
', NRHS=', i4,
', NB=', i4,
812 $
', type', i2,
', test(', i2,
')=', g12.5 )
813 9997
FORMAT(
' TRANS=''', a1,
' M=', i5,
', N=', i5,
', NRHS=', i4,
814 $
', MB=', i4,
', NB=', i4,
', type', i2,
815 $
', 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 sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine sdrvls(DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, COPYB, C, S, COPYS, NOUT)
SDRVLS
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 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 slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
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 slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine serrls(PATH, NUNIT)
SERRLS
subroutine sgetsls(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)