191 SUBROUTINE cdrvls( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
192 $ nbval, nxval, thresh, tsterr, a, copya, b,
193 $ copyb, c, s, copys, nout )
202 INTEGER NM, NN, NNB, NNS, NOUT
207 INTEGER MVAL( * ), NBVAL( * ), NSVAL( * ),
208 $ nval( * ), nxval( * )
209 REAL COPYS( * ), S( * )
210 COMPLEX A( * ), B( * ), C( * ), COPYA( * ), COPYB( * )
217 parameter ( ntests = 16 )
219 parameter ( smlsiz = 25 )
221 parameter ( one = 1.0e+0, zero = 0.0e+0 )
223 parameter ( cone = ( 1.0e+0, 0.0e+0 ),
224 $ czero = ( 0.0e+0, 0.0e+0 ) )
229 INTEGER CRANK, I, IM, IMB, IN, INB, INFO, INS, IRANK,
230 $ iscale, itran, itype, j, k, lda, ldb, ldwork,
231 $ lwlsy, lwork, m, mnmin, n, nb, ncols, nerrs,
232 $ nfail, nrhs, nrows, nrun, rank, mb,
233 $ mmax, nmax, nsmax, liwork, lrwork,
234 $ lwork_cgels, lwork_cgetsls, lwork_cgelss,
235 $ lwork_cgelsy, lwork_cgelsd,
236 $ lrwork_cgelsy, lrwork_cgelss, lrwork_cgelsd
237 REAL EPS, NORMA, NORMB, RCOND
240 INTEGER ISEED( 4 ), ISEEDY( 4 ), IWORKQUERY
241 REAL RESULT( ntests ), RWORKQUERY
245 COMPLEX,
ALLOCATABLE :: WORK (:)
246 REAL,
ALLOCATABLE :: RWORK (:)
247 INTEGER,
ALLOCATABLE :: IWORK (:)
250 REAL CQRT12, CQRT14, CQRT17, SASUM, SLAMCH
251 EXTERNAL cqrt12, cqrt14, cqrt17, sasum, slamch
260 INTRINSIC max, min, int,
REAL, SQRT
265 INTEGER INFOT, IOUNIT
268 COMMON / infoc / infot, iounit, ok, lerr
269 COMMON / srnamc / srnamt
272 DATA iseedy / 1988, 1989, 1990, 1991 /
278 path( 1: 1 ) =
'Complex precision'
284 iseed( i ) = iseedy( i )
286 eps = slamch(
'Epsilon' )
290 rcond = sqrt( eps ) - ( sqrt( eps )-eps ) / 2
296 $
CALL cerrls( path, nout )
300 IF( ( nm.EQ.0 .OR. nn.EQ.0 ) .AND. thresh.EQ.zero )
301 $
CALL alahd( nout, path )
310 IF ( mval( i ).GT.mmax )
THEN
315 IF ( nval( i ).GT.nmax )
THEN
320 IF ( nsval( i ).GT.nsmax )
THEN
329 mnmin = max( min( m, n ), 1 )
334 lwork = max( ( m+n )*nrhs,
335 $ ( n+nrhs )*( m+2 ), ( m+nrhs )*( n+2 ),
336 $ max( m+mnmin, nrhs*mnmin,2*n+m ),
337 $ max( m*n+4*mnmin+max(m,n), m*n+2*mnmin+4*n ) )
340 CALL cgels(
'N', m, n, nrhs, a, lda, b, ldb,
341 $ workquery, -1, info )
342 lwork_cgels = int( workquery )
344 CALL cgetsls(
'N', m, n, nrhs, a, lda, b, ldb,
345 $ workquery, -1, info )
346 lwork_cgetsls = int( workquery )
348 CALL cgelsy( m, n, nrhs, a, lda, b, ldb, iworkquery,
349 $ rcond, crank, workquery, -1, rwork, info )
350 lwork_cgelsy = int( workquery )
353 CALL cgelss( m, n, nrhs, a, lda, b, ldb, s,
354 $ rcond, crank, workquery, -1, rwork, info )
355 lwork_cgelss = int( workquery )
356 lrwork_cgelss = 5*mnmin
358 CALL cgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, crank,
359 $ workquery, -1, rworkquery, iworkquery, info )
360 lwork_cgelsd = int( workquery )
361 lrwork_cgelsd = int( rworkquery )
363 liwork = max( 1, n, iworkquery )
365 lrwork = max( 1, lrwork_cgelsy, lrwork_cgelss, lrwork_cgelsd )
367 lwork = max( 1, lwork, lwork_cgels, lwork_cgetsls, lwork_cgelsy,
368 $ lwork_cgelss, lwork_cgelsd )
371 ALLOCATE( work( lwork ) )
372 ALLOCATE( iwork( liwork ) )
373 ALLOCATE( rwork( lrwork ) )
381 mnmin = max(min( m, n ),1)
390 itype = ( irank-1 )*3 + iscale
391 IF( .NOT.dotype( itype ) )
394 IF( irank.EQ.1 )
THEN
400 CALL cqrt13( iscale, m, n, copya, lda, norma,
405 CALL xlaenv( 3, nxval( inb ) )
408 IF( itran.EQ.1 )
THEN
417 ldwork = max( 1, ncols )
421 IF( ncols.GT.0 )
THEN
422 CALL clarnv( 2, iseed, ncols*nrhs,
425 $ one /
REAL( NCOLS ), WORK,
428 CALL cgemm( trans,
'No transpose', nrows,
429 $ nrhs, ncols, cone, copya, lda,
430 $ work, ldwork, czero, b, ldb )
431 CALL clacpy(
'Full', nrows, nrhs, b, ldb,
436 IF( m.GT.0 .AND. n.GT.0 )
THEN
437 CALL clacpy(
'Full', m, n, copya, lda,
439 CALL clacpy(
'Full', nrows, nrhs,
440 $ copyb, ldb, b, ldb )
443 CALL cgels( trans, m, n, nrhs, a, lda, b,
444 $ ldb, work, lwork, info )
447 $
CALL alaerh( path,
'CGELS ', info, 0,
448 $ trans, m, n, nrhs, -1, nb,
449 $ itype, nfail, nerrs,
454 ldwork = max( 1, nrows )
455 IF( nrows.GT.0 .AND. nrhs.GT.0 )
456 $
CALL clacpy(
'Full', nrows, nrhs,
457 $ copyb, ldb, c, ldb )
458 CALL cqrt16( trans, m, n, nrhs, copya,
459 $ lda, b, ldb, c, ldb, rwork,
462 IF( ( itran.EQ.1 .AND. m.GE.n ) .OR.
463 $ ( itran.EQ.2 .AND. m.LT.n ) )
THEN
467 result( 2 ) = cqrt17( trans, 1, m, n,
468 $ nrhs, copya, lda, b, ldb,
469 $ copyb, ldb, c, work,
475 result( 2 ) = cqrt14( trans, m, n,
476 $ nrhs, copya, lda, b, ldb,
484 IF( result( k ).GE.thresh )
THEN
485 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
486 $
CALL alahd( nout, path )
487 WRITE( nout, fmt = 9999 )trans, m,
488 $ n, nrhs, nb, itype, k,
502 CALL cqrt13( iscale, m, n, copya, lda, norma,
512 IF( itran.EQ.1 )
THEN
521 ldwork = max( 1, ncols )
525 IF( ncols.GT.0 )
THEN
526 CALL clarnv( 2, iseed, ncols*nrhs,
528 CALL cscal( ncols*nrhs,
529 $ one /
REAL( NCOLS ), WORK,
532 CALL cgemm( trans,
'No transpose', nrows,
533 $ nrhs, ncols, cone, copya, lda,
534 $ work, ldwork, czero, b, ldb )
535 CALL clacpy(
'Full', nrows, nrhs, b, ldb,
540 IF( m.GT.0 .AND. n.GT.0 )
THEN
541 CALL clacpy(
'Full', m, n, copya, lda,
543 CALL clacpy(
'Full', nrows, nrhs,
544 $ copyb, ldb, b, ldb )
547 CALL cgetsls( trans, m, n, nrhs, a,
548 $ lda, b, ldb, work, lwork, info )
550 $
CALL alaerh( path,
'CGETSLS ', info, 0,
551 $ trans, m, n, nrhs, -1, nb,
552 $ itype, nfail, nerrs,
557 ldwork = max( 1, nrows )
558 IF( nrows.GT.0 .AND. nrhs.GT.0 )
559 $
CALL clacpy(
'Full', nrows, nrhs,
560 $ copyb, ldb, c, ldb )
561 CALL cqrt16( trans, m, n, nrhs, copya,
562 $ lda, b, ldb, c, ldb, work,
565 IF( ( itran.EQ.1 .AND. m.GE.n ) .OR.
566 $ ( itran.EQ.2 .AND. m.LT.n ) )
THEN
570 result( 16 ) = cqrt17( trans, 1, m, n,
571 $ nrhs, copya, lda, b, ldb,
572 $ copyb, ldb, c, work,
578 result( 16 ) = cqrt14( trans, m, n,
579 $ nrhs, copya, lda, b, ldb,
587 IF( result( k ).GE.thresh )
THEN
588 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
589 $
CALL alahd( nout, path )
590 WRITE( nout, fmt = 9997 )trans, m,
591 $ n, nrhs, mb, nb, itype, k,
605 CALL cqrt15( iscale, irank, m, n, nrhs, copya, lda,
606 $ copyb, ldb, copys, rank, norma, normb,
607 $ iseed, work, lwork )
618 CALL xlaenv( 3, nxval( inb ) )
627 CALL clacpy(
'Full', m, n, copya, lda, a, lda )
628 CALL clacpy(
'Full', m, nrhs, copyb, ldb, b,
638 CALL cgelsy( m, n, nrhs, a, lda, b, ldb, iwork,
639 $ rcond, crank, work, lwlsy, rwork,
642 $
CALL alaerh( path,
'CGELSY', info, 0,
' ', m,
643 $ n, nrhs, -1, nb, itype, nfail,
651 result( 3 ) = cqrt12( crank, crank, a, lda,
652 $ copys, work, lwork, rwork )
657 CALL clacpy(
'Full', m, nrhs, copyb, ldb, work,
659 CALL cqrt16(
'No transpose', m, n, nrhs, copya,
660 $ lda, b, ldb, work, ldwork, rwork,
668 $ result( 5 ) = cqrt17(
'No transpose', 1, m,
669 $ n, nrhs, copya, lda, b, ldb,
670 $ copyb, ldb, c, work, lwork )
678 $ result( 6 ) = cqrt14(
'No transpose', m, n,
679 $ nrhs, copya, lda, b, ldb,
688 CALL clacpy(
'Full', m, n, copya, lda, a, lda )
689 CALL clacpy(
'Full', m, nrhs, copyb, ldb, b,
692 CALL cgelss( m, n, nrhs, a, lda, b, ldb, s,
693 $ rcond, crank, work, lwork, rwork,
697 $
CALL alaerh( path,
'CGELSS', info, 0,
' ', m,
698 $ n, nrhs, -1, nb, itype, nfail,
707 CALL saxpy( mnmin, -one, copys, 1, s, 1 )
708 result( 7 ) = sasum( mnmin, s, 1 ) /
709 $ sasum( mnmin, copys, 1 ) /
710 $ ( eps*
REAL( MNMIN ) )
717 CALL clacpy(
'Full', m, nrhs, copyb, ldb, work,
719 CALL cqrt16(
'No transpose', m, n, nrhs, copya,
720 $ lda, b, ldb, work, ldwork, rwork,
727 $ result( 9 ) = cqrt17(
'No transpose', 1, m,
728 $ n, nrhs, copya, lda, b, ldb,
729 $ copyb, ldb, c, work, lwork )
735 $ result( 10 ) = cqrt14(
'No transpose', m, n,
736 $ nrhs, copya, lda, b, ldb,
747 CALL clacpy(
'Full', m, n, copya, lda, a, lda )
748 CALL clacpy(
'Full', m, nrhs, copyb, ldb, b,
752 CALL cgelsd( m, n, nrhs, a, lda, b, ldb, s,
753 $ rcond, crank, work, lwork, rwork,
756 $
CALL alaerh( path,
'CGELSD', info, 0,
' ', m,
757 $ n, nrhs, -1, nb, itype, nfail,
763 CALL saxpy( mnmin, -one, copys, 1, s, 1 )
764 result( 11 ) = sasum( mnmin, s, 1 ) /
765 $ sasum( mnmin, copys, 1 ) /
766 $ ( eps*
REAL( MNMIN ) )
773 CALL clacpy(
'Full', m, nrhs, copyb, ldb, work,
775 CALL cqrt16(
'No transpose', m, n, nrhs, copya,
776 $ lda, b, ldb, work, ldwork, rwork,
783 $ result( 13 ) = cqrt17(
'No transpose', 1, m,
784 $ n, nrhs, copya, lda, b, ldb,
785 $ copyb, ldb, c, work, lwork )
791 $ result( 14 ) = cqrt14(
'No transpose', m, n,
792 $ nrhs, copya, lda, b, ldb,
799 IF( result( k ).GE.thresh )
THEN
800 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
801 $
CALL alahd( nout, path )
802 WRITE( nout, fmt = 9998 )m, n, nrhs, nb,
803 $ itype, k, result( k )
818 CALL alasvm( path, nout, nfail, nrun, nerrs )
820 9999
FORMAT(
' TRANS=''', a1,
''', M=', i5,
', N=', i5,
', NRHS=', i4,
821 $
', NB=', i4,
', type', i2,
', test(', i2,
')=', g12.5 )
822 9998
FORMAT(
' M=', i5,
', N=', i5,
', NRHS=', i4,
', NB=', i4,
823 $
', type', i2,
', test(', i2,
')=', g12.5 )
824 9997
FORMAT(
' TRANS=''', a1,
' M=', i5,
', N=', i5,
', NRHS=', i4,
825 $
', MB=', i4,
', NB=', i4,
', type', i2,
826 $
', test(', i2,
')=', g12.5 )
subroutine cgetsls(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
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
subroutine cdrvls(DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB, NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B, COPYB, C, S, COPYS, NOUT)
CDRVLS
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 clarnv(IDIST, ISEED, N, X)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine cscal(N, CA, CX, INCX)
CSCAL
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
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
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