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 = 14 )
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 )
454 CALL xlaenv( 3, nxval( inb ) )
463 CALL clacpy(
'Full', m, n, copya, lda, a, lda )
464 CALL clacpy(
'Full', m, nrhs, copyb, ldb, b,
475 lwlsy = mnmin + max( 2*mnmin, nb*( n+1 ),
477 lwlsy = max( 1, lwlsy )
480 CALL cgelsy( m, n, nrhs, a, lda, b, ldb, iwork,
481 $ rcond, crank, work, lwlsy, rwork,
484 $
CALL alaerh( path,
'CGELSY', info, 0,
' ', m,
485 $ n, nrhs, -1, nb, itype, nfail,
493 result( 3 ) =
cqrt12( crank, crank, a, lda,
494 $ copys, work, lwork, rwork )
499 CALL clacpy(
'Full', m, nrhs, copyb, ldb, work,
501 CALL cqrt16(
'No transpose', m, n, nrhs, copya,
502 $ lda, b, ldb, work, ldwork, rwork,
510 $ result( 5 ) =
cqrt17(
'No transpose', 1, m,
511 $ n, nrhs, copya, lda, b, ldb,
512 $ copyb, ldb, c, work, lwork )
520 $ result( 6 ) =
cqrt14(
'No transpose', m, n,
521 $ nrhs, copya, lda, b, ldb,
530 CALL clacpy(
'Full', m, n, copya, lda, a, lda )
531 CALL clacpy(
'Full', m, nrhs, copyb, ldb, b,
534 CALL cgelss( m, n, nrhs, a, lda, b, ldb, s,
535 $ rcond, crank, work, lwork, rwork,
539 $
CALL alaerh( path,
'CGELSS', info, 0,
' ', m,
540 $ n, nrhs, -1, nb, itype, nfail,
549 CALL saxpy( mnmin, -one, copys, 1, s, 1 )
550 result( 7 ) =
sasum( mnmin, s, 1 ) /
551 $
sasum( mnmin, copys, 1 ) /
552 $ ( eps*
REAL( MNMIN ) )
559 CALL clacpy(
'Full', m, nrhs, copyb, ldb, work,
561 CALL cqrt16(
'No transpose', m, n, nrhs, copya,
562 $ lda, b, ldb, work, ldwork, rwork,
569 $ result( 9 ) =
cqrt17(
'No transpose', 1, m,
570 $ n, nrhs, copya, lda, b, ldb,
571 $ copyb, ldb, c, work, lwork )
577 $ result( 10 ) =
cqrt14(
'No transpose', m, n,
578 $ nrhs, copya, lda, b, ldb,
589 CALL clacpy(
'Full', m, n, copya, lda, a, lda )
590 CALL clacpy(
'Full', m, nrhs, copyb, ldb, b,
594 CALL cgelsd( m, n, nrhs, a, lda, b, ldb, s,
595 $ rcond, crank, work, lwork, rwork,
598 $
CALL alaerh( path,
'CGELSD', info, 0,
' ', m,
599 $ n, nrhs, -1, nb, itype, nfail,
605 CALL saxpy( mnmin, -one, copys, 1, s, 1 )
606 result( 11 ) =
sasum( mnmin, s, 1 ) /
607 $
sasum( mnmin, copys, 1 ) /
608 $ ( eps*
REAL( MNMIN ) )
615 CALL clacpy(
'Full', m, nrhs, copyb, ldb, work,
617 CALL cqrt16(
'No transpose', m, n, nrhs, copya,
618 $ lda, b, ldb, work, ldwork, rwork,
625 $ result( 13 ) =
cqrt17(
'No transpose', 1, m,
626 $ n, nrhs, copya, lda, b, ldb,
627 $ copyb, ldb, c, work, lwork )
633 $ result( 14 ) =
cqrt14(
'No transpose', m, n,
634 $ nrhs, copya, lda, b, ldb,
641 IF( result( k ).GE.thresh )
THEN
642 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
643 $
CALL alahd( nout, path )
644 WRITE( nout, fmt = 9998 )m, n, nrhs, nb,
645 $ itype, k, result( k )
660 CALL alasvm( path, nout, nfail, nrun, nerrs )
662 9999
FORMAT(
' TRANS=''', a1,
''', M=', i5,
', N=', i5,
', NRHS=', i4,
663 $
', NB=', i4,
', type', i2,
', test(', i2,
')=', g12.5 )
664 9998
FORMAT(
' M=', i5,
', N=', i5,
', NRHS=', i4,
', NB=', i4,
665 $
', type', i2,
', test(', i2,
')=', g12.5 )
subroutine cqrt16(TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CQRT16
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
real function cqrt14(TRANS, M, N, NRHS, A, LDA, X, LDX, WORK, LWORK)
CQRT14
subroutine cqrt15(SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, RANK, NORMA, NORMB, ISEED, WORK, LWORK)
CQRT15
subroutine cqrt13(SCALE, M, N, A, LDA, NORMA, ISEED)
CQRT13
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
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
subroutine cgels(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
CGELS solves overdetermined or underdetermined systems for GE matrices
real function cqrt17(TRANS, IRESID, M, N, NRHS, A, LDA, X, LDX, B, LDB, C, WORK, LWORK)
CQRT17
subroutine clarnv(IDIST, ISEED, N, X)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
real function sasum(N, SX, INCX)
SASUM
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 cgelsy(M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO)
CGELSY solves overdetermined or underdetermined systems for GE matrices
real function cqrt12(M, N, A, LDA, S, WORK, LWORK, RWORK)
CQRT12
real function slamch(CMACH)
SLAMCH
subroutine cerrls(PATH, NUNIT)
CERRLS
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
subroutine csscal(N, SA, CX, INCX)
CSSCAL