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
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
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
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