163 SUBROUTINE cdrvge( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
164 $ a, afac, asav,
b, bsav,
x, xact, s, work,
165 $ rwork, iwork, nout )
174 INTEGER nmax, nn, nout, nrhs
179 INTEGER iwork( * ), nval( * )
180 REAL rwork( * ), s( * )
181 COMPLEX a( * ), afac( * ), asav( * ),
b( * ),
182 $ bsav( * ), work( * ),
x( * ), xact( * )
189 parameter( one = 1.0e+0, zero = 0.0e+0 )
191 parameter( ntypes = 11 )
193 parameter( ntests = 7 )
195 parameter( ntran = 3 )
198 LOGICAL equil, nofact, prefac, trfcon, zerot
199 CHARACTER dist, equed, fact, trans, type, xtype
201 INTEGER i, iequed, ifact, imat, in, info, ioff, itran,
202 $ izero, k, k1, kl, ku, lda, lwork, mode, n, nb,
203 $ nbmin, nerrs, nfact, nfail, nimat, nrun, nt
204 REAL ainvnm, amax, anorm, anormi, anormo, cndnum,
205 $ colcnd, rcond, rcondc, rcondi, rcondo, roldc,
206 $ roldi, roldo, rowcnd, rpvgrw
209 CHARACTER equeds( 4 ), facts( 3 ), transs( ntran )
210 INTEGER iseed( 4 ), iseedy( 4 )
211 REAL rdum( 1 ), result( ntests )
225 INTRINSIC abs, cmplx, max
233 COMMON / infoc / infot, nunit, ok, lerr
234 COMMON / srnamc / srnamt
237 DATA iseedy / 1988, 1989, 1990, 1991 /
238 DATA transs /
'N',
'T',
'C' /
239 DATA facts /
'F',
'N',
'E' /
240 DATA equeds /
'N',
'R',
'C',
'B' /
246 path( 1: 1 ) =
'Complex precision'
252 iseed( i ) = iseedy( i )
258 $ CALL
cerrvx( path, nout )
278 DO 80 imat = 1, nimat
282 IF( .NOT.dotype( imat ) )
287 zerot = imat.GE.5 .AND. imat.LE.7
288 IF( zerot .AND. n.LT.imat-4 )
294 CALL
clatb4( path, imat, n, n, type, kl, ku, anorm, mode,
296 rcondc = one / cndnum
299 CALL
clatms( n, n, dist, iseed, type, rwork, mode, cndnum,
300 $ anorm, kl, ku,
'No packing', a, lda, work,
306 CALL
alaerh( path,
'CLATMS', info, 0,
' ', n, n, -1, -1,
307 $ -1, imat, nfail, nerrs, nout )
317 ELSE IF( imat.EQ.6 )
THEN
322 ioff = ( izero-1 )*lda
328 CALL
claset(
'Full', n, n-izero+1, cmplx( zero ),
329 $ cmplx( zero ), a( ioff+1 ), lda )
337 CALL
clacpy(
'Full', n, n, a, lda, asav, lda )
340 equed = equeds( iequed )
341 IF( iequed.EQ.1 )
THEN
347 DO 60 ifact = 1, nfact
348 fact = facts( ifact )
349 prefac =
lsame( fact,
'F' )
350 nofact =
lsame( fact,
'N' )
351 equil =
lsame( fact,
'E' )
359 ELSE IF( .NOT.nofact )
THEN
366 CALL
clacpy(
'Full', n, n, asav, lda, afac, lda )
367 IF( equil .OR. iequed.GT.1 )
THEN
372 CALL
cgeequ( n, n, afac, lda, s, s( n+1 ),
373 $ rowcnd, colcnd, amax, info )
374 IF( info.EQ.0 .AND. n.GT.0 )
THEN
375 IF(
lsame( equed,
'R' ) )
THEN
378 ELSE IF(
lsame( equed,
'C' ) )
THEN
381 ELSE IF(
lsame( equed,
'B' ) )
THEN
388 CALL
claqge( n, n, afac, lda, s, s( n+1 ),
389 $ rowcnd, colcnd, amax, equed )
403 anormo =
clange(
'1', n, n, afac, lda, rwork )
404 anormi =
clange(
'I', n, n, afac, lda, rwork )
409 CALL
cgetrf( n, n, afac, lda, iwork, info )
413 CALL
clacpy(
'Full', n, n, afac, lda, a, lda )
414 lwork = nmax*max( 3, nrhs )
416 CALL
cgetri( n, a, lda, iwork, work, lwork, info )
420 ainvnm =
clange(
'1', n, n, a, lda, rwork )
421 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
424 rcondo = ( one / anormo ) / ainvnm
429 ainvnm =
clange(
'I', n, n, a, lda, rwork )
430 IF( anormi.LE.zero .OR. ainvnm.LE.zero )
THEN
433 rcondi = ( one / anormi ) / ainvnm
437 DO 50 itran = 1, ntran
441 trans = transs( itran )
442 IF( itran.EQ.1 )
THEN
450 CALL
clacpy(
'Full', n, n, asav, lda, a, lda )
455 CALL
clarhs( path, xtype,
'Full', trans, n, n, kl,
456 $ ku, nrhs, a, lda, xact, lda,
b, lda,
459 CALL
clacpy(
'Full', n, nrhs,
b, lda, bsav, lda )
461 IF( nofact .AND. itran.EQ.1 )
THEN
468 CALL
clacpy(
'Full', n, n, a, lda, afac, lda )
469 CALL
clacpy(
'Full', n, nrhs,
b, lda,
x, lda )
472 CALL
cgesv( n, nrhs, afac, lda, iwork,
x, lda,
478 $ CALL
alaerh( path,
'CGESV ', info, izero,
479 $
' ', n, n, -1, -1, nrhs, imat,
480 $ nfail, nerrs, nout )
485 CALL
cget01( n, n, a, lda, afac, lda, iwork,
486 $ rwork, result( 1 ) )
488 IF( izero.EQ.0 )
THEN
492 CALL
clacpy(
'Full', n, nrhs,
b, lda, work,
494 CALL
cget02(
'No transpose', n, n, nrhs, a,
495 $ lda,
x, lda, work, lda, rwork,
500 CALL
cget04( n, nrhs,
x, lda, xact, lda,
501 $ rcondc, result( 3 ) )
509 IF( result( k ).GE.thresh )
THEN
510 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
511 $ CALL
aladhd( nout, path )
512 WRITE( nout, fmt = 9999 )
'CGESV ', n,
513 $ imat, k, result( k )
523 $ CALL
claset(
'Full', n, n, cmplx( zero ),
524 $ cmplx( zero ), afac, lda )
525 CALL
claset(
'Full', n, nrhs, cmplx( zero ),
526 $ cmplx( zero ),
x, lda )
527 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
532 CALL
claqge( n, n, a, lda, s, s( n+1 ), rowcnd,
533 $ colcnd, amax, equed )
540 CALL
cgesvx( fact, trans, n, nrhs, a, lda, afac,
541 $ lda, iwork, equed, s, s( n+1 ),
b,
542 $ lda,
x, lda, rcond, rwork,
543 $ rwork( nrhs+1 ), work,
544 $ rwork( 2*nrhs+1 ), info )
549 $ CALL
alaerh( path,
'CGESVX', info, izero,
550 $ fact // trans, n, n, -1, -1, nrhs,
551 $ imat, nfail, nerrs, nout )
556 IF( info.NE.0 .AND. info.LE.n)
THEN
557 rpvgrw =
clantr(
'M',
'U',
'N', info, info,
559 IF( rpvgrw.EQ.zero )
THEN
562 rpvgrw =
clange(
'M', n, info, a, lda,
566 rpvgrw =
clantr(
'M',
'U',
'N', n, n, afac, lda,
568 IF( rpvgrw.EQ.zero )
THEN
571 rpvgrw =
clange(
'M', n, n, a, lda, rdum ) /
575 result( 7 ) = abs( rpvgrw-rwork( 2*nrhs+1 ) ) /
576 $ max( rwork( 2*nrhs+1 ), rpvgrw ) /
579 IF( .NOT.prefac )
THEN
584 CALL
cget01( n, n, a, lda, afac, lda, iwork,
585 $ rwork( 2*nrhs+1 ), result( 1 ) )
596 CALL
clacpy(
'Full', n, nrhs, bsav, lda, work,
598 CALL
cget02( trans, n, n, nrhs, asav, lda,
x,
599 $ lda, work, lda, rwork( 2*nrhs+1 ),
604 IF( nofact .OR. ( prefac .AND.
lsame( equed,
606 CALL
cget04( n, nrhs,
x, lda, xact, lda,
607 $ rcondc, result( 3 ) )
609 IF( itran.EQ.1 )
THEN
614 CALL
cget04( n, nrhs,
x, lda, xact, lda,
615 $ roldc, result( 3 ) )
621 CALL
cget07( trans, n, nrhs, asav, lda,
b, lda,
622 $
x, lda, xact, lda, rwork, .true.,
623 $ rwork( nrhs+1 ), result( 4 ) )
631 result( 6 ) =
sget06( rcond, rcondc )
636 IF( .NOT.trfcon )
THEN
638 IF( result( k ).GE.thresh )
THEN
639 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
640 $ CALL
aladhd( nout, path )
642 WRITE( nout, fmt = 9997 )
'CGESVX',
643 $ fact, trans, n, equed, imat, k,
646 WRITE( nout, fmt = 9998 )
'CGESVX',
647 $ fact, trans, n, imat, k, result( k )
654 IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
656 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
657 $ CALL
aladhd( nout, path )
659 WRITE( nout, fmt = 9997 )
'CGESVX', fact,
660 $ trans, n, equed, imat, 1, result( 1 )
662 WRITE( nout, fmt = 9998 )
'CGESVX', fact,
663 $ trans, n, imat, 1, result( 1 )
668 IF( result( 6 ).GE.thresh )
THEN
669 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
670 $ CALL
aladhd( nout, path )
672 WRITE( nout, fmt = 9997 )
'CGESVX', fact,
673 $ trans, n, equed, imat, 6, result( 6 )
675 WRITE( nout, fmt = 9998 )
'CGESVX', fact,
676 $ trans, n, imat, 6, result( 6 )
681 IF( result( 7 ).GE.thresh )
THEN
682 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
683 $ CALL
aladhd( nout, path )
685 WRITE( nout, fmt = 9997 )
'CGESVX', fact,
686 $ trans, n, equed, imat, 7, result( 7 )
688 WRITE( nout, fmt = 9998 )
'CGESVX', fact,
689 $ trans, n, imat, 7, result( 7 )
705 CALL
alasvm( path, nout, nfail, nrun, nerrs )
707 9999
FORMAT( 1
x, a,
', N =', i5,
', type ', i2,
', test(', i2,
') =',
709 9998
FORMAT( 1
x, a,
', FACT=''', a1,
''', TRANS=''', a1,
''', N=', i5,
710 $
', type ', i2,
', test(', i1,
')=', g12.5 )
711 9997
FORMAT( 1
x, a,
', FACT=''', a1,
''', TRANS=''', a1,
''', N=', i5,
712 $
', EQUED=''', a1,
''', type ', i2,
', test(', i1,
')=',
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 clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
LOGICAL function lsame(CA, CB)
LSAME
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine cget01(M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK, RESID)
CGET01
REAL function slamch(CMACH)
SLAMCH
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine cgetri(N, A, LDA, IPIV, WORK, LWORK, INFO)
CGETRI
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...
REAL function sget06(RCOND, RCONDC)
SGET06
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.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine cget07(TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, CHKFERR, BERR, RESLTS)
CGET07
subroutine cgetrf(M, N, A, LDA, IPIV, INFO)
CGETRF
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 ...
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 clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
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 aladhd(IOUNIT, PATH)
ALADHD
subroutine cerrvx(PATH, NUNIT)
CERRVX
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 cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
subroutine cgeequ(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO)
CGEEQU