LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ ddrvpp()

subroutine ddrvpp ( logical, dimension( * )  dotype,
integer  nn,
integer, dimension( * )  nval,
integer  nrhs,
double precision  thresh,
logical  tsterr,
integer  nmax,
double precision, dimension( * )  a,
double precision, dimension( * )  afac,
double precision, dimension( * )  asav,
double precision, dimension( * )  b,
double precision, dimension( * )  bsav,
double precision, dimension( * )  x,
double precision, dimension( * )  xact,
double precision, dimension( * )  s,
double precision, dimension( * )  work,
double precision, dimension( * )  rwork,
integer, dimension( * )  iwork,
integer  nout 
)

DDRVPP

Purpose:
 DDRVPP tests the driver routines DPPSV and -SVX.
Parameters
[in]DOTYPE
          DOTYPE is LOGICAL array, dimension (NTYPES)
          The matrix types to be used for testing.  Matrices of type j
          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
[in]NN
          NN is INTEGER
          The number of values of N contained in the vector NVAL.
[in]NVAL
          NVAL is INTEGER array, dimension (NN)
          The values of the matrix dimension N.
[in]NRHS
          NRHS is INTEGER
          The number of right hand side vectors to be generated for
          each linear system.
[in]THRESH
          THRESH is DOUBLE PRECISION
          The threshold value for the test ratios.  A result is
          included in the output file if RESULT >= THRESH.  To have
          every test ratio printed, use THRESH = 0.
[in]TSTERR
          TSTERR is LOGICAL
          Flag that indicates whether error exits are to be tested.
[in]NMAX
          NMAX is INTEGER
          The maximum value permitted for N, used in dimensioning the
          work arrays.
[out]A
          A is DOUBLE PRECISION array, dimension
                      (NMAX*(NMAX+1)/2)
[out]AFAC
          AFAC is DOUBLE PRECISION array, dimension
                      (NMAX*(NMAX+1)/2)
[out]ASAV
          ASAV is DOUBLE PRECISION array, dimension
                      (NMAX*(NMAX+1)/2)
[out]B
          B is DOUBLE PRECISION array, dimension (NMAX*NRHS)
[out]BSAV
          BSAV is DOUBLE PRECISION array, dimension (NMAX*NRHS)
[out]X
          X is DOUBLE PRECISION array, dimension (NMAX*NRHS)
[out]XACT
          XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS)
[out]S
          S is DOUBLE PRECISION array, dimension (NMAX)
[out]WORK
          WORK is DOUBLE PRECISION array, dimension
                      (NMAX*max(3,NRHS))
[out]RWORK
          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
[out]IWORK
          IWORK is INTEGER array, dimension (NMAX)
[in]NOUT
          NOUT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 164 of file ddrvpp.f.

