158 SUBROUTINE zdrvpp( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
159 $ a, afac, asav,
b, bsav,
x, xact, s, work,
169 INTEGER nmax, nn, nout, nrhs
170 DOUBLE PRECISION thresh
175 DOUBLE PRECISION rwork( * ), s( * )
176 COMPLEX*16 a( * ), afac( * ), asav( * ),
b( * ),
177 $ bsav( * ), work( * ),
x( * ), xact( * )
183 DOUBLE PRECISION one, zero
184 parameter( one = 1.0d+0, zero = 0.0d+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 DOUBLE PRECISION ainvnm, amax, anorm, cndnum, rcond, rcondc,
201 CHARACTER equeds( 2 ), facts( 3 ), packs( 2 ), uplos( 2 )
202 INTEGER iseed( 4 ), iseedy( 4 )
203 DOUBLE PRECISION result( ntests )
222 COMMON / infoc / infot, nunit, ok, lerr
223 COMMON / srnamc / srnamt
226 INTRINSIC dcmplx, max
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 ) =
'Zomplex precision'
243 iseed( i ) = iseedy( i )
249 $ CALL
zerrvx( 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
zlatb4( path, imat, n, n, type, kl, ku, anorm, mode,
287 rcondc = one / cndnum
290 CALL
zlatms( n, n, dist, iseed, type, rwork, mode,
291 $ cndnum, anorm, kl, ku, packit, a, lda, work,
297 CALL
alaerh( path,
'ZLATMS', 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
zlaipd( n, a, n, -1 )
351 CALL
zcopy( 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
zcopy( npp, asav, 1, afac, 1 )
380 IF( equil .OR. iequed.GT.1 )
THEN
385 CALL
zppequ( uplo, n, afac, s, scond, amax,
387 IF( info.EQ.0 .AND. n.GT.0 )
THEN
393 CALL
zlaqhp( uplo, n, afac, s, scond,
406 anorm =
zlanhp(
'1', uplo, n, afac, rwork )
410 CALL
zpptrf( uplo, n, afac, info )
414 CALL
zcopy( npp, afac, 1, a, 1 )
415 CALL
zpptri( uplo, n, a, info )
419 ainvnm =
zlanhp(
'1', uplo, n, a, rwork )
420 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
423 rcondc = ( one / anorm ) / ainvnm
429 CALL
zcopy( npp, asav, 1, a, 1 )
434 CALL
zlarhs( path, xtype, uplo,
' ', n, n, kl, ku,
435 $ nrhs, a, lda, xact, lda,
b, lda,
438 CALL
zlacpy(
'Full', n, nrhs,
b, lda, bsav, lda )
447 CALL
zcopy( npp, a, 1, afac, 1 )
448 CALL
zlacpy(
'Full', n, nrhs,
b, lda,
x, lda )
451 CALL
zppsv( uplo, n, nrhs, afac,
x, lda, info )
455 IF( info.NE.izero )
THEN
456 CALL
alaerh( path,
'ZPPSV ', info, izero,
457 $ uplo, n, n, -1, -1, nrhs, imat,
458 $ nfail, nerrs, nout )
460 ELSE IF( info.NE.0 )
THEN
467 CALL
zppt01( uplo, n, a, afac, rwork,
472 CALL
zlacpy(
'Full', n, nrhs,
b, lda, work,
474 CALL
zppt02( uplo, n, nrhs, a,
x, lda, work,
475 $ lda, rwork, result( 2 ) )
479 CALL
zget04( 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 )
'ZPPSV ', uplo,
491 $ n, imat, k, result( k )
501 IF( .NOT.prefac .AND. npp.GT.0 )
502 $ CALL
zlaset(
'Full', npp, 1, dcmplx( zero ),
503 $ dcmplx( zero ), afac, npp )
504 CALL
zlaset(
'Full', n, nrhs, dcmplx( zero ),
505 $ dcmplx( zero ),
x, lda )
506 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
511 CALL
zlaqhp( uplo, n, a, s, scond, amax, equed )
518 CALL
zppsvx( 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,
'ZPPSVX', info, izero,
527 $ fact // uplo, n, n, -1, -1, nrhs,
528 $ imat, nfail, nerrs, nout )
533 IF( .NOT.prefac )
THEN
538 CALL
zppt01( uplo, n, a, afac,
539 $ rwork( 2*nrhs+1 ), result( 1 ) )
547 CALL
zlacpy(
'Full', n, nrhs, bsav, lda, work,
549 CALL
zppt02( uplo, n, nrhs, asav,
x, lda, work,
550 $ lda, rwork( 2*nrhs+1 ),
555 IF( nofact .OR. ( prefac .AND.
lsame( equed,
557 CALL
zget04( n, nrhs,
x, lda, xact, lda,
558 $ rcondc, result( 3 ) )
560 CALL
zget04( n, nrhs,
x, lda, xact, lda,
561 $ roldc, result( 3 ) )
567 CALL
zppt05( uplo, n, nrhs, asav,
b, lda,
x,
568 $ lda, xact, lda, rwork,
569 $ rwork( nrhs+1 ), result( 4 ) )
577 result( 6 ) =
dget06( 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 )
'ZPPSVX', fact,
588 $ uplo, n, equed, imat, k, result( k )
590 WRITE( nout, fmt = 9998 )
'ZPPSVX', 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 zppt01(UPLO, N, A, AFAC, RWORK, RESID)
ZPPT01
LOGICAL function lsame(CA, CB)
LSAME
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zpptri(UPLO, N, AP, INFO)
ZPPTRI
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine zppsvx(FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
ZPPSVX computes the solution to system of linear equations A * X = B for OTHER matrices ...
subroutine zppsv(UPLO, N, NRHS, AP, B, LDB, INFO)
ZPPSV computes the solution to system of linear equations A * X = B for OTHER matrices ...
subroutine zdrvpp(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, NOUT)
ZDRVPP
subroutine zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine zpptrf(UPLO, N, AP, INFO)
ZPPTRF
DOUBLE PRECISION function dget06(RCOND, RCONDC)
DGET06
subroutine zlaqhp(UPLO, N, AP, S, SCOND, AMAX, EQUED)
ZLAQHP scales a Hermitian matrix stored in packed form.
DOUBLE PRECISION function zlanhp(NORM, UPLO, N, AP, WORK)
ZLANHP 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 zppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
ZPPT05
subroutine zppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
ZPPT02
subroutine zppequ(UPLO, N, AP, S, SCOND, AMAX, INFO)
ZPPEQU
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine zerrvx(PATH, NUNIT)
ZERRVX
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
subroutine zlaipd(N, A, INDA, VINDA)
ZLAIPD
subroutine zlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
ZLATB4