156 SUBROUTINE zdrvpp( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
157 $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
166 INTEGER NMAX, NN, NOUT, NRHS
167 DOUBLE PRECISION THRESH
172 DOUBLE PRECISION RWORK( * ), S( * )
173 COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ),
174 $ bsav( * ), work( * ), x( * ), xact( * )
180 DOUBLE PRECISION ONE, ZERO
181 PARAMETER ( ONE = 1.0d+0, zero = 0.0d+0 )
183 parameter( ntypes = 9 )
185 parameter( ntests = 6 )
188 LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
189 CHARACTER DIST, EQUED, FACT, PACKIT,
TYPE, UPLO, XTYPE
191 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
192 $ izero, k, k1, kl, ku, lda, mode, n, nerrs,
193 $ nfact, nfail, nimat, npp, nrun, nt
194 DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
198 CHARACTER EQUEDS( 2 ), FACTS( 3 ), PACKS( 2 ), UPLOS( 2 )
199 INTEGER ISEED( 4 ), ISEEDY( 4 )
200 DOUBLE PRECISION RESULT( NTESTS )
204 DOUBLE PRECISION DGET06, ZLANHP
205 EXTERNAL lsame, dget06, zlanhp
219 COMMON / infoc / infot, nunit, ok, lerr
220 COMMON / srnamc / srnamt
223 INTRINSIC dcmplx, max
226 DATA iseedy / 1988, 1989, 1990, 1991 /
227 DATA uplos /
'U',
'L' / , facts /
'F',
'N',
'E' / ,
228 $ packs /
'C',
'R' / , equeds /
'N',
'Y' /
234 path( 1: 1 ) =
'Zomplex precision'
240 iseed( i ) = iseedy( i )
246 $
CALL zerrvx( path, nout )
260 DO 130 imat = 1, nimat
264 IF( .NOT.dotype( imat ) )
269 zerot = imat.GE.3 .AND. imat.LE.5
270 IF( zerot .AND. n.LT.imat-2 )
276 uplo = uplos( iuplo )
277 packit = packs( iuplo )
282 CALL zlatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
284 rcondc = one / cndnum
287 CALL zlatms( n, n, dist, iseed,
TYPE, rwork, mode,
288 $ cndnum, anorm, kl, ku, packit, a, lda, work,
294 CALL alaerh( path,
'ZLATMS', info, 0, uplo, n, n, -1,
295 $ -1, -1, imat, nfail, nerrs, nout )
305 ELSE IF( imat.EQ.4 )
THEN
313 IF( iuplo.EQ.1 )
THEN
314 ioff = ( izero-1 )*izero / 2
315 DO 20 i = 1, izero - 1
325 DO 40 i = 1, izero - 1
340 IF( iuplo.EQ.1 )
THEN
343 CALL zlaipd( n, a, n, -1 )
348 CALL zcopy( npp, a, 1, asav, 1 )
351 equed = equeds( iequed )
352 IF( iequed.EQ.1 )
THEN
358 DO 100 ifact = 1, nfact
359 fact = facts( ifact )
360 prefac = lsame( fact,
'F' )
361 nofact = lsame( fact,
'N' )
362 equil = lsame( fact,
'E' )
369 ELSE IF( .NOT.lsame( fact,
'N' ) )
THEN
376 CALL zcopy( npp, asav, 1, afac, 1 )
377 IF( equil .OR. iequed.GT.1 )
THEN
382 CALL zppequ( uplo, n, afac, s, scond, amax,
384 IF( info.EQ.0 .AND. n.GT.0 )
THEN
390 CALL zlaqhp( uplo, n, afac, s, scond,
403 anorm = zlanhp(
'1', uplo, n, afac, rwork )
407 CALL zpptrf( uplo, n, afac, info )
411 CALL zcopy( npp, afac, 1, a, 1 )
412 CALL zpptri( uplo, n, a, info )
416 ainvnm = zlanhp(
'1', uplo, n, a, rwork )
417 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
420 rcondc = ( one / anorm ) / ainvnm
426 CALL zcopy( npp, asav, 1, a, 1 )
431 CALL zlarhs( path, xtype, uplo,
' ', n, n, kl, ku,
432 $ nrhs, a, lda, xact, lda, b, lda,
435 CALL zlacpy(
'Full', n, nrhs, b, lda, bsav, lda )
444 CALL zcopy( npp, a, 1, afac, 1 )
445 CALL zlacpy(
'Full', n, nrhs, b, lda, x, lda )
448 CALL zppsv( uplo, n, nrhs, afac, x, lda, info )
452 IF( info.NE.izero )
THEN
453 CALL alaerh( path,
'ZPPSV ', info, izero,
454 $ uplo, n, n, -1, -1, nrhs, imat,
455 $ nfail, nerrs, nout )
457 ELSE IF( info.NE.0 )
THEN
464 CALL zppt01( uplo, n, a, afac, rwork,
469 CALL zlacpy(
'Full', n, nrhs, b, lda, work,
471 CALL zppt02( uplo, n, nrhs, a, x, lda, work,
472 $ lda, rwork, result( 2 ) )
476 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
484 IF( result( k ).GE.thresh )
THEN
485 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
486 $
CALL aladhd( nout, path )
487 WRITE( nout, fmt = 9999 )
'ZPPSV ', uplo,
488 $ n, imat, k, result( k )
498 IF( .NOT.prefac .AND. npp.GT.0 )
499 $
CALL zlaset(
'Full', npp, 1, dcmplx( zero ),
500 $ dcmplx( zero ), afac, npp )
501 CALL zlaset(
'Full', n, nrhs, dcmplx( zero ),
502 $ dcmplx( zero ), x, lda )
503 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
508 CALL zlaqhp( uplo, n, a, s, scond, amax, equed )
515 CALL zppsvx( fact, uplo, n, nrhs, a, afac, equed,
516 $ s, b, lda, x, lda, rcond, rwork,
517 $ rwork( nrhs+1 ), work,
518 $ rwork( 2*nrhs+1 ), info )
522 IF( info.NE.izero )
THEN
523 CALL alaerh( path,
'ZPPSVX', info, izero,
524 $ fact // uplo, n, n, -1, -1, nrhs,
525 $ imat, nfail, nerrs, nout )
530 IF( .NOT.prefac )
THEN
535 CALL zppt01( uplo, n, a, afac,
536 $ rwork( 2*nrhs+1 ), result( 1 ) )
544 CALL zlacpy(
'Full', n, nrhs, bsav, lda, work,
546 CALL zppt02( uplo, n, nrhs, asav, x, lda, work,
547 $ lda, rwork( 2*nrhs+1 ),
552 IF( nofact .OR. ( prefac .AND. lsame( equed,
554 CALL zget04( n, nrhs, x, lda, xact, lda,
555 $ rcondc, result( 3 ) )
557 CALL zget04( n, nrhs, x, lda, xact, lda,
558 $ roldc, result( 3 ) )
564 CALL zppt05( uplo, n, nrhs, asav, b, lda, x,
565 $ lda, xact, lda, rwork,
566 $ rwork( nrhs+1 ), result( 4 ) )
574 result( 6 ) = dget06( rcond, rcondc )
580 IF( result( k ).GE.thresh )
THEN
581 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
582 $
CALL aladhd( nout, path )
584 WRITE( nout, fmt = 9997 )
'ZPPSVX', fact,
585 $ uplo, n, equed, imat, k, result( k )
587 WRITE( nout, fmt = 9998 )
'ZPPSVX', fact,
588 $ uplo, n, imat, k, result( k )
603 CALL alasvm( path, nout, nfail, nrun, nerrs )
605 9999
FORMAT( 1x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i1,
606 $
', test(', i1,
')=', g12.5 )
607 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
608 $
', type ', i1,
', test(', i1,
')=', g12.5 )
609 9997
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
610 $
', EQUED=''', a1,
''', type ', i1,
', test(', i1,
')=',