156 SUBROUTINE zdrvhp( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
157 $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
167 INTEGER nmax, nn, nout, nrhs
168 DOUBLE PRECISION thresh
172 INTEGER IWORK( * ), NVAL( * )
173 DOUBLE PRECISION RWORK( * )
174 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
175 $ work( * ), x( * ), xact( * )
181 DOUBLE PRECISION ONE, ZERO
182 PARAMETER ( ONE = 1.0d+0, zero = 0.0d+0 )
183 INTEGER NTYPES, NTESTS
184 parameter( ntypes = 10, ntests = 6 )
186 parameter( nfact = 2 )
190 CHARACTER DIST, FACT, PACKIT,
TYPE, UPLO, XTYPE
192 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
193 $ izero, j, k, k1, kl, ku, lda, mode, n, nb,
194 $ nbmin, nerrs, nfail, nimat, npp, nrun, nt
195 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC
198 CHARACTER FACTS( NFACT )
199 INTEGER ISEED( 4 ), ISEEDY( 4 )
200 DOUBLE PRECISION RESULT( NTESTS )
203 DOUBLE PRECISION DGET06, ZLANHP
204 EXTERNAL DGET06, ZLANHP
218 COMMON / infoc / infot, nunit, ok, lerr
219 COMMON / srnamc / srnamt
222 INTRINSIC dcmplx, max, min
225 DATA iseedy / 1988, 1989, 1990, 1991 /
226 DATA facts /
'F',
'N' /
238 iseed( i ) = iseedy( i )
244 $
CALL zerrvx( path, nout )
265 DO 170 imat = 1, nimat
269 IF( .NOT.dotype( imat ) )
274 zerot = imat.GE.3 .AND. imat.LE.6
275 IF( zerot .AND. n.LT.imat-2 )
281 IF( iuplo.EQ.1 )
THEN
292 CALL zlatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
296 CALL zlatms( n, n, dist, iseed,
TYPE, rwork, mode,
297 $ cndnum, anorm, kl, ku, packit, a, lda, work,
303 CALL alaerh( path,
'ZLATMS', info, 0, uplo, n, n, -1,
304 $ -1, -1, imat, nfail, nerrs, nout )
314 ELSE IF( imat.EQ.4 )
THEN
324 IF( iuplo.EQ.1 )
THEN
325 ioff = ( izero-1 )*izero / 2
326 DO 20 i = 1, izero - 1
336 DO 40 i = 1, izero - 1
347 IF( iuplo.EQ.1 )
THEN
377 IF( iuplo.EQ.1 )
THEN
380 CALL zlaipd( n, a, n, -1 )
383 DO 150 ifact = 1, nfact
387 fact = facts( ifact )
397 ELSE IF( ifact.EQ.1 )
THEN
401 anorm = zlanhp(
'1', uplo, n, a, rwork )
405 CALL zcopy( npp, a, 1, afac, 1 )
406 CALL zhptrf( uplo, n, afac, iwork, info )
410 CALL zcopy( npp, afac, 1, ainv, 1 )
411 CALL zhptri( uplo, n, ainv, iwork, work, info )
412 ainvnm = zlanhp(
'1', uplo, n, ainv, rwork )
416 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
419 rcondc = ( one / anorm ) / ainvnm
426 CALL zlarhs( path, xtype, uplo,
' ', n, n, kl, ku,
427 $ nrhs, a, lda, xact, lda, b, lda, iseed,
433 IF( ifact.EQ.2 )
THEN
434 CALL zcopy( npp, a, 1, afac, 1 )
435 CALL zlacpy(
'Full', n, nrhs, b, lda, x, lda )
440 CALL zhpsv( uplo, n, nrhs, afac, iwork, x, lda,
449 IF( iwork( k ).LT.0 )
THEN
450 IF( iwork( k ).NE.-k )
THEN
454 ELSE IF( iwork( k ).NE.k )
THEN
463 CALL alaerh( path,
'ZHPSV ', info, k, uplo, n,
464 $ n, -1, -1, nrhs, imat, nfail,
467 ELSE IF( info.NE.0 )
THEN
474 CALL zhpt01( uplo, n, a, afac, iwork, ainv, lda,
475 $ rwork, result( 1 ) )
479 CALL zlacpy(
'Full', n, nrhs, b, lda, work, lda )
480 CALL zppt02( uplo, n, nrhs, a, x, lda, work, lda,
481 $ rwork, result( 2 ) )
485 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
493 IF( result( k ).GE.thresh )
THEN
494 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
495 $
CALL aladhd( nout, path )
496 WRITE( nout, fmt = 9999 )
'ZHPSV ', uplo, n,
497 $ imat, k, result( k )
507 IF( ifact.EQ.2 .AND. npp.GT.0 )
508 $
CALL zlaset(
'Full', npp, 1, dcmplx( zero ),
509 $ dcmplx( zero ), afac, npp )
510 CALL zlaset(
'Full', n, nrhs, dcmplx( zero ),
511 $ dcmplx( zero ), x, lda )
517 CALL zhpsvx( fact, uplo, n, nrhs, a, afac, iwork, b,
518 $ lda, x, lda, rcond, rwork,
519 $ rwork( nrhs+1 ), work, rwork( 2*nrhs+1 ),
528 IF( iwork( k ).LT.0 )
THEN
529 IF( iwork( k ).NE.-k )
THEN
533 ELSE IF( iwork( k ).NE.k )
THEN
542 CALL alaerh( path,
'ZHPSVX', info, k, fact // uplo,
543 $ n, n, -1, -1, nrhs, imat, nfail,
549 IF( ifact.GE.2 )
THEN
554 CALL zhpt01( uplo, n, a, afac, iwork, ainv, lda,
555 $ rwork( 2*nrhs+1 ), result( 1 ) )
563 CALL zlacpy(
'Full', n, nrhs, b, lda, work, lda )
564 CALL zppt02( uplo, n, nrhs, a, x, lda, work, lda,
565 $ rwork( 2*nrhs+1 ), result( 2 ) )
569 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
574 CALL zppt05( uplo, n, nrhs, a, b, lda, x, lda,
575 $ xact, lda, rwork, rwork( nrhs+1 ),
584 result( 6 ) = dget06( rcond, rcondc )
590 IF( result( k ).GE.thresh )
THEN
591 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
592 $
CALL aladhd( nout, path )
593 WRITE( nout, fmt = 9998 )
'ZHPSVX', fact, uplo,
594 $ n, imat, k, result( k )
608 CALL alasvm( path, nout, nfail, nrun, nerrs )
610 9999
FORMAT( 1x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i2,
611 $
', test ', i2,
', ratio =', g12.5 )
612 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N =', i5,
613 $
', type ', i2,
', test ', i2,
', ratio =', g12.5 )