166 SUBROUTINE cdrvge( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
167 $ a, afac, asav, b, bsav, x, xact, s, work,
168 $ rwork, iwork, nout )
177 INTEGER nmax, nn, nout, nrhs
182 INTEGER iwork( * ), nval( * )
183 REAL rwork( * ), s( * )
184 COMPLEX a( * ), afac( * ), asav( * ), b( * ),
185 $ bsav( * ), work( * ), x( * ), xact( * )
192 parameter ( one = 1.0e+0, zero = 0.0e+0 )
194 parameter ( ntypes = 11 )
196 parameter ( ntests = 7 )
198 parameter ( ntran = 3 )
201 LOGICAL equil, nofact, prefac, trfcon, zerot
202 CHARACTER dist, equed, fact, trans,
TYPE, xtype
204 INTEGER i, iequed, ifact, imat, in, info, ioff, itran,
205 $ izero, k, k1, kl, ku, lda, lwork, mode, n, nb,
206 $ nbmin, nerrs, nfact, nfail, nimat, nrun, nt,
208 REAL ainvnm, amax, anorm, anormi, anormo, cndnum,
209 $ colcnd, rcond, rcondc, rcondi, rcondo, roldc,
210 $ roldi, roldo, rowcnd, rpvgrw, rpvgrw_svxx
213 CHARACTER equeds( 4 ), facts( 3 ), transs( ntran )
214 INTEGER iseed( 4 ), iseedy( 4 )
215 REAL rdum( 1 ), result( ntests ), berr( nrhs ),
216 $ errbnds_n( nrhs, 3 ), errbnds_c( nrhs, 3 )
231 INTRINSIC abs, cmplx, max
239 COMMON / infoc / infot, nunit, ok, lerr
240 COMMON / srnamc / srnamt
243 DATA iseedy / 1988, 1989, 1990, 1991 /
244 DATA transs /
'N',
'T',
'C' /
245 DATA facts /
'F',
'N',
'E' /
246 DATA equeds /
'N',
'R',
'C',
'B' /
252 path( 1: 1 ) =
'Complex precision'
258 iseed( i ) = iseedy( i )
264 $
CALL cerrvx( path, nout )
284 DO 80 imat = 1, nimat
288 IF( .NOT.dotype( imat ) )
293 zerot = imat.GE.5 .AND. imat.LE.7
294 IF( zerot .AND. n.LT.imat-4 )
300 CALL clatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
302 rcondc = one / cndnum
305 CALL clatms( n, n, dist, iseed,
TYPE, rwork, mode, cndnum,
306 $ anorm, kl, ku,
'No packing', a, lda, work,
312 CALL alaerh( path,
'CLATMS', info, 0,
' ', n, n, -1, -1,
313 $ -1, imat, nfail, nerrs, nout )
323 ELSE IF( imat.EQ.6 )
THEN
328 ioff = ( izero-1 )*lda
334 CALL claset(
'Full', n, n-izero+1, cmplx( zero ),
335 $ cmplx( zero ), a( ioff+1 ), lda )
343 CALL clacpy(
'Full', n, n, a, lda, asav, lda )
346 equed = equeds( iequed )
347 IF( iequed.EQ.1 )
THEN
353 DO 60 ifact = 1, nfact
354 fact = facts( ifact )
355 prefac =
lsame( fact,
'F' )
356 nofact =
lsame( fact,
'N' )
357 equil =
lsame( fact,
'E' )
365 ELSE IF( .NOT.nofact )
THEN
372 CALL clacpy(
'Full', n, n, asav, lda, afac, lda )
373 IF( equil .OR. iequed.GT.1 )
THEN
378 CALL cgeequ( n, n, afac, lda, s, s( n+1 ),
379 $ rowcnd, colcnd, amax, info )
380 IF( info.EQ.0 .AND. n.GT.0 )
THEN
381 IF(
lsame( equed,
'R' ) )
THEN
384 ELSE IF(
lsame( equed,
'C' ) )
THEN
387 ELSE IF(
lsame( equed,
'B' ) )
THEN
394 CALL claqge( n, n, afac, lda, s, s( n+1 ),
395 $ rowcnd, colcnd, amax, equed )
409 anormo =
clange(
'1', n, n, afac, lda, rwork )
410 anormi =
clange(
'I', n, n, afac, lda, rwork )
414 CALL cgetrf( n, n, afac, lda, iwork, info )
418 CALL clacpy(
'Full', n, n, afac, lda, a, lda )
419 lwork = nmax*max( 3, nrhs )
420 CALL cgetri( n, a, lda, iwork, work, lwork, info )
424 ainvnm =
clange(
'1', n, n, a, lda, rwork )
425 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
428 rcondo = ( one / anormo ) / ainvnm
433 ainvnm =
clange(
'I', n, n, a, lda, rwork )
434 IF( anormi.LE.zero .OR. ainvnm.LE.zero )
THEN
437 rcondi = ( one / anormi ) / ainvnm
441 DO 50 itran = 1, ntran
445 trans = transs( itran )
446 IF( itran.EQ.1 )
THEN
454 CALL clacpy(
'Full', n, n, asav, lda, a, lda )
459 CALL clarhs( path, xtype,
'Full', trans, n, n, kl,
460 $ ku, nrhs, a, lda, xact, lda, b, lda,
463 CALL clacpy(
'Full', n, nrhs, b, lda, bsav, lda )
465 IF( nofact .AND. itran.EQ.1 )
THEN
472 CALL clacpy(
'Full', n, n, a, lda, afac, lda )
473 CALL clacpy(
'Full', n, nrhs, b, lda, x, lda )
476 CALL cgesv( n, nrhs, afac, lda, iwork, x, lda,
482 $
CALL alaerh( path,
'CGESV ', info, izero,
483 $
' ', n, n, -1, -1, nrhs, imat,
484 $ nfail, nerrs, nout )
489 CALL cget01( n, n, a, lda, afac, lda, iwork,
490 $ rwork, result( 1 ) )
492 IF( izero.EQ.0 )
THEN
496 CALL clacpy(
'Full', n, nrhs, b, lda, work,
498 CALL cget02(
'No transpose', n, n, nrhs, a,
499 $ lda, x, lda, work, lda, rwork,
504 CALL cget04( n, nrhs, x, lda, xact, lda,
505 $ rcondc, result( 3 ) )
513 IF( result( k ).GE.thresh )
THEN
514 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
515 $
CALL aladhd( nout, path )
516 WRITE( nout, fmt = 9999 )
'CGESV ', n,
517 $ imat, k, result( k )
527 $
CALL claset(
'Full', n, n, cmplx( zero ),
528 $ cmplx( zero ), afac, lda )
529 CALL claset(
'Full', n, nrhs, cmplx( zero ),
530 $ cmplx( zero ), x, lda )
531 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
536 CALL claqge( n, n, a, lda, s, s( n+1 ), rowcnd,
537 $ colcnd, amax, equed )
544 CALL cgesvx( fact, trans, n, nrhs, a, lda, afac,
545 $ lda, iwork, equed, s, s( n+1 ), b,
546 $ lda, x, lda, rcond, rwork,
547 $ rwork( nrhs+1 ), work,
548 $ rwork( 2*nrhs+1 ), info )
553 $
CALL alaerh( path,
'CGESVX', info, izero,
554 $ fact // trans, n, n, -1, -1, nrhs,
555 $ imat, nfail, nerrs, nout )
561 rpvgrw =
clantr(
'M',
'U',
'N', info, info,
563 IF( rpvgrw.EQ.zero )
THEN
566 rpvgrw =
clange(
'M', n, info, a, lda,
570 rpvgrw =
clantr(
'M',
'U',
'N', n, n, afac, lda,
572 IF( rpvgrw.EQ.zero )
THEN
575 rpvgrw =
clange(
'M', n, n, a, lda, rdum ) /
579 result( 7 ) = abs( rpvgrw-rwork( 2*nrhs+1 ) ) /
580 $ max( rwork( 2*nrhs+1 ), rpvgrw ) /
583 IF( .NOT.prefac )
THEN
588 CALL cget01( n, n, a, lda, afac, lda, iwork,
589 $ rwork( 2*nrhs+1 ), result( 1 ) )
600 CALL clacpy(
'Full', n, nrhs, bsav, lda, work,
602 CALL cget02( trans, n, n, nrhs, asav, lda, x,
603 $ lda, work, lda, rwork( 2*nrhs+1 ),
608 IF( nofact .OR. ( prefac .AND.
lsame( equed,
610 CALL cget04( n, nrhs, x, lda, xact, lda,
611 $ rcondc, result( 3 ) )
613 IF( itran.EQ.1 )
THEN
618 CALL cget04( n, nrhs, x, lda, xact, lda,
619 $ roldc, result( 3 ) )
625 CALL cget07( trans, n, nrhs, asav, lda, b, lda,
626 $ x, lda, xact, lda, rwork, .true.,
627 $ rwork( nrhs+1 ), result( 4 ) )
635 result( 6 ) =
sget06( rcond, rcondc )
640 IF( .NOT.trfcon )
THEN
642 IF( result( k ).GE.thresh )
THEN
643 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
644 $
CALL aladhd( nout, path )
646 WRITE( nout, fmt = 9997 )
'CGESVX',
647 $ fact, trans, n, equed, imat, k,
650 WRITE( nout, fmt = 9998 )
'CGESVX',
651 $ fact, trans, n, imat, k, result( k )
658 IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
660 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
661 $
CALL aladhd( nout, path )
663 WRITE( nout, fmt = 9997 )
'CGESVX', fact,
664 $ trans, n, equed, imat, 1, result( 1 )
666 WRITE( nout, fmt = 9998 )
'CGESVX', fact,
667 $ trans, n, imat, 1, result( 1 )
672 IF( result( 6 ).GE.thresh )
THEN
673 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
674 $
CALL aladhd( nout, path )
676 WRITE( nout, fmt = 9997 )
'CGESVX', fact,
677 $ trans, n, equed, imat, 6, result( 6 )
679 WRITE( nout, fmt = 9998 )
'CGESVX', fact,
680 $ trans, n, imat, 6, result( 6 )
685 IF( result( 7 ).GE.thresh )
THEN
686 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
687 $
CALL aladhd( nout, path )
689 WRITE( nout, fmt = 9997 )
'CGESVX', fact,
690 $ trans, n, equed, imat, 7, result( 7 )
692 WRITE( nout, fmt = 9998 )
'CGESVX', fact,
693 $ trans, n, imat, 7, result( 7 )
706 CALL clacpy(
'Full', n, n, asav, lda, a, lda )
707 CALL clacpy(
'Full', n, nrhs, bsav, lda, b, lda )
710 $
CALL claset(
'Full', n, n, zero, zero, afac,
712 CALL claset(
'Full', n, nrhs, zero, zero, x, lda )
713 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
718 CALL claqge( n, n, a, lda, s, s( n+1 ), rowcnd,
719 $ colcnd, amax, equed )
727 CALL cgesvxx( fact, trans, n, nrhs, a, lda, afac,
728 $ lda, iwork, equed, s, s( n+1 ), b, lda, x,
729 $ lda, rcond, rpvgrw_svxx, berr, n_err_bnds,
730 $ errbnds_n, errbnds_c, 0, zero, work,
735 IF( info.EQ.n+1 )
GOTO 50
736 IF( info.NE.izero )
THEN
737 CALL alaerh( path,
'CGESVXX', info, izero,
738 $ fact // trans, n, n, -1, -1, nrhs,
739 $ imat, nfail, nerrs, nout )
747 IF ( info .GT. 0 .AND. info .LT. n+1 )
THEN
749 $ (n, info, a, lda, afac, lda)
752 $ (n, n, a, lda, afac, lda)
755 result( 7 ) = abs( rpvgrw-rpvgrw_svxx ) /
756 $ max( rpvgrw_svxx, rpvgrw ) /
759 IF( .NOT.prefac )
THEN
764 CALL cget01( n, n, a, lda, afac, lda, iwork,
765 $ rwork( 2*nrhs+1 ), result( 1 ) )
776 CALL clacpy(
'Full', n, nrhs, bsav, lda, work,
778 CALL cget02( trans, n, n, nrhs, asav, lda, x,
779 $ lda, work, lda, rwork( 2*nrhs+1 ),
784 IF( nofact .OR. ( prefac .AND.
lsame( equed,
786 CALL cget04( n, nrhs, x, lda, xact, lda,
787 $ rcondc, result( 3 ) )
789 IF( itran.EQ.1 )
THEN
794 CALL cget04( n, nrhs, x, lda, xact, lda,
795 $ roldc, result( 3 ) )
804 result( 6 ) =
sget06( rcond, rcondc )
809 IF( .NOT.trfcon )
THEN
811 IF( result( k ).GE.thresh )
THEN
812 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
813 $
CALL aladhd( nout, path )
815 WRITE( nout, fmt = 9997 )
'CGESVXX',
816 $ fact, trans, n, equed, imat, k,
819 WRITE( nout, fmt = 9998 )
'CGESVXX',
820 $ fact, trans, n, imat, k, result( k )
827 IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
829 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
830 $
CALL aladhd( nout, path )
832 WRITE( nout, fmt = 9997 )
'CGESVXX', fact,
833 $ trans, n, equed, imat, 1, result( 1 )
835 WRITE( nout, fmt = 9998 )
'CGESVXX', fact,
836 $ trans, n, imat, 1, result( 1 )
841 IF( result( 6 ).GE.thresh )
THEN
842 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
843 $
CALL aladhd( nout, path )
845 WRITE( nout, fmt = 9997 )
'CGESVXX', fact,
846 $ trans, n, equed, imat, 6, result( 6 )
848 WRITE( nout, fmt = 9998 )
'CGESVXX', fact,
849 $ trans, n, imat, 6, result( 6 )
854 IF( result( 7 ).GE.thresh )
THEN
855 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
856 $
CALL aladhd( nout, path )
858 WRITE( nout, fmt = 9997 )
'CGESVXX', fact,
859 $ trans, n, equed, imat, 7, result( 7 )
861 WRITE( nout, fmt = 9998 )
'CGESVXX', fact,
862 $ trans, n, imat, 7, result( 7 )
878 CALL alasvm( path, nout, nfail, nrun, nerrs )
885 9999
FORMAT( 1x, a,
', N =', i5,
', type ', i2,
', test(', i2,
') =',
887 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', TRANS=''', a1,
''', N=', i5,
888 $
', type ', i2,
', test(', i1,
')=', g12.5 )
889 9997
FORMAT( 1x, a,
', FACT=''', a1,
''', TRANS=''', a1,
''', N=', i5,
890 $
', EQUED=''', a1,
''', type ', i2,
', test(', i1,
')=',
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine cget01(M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, RESID)
CGET01
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
subroutine cget07(TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, CHKFERR, BERR, RESLTS)
CGET07
subroutine cgetri(N, A, LDA, IPIV, WORK, LWORK, INFO)
CGETRI
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine cebchvxx(THRESH, PATH)
CEBCHVXX
subroutine cerrvx(PATH, NUNIT)
CERRVX
real function sget06(RCOND, RCONDC)
SGET06
real function cla_gerpvgrw(N, NCOLS, A, LDA, AF, LDAF)
CLA_GERPVGRW multiplies a square real matrix by a complex matrix.
real function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine claqge(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED)
CLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ...
subroutine cget02(TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CGET02
subroutine cdrvge(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
CDRVGE
subroutine cgesvx(FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
CGESVX computes the solution to system of linear equations A * X = B for GE matrices ...
subroutine cgeequ(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO)
CGEEQU
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
subroutine aladhd(IOUNIT, PATH)
ALADHD
logical function lsame(CA, CB)
LSAME
real function slamch(CMACH)
SLAMCH
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine cgetrf(M, N, A, LDA, IPIV, INFO)
CGETRF
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
real function clantr(NORM, UPLO, DIAG, M, N, A, LDA, WORK)
CLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a trapezoidal or triangular matrix.
subroutine cgesv(N, NRHS, A, LDA, IPIV, B, LDB, INFO)
CGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver) ...
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
subroutine cgesvxx(FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO)
CGESVXX computes the solution to system of linear equations A * X = B for GE matrices ...