151 SUBROUTINE ddrvsy( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
152 $ a, afac, ainv,
b, x, xact, work, rwork, iwork,
162 INTEGER nmax, nn, nout, nrhs
163 DOUBLE PRECISION thresh
167 INTEGER iwork( * ), nval( * )
168 DOUBLE PRECISION a( * ), afac( * ), ainv( * ),
b( * ),
169 $ rwork( * ), work( * ), x( * ), xact( * )
175 DOUBLE PRECISION one, zero
176 parameter( one = 1.0d+0, zero = 0.0d+0 )
177 INTEGER ntypes, ntests
178 parameter( ntypes = 10, ntests = 6 )
180 parameter( nfact = 2 )
184 CHARACTER dist, fact, type, uplo, xtype
186 INTEGER i, i1, i2, ifact, imat, in, info, ioff, iuplo,
187 $ izero,
j, k, k1, kl, ku, lda, lwork, mode, n,
188 $ nb, nbmin, nerrs, nfail, nimat, nrun, nt
189 DOUBLE PRECISION ainvnm, anorm, cndnum, rcond, rcondc
192 CHARACTER facts( nfact ), uplos( 2 )
193 INTEGER iseed( 4 ), iseedy( 4 )
194 DOUBLE PRECISION result( ntests )
211 COMMON / infoc / infot, nunit, ok, lerr
212 COMMON / srnamc / srnamt
218 DATA iseedy / 1988, 1989, 1990, 1991 /
219 DATA uplos /
'U',
'L' / , facts /
'F',
'N' /
225 path( 1: 1 ) =
'Double precision'
231 iseed( i ) = iseedy( i )
233 lwork = max( 2*nmax, nmax*nrhs )
238 $ CALL
derrvx( path, nout )
258 DO 170 imat = 1, nimat
262 IF( .NOT.dotype( imat ) )
267 zerot = imat.GE.3 .AND. imat.LE.6
268 IF( zerot .AND. n.LT.imat-2 )
274 uplo = uplos( iuplo )
279 CALL
dlatb4( path, imat, n, n, type, kl, ku, anorm, mode,
283 CALL
dlatms( n, n, dist, iseed, type, rwork, mode,
284 $ cndnum, anorm, kl, ku, uplo, a, lda, work,
290 CALL
alaerh( path,
'DLATMS', info, 0, uplo, n, n, -1,
291 $ -1, -1, imat, nfail, nerrs, nout )
301 ELSE IF( imat.EQ.4 )
THEN
311 IF( iuplo.EQ.1 )
THEN
312 ioff = ( izero-1 )*lda
313 DO 20 i = 1, izero - 1
323 DO 40 i = 1, izero - 1
334 IF( iuplo.EQ.1 )
THEN
362 DO 150 ifact = 1, nfact
366 fact = facts( ifact )
376 ELSE IF( ifact.EQ.1 )
THEN
380 anorm =
dlansy(
'1', uplo, n, a, lda, rwork )
384 CALL
dlacpy( uplo, n, n, a, lda, afac, lda )
385 CALL
dsytrf( uplo, n, afac, lda, iwork, work,
390 CALL
dlacpy( uplo, n, n, afac, lda, ainv, lda )
391 lwork = (n+nb+1)*(nb+3)
392 CALL
dsytri2( uplo, n, ainv, lda, iwork, work,
394 ainvnm =
dlansy(
'1', uplo, n, ainv, lda, rwork )
398 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
401 rcondc = ( one / anorm ) / ainvnm
408 CALL
dlarhs( path, xtype, uplo,
' ', n, n, kl, ku,
409 $ nrhs, a, lda, xact, lda,
b, lda, iseed,
415 IF( ifact.EQ.2 )
THEN
416 CALL
dlacpy( uplo, n, n, a, lda, afac, lda )
417 CALL
dlacpy(
'Full', n, nrhs,
b, lda, x, lda )
422 CALL
dsysv( uplo, n, nrhs, afac, lda, iwork, x,
423 $ lda, work, lwork, info )
431 IF( iwork( k ).LT.0 )
THEN
432 IF( iwork( k ).NE.-k )
THEN
436 ELSE IF( iwork( k ).NE.k )
THEN
445 CALL
alaerh( path,
'DSYSV ', info, k, uplo, n,
446 $ n, -1, -1, nrhs, imat, nfail,
449 ELSE IF( info.NE.0 )
THEN
456 CALL
dsyt01( uplo, n, a, lda, afac, lda, iwork,
457 $ ainv, lda, rwork, result( 1 ) )
461 CALL
dlacpy(
'Full', n, nrhs,
b, lda, work, lda )
462 CALL
dpot02( uplo, n, nrhs, a, lda, x, lda, work,
463 $ lda, rwork, result( 2 ) )
467 CALL
dget04( n, nrhs, x, lda, xact, lda, rcondc,
475 IF( result( k ).GE.thresh )
THEN
476 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
477 $ CALL
aladhd( nout, path )
478 WRITE( nout, fmt = 9999 )
'DSYSV ', uplo, n,
479 $ imat, k, result( k )
490 $ CALL
dlaset( uplo, n, n, zero, zero, afac, lda )
491 CALL
dlaset(
'Full', n, nrhs, zero, zero, x, lda )
497 CALL
dsysvx( fact, uplo, n, nrhs, a, lda, afac, lda,
498 $ iwork,
b, lda, x, lda, rcond, rwork,
499 $ rwork( nrhs+1 ), work, lwork,
500 $ iwork( n+1 ), info )
508 IF( iwork( k ).LT.0 )
THEN
509 IF( iwork( k ).NE.-k )
THEN
513 ELSE IF( iwork( k ).NE.k )
THEN
522 CALL
alaerh( path,
'DSYSVX', info, k, fact // uplo,
523 $ n, n, -1, -1, nrhs, imat, nfail,
529 IF( ifact.GE.2 )
THEN
534 CALL
dsyt01( uplo, n, a, lda, afac, lda, iwork,
535 $ ainv, lda, rwork( 2*nrhs+1 ),
544 CALL
dlacpy(
'Full', n, nrhs,
b, lda, work, lda )
545 CALL
dpot02( uplo, n, nrhs, a, lda, x, lda, work,
546 $ lda, rwork( 2*nrhs+1 ), result( 2 ) )
550 CALL
dget04( n, nrhs, x, lda, xact, lda, rcondc,
555 CALL
dpot05( uplo, n, nrhs, a, lda,
b, lda, x, lda,
556 $ xact, lda, rwork, rwork( nrhs+1 ),
565 result( 6 ) =
dget06( rcond, rcondc )
571 IF( result( k ).GE.thresh )
THEN
572 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
573 $ CALL
aladhd( nout, path )
574 WRITE( nout, fmt = 9998 )
'DSYSVX', fact, uplo,
575 $ n, imat, k, result( k )
589 CALL
alasvm( path, nout, nfail, nrun, nerrs )
591 9999
FORMAT( 1x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i2,
592 $
', test ', i2,
', ratio =', g12.5 )
593 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N =', i5,
594 $
', type ', i2,
', test ', i2,
', ratio =', g12.5 )