139 SUBROUTINE cdrvgt( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF,
140 $
b, x, xact, work, rwork, iwork, nout )
149 INTEGER nn, nout, nrhs
154 INTEGER iwork( * ), nval( * )
156 COMPLEX a( * ), af( * ),
b( * ), work( * ), x( * ),
164 parameter( one = 1.0e+0, zero = 0.0e+0 )
166 parameter( ntypes = 12 )
168 parameter( ntests = 6 )
171 LOGICAL trfcon, zerot
172 CHARACTER dist, fact, trans, type
174 INTEGER i, ifact, imat, in, info, itran, ix, izero,
j,
175 $ k, k1, kl, koff, ku, lda, m, mode, n, nerrs,
176 $ nfail, nimat, nrun, nt
177 REAL ainvnm, anorm, anormi, anormo, cond, rcond,
178 $ rcondc, rcondi, rcondo
181 CHARACTER transs( 3 )
182 INTEGER iseed( 4 ), iseedy( 4 )
183 REAL result( ntests ), z( 3 )
204 COMMON / infoc / infot, nunit, ok, lerr
205 COMMON / srnamc / srnamt
208 DATA iseedy / 0, 0, 0, 1 / , transs /
'N',
'T',
213 path( 1: 1 ) =
'Complex precision'
219 iseed( i ) = iseedy( i )
225 $ CALL
cerrvx( path, nout )
239 DO 130 imat = 1, nimat
243 IF( .NOT.dotype( imat ) )
248 CALL
clatb4( path, imat, n, n, type, kl, ku, anorm, mode,
251 zerot = imat.GE.8 .AND. imat.LE.10
256 koff = max( 2-ku, 3-max( 1, n ) )
258 CALL
clatms( n, n, dist, iseed, type, rwork, mode, cond,
259 $ anorm, kl, ku,
'Z', af( koff ), 3, work,
265 CALL
alaerh( path,
'CLATMS', info, 0,
' ', n, n, kl,
266 $ ku, -1, imat, nfail, nerrs, nout )
272 CALL
ccopy( n-1, af( 4 ), 3, a, 1 )
273 CALL
ccopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
275 CALL
ccopy( n, af( 2 ), 3, a( m+1 ), 1 )
281 IF( .NOT.zerot .OR. .NOT.dotype( 7 ) )
THEN
285 CALL
clarnv( 2, iseed, n+2*m, a )
287 $ CALL
csscal( n+2*m, anorm, a, 1 )
288 ELSE IF( izero.GT.0 )
THEN
293 IF( izero.EQ.1 )
THEN
297 ELSE IF( izero.EQ.n )
THEN
301 a( 2*n-2+izero ) = z( 1 )
302 a( n-1+izero ) = z( 2 )
309 IF( .NOT.zerot )
THEN
311 ELSE IF( imat.EQ.8 )
THEN
319 ELSE IF( imat.EQ.9 )
THEN
327 DO 20 i = izero, n - 1
338 IF( ifact.EQ.1 )
THEN
353 ELSE IF( ifact.EQ.1 )
THEN
354 CALL
ccopy( n+2*m, a, 1, af, 1 )
358 anormo =
clangt(
'1', n, a, a( m+1 ), a( n+m+1 ) )
359 anormi =
clangt(
'I', n, a, a( m+1 ), a( n+m+1 ) )
363 CALL
cgttrf( n, af, af( m+1 ), af( n+m+1 ),
364 $ af( n+2*m+1 ), iwork, info )
375 CALL
cgttrs(
'No transpose', n, 1, af, af( m+1 ),
376 $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
378 ainvnm = max( ainvnm,
scasum( n, x, 1 ) )
383 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
386 rcondo = ( one / anormo ) / ainvnm
398 CALL
cgttrs(
'Conjugate transpose', n, 1, af,
399 $ af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
400 $ iwork, x, lda, info )
401 ainvnm = max( ainvnm,
scasum( n, x, 1 ) )
406 IF( anormi.LE.zero .OR. ainvnm.LE.zero )
THEN
409 rcondi = ( one / anormi ) / ainvnm
414 trans = transs( itran )
415 IF( itran.EQ.1 )
THEN
425 CALL
clarnv( 2, iseed, n, xact( ix ) )
431 CALL
clagtm( trans, n, nrhs, one, a, a( m+1 ),
432 $ a( n+m+1 ), xact, lda, zero,
b, lda )
434 IF( ifact.EQ.2 .AND. itran.EQ.1 )
THEN
441 CALL
ccopy( n+2*m, a, 1, af, 1 )
442 CALL
clacpy(
'Full', n, nrhs,
b, lda, x, lda )
445 CALL
cgtsv( n, nrhs, af, af( m+1 ), af( n+m+1 ), x,
451 $ CALL
alaerh( path,
'CGTSV ', info, izero,
' ',
452 $ n, n, 1, 1, nrhs, imat, nfail,
455 IF( izero.EQ.0 )
THEN
459 CALL
clacpy(
'Full', n, nrhs,
b, lda, work,
461 CALL
cgtt02( trans, n, nrhs, a, a( m+1 ),
462 $ a( n+m+1 ), x, lda, work, lda,
467 CALL
cget04( n, nrhs, x, lda, xact, lda, rcondc,
476 IF( result( k ).GE.thresh )
THEN
477 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
478 $ CALL
aladhd( nout, path )
479 WRITE( nout, fmt = 9999 )
'CGTSV ', n, imat,
489 IF( ifact.GT.1 )
THEN
497 CALL
claset(
'Full', n, nrhs, cmplx( zero ),
498 $ cmplx( zero ), x, lda )
504 CALL
cgtsvx( fact, trans, n, nrhs, a, a( m+1 ),
505 $ a( n+m+1 ), af, af( m+1 ), af( n+m+1 ),
506 $ af( n+2*m+1 ), iwork,
b, lda, x, lda,
507 $ rcond, rwork, rwork( nrhs+1 ), work,
508 $ rwork( 2*nrhs+1 ), info )
513 $ CALL
alaerh( path,
'CGTSVX', info, izero,
514 $ fact // trans, n, n, 1, 1, nrhs, imat,
515 $ nfail, nerrs, nout )
517 IF( ifact.GE.2 )
THEN
522 CALL
cgtt01( n, a, a( m+1 ), a( n+m+1 ), af,
523 $ af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
524 $ iwork, work, lda, rwork, result( 1 ) )
535 CALL
clacpy(
'Full', n, nrhs,
b, lda, work, lda )
536 CALL
cgtt02( trans, n, nrhs, a, a( m+1 ),
537 $ a( n+m+1 ), x, lda, work, lda,
542 CALL
cget04( n, nrhs, x, lda, xact, lda, rcondc,
547 CALL
cgtt05( trans, n, nrhs, a, a( m+1 ),
548 $ a( n+m+1 ),
b, lda, x, lda, xact, lda,
549 $ rwork, rwork( nrhs+1 ), result( 4 ) )
557 IF( result( k ).GE.thresh )
THEN
558 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
559 $ CALL
aladhd( nout, path )
560 WRITE( nout, fmt = 9998 )
'CGTSVX', fact, trans,
561 $ n, imat, k, result( k )
568 result( 6 ) =
sget06( rcond, rcondc )
569 IF( result( 6 ).GE.thresh )
THEN
570 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
571 $ CALL
aladhd( nout, path )
572 WRITE( nout, fmt = 9998 )
'CGTSVX', fact, trans, n,
573 $ imat, k, result( k )
576 nrun = nrun + nt - k1 + 2
585 CALL
alasvm( path, nout, nfail, nrun, nerrs )
587 9999
FORMAT( 1x, a,
', N =', i5,
', type ', i2,
', test ', i2,
588 $
', ratio = ', g12.5 )
589 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', TRANS=''', a1,
''', N =',
590 $ i5,
', type ', i2,
', test ', i2,
', ratio = ', g12.5 )
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
subroutine cgtsvx(FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
CGTSVX computes the solution to system of linear equations A * X = B for GT matrices ...
subroutine cgtt01(N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK, LDWORK, RWORK, RESID)
CGTT01
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine cgtt05(TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CGTT05
subroutine cgtt02(TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB, RESID)
CGTT02
real function sget06(RCOND, RCONDC)
SGET06
subroutine cgttrs(TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO)
CGTTRS
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
real function scasum(N, CX, INCX)
SCASUM
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
real function clangt(NORM, N, DL, D, DU)
CLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine cdrvgt(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT)
CDRVGT
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine cgttrf(N, DL, D, DU, DU2, IPIV, INFO)
CGTTRF
subroutine cgtsv(N, NRHS, DL, D, DU, B, LDB, INFO)
CGTSV computes the solution to system of linear equations A * X = B for GT matrices ...
subroutine clarnv(IDIST, ISEED, N, X)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
subroutine aladhd(IOUNIT, PATH)
ALADHD
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine cerrvx(PATH, NUNIT)
CERRVX
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine csscal(N, SA, CX, INCX)
CSSCAL
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
subroutine clagtm(TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB)
CLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix...