208 SUBROUTINE zdrvls( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
209 $ nbval, nxval, thresh, tsterr, a, copya,
b,
210 $ copyb, c, s, copys, work, rwork, iwork, nout )
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
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine zdrvls(DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, COPYB, C, S, COPYS, WORK, RWORK, IWORK, NOUT)
ZDRVLS
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
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
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