164 SUBROUTINE ddrvpp( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
165 $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
166 $ RWORK, IWORK, NOUT )
174 INTEGER NMAX, NN, NOUT, NRHS
175 DOUBLE PRECISION THRESH
179 INTEGER IWORK( * ), NVAL( * )
180 DOUBLE PRECISION A( * ), AFAC( * ), ASAV( * ), B( * ),
181 $ bsav( * ), rwork( * ), s( * ), work( * ),
188 DOUBLE PRECISION ONE, ZERO
189 PARAMETER ( ONE = 1.0d+0, zero = 0.0d+0 )
191 parameter( ntypes = 9 )
193 parameter( ntests = 6 )
196 LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
197 CHARACTER DIST, EQUED, FACT, PACKIT,
TYPE, UPLO, XTYPE
199 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
200 $ izero, k, k1, kl, ku, lda, mode, n, nerrs,
201 $ nfact, nfail, nimat, npp, nrun, nt
202 DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
206 CHARACTER EQUEDS( 2 ), FACTS( 3 ), PACKS( 2 ), UPLOS( 2 )
207 INTEGER ISEED( 4 ), ISEEDY( 4 )
208 DOUBLE PRECISION RESULT( NTESTS )
212 DOUBLE PRECISION DGET06, DLANSP
213 EXTERNAL lsame, dget06, dlansp
227 COMMON / infoc / infot, nunit, ok, lerr
228 COMMON / srnamc / srnamt
234 DATA iseedy / 1988, 1989, 1990, 1991 /
235 DATA uplos /
'U',
'L' / , facts /
'F',
'N',
'E' / ,
236 $ packs /
'C',
'R' / , equeds /
'N',
'Y' /
242 path( 1: 1 ) =
'Double precision'
248 iseed( i ) = iseedy( i )
254 $
CALL derrvx( path, nout )
268 DO 130 imat = 1, nimat
272 IF( .NOT.dotype( imat ) )
277 zerot = imat.GE.3 .AND. imat.LE.5
278 IF( zerot .AND. n.LT.imat-2 )
284 uplo = uplos( iuplo )
285 packit = packs( iuplo )
290 CALL dlatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
292 rcondc = one / cndnum
295 CALL dlatms( n, n, dist, iseed,
TYPE, rwork, mode,
296 $ cndnum, anorm, kl, ku, packit, a, lda, work,
302 CALL alaerh( path,
'DLATMS', info, 0, uplo, n, n, -1,
303 $ -1, -1, imat, nfail, nerrs, nout )
313 ELSE IF( imat.EQ.4 )
THEN
321 IF( iuplo.EQ.1 )
THEN
322 ioff = ( izero-1 )*izero / 2
323 DO 20 i = 1, izero - 1
333 DO 40 i = 1, izero - 1
348 CALL dcopy( 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 dcopy( npp, asav, 1, afac, 1 )
377 IF( equil .OR. iequed.GT.1 )
THEN
382 CALL dppequ( uplo, n, afac, s, scond, amax,
384 IF( info.EQ.0 .AND. n.GT.0 )
THEN
390 CALL dlaqsp( uplo, n, afac, s, scond,
403 anorm = dlansp(
'1', uplo, n, afac, rwork )
407 CALL dpptrf( uplo, n, afac, info )
411 CALL dcopy( npp, afac, 1, a, 1 )
412 CALL dpptri( uplo, n, a, info )
416 ainvnm = dlansp(
'1', uplo, n, a, rwork )
417 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
420 rcondc = ( one / anorm ) / ainvnm
426 CALL dcopy( npp, asav, 1, a, 1 )
431 CALL dlarhs( path, xtype, uplo,
' ', n, n, kl, ku,
432 $ nrhs, a, lda, xact, lda, b, lda,
435 CALL dlacpy(
'Full', n, nrhs, b, lda, bsav, lda )
444 CALL dcopy( npp, a, 1, afac, 1 )
445 CALL dlacpy(
'Full', n, nrhs, b, lda, x, lda )
448 CALL dppsv( uplo, n, nrhs, afac, x, lda, info )
452 IF( info.NE.izero )
THEN
453 CALL alaerh( path,
'DPPSV ', info, izero,
454 $ uplo, n, n, -1, -1, nrhs, imat,
455 $ nfail, nerrs, nout )
457 ELSE IF( info.NE.0 )
THEN
464 CALL dppt01( uplo, n, a, afac, rwork,
469 CALL dlacpy(
'Full', n, nrhs, b, lda, work,
471 CALL dppt02( uplo, n, nrhs, a, x, lda, work,
472 $ lda, rwork, result( 2 ) )
476 CALL dget04( 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 )
'DPPSV ', uplo,
488 $ n, imat, k, result( k )
498 IF( .NOT.prefac .AND. npp.GT.0 )
499 $
CALL dlaset(
'Full', npp, 1, zero, zero, afac,
501 CALL dlaset(
'Full', n, nrhs, zero, zero, x, lda )
502 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
507 CALL dlaqsp( uplo, n, a, s, scond, amax, equed )
514 CALL dppsvx( fact, uplo, n, nrhs, a, afac, equed,
515 $ s, b, lda, x, lda, rcond, rwork,
516 $ rwork( nrhs+1 ), work, iwork, info )
520 IF( info.NE.izero )
THEN
521 CALL alaerh( path,
'DPPSVX', info, izero,
522 $ fact // uplo, n, n, -1, -1, nrhs,
523 $ imat, nfail, nerrs, nout )
528 IF( .NOT.prefac )
THEN
533 CALL dppt01( uplo, n, a, afac,
534 $ rwork( 2*nrhs+1 ), result( 1 ) )
542 CALL dlacpy(
'Full', n, nrhs, bsav, lda, work,
544 CALL dppt02( uplo, n, nrhs, asav, x, lda, work,
545 $ lda, rwork( 2*nrhs+1 ),
550 IF( nofact .OR. ( prefac .AND. lsame( equed,
552 CALL dget04( n, nrhs, x, lda, xact, lda,
553 $ rcondc, result( 3 ) )
555 CALL dget04( n, nrhs, x, lda, xact, lda,
556 $ roldc, result( 3 ) )
562 CALL dppt05( uplo, n, nrhs, asav, b, lda, x,
563 $ lda, xact, lda, rwork,
564 $ rwork( nrhs+1 ), result( 4 ) )
572 result( 6 ) = dget06( rcond, rcondc )
578 IF( result( k ).GE.thresh )
THEN
579 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
580 $
CALL aladhd( nout, path )
582 WRITE( nout, fmt = 9997 )
'DPPSVX', fact,
583 $ uplo, n, equed, imat, k, result( k )
585 WRITE( nout, fmt = 9998 )
'DPPSVX', fact,
586 $ uplo, n, imat, k, result( k )
601 CALL alasvm( path, nout, nfail, nrun, nerrs )
603 9999
FORMAT( 1x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i1,
604 $
', test(', i1,
')=', g12.5 )
605 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
606 $
', type ', i1,
', test(', i1,
')=', g12.5 )
607 9997
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
608 $
', EQUED=''', a1,
''', type ', i1,
', test(', i1,
')=',