167*
168* -- LAPACK test routine --
169* -- LAPACK is a software package provided by Univ. of Tennessee, --
170* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
171*
172* .. Scalar Arguments ..
173 LOGICAL TSTERR
174 INTEGER NMAX, NN, NOUT, NRHS
175 DOUBLE PRECISION THRESH
176* ..
177* .. Array Arguments ..
178 LOGICAL DOTYPE( * )
179 INTEGER IWORK( * ), NVAL( * )
180 DOUBLE PRECISION A( * ), AFAC( * ), ASAV( * ), B( * ),
181 $ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
182 $ X( * ), XACT( * )
183* ..
184*
185* =====================================================================
186*
187* .. Parameters ..
188 DOUBLE PRECISION ONE, ZERO
189 parameter( one = 1.0d+0, zero = 0.0d+0 )
190 INTEGER NTYPES
191 parameter( ntypes = 9 )
192 INTEGER NTESTS
193 parameter( ntests = 6 )
194* ..
195* .. Local Scalars ..
196 LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
197 CHARACTER DIST, EQUED, FACT, PACKIT, TYPE, UPLO, XTYPE
198 CHARACTER*3 PATH
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,
203 $ ROLDC, SCOND
204* ..
205* .. Local Arrays ..
206 CHARACTER EQUEDS( 2 ), FACTS( 3 ), PACKS( 2 ), UPLOS( 2 )
207 INTEGER ISEED( 4 ), ISEEDY( 4 )
208 DOUBLE PRECISION RESULT( NTESTS )
209* ..
210* .. External Functions ..
211 LOGICAL LSAME
212 DOUBLE PRECISION DGET06, DLANSP
213 EXTERNAL lsame, dget06, dlansp
214* ..
215* .. External Subroutines ..
216 EXTERNAL aladhd, alaerh, alasvm, dcopy, derrvx, dget04,
217 $ dlacpy, dlaqsp, dlarhs, dlaset, dlatb4, dlatms,
218 $ dppequ, dppsv, dppsvx, dppt01, dppt02, dppt05,
219 $ dpptrf, dpptri
220* ..
221* .. Scalars in Common ..
222 LOGICAL LERR, OK
223 CHARACTER*32 SRNAMT
224 INTEGER INFOT, NUNIT
225* ..
226* .. Common blocks ..
227 COMMON / infoc / infot, nunit, ok, lerr
228 COMMON / srnamc / srnamt
229* ..
230* .. Intrinsic Functions ..
231 INTRINSIC max
232* ..
233* .. Data statements ..
234 DATA iseedy / 1988, 1989, 1990, 1991 /
235 DATA uplos / 'U', 'L' / , facts / 'F', 'N', 'E' / ,
236 $ packs / 'C', 'R' / , equeds / 'N', 'Y' /
237* ..
238* .. Executable Statements ..
239*
240* Initialize constants and the random number seed.
241*
242 path( 1: 1 ) = 'Double precision'
243 path( 2: 3 ) = 'PP'
244 nrun = 0
245 nfail = 0
246 nerrs = 0
247 DO 10 i = 1, 4
248 iseed( i ) = iseedy( i )
249 10 CONTINUE
250*
251* Test the error exits
252*
253 IF( tsterr )
254 $ CALL derrvx( path, nout )
255 infot = 0
256*
257* Do for each value of N in NVAL
258*
259 DO 140 in = 1, nn
260 n = nval( in )
261 lda = max( n, 1 )
262 npp = n*( n+1 ) / 2
263 xtype = 'N'
264 nimat = ntypes
265 IF( n.LE.0 )
266 $ nimat = 1
267*
268 DO 130 imat = 1, nimat
269*
270* Do the tests only if DOTYPE( IMAT ) is true.
271*
272 IF( .NOT.dotype( imat ) )
273 $ GO TO 130
274*
275* Skip types 3, 4, or 5 if the matrix size is too small.
276*
277 zerot = imat.GE.3 .AND. imat.LE.5
278 IF( zerot .AND. n.LT.imat-2 )
279 $ GO TO 130
280*
281* Do first for UPLO = 'U', then for UPLO = 'L'
282*
283 DO 120 iuplo = 1, 2
284 uplo = uplos( iuplo )
285 packit = packs( iuplo )
286*
287* Set up parameters with DLATB4 and generate a test matrix
288* with DLATMS.
289*
290 CALL dlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
291 $ CNDNUM, DIST )
292 rcondc = one / cndnum
293*
294 srnamt = 'DLATMS'
295 CALL dlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
296 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
297 $ INFO )
298*
299* Check error code from DLATMS.
300*
301 IF( info.NE.0 ) THEN
302 CALL alaerh( path, 'DLATMS', info, 0, uplo, n, n, -1,
303 $ -1, -1, imat, nfail, nerrs, nout )
304 GO TO 120
305 END IF
306*
307* For types 3-5, zero one row and column of the matrix to
308* test that INFO is returned correctly.
309*
310 IF( zerot ) THEN
311 IF( imat.EQ.3 ) THEN
312 izero = 1
313 ELSE IF( imat.EQ.4 ) THEN
314 izero = n
315 ELSE
316 izero = n / 2 + 1
317 END IF
318*
319* Set row and column IZERO of A to 0.
320*
321 IF( iuplo.EQ.1 ) THEN
322 ioff = ( izero-1 )*izero / 2
323 DO 20 i = 1, izero - 1
324 a( ioff+i ) = zero
325 20 CONTINUE
326 ioff = ioff + izero
327 DO 30 i = izero, n
328 a( ioff ) = zero
329 ioff = ioff + i
330 30 CONTINUE
331 ELSE
332 ioff = izero
333 DO 40 i = 1, izero - 1
334 a( ioff ) = zero
335 ioff = ioff + n - i
336 40 CONTINUE
337 ioff = ioff - izero
338 DO 50 i = izero, n
339 a( ioff+i ) = zero
340 50 CONTINUE
341 END IF
342 ELSE
343 izero = 0
344 END IF
345*
346* Save a copy of the matrix A in ASAV.
347*
348 CALL dcopy( npp, a, 1, asav, 1 )
349*
350 DO 110 iequed = 1, 2
351 equed = equeds( iequed )
352 IF( iequed.EQ.1 ) THEN
353 nfact = 3
354 ELSE
355 nfact = 1
356 END IF
357*
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' )
363*
364 IF( zerot ) THEN
365 IF( prefac )
366 $ GO TO 100
367 rcondc = zero
368*
369 ELSE IF( .NOT.lsame( fact, 'N' ) ) THEN
370*
371* Compute the condition number for comparison with
372* the value returned by DPPSVX (FACT = 'N' reuses
373* the condition number from the previous iteration
374* with FACT = 'F').
375*
376 CALL dcopy( npp, asav, 1, afac, 1 )
377 IF( equil .OR. iequed.GT.1 ) THEN
378*
379* Compute row and column scale factors to
380* equilibrate the matrix A.
381*
382 CALL dppequ( uplo, n, afac, s, scond, amax,
383 $ info )
384 IF( info.EQ.0 .AND. n.GT.0 ) THEN
385 IF( iequed.GT.1 )
386 $ scond = zero
387*
388* Equilibrate the matrix.
389*
390 CALL dlaqsp( uplo, n, afac, s, scond,
391 $ amax, equed )
392 END IF
393 END IF
394*
395* Save the condition number of the
396* non-equilibrated system for use in DGET04.
397*
398 IF( equil )
399 $ roldc = rcondc
400*
401* Compute the 1-norm of A.
402*
403 anorm = dlansp( '1', uplo, n, afac, rwork )
404*
405* Factor the matrix A.
406*
407 CALL dpptrf( uplo, n, afac, info )
408*
409* Form the inverse of A.
410*
411 CALL dcopy( npp, afac, 1, a, 1 )
412 CALL dpptri( uplo, n, a, info )
413*
414* Compute the 1-norm condition number of A.
415*
416 ainvnm = dlansp( '1', uplo, n, a, rwork )
417 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
418 rcondc = one
419 ELSE
420 rcondc = ( one / anorm ) / ainvnm
421 END IF
422 END IF
423*
424* Restore the matrix A.
425*
426 CALL dcopy( npp, asav, 1, a, 1 )
427*
428* Form an exact solution and set the right hand side.
429*
430 srnamt = 'DLARHS'
431 CALL dlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
432 $ nrhs, a, lda, xact, lda, b, lda,
433 $ iseed, info )
434 xtype = 'C'
435 CALL dlacpy( 'Full', n, nrhs, b, lda, bsav, lda )
436*
437 IF( nofact ) THEN
438*
439* --- Test DPPSV ---
440*
441* Compute the L*L' or U'*U factorization of the
442* matrix and solve the system.
443*
444 CALL dcopy( npp, a, 1, afac, 1 )
445 CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
446*
447 srnamt = 'DPPSV '
448 CALL dppsv( uplo, n, nrhs, afac, x, lda, info )
449*
450* Check error code from DPPSV .
451*
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 )
456 GO TO 70
457 ELSE IF( info.NE.0 ) THEN
458 GO TO 70
459 END IF
460*
461* Reconstruct matrix from factors and compute
462* residual.
463*
464 CALL dppt01( uplo, n, a, afac, rwork,
465 $ result( 1 ) )
466*
467* Compute residual of the computed solution.
468*
469 CALL dlacpy( 'Full', n, nrhs, b, lda, work,
470 $ lda )
471 CALL dppt02( uplo, n, nrhs, a, x, lda, work,
472 $ lda, rwork, result( 2 ) )
473*
474* Check solution from generated exact solution.
475*
476 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
477 $ result( 3 ) )
478 nt = 3
479*
480* Print information about the tests that did not
481* pass the threshold.
482*
483 DO 60 k = 1, nt
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 )
489 nfail = nfail + 1
490 END IF
491 60 CONTINUE
492 nrun = nrun + nt
493 70 CONTINUE
494 END IF
495*
496* --- Test DPPSVX ---
497*
498 IF( .NOT.prefac .AND. npp.GT.0 )
499 $ CALL dlaset( 'Full', npp, 1, zero, zero, afac,
500 $ npp )
501 CALL dlaset( 'Full', n, nrhs, zero, zero, x, lda )
502 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
503*
504* Equilibrate the matrix if FACT='F' and
505* EQUED='Y'.
506*
507 CALL dlaqsp( uplo, n, a, s, scond, amax, equed )
508 END IF
509*
510* Solve the system and compute the condition number
511* and error bounds using DPPSVX.
512*
513 srnamt = 'DPPSVX'
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 )
517*
518* Check the error code from DPPSVX.
519*
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 )
524 GO TO 90
525 END IF
526*
527 IF( info.EQ.0 ) THEN
528 IF( .NOT.prefac ) THEN
529*
530* Reconstruct matrix from factors and compute
531* residual.
532*
533 CALL dppt01( uplo, n, a, afac,
534 $ rwork( 2*nrhs+1 ), result( 1 ) )
535 k1 = 1
536 ELSE
537 k1 = 2
538 END IF
539*
540* Compute residual of the computed solution.
541*
542 CALL dlacpy( 'Full', n, nrhs, bsav, lda, work,
543 $ lda )
544 CALL dppt02( uplo, n, nrhs, asav, x, lda, work,
545 $ lda, rwork( 2*nrhs+1 ),
546 $ result( 2 ) )
547*
548* Check solution from generated exact solution.
549*
550 IF( nofact .OR. ( prefac .AND. lsame( equed,
551 $ 'N' ) ) ) THEN
552 CALL dget04( n, nrhs, x, lda, xact, lda,
553 $ rcondc, result( 3 ) )
554 ELSE
555 CALL dget04( n, nrhs, x, lda, xact, lda,
556 $ roldc, result( 3 ) )
557 END IF
558*
559* Check the error bounds from iterative
560* refinement.
561*
562 CALL dppt05( uplo, n, nrhs, asav, b, lda, x,
563 $ lda, xact, lda, rwork,
564 $ rwork( nrhs+1 ), result( 4 ) )
565 ELSE
566 k1 = 6
567 END IF
568*
569* Compare RCOND from DPPSVX with the computed value
570* in RCONDC.
571*
572 result( 6 ) = dget06( rcond, rcondc )
573*
574* Print information about the tests that did not pass
575* the threshold.
576*
577 DO 80 k = k1, 6
578 IF( result( k ).GE.thresh ) THEN
579 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
580 $ CALL aladhd( nout, path )
581 IF( prefac ) THEN
582 WRITE( nout, fmt = 9997 )'DPPSVX', fact,
583 $ uplo, n, equed, imat, k, result( k )
584 ELSE
585 WRITE( nout, fmt = 9998 )'DPPSVX', fact,
586 $ uplo, n, imat, k, result( k )
587 END IF
588 nfail = nfail + 1
589 END IF
590 80 CONTINUE
591 nrun = nrun + 7 - k1
592 90 CONTINUE
593 100 CONTINUE
594 110 CONTINUE
595 120 CONTINUE
596 130 CONTINUE
597 140 CONTINUE
598*
599* Print a summary of the results.
600*
601 CALL alasvm( path, nout, nfail, nrun, nerrs )
602*
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, ')=',
609 $ g12.5 )
610 RETURN
611*
612* End of DDRVPP
613*
alasvm
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
Definition alasvm.f:73
dlarhs
subroutine dlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
DLARHS
Definition dlarhs.f:205
aladhd
subroutine aladhd(iounit, path)
ALADHD
Definition aladhd.f:90
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
derrvx
subroutine derrvx(path, nunit)
DERRVX
Definition derrvx.f:55
dget04
subroutine dget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
DGET04
Definition dget04.f:102
dget06
double precision function dget06(rcond, rcondc)
DGET06
Definition dget06.f:55
dlatb4
subroutine dlatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
DLATB4
Definition dlatb4.f:120
dlatms
subroutine dlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
DLATMS
Definition dlatms.f:321
dppt01
subroutine dppt01(uplo, n, a, afac, rwork, resid)
DPPT01
Definition dppt01.f:93
dppt02
subroutine dppt02(uplo, n, nrhs, a, x, ldx, b, ldb, rwork, resid)
DPPT02
Definition dppt02.f:122
dppt05
subroutine dppt05(uplo, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
DPPT05
Definition dppt05.f:156
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
Definition dcopy.f:82
dlacpy
subroutine dlacpy(uplo, m, n, a, lda, b, ldb)
DLACPY copies all or part of one two-dimensional array to another.
Definition dlacpy.f:103
dlansp
double precision function dlansp(norm, uplo, n, ap, work)
DLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlansp.f:114
dlaqsp
subroutine dlaqsp(uplo, n, ap, s, scond, amax, equed)
DLAQSP scales a symmetric/Hermitian matrix in packed storage, using scaling factors computed by sppeq...
Definition dlaqsp.f:125
dlaset
subroutine dlaset(uplo, m, n, alpha, beta, a, lda)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition dlaset.f:110
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
dppequ
subroutine dppequ(uplo, n, ap, s, scond, amax, info)
DPPEQU
Definition dppequ.f:116
dppsv
subroutine dppsv(uplo, n, nrhs, ap, b, ldb, info)
DPPSV computes the solution to system of linear equations A * X = B for OTHER matrices
Definition dppsv.f:144
dppsvx
subroutine dppsvx(fact, uplo, n, nrhs, ap, afp, equed, s, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)
DPPSVX computes the solution to system of linear equations A * X = B for OTHER matrices
Definition dppsvx.f:311
dpptrf
subroutine dpptrf(uplo, n, ap, info)
DPPTRF
Definition dpptrf.f:119
dpptri
subroutine dpptri(uplo, n, ap, info)
DPPTRI
Definition dpptri.f:93
Here is the call graph for this function:
Here is the caller graph for this function: