LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ 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 *
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
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:53
alasvm
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:73
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
dcopy
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
Definition: dcopy.f:82
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
dppt02
subroutine dppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
DPPT02
Definition: dppt02.f:122
dget04
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
Definition: dget04.f:102
dppt01
subroutine dppt01(UPLO, N, A, AFAC, RWORK, RESID)
DPPT01
Definition: dppt01.f:93
dlatb4
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
Definition: dlatb4.f:120
derrvx
subroutine derrvx(PATH, NUNIT)
DERRVX
Definition: derrvx.f:55
dppt05
subroutine dppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DPPT05
Definition: dppt05.f:156
dget06
double precision function dget06(RCOND, RCONDC)
DGET06
Definition: dget06.f:55
dlatms
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
Definition: dlatms.f:321
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
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
dpptrf
subroutine dpptrf(UPLO, N, AP, INFO)
DPPTRF
Definition: dpptrf.f:119
dppequ
subroutine dppequ(UPLO, N, AP, S, SCOND, AMAX, INFO)
DPPEQU
Definition: dppequ.f:116
dpptri
subroutine dpptri(UPLO, N, AP, INFO)
DPPTRI
Definition: dpptri.f:93
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
Here is the call graph for this function:
Here is the caller graph for this function: