158 SUBROUTINE cdrvpp( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
159 $ a, afac, asav,
b, bsav,
x, xact, s, work,
169 INTEGER nmax, nn, nout, nrhs
175 REAL rwork( * ), s( * )
176 COMPLEX a( * ), afac( * ), asav( * ),
b( * ),
177 $ bsav( * ), work( * ),
x( * ), xact( * )
184 parameter( one = 1.0e+0, zero = 0.0e+0 )
186 parameter( ntypes = 9 )
188 parameter( ntests = 6 )
191 LOGICAL equil, nofact, prefac, zerot
192 CHARACTER dist, equed, fact, packit, type, uplo, xtype
194 INTEGER i, iequed, ifact, imat, in, info, ioff, iuplo,
195 $ izero, k, k1, kl, ku, lda, mode, n, nerrs,
196 $ nfact, nfail, nimat, npp, nrun, nt
197 REAL ainvnm, amax, anorm, cndnum, rcond, rcondc,
201 CHARACTER equeds( 2 ), facts( 3 ), packs( 2 ), uplos( 2 )
202 INTEGER iseed( 4 ), iseedy( 4 )
203 REAL result( ntests )
222 COMMON / infoc / infot, nunit, ok, lerr
223 COMMON / srnamc / srnamt
229 DATA iseedy / 1988, 1989, 1990, 1991 /
230 DATA uplos /
'U',
'L' / , facts /
'F',
'N',
'E' / ,
231 $ packs /
'C',
'R' / , equeds /
'N',
'Y' /
237 path( 1: 1 ) =
'Complex precision'
243 iseed( i ) = iseedy( i )
249 $ CALL
cerrvx( path, nout )
263 DO 130 imat = 1, nimat
267 IF( .NOT.dotype( imat ) )
272 zerot = imat.GE.3 .AND. imat.LE.5
273 IF( zerot .AND. n.LT.imat-2 )
279 uplo = uplos( iuplo )
280 packit = packs( iuplo )
285 CALL
clatb4( path, imat, n, n, type, kl, ku, anorm, mode,
287 rcondc = one / cndnum
290 CALL
clatms( n, n, dist, iseed, type, rwork, mode,
291 $ cndnum, anorm, kl, ku, packit, a, lda, work,
297 CALL
alaerh( path,
'CLATMS', info, 0, uplo, n, n, -1,
298 $ -1, -1, imat, nfail, nerrs, nout )
308 ELSE IF( imat.EQ.4 )
THEN
316 IF( iuplo.EQ.1 )
THEN
317 ioff = ( izero-1 )*izero / 2
318 DO 20 i = 1, izero - 1
328 DO 40 i = 1, izero - 1
343 IF( iuplo.EQ.1 )
THEN
346 CALL
claipd( n, a, n, -1 )
351 CALL
ccopy( npp, a, 1, asav, 1 )
354 equed = equeds( iequed )
355 IF( iequed.EQ.1 )
THEN
361 DO 100 ifact = 1, nfact
362 fact = facts( ifact )
363 prefac =
lsame( fact,
'F' )
364 nofact =
lsame( fact,
'N' )
365 equil =
lsame( fact,
'E' )
372 ELSE IF( .NOT.
lsame( fact,
'N' ) )
THEN
379 CALL
ccopy( npp, asav, 1, afac, 1 )
380 IF( equil .OR. iequed.GT.1 )
THEN
385 CALL
cppequ( uplo, n, afac, s, scond, amax,
387 IF( info.EQ.0 .AND. n.GT.0 )
THEN
393 CALL
claqhp( uplo, n, afac, s, scond,
406 anorm =
clanhp(
'1', uplo, n, afac, rwork )
410 CALL
cpptrf( uplo, n, afac, info )
414 CALL
ccopy( npp, afac, 1, a, 1 )
415 CALL
cpptri( uplo, n, a, info )
419 ainvnm =
clanhp(
'1', uplo, n, a, rwork )
420 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
423 rcondc = ( one / anorm ) / ainvnm
429 CALL
ccopy( npp, asav, 1, a, 1 )
434 CALL
clarhs( path, xtype, uplo,
' ', n, n, kl, ku,
435 $ nrhs, a, lda, xact, lda,
b, lda,
438 CALL
clacpy(
'Full', n, nrhs,
b, lda, bsav, lda )
447 CALL
ccopy( npp, a, 1, afac, 1 )
448 CALL
clacpy(
'Full', n, nrhs,
b, lda,
x, lda )
451 CALL
cppsv( uplo, n, nrhs, afac,
x, lda, info )
455 IF( info.NE.izero )
THEN
456 CALL
alaerh( path,
'CPPSV ', info, izero,
457 $ uplo, n, n, -1, -1, nrhs, imat,
458 $ nfail, nerrs, nout )
460 ELSE IF( info.NE.0 )
THEN
467 CALL
cppt01( uplo, n, a, afac, rwork,
472 CALL
clacpy(
'Full', n, nrhs,
b, lda, work,
474 CALL
cppt02( uplo, n, nrhs, a,
x, lda, work,
475 $ lda, rwork, result( 2 ) )
479 CALL
cget04( n, nrhs,
x, lda, xact, lda, rcondc,
487 IF( result( k ).GE.thresh )
THEN
488 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
489 $ CALL
aladhd( nout, path )
490 WRITE( nout, fmt = 9999 )
'CPPSV ', uplo,
491 $ n, imat, k, result( k )
501 IF( .NOT.prefac .AND. npp.GT.0 )
502 $ CALL
claset(
'Full', npp, 1, cmplx( zero ),
503 $ cmplx( zero ), afac, npp )
504 CALL
claset(
'Full', n, nrhs, cmplx( zero ),
505 $ cmplx( zero ),
x, lda )
506 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
511 CALL
claqhp( uplo, n, a, s, scond, amax, equed )
518 CALL
cppsvx( fact, uplo, n, nrhs, a, afac, equed,
519 $ s,
b, lda,
x, lda, rcond, rwork,
520 $ rwork( nrhs+1 ), work,
521 $ rwork( 2*nrhs+1 ), info )
525 IF( info.NE.izero )
THEN
526 CALL
alaerh( path,
'CPPSVX', info, izero,
527 $ fact // uplo, n, n, -1, -1, nrhs,
528 $ imat, nfail, nerrs, nout )
533 IF( .NOT.prefac )
THEN
538 CALL
cppt01( uplo, n, a, afac,
539 $ rwork( 2*nrhs+1 ), result( 1 ) )
547 CALL
clacpy(
'Full', n, nrhs, bsav, lda, work,
549 CALL
cppt02( uplo, n, nrhs, asav,
x, lda, work,
550 $ lda, rwork( 2*nrhs+1 ),
555 IF( nofact .OR. ( prefac .AND.
lsame( equed,
557 CALL
cget04( n, nrhs,
x, lda, xact, lda,
558 $ rcondc, result( 3 ) )
560 CALL
cget04( n, nrhs,
x, lda, xact, lda,
561 $ roldc, result( 3 ) )
567 CALL
cppt05( uplo, n, nrhs, asav,
b, lda,
x,
568 $ lda, xact, lda, rwork,
569 $ rwork( nrhs+1 ), result( 4 ) )
577 result( 6 ) =
sget06( rcond, rcondc )
583 IF( result( k ).GE.thresh )
THEN
584 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
585 $ CALL
aladhd( nout, path )
587 WRITE( nout, fmt = 9997 )
'CPPSVX', fact,
588 $ uplo, n, equed, imat, k, result( k )
590 WRITE( nout, fmt = 9998 )
'CPPSVX', fact,
591 $ uplo, n, imat, k, result( k )
606 CALL
alasvm( path, nout, nfail, nrun, nerrs )
608 9999
FORMAT( 1
x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i1,
609 $
', test(', i1,
')=', g12.5 )
610 9998
FORMAT( 1
x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
611 $
', type ', i1,
', test(', i1,
')=', g12.5 )
612 9997
FORMAT( 1
x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
613 $
', EQUED=''', a1,
''', type ', i1,
', 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 claipd(N, A, INDA, VINDA)
CLAIPD
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
REAL function sget06(RCOND, RCONDC)
SGET06
subroutine cppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPPT05
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine cpptrf(UPLO, N, AP, INFO)
CPPTRF
subroutine cpptri(UPLO, N, AP, INFO)
CPPTRI
subroutine cppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
CPPT02
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine claqhp(UPLO, N, AP, S, SCOND, AMAX, EQUED)
CLAQHP scales a Hermitian matrix stored in packed form.
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
subroutine cppsv(UPLO, N, NRHS, AP, B, LDB, INFO)
CPPSV computes the solution to system of linear equations A * X = B for OTHER matrices ...
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine cppequ(UPLO, N, AP, S, SCOND, AMAX, INFO)
CPPEQU
subroutine cerrvx(PATH, NUNIT)
CERRVX
subroutine cdrvpp(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, NOUT)
CDRVPP
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine cppt01(UPLO, N, A, AFAC, RWORK, RESID)
CPPT01
REAL function clanhp(NORM, UPLO, N, AP, WORK)
CLANHP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian matrix supplied in packed form.
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
subroutine cppsvx(FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
CPPSVX computes the solution to system of linear equations A * X = B for OTHER matrices ...