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( 1x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i1,
609 $
', test(', i1,
')=', g12.5 )
610 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
611 $
', type ', i1,
', test(', i1,
')=', g12.5 )
612 9997
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
613 $
', EQUED=''', a1,
''', type ', i1,
', test(', i1,
')=',
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 zlaqhp(UPLO, N, AP, S, SCOND, AMAX, EQUED)
ZLAQHP scales a Hermitian matrix stored in packed form.
subroutine zppequ(UPLO, N, AP, S, SCOND, AMAX, INFO)
ZPPEQU
subroutine zpptrf(UPLO, N, AP, INFO)
ZPPTRF
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
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 zlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
ZLATB4
subroutine zlaipd(N, A, INDA, VINDA)
ZLAIPD
subroutine zpptri(UPLO, N, AP, INFO)
ZPPTRI
subroutine aladhd(IOUNIT, PATH)
ALADHD
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...
logical function lsame(CA, CB)
LSAME
subroutine zppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
ZPPT02
double precision function dget06(RCOND, RCONDC)
DGET06
subroutine zppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
ZPPT05
subroutine zerrvx(PATH, NUNIT)
ZERRVX
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 zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
subroutine zppt01(UPLO, N, A, AFAC, RWORK, RESID)
ZPPT01
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.