219 INTEGER nm, nn, nnb, nns, nout
220 DOUBLE PRECISION thresh
224 INTEGER iwork( * ), mval( * ), nbval( * ), nsval( * ),
225 $ nval( * ), nxval( * )
226 DOUBLE PRECISION copys( * ), rwork( * ), s( * )
227 COMPLEX*16 a( * ), b( * ), c( * ), copya( * ), copyb( * ),
235 parameter( ntests = 18 )
237 parameter( smlsiz = 25 )
238 DOUBLE PRECISION one, zero
239 parameter( one = 1.0d+0, zero = 0.0d+0 )
240 COMPLEX*16 cone, czero
241 parameter( cone = ( 1.0d+0, 0.0d+0 ),
242 $ czero = ( 0.0d+0, 0.0d+0 ) )
247 INTEGER crank, i, im, in, inb, info, ins, irank,
248 $ iscale, itran, itype, j, k, lda, ldb, ldwork,
249 $ lwlsy, lwork, m, mnmin, n, nb, ncols, nerrs,
250 $ nfail, nrhs, nrows, nrun, rank
251 DOUBLE PRECISION eps, norma, normb, rcond
254 INTEGER iseed( 4 ), iseedy( 4 )
255 DOUBLE PRECISION result( ntests )
268 INTRINSIC dble, max, min, sqrt
273 INTEGER infot, iounit
276 COMMON / infoc / infot, iounit, ok, lerr
277 COMMON / srnamc / srnamt
280 DATA iseedy / 1988, 1989, 1990, 1991 /
286 path( 1: 1 ) =
'Zomplex precision'
292 iseed( i ) = iseedy( i )
298 rcond = sqrt( eps ) - ( sqrt( eps )-eps ) / 2
304 $
CALL zerrls( path, nout )
308 IF( ( nm.EQ.0 .OR. nn.EQ.0 ) .AND. thresh.EQ.zero )
309 $
CALL alahd( nout, path )
323 lwork = max( 1, ( m+nrhs )*( n+2 ), ( n+nrhs )*( m+2 ),
324 $ m*n+4*mnmin+max( m, n ), 2*n+m )
328 itype = ( irank-1 )*3 + iscale
329 IF( .NOT.dotype( itype ) )
332 IF( irank.EQ.1 )
THEN
338 CALL zqrt13( iscale, m, n, copya, lda, norma,
343 CALL xlaenv( 3, nxval( inb ) )
346 IF( itran.EQ.1 )
THEN
355 ldwork = max( 1, ncols )
359 IF( ncols.GT.0 )
THEN
360 CALL zlarnv( 2, iseed, ncols*nrhs,
363 $ one / dble( ncols ), work,
366 CALL zgemm( trans,
'No transpose', nrows,
367 $ nrhs, ncols, cone, copya, lda,
368 $ work, ldwork, czero, b, ldb )
369 CALL zlacpy(
'Full', nrows, nrhs, b, ldb,
374 IF( m.GT.0 .AND. n.GT.0 )
THEN
375 CALL zlacpy(
'Full', m, n, copya, lda,
377 CALL zlacpy(
'Full', nrows, nrhs,
378 $ copyb, ldb, b, ldb )
381 CALL zgels( trans, m, n, nrhs, a, lda, b,
382 $ ldb, work, lwork, info )
385 $
CALL alaerh( path,
'ZGELS ', info, 0,
386 $ trans, m, n, nrhs, -1, nb,
387 $ itype, nfail, nerrs,
392 ldwork = max( 1, nrows )
393 IF( nrows.GT.0 .AND. nrhs.GT.0 )
394 $
CALL zlacpy(
'Full', nrows, nrhs,
395 $ copyb, ldb, c, ldb )
396 CALL zqrt16( trans, m, n, nrhs, copya,
397 $ lda, b, ldb, c, ldb, rwork,
400 IF( ( itran.EQ.1 .AND. m.GE.n ) .OR.
401 $ ( itran.EQ.2 .AND. m.LT.n ) )
THEN
405 result( 2 ) =
zqrt17( trans, 1, m, n,
406 $ nrhs, copya, lda, b, ldb,
407 $ copyb, ldb, c, work,
413 result( 2 ) =
zqrt14( trans, m, n,
414 $ nrhs, copya, lda, b, ldb,
422 IF( result( k ).GE.thresh )
THEN
423 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
424 $
CALL alahd( nout, path )
425 WRITE( nout, fmt = 9999 )trans, m,
426 $ n, nrhs, nb, itype, k,
439 CALL zqrt15( iscale, irank, m, n, nrhs, copya, lda,
440 $ copyb, ldb, copys, rank, norma, normb,
441 $ iseed, work, lwork )
456 CALL zlacpy(
'Full', m, n, copya, lda, a, lda )
457 CALL zlacpy(
'Full', m, nrhs, copyb, ldb, b, ldb )
460 CALL zgelsx( m, n, nrhs, a, lda, b, ldb, iwork,
461 $ rcond, crank, work, rwork, info )
464 $
CALL alaerh( path,
'ZGELSX', info, 0,
' ', m, n,
465 $ nrhs, -1, nb, itype, nfail, nerrs,
473 result( 3 ) =
zqrt12( crank, crank, a, lda, copys,
474 $ work, lwork, rwork )
479 CALL zlacpy(
'Full', m, nrhs, copyb, ldb, work,
481 CALL zqrt16(
'No transpose', m, n, nrhs, copya,
482 $ lda, b, ldb, work, ldwork, rwork,
490 $ result( 5 ) =
zqrt17(
'No transpose', 1, m, n,
491 $ nrhs, copya, lda, b, ldb, copyb,
492 $ ldb, c, work, lwork )
500 $ result( 6 ) =
zqrt14(
'No transpose', m, n,
501 $ nrhs, copya, lda, b, ldb, work,
508 IF( result( k ).GE.thresh )
THEN
509 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
510 $
CALL alahd( nout, path )
511 WRITE( nout, fmt = 9998 )m, n, nrhs, 0,
512 $ itype, k, result( k )
523 CALL xlaenv( 3, nxval( inb ) )
532 CALL zlacpy(
'Full', m, n, copya, lda, a, lda )
533 CALL zlacpy(
'Full', m, nrhs, copyb, ldb, b,
544 lwlsy = mnmin + max( 2*mnmin, nb*( n+1 ),
546 lwlsy = max( 1, lwlsy )
549 CALL zgelsy( m, n, nrhs, a, lda, b, ldb, iwork,
550 $ rcond, crank, work, lwlsy, rwork,
553 $
CALL alaerh( path,
'ZGELSY', info, 0,
' ', m,
554 $ n, nrhs, -1, nb, itype, nfail,
562 result( 7 ) =
zqrt12( crank, crank, a, lda,
563 $ copys, work, lwork, rwork )
568 CALL zlacpy(
'Full', m, nrhs, copyb, ldb, work,
570 CALL zqrt16(
'No transpose', m, n, nrhs, copya,
571 $ lda, b, ldb, work, ldwork, rwork,
579 $ result( 9 ) =
zqrt17(
'No transpose', 1, m,
580 $ n, nrhs, copya, lda, b, ldb,
581 $ copyb, ldb, c, work, lwork )
589 $ result( 10 ) =
zqrt14(
'No transpose', m, n,
590 $ nrhs, copya, lda, b, ldb,
599 CALL zlacpy(
'Full', m, n, copya, lda, a, lda )
600 CALL zlacpy(
'Full', m, nrhs, copyb, ldb, b,
603 CALL zgelss( m, n, nrhs, a, lda, b, ldb, s,
604 $ rcond, crank, work, lwork, rwork,
608 $
CALL alaerh( path,
'ZGELSS', info, 0,
' ', m,
609 $ n, nrhs, -1, nb, itype, nfail,
618 CALL daxpy( mnmin, -one, copys, 1, s, 1 )
619 result( 11 ) =
dasum( mnmin, s, 1 ) /
620 $
dasum( mnmin, copys, 1 ) /
621 $ ( eps*dble( mnmin ) )
628 CALL zlacpy(
'Full', m, nrhs, copyb, ldb, work,
630 CALL zqrt16(
'No transpose', m, n, nrhs, copya,
631 $ lda, b, ldb, work, ldwork, rwork,
638 $ result( 13 ) =
zqrt17(
'No transpose', 1, m,
639 $ n, nrhs, copya, lda, b, ldb,
640 $ copyb, ldb, c, work, lwork )
646 $ result( 14 ) =
zqrt14(
'No transpose', m, n,
647 $ nrhs, copya, lda, b, ldb,
658 CALL zlacpy(
'Full', m, n, copya, lda, a, lda )
659 CALL zlacpy(
'Full', m, nrhs, copyb, ldb, b,
663 CALL zgelsd( m, n, nrhs, a, lda, b, ldb, s,
664 $ rcond, crank, work, lwork, rwork,
667 $
CALL alaerh( path,
'ZGELSD', info, 0,
' ', m,
668 $ n, nrhs, -1, nb, itype, nfail,
674 CALL daxpy( mnmin, -one, copys, 1, s, 1 )
675 result( 15 ) =
dasum( mnmin, s, 1 ) /
676 $
dasum( mnmin, copys, 1 ) /
677 $ ( eps*dble( mnmin ) )
684 CALL zlacpy(
'Full', m, nrhs, copyb, ldb, work,
686 CALL zqrt16(
'No transpose', m, n, nrhs, copya,
687 $ lda, b, ldb, work, ldwork, rwork,
694 $ result( 17 ) =
zqrt17(
'No transpose', 1, m,
695 $ n, nrhs, copya, lda, b, ldb,
696 $ copyb, ldb, c, work, lwork )
702 $ result( 18 ) =
zqrt14(
'No transpose', m, n,
703 $ nrhs, copya, lda, b, ldb,
710 IF( result( k ).GE.thresh )
THEN
711 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
712 $
CALL alahd( nout, path )
713 WRITE( nout, fmt = 9998 )m, n, nrhs, nb,
714 $ itype, k, result( k )
729 CALL alasvm( path, nout, nfail, nrun, nerrs )
731 9999
FORMAT(
' TRANS=''', a1,
''', M=', i5,
', N=', i5,
', NRHS=', i4,
732 $
', NB=', i4,
', type', i2,
', test(', i2,
')=', g12.5 )
733 9998
FORMAT(
' M=', i5,
', N=', i5,
', NRHS=', i4,
', NB=', i4,
734 $
', type', i2,
', test(', i2,
')=', g12.5 )
subroutine dlasrt(ID, N, D, INFO)
DLASRT sorts numbers in increasing or decreasing order.
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
double precision function zqrt12(M, N, A, LDA, S, WORK, LWORK, RWORK)
ZQRT12
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
double precision function zqrt14(TRANS, M, N, NRHS, A, LDA, X, LDX, WORK, LWORK)
ZQRT14
subroutine zgelsx(M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, RWORK, INFO)
ZGELSX solves overdetermined or underdetermined systems for GE matrices
subroutine zgelsy(M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO)
ZGELSY solves overdetermined or underdetermined systems for GE matrices
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
subroutine zqrt15(SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, RANK, NORMA, NORMB, ISEED, WORK, LWORK)
ZQRT15
subroutine zqrt16(TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
ZQRT16
double precision function zqrt17(TRANS, IRESID, M, N, NRHS, A, LDA, X, LDX, B, LDB, C, WORK, LWORK)
ZQRT17
subroutine zgelss(M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, INFO)
ZGELSS solves overdetermined or underdetermined systems for GE matrices
subroutine zlarnv(IDIST, ISEED, N, X)
ZLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
double precision function dlamch(CMACH)
DLAMCH
subroutine daxpy(N, DA, DX, INCX, DY, INCY)
DAXPY
subroutine zqrt13(SCALE, M, N, A, LDA, NORMA, ISEED)
ZQRT13
subroutine zgelsd(M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, IWORK, INFO)
ZGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices ...
double precision function dasum(N, DX, INCX)
DASUM
subroutine zerrls(PATH, NUNIT)
ZERRLS
subroutine zgels(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
ZGELS solves overdetermined or underdetermined systems for GE matrices