209 SUBROUTINE cdrvls( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
210 $ nbval, nxval, thresh, tsterr, a, copya,
b,
211 $ copyb, c, s, copys, work, rwork, iwork,
221 INTEGER nm, nn, nnb, nns, nout
226 INTEGER iwork( * ), mval( * ), nbval( * ), nsval( * ),
227 $ nval( * ), nxval( * )
228 REAL copys( * ), rwork( * ), s( * )
229 COMPLEX a( * ),
b( * ), c( * ), copya( * ), copyb( * ),
237 parameter( ntests = 18 )
239 parameter( smlsiz = 25 )
241 parameter( one = 1.0e+0, zero = 0.0e+0 )
243 parameter( cone = ( 1.0e+0, 0.0e+0 ),
244 $ czero = ( 0.0e+0, 0.0e+0 ) )
249 INTEGER crank, i, im, in, inb, info, ins, irank,
250 $ iscale, itran, itype,
j, k, lda, ldb, ldwork,
251 $ lwlsy, lwork, m, mnmin, n, nb, ncols, nerrs,
252 $ nfail, nrhs, nrows, nrun, rank
253 REAL eps, norma, normb, rcond
256 INTEGER iseed( 4 ), iseedy( 4 )
257 REAL result( ntests )
270 INTRINSIC max, min,
REAL, sqrt
275 INTEGER infot, iounit
278 COMMON / infoc / infot, iounit, ok, lerr
279 COMMON / srnamc / srnamt
282 DATA iseedy / 1988, 1989, 1990, 1991 /
288 path( 1: 1 ) =
'Complex precision'
294 iseed( i ) = iseedy( i )
300 rcond = sqrt( eps ) - ( sqrt( eps )-eps ) / 2
306 $ CALL
cerrls( path, nout )
310 IF( ( nm.EQ.0 .OR. nn.EQ.0 ) .AND. thresh.EQ.zero )
311 $ CALL
alahd( nout, path )
325 lwork = max( 1, ( m+nrhs )*( n+2 ), ( n+nrhs )*( m+2 ),
326 $ m*n+4*mnmin+max( m, n ), 2*n+m )
330 itype = ( irank-1 )*3 + iscale
331 IF( .NOT.dotype( itype ) )
334 IF( irank.EQ.1 )
THEN
340 CALL
cqrt13( iscale, m, n, copya, lda, norma,
345 CALL
xlaenv( 3, nxval( inb ) )
348 IF( itran.EQ.1 )
THEN
357 ldwork = max( 1, ncols )
361 IF( ncols.GT.0 )
THEN
362 CALL
clarnv( 2, iseed, ncols*nrhs,
365 $ one /
REAL( NCOLS ), work,
368 CALL
cgemm( trans,
'No transpose', nrows,
369 $ nrhs, ncols, cone, copya, lda,
370 $ work, ldwork, czero,
b, ldb )
371 CALL
clacpy(
'Full', nrows, nrhs,
b, ldb,
376 IF( m.GT.0 .AND. n.GT.0 )
THEN
377 CALL
clacpy(
'Full', m, n, copya, lda,
379 CALL
clacpy(
'Full', nrows, nrhs,
380 $ copyb, ldb,
b, ldb )
383 CALL
cgels( trans, m, n, nrhs, a, lda,
b,
384 $ ldb, work, lwork, info )
387 $ CALL
alaerh( path,
'CGELS ', info, 0,
388 $ trans, m, n, nrhs, -1, nb,
389 $ itype, nfail, nerrs,
394 ldwork = max( 1, nrows )
395 IF( nrows.GT.0 .AND. nrhs.GT.0 )
396 $ CALL
clacpy(
'Full', nrows, nrhs,
397 $ copyb, ldb, c, ldb )
398 CALL
cqrt16( trans, m, n, nrhs, copya,
399 $ lda,
b, ldb, c, ldb, rwork,
402 IF( ( itran.EQ.1 .AND. m.GE.n ) .OR.
403 $ ( itran.EQ.2 .AND. m.LT.n ) )
THEN
407 result( 2 ) =
cqrt17( trans, 1, m, n,
408 $ nrhs, copya, lda,
b, ldb,
409 $ copyb, ldb, c, work,
415 result( 2 ) =
cqrt14( trans, m, n,
416 $ nrhs, copya, lda,
b, ldb,
424 IF( result( k ).GE.thresh )
THEN
425 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
426 $ CALL
alahd( nout, path )
427 WRITE( nout, fmt = 9999 )trans, m,
428 $ n, nrhs, nb, itype, k,
441 CALL
cqrt15( iscale, irank, m, n, nrhs, copya, lda,
442 $ copyb, ldb, copys, rank, norma, normb,
443 $ iseed, work, lwork )
458 CALL
clacpy(
'Full', m, n, copya, lda, a, lda )
459 CALL
clacpy(
'Full', m, nrhs, copyb, ldb,
b, ldb )
462 CALL
cgelsx( m, n, nrhs, a, lda,
b, ldb, iwork,
463 $ rcond, crank, work, rwork, info )
466 $ CALL
alaerh( path,
'CGELSX', info, 0,
' ', m, n,
467 $ nrhs, -1, nb, itype, nfail, nerrs,
475 result( 3 ) =
cqrt12( crank, crank, a, lda, copys,
476 $ work, lwork, rwork )
481 CALL
clacpy(
'Full', m, nrhs, copyb, ldb, work,
483 CALL
cqrt16(
'No transpose', m, n, nrhs, copya,
484 $ lda,
b, ldb, work, ldwork, rwork,
492 $ result( 5 ) =
cqrt17(
'No transpose', 1, m, n,
493 $ nrhs, copya, lda,
b, ldb, copyb,
494 $ ldb, c, work, lwork )
502 $ result( 6 ) =
cqrt14(
'No transpose', m, n,
503 $ nrhs, copya, lda,
b, ldb, work,
510 IF( result( k ).GE.thresh )
THEN
511 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
512 $ CALL
alahd( nout, path )
513 WRITE( nout, fmt = 9998 )m, n, nrhs, 0,
514 $ itype, k, result( k )
525 CALL
xlaenv( 3, nxval( inb ) )
534 CALL
clacpy(
'Full', m, n, copya, lda, a, lda )
535 CALL
clacpy(
'Full', m, nrhs, copyb, ldb,
b,
546 lwlsy = mnmin + max( 2*mnmin, nb*( n+1 ),
548 lwlsy = max( 1, lwlsy )
551 CALL
cgelsy( m, n, nrhs, a, lda,
b, ldb, iwork,
552 $ rcond, crank, work, lwlsy, rwork,
555 $ CALL
alaerh( path,
'CGELSY', info, 0,
' ', m,
556 $ n, nrhs, -1, nb, itype, nfail,
564 result( 7 ) =
cqrt12( crank, crank, a, lda,
565 $ copys, work, lwork, rwork )
570 CALL
clacpy(
'Full', m, nrhs, copyb, ldb, work,
572 CALL
cqrt16(
'No transpose', m, n, nrhs, copya,
573 $ lda,
b, ldb, work, ldwork, rwork,
581 $ result( 9 ) =
cqrt17(
'No transpose', 1, m,
582 $ n, nrhs, copya, lda,
b, ldb,
583 $ copyb, ldb, c, work, lwork )
591 $ result( 10 ) =
cqrt14(
'No transpose', m, n,
592 $ nrhs, copya, lda,
b, ldb,
601 CALL
clacpy(
'Full', m, n, copya, lda, a, lda )
602 CALL
clacpy(
'Full', m, nrhs, copyb, ldb,
b,
605 CALL
cgelss( m, n, nrhs, a, lda,
b, ldb, s,
606 $ rcond, crank, work, lwork, rwork,
610 $ CALL
alaerh( path,
'CGELSS', info, 0,
' ', m,
611 $ n, nrhs, -1, nb, itype, nfail,
620 CALL
saxpy( mnmin, -one, copys, 1, s, 1 )
621 result( 11 ) =
sasum( mnmin, s, 1 ) /
622 $
sasum( mnmin, copys, 1 ) /
623 $ ( eps*
REAL( MNMIN ) )
630 CALL
clacpy(
'Full', m, nrhs, copyb, ldb, work,
632 CALL
cqrt16(
'No transpose', m, n, nrhs, copya,
633 $ lda,
b, ldb, work, ldwork, rwork,
640 $ result( 13 ) =
cqrt17(
'No transpose', 1, m,
641 $ n, nrhs, copya, lda,
b, ldb,
642 $ copyb, ldb, c, work, lwork )
648 $ result( 14 ) =
cqrt14(
'No transpose', m, n,
649 $ nrhs, copya, lda,
b, ldb,
660 CALL
clacpy(
'Full', m, n, copya, lda, a, lda )
661 CALL
clacpy(
'Full', m, nrhs, copyb, ldb,
b,
665 CALL
cgelsd( m, n, nrhs, a, lda,
b, ldb, s,
666 $ rcond, crank, work, lwork, rwork,
669 $ CALL
alaerh( path,
'CGELSD', info, 0,
' ', m,
670 $ n, nrhs, -1, nb, itype, nfail,
676 CALL
saxpy( mnmin, -one, copys, 1, s, 1 )
677 result( 15 ) =
sasum( mnmin, s, 1 ) /
678 $
sasum( mnmin, copys, 1 ) /
679 $ ( eps*
REAL( MNMIN ) )
686 CALL
clacpy(
'Full', m, nrhs, copyb, ldb, work,
688 CALL
cqrt16(
'No transpose', m, n, nrhs, copya,
689 $ lda,
b, ldb, work, ldwork, rwork,
696 $ result( 17 ) =
cqrt17(
'No transpose', 1, m,
697 $ n, nrhs, copya, lda,
b, ldb,
698 $ copyb, ldb, c, work, lwork )
704 $ result( 18 ) =
cqrt14(
'No transpose', m, n,
705 $ nrhs, copya, lda,
b, ldb,
712 IF( result( k ).GE.thresh )
THEN
713 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
714 $ CALL
alahd( nout, path )
715 WRITE( nout, fmt = 9998 )m, n, nrhs, nb,
716 $ itype, k, result( k )
731 CALL
alasvm( path, nout, nfail, nrun, nerrs )
733 9999
FORMAT(
' TRANS=''', a1,
''', M=', i5,
', N=', i5,
', NRHS=', i4,
734 $
', NB=', i4,
', type', i2,
', test(', i2,
')=', g12.5 )
735 9998
FORMAT(
' M=', i5,
', N=', i5,
', NRHS=', i4,
', NB=', i4,
736 $
', type', i2,
', test(', i2,
')=', g12.5 )
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine cdrvls(DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, COPYB, C, S, COPYS, WORK, RWORK, IWORK, NOUT)
CDRVLS
real function cqrt14(TRANS, M, N, NRHS, A, LDA, X, LDX, WORK, LWORK)
CQRT14
subroutine cgelsy(M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO)
CGELSY solves overdetermined or underdetermined systems for GE matrices
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
real function sasum(N, SX, INCX)
SASUM
real function cqrt12(M, N, A, LDA, S, WORK, LWORK, RWORK)
CQRT12
subroutine cqrt13(SCALE, M, N, A, LDA, NORMA, ISEED)
CQRT13
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine cerrls(PATH, NUNIT)
CERRLS
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine saxpy(N, SA, SX, INCX, SY, INCY)
SAXPY
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine cgelsd(M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, IWORK, INFO)
CGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices ...
subroutine cgelss(M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, INFO)
CGELSS solves overdetermined or underdetermined systems for GE matrices
real function slamch(CMACH)
SLAMCH
subroutine clarnv(IDIST, ISEED, N, X)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
real function cqrt17(TRANS, IRESID, M, N, NRHS, A, LDA, X, LDX, B, LDB, C, WORK, LWORK)
CQRT17
subroutine csscal(N, SA, CX, INCX)
CSSCAL
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
subroutine cqrt15(SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, RANK, NORMA, NORMB, ISEED, WORK, LWORK)
CQRT15
subroutine cqrt16(TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CQRT16
subroutine cgelsx(M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, RWORK, INFO)
CGELSX solves overdetermined or underdetermined systems for GE matrices
subroutine cgels(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
CGELS solves overdetermined or underdetermined systems for GE matrices