LAPACK  3.7.1
LAPACK: Linear Algebra PACKage

◆ ddrvsp()

subroutine ddrvsp ( 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( * )  AINV,
double precision, dimension( * )  B,
double precision, dimension( * )  X,
double precision, dimension( * )  XACT,
double precision, dimension( * )  WORK,
double precision, dimension( * )  RWORK,
integer, dimension( * )  IWORK,
integer  NOUT 
)

DDRVSP

Purpose: 
 DDRVSP tests the driver routines DSPSV 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]AINV
          AINV is DOUBLE PRECISION array, dimension
                      (NMAX*(NMAX+1)/2)
[out]B
          B 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]WORK
          WORK is DOUBLE PRECISION array, dimension
                      (NMAX*max(2,NRHS))
[out]RWORK
          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
[out]IWORK
          IWORK is INTEGER array, dimension (2*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.
Date
December 2016

Definition at line 158 of file ddrvsp.f.

158 *
159 * -- LAPACK test routine (version 3.7.0) --
160 * -- LAPACK is a software package provided by Univ. of Tennessee, --
161 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
162 * December 2016
163 *
164 * .. Scalar Arguments ..
165  LOGICAL tsterr
166  INTEGER nmax, nn, nout, nrhs
167  DOUBLE PRECISION thresh
168 * ..
169 * .. Array Arguments ..
170  LOGICAL dotype( * )
171  INTEGER iwork( * ), nval( * )
172  DOUBLE PRECISION a( * ), afac( * ), ainv( * ), b( * ),
173  $ rwork( * ), work( * ), x( * ), xact( * )
174 * ..
175 *
176 * =====================================================================
177 *
178 * .. Parameters ..
179  DOUBLE PRECISION one, zero
180  parameter( one = 1.0d+0, zero = 0.0d+0 )
181  INTEGER ntypes, ntests
182  parameter( ntypes = 10, ntests = 6 )
183  INTEGER nfact
184  parameter( nfact = 2 )
185 * ..
186 * .. Local Scalars ..
187  LOGICAL zerot
188  CHARACTER dist, fact, packit, TYPE, uplo, xtype
189  CHARACTER*3 path
190  INTEGER i, i1, i2, ifact, imat, in, info, ioff, iuplo,
191  $ izero, j, k, k1, kl, ku, lda, lwork, mode, n,
192  $ nerrs, nfail, nimat, npp, nrun, nt
193  DOUBLE PRECISION ainvnm, anorm, cndnum, rcond, rcondc
194 * ..
195 * .. Local Arrays ..
196  CHARACTER facts( nfact )
197  INTEGER iseed( 4 ), iseedy( 4 )
198  DOUBLE PRECISION result( ntests )
199 * ..
200 * .. External Functions ..
201  DOUBLE PRECISION dget06, dlansp
202  EXTERNAL dget06, dlansp
203 * ..
204 * .. External Subroutines ..
205  EXTERNAL aladhd, alaerh, alasvm, dcopy, derrvx, dget04,
206  $ dlacpy, dlarhs, dlaset, dlatb4, dlatms, dppt02,
207  $ dppt05, dspsv, dspsvx, dspt01, dsptrf, dsptri
208 * ..
209 * .. Scalars in Common ..
210  LOGICAL lerr, ok
211  CHARACTER*32 srnamt
212  INTEGER infot, nunit
213 * ..
214 * .. Common blocks ..
215  COMMON / infoc / infot, nunit, ok, lerr
216  COMMON / srnamc / srnamt
217 * ..
218 * .. Intrinsic Functions ..
219  INTRINSIC max, min
220 * ..
221 * .. Data statements ..
222  DATA iseedy / 1988, 1989, 1990, 1991 /
223  DATA facts / 'F', 'N' /
224 * ..
225 * .. Executable Statements ..
226 *
227 * Initialize constants and the random number seed.
228 *
229  path( 1: 1 ) = 'Double precision'
230  path( 2: 3 ) = 'SP'
231  nrun = 0
232  nfail = 0
233  nerrs = 0
234  DO 10 i = 1, 4
235  iseed( i ) = iseedy( i )
236  10 CONTINUE
237  lwork = max( 2*nmax, nmax*nrhs )
238 *
239 * Test the error exits
240 *
241  IF( tsterr )
242  $ CALL derrvx( path, nout )
243  infot = 0
244 *
245 * Do for each value of N in NVAL
246 *
247  DO 180 in = 1, nn
248  n = nval( in )
249  lda = max( n, 1 )
250  npp = n*( n+1 ) / 2
251  xtype = 'N'
252  nimat = ntypes
253  IF( n.LE.0 )
254  $ nimat = 1
255 *
256  DO 170 imat = 1, nimat
257 *
258 * Do the tests only if DOTYPE( IMAT ) is true.
259 *
260  IF( .NOT.dotype( imat ) )
261  $ GO TO 170
262 *
263 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
264 *
265  zerot = imat.GE.3 .AND. imat.LE.6
266  IF( zerot .AND. n.LT.imat-2 )
267  $ GO TO 170
268 *
269 * Do first for UPLO = 'U', then for UPLO = 'L'
270 *
271  DO 160 iuplo = 1, 2
272  IF( iuplo.EQ.1 ) THEN
273  uplo = 'U'
274  packit = 'C'
275  ELSE
276  uplo = 'L'
277  packit = 'R'
278  END IF
279 *
280 * Set up parameters with DLATB4 and generate a test matrix
281 * with DLATMS.
282 *
283  CALL dlatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
284  $ cndnum, dist )
285 *
286  srnamt = 'DLATMS'
287  CALL dlatms( n, n, dist, iseed, TYPE, rwork, mode,
288  $ cndnum, anorm, kl, ku, packit, a, lda, work,
289  $ info )
290 *
291 * Check error code from DLATMS.
292 *
293  IF( info.NE.0 ) THEN
294  CALL alaerh( path, 'DLATMS', info, 0, uplo, n, n, -1,
295  $ -1, -1, imat, nfail, nerrs, nout )
296  GO TO 160
297  END IF
298 *
299 * For types 3-6, zero one or more rows and columns of the
300 * matrix to test that INFO is returned correctly.
301 *
302  IF( zerot ) THEN
303  IF( imat.EQ.3 ) THEN
304  izero = 1
305  ELSE IF( imat.EQ.4 ) THEN
306  izero = n
307  ELSE
308  izero = n / 2 + 1
309  END IF
310 *
311  IF( imat.LT.6 ) THEN
312 *
313 * Set row and column IZERO to zero.
314 *
315  IF( iuplo.EQ.1 ) THEN
316  ioff = ( izero-1 )*izero / 2
317  DO 20 i = 1, izero - 1
318  a( ioff+i ) = zero
319  20 CONTINUE
320  ioff = ioff + izero
321  DO 30 i = izero, n
322  a( ioff ) = zero
323  ioff = ioff + i
324  30 CONTINUE
325  ELSE
326  ioff = izero
327  DO 40 i = 1, izero - 1
328  a( ioff ) = zero
329  ioff = ioff + n - i
330  40 CONTINUE
331  ioff = ioff - izero
332  DO 50 i = izero, n
333  a( ioff+i ) = zero
334  50 CONTINUE
335  END IF
336  ELSE
337  ioff = 0
338  IF( iuplo.EQ.1 ) THEN
339 *
340 * Set the first IZERO rows and columns to zero.
341 *
342  DO 70 j = 1, n
343  i2 = min( j, izero )
344  DO 60 i = 1, i2
345  a( ioff+i ) = zero
346  60 CONTINUE
347  ioff = ioff + j
348  70 CONTINUE
349  ELSE
350 *
351 * Set the last IZERO rows and columns to zero.
352 *
353  DO 90 j = 1, n
354  i1 = max( j, izero )
355  DO 80 i = i1, n
356  a( ioff+i ) = zero
357  80 CONTINUE
358  ioff = ioff + n - j
359  90 CONTINUE
360  END IF
361  END IF
362  ELSE
363  izero = 0
364  END IF
365 *
366  DO 150 ifact = 1, nfact
367 *
368 * Do first for FACT = 'F', then for other values.
369 *
370  fact = facts( ifact )
371 *
372 * Compute the condition number for comparison with
373 * the value returned by DSPSVX.
374 *
375  IF( zerot ) THEN
376  IF( ifact.EQ.1 )
377  $ GO TO 150
378  rcondc = zero
379 *
380  ELSE IF( ifact.EQ.1 ) THEN
381 *
382 * Compute the 1-norm of A.
383 *
384  anorm = dlansp( '1', uplo, n, a, rwork )
385 *
386 * Factor the matrix A.
387 *
388  CALL dcopy( npp, a, 1, afac, 1 )
389  CALL dsptrf( uplo, n, afac, iwork, info )
390 *
391 * Compute inv(A) and take its norm.
392 *
393  CALL dcopy( npp, afac, 1, ainv, 1 )
394  CALL dsptri( uplo, n, ainv, iwork, work, info )
395  ainvnm = dlansp( '1', uplo, n, ainv, rwork )
396 *
397 * Compute the 1-norm condition number of A.
398 *
399  IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
400  rcondc = one
401  ELSE
402  rcondc = ( one / anorm ) / ainvnm
403  END IF
404  END IF
405 *
406 * Form an exact solution and set the right hand side.
407 *
408  srnamt = 'DLARHS'
409  CALL dlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
410  $ nrhs, a, lda, xact, lda, b, lda, iseed,
411  $ info )
412  xtype = 'C'
413 *
414 * --- Test DSPSV ---
415 *
416  IF( ifact.EQ.2 ) THEN
417  CALL dcopy( npp, a, 1, afac, 1 )
418  CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
419 *
420 * Factor the matrix and solve the system using DSPSV.
421 *
422  srnamt = 'DSPSV '
423  CALL dspsv( uplo, n, nrhs, afac, iwork, x, lda,
424  $ info )
425 *
426 * Adjust the expected value of INFO to account for
427 * pivoting.
428 *
429  k = izero
430  IF( k.GT.0 ) THEN
431  100 CONTINUE
432  IF( iwork( k ).LT.0 ) THEN
433  IF( iwork( k ).NE.-k ) THEN
434  k = -iwork( k )
435  GO TO 100
436  END IF
437  ELSE IF( iwork( k ).NE.k ) THEN
438  k = iwork( k )
439  GO TO 100
440  END IF
441  END IF
442 *
443 * Check error code from DSPSV .
444 *
445  IF( info.NE.k ) THEN
446  CALL alaerh( path, 'DSPSV ', info, k, uplo, n,
447  $ n, -1, -1, nrhs, imat, nfail,
448  $ nerrs, nout )
449  GO TO 120
450  ELSE IF( info.NE.0 ) THEN
451  GO TO 120
452  END IF
453 *
454 * Reconstruct matrix from factors and compute
455 * residual.
456 *
457  CALL dspt01( uplo, n, a, afac, iwork, ainv, lda,
458  $ rwork, result( 1 ) )
459 *
460 * Compute residual of the computed solution.
461 *
462  CALL dlacpy( 'Full', n, nrhs, b, lda, work, lda )
463  CALL dppt02( uplo, n, nrhs, a, x, lda, work, lda,
464  $ rwork, result( 2 ) )
465 *
466 * Check solution from generated exact solution.
467 *
468  CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
469  $ result( 3 ) )
470  nt = 3
471 *
472 * Print information about the tests that did not pass
473 * the threshold.
474 *
475  DO 110 k = 1, nt
476  IF( result( k ).GE.thresh ) THEN
477  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
478  $ CALL aladhd( nout, path )
479  WRITE( nout, fmt = 9999 )'DSPSV ', uplo, n,
480  $ imat, k, result( k )
481  nfail = nfail + 1
482  END IF
483  110 CONTINUE
484  nrun = nrun + nt
485  120 CONTINUE
486  END IF
487 *
488 * --- Test DSPSVX ---
489 *
490  IF( ifact.EQ.2 .AND. npp.GT.0 )
491  $ CALL dlaset( 'Full', npp, 1, zero, zero, afac,
492  $ npp )
493  CALL dlaset( 'Full', n, nrhs, zero, zero, x, lda )
494 *
495 * Solve the system and compute the condition number and
496 * error bounds using DSPSVX.
497 *
498  srnamt = 'DSPSVX'
499  CALL dspsvx( fact, uplo, n, nrhs, a, afac, iwork, b,
500  $ lda, x, lda, rcond, rwork,
501  $ rwork( nrhs+1 ), work, iwork( n+1 ),
502  $ info )
503 *
504 * Adjust the expected value of INFO to account for
505 * pivoting.
506 *
507  k = izero
508  IF( k.GT.0 ) THEN
509  130 CONTINUE
510  IF( iwork( k ).LT.0 ) THEN
511  IF( iwork( k ).NE.-k ) THEN
512  k = -iwork( k )
513  GO TO 130
514  END IF
515  ELSE IF( iwork( k ).NE.k ) THEN
516  k = iwork( k )
517  GO TO 130
518  END IF
519  END IF
520 *
521 * Check the error code from DSPSVX.
522 *
523  IF( info.NE.k ) THEN
524  CALL alaerh( path, 'DSPSVX', info, k, fact // uplo,
525  $ n, n, -1, -1, nrhs, imat, nfail,
526  $ nerrs, nout )
527  GO TO 150
528  END IF
529 *
530  IF( info.EQ.0 ) THEN
531  IF( ifact.GE.2 ) THEN
532 *
533 * Reconstruct matrix from factors and compute
534 * residual.
535 *
536  CALL dspt01( uplo, n, a, afac, iwork, ainv, lda,
537  $ rwork( 2*nrhs+1 ), result( 1 ) )
538  k1 = 1
539  ELSE
540  k1 = 2
541  END IF
542 *
543 * Compute residual of the computed solution.
544 *
545  CALL dlacpy( 'Full', n, nrhs, b, lda, work, lda )
546  CALL dppt02( uplo, n, nrhs, a, x, lda, work, lda,
547  $ rwork( 2*nrhs+1 ), result( 2 ) )
548 *
549 * Check solution from generated exact solution.
550 *
551  CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
552  $ result( 3 ) )
553 *
554 * Check the error bounds from iterative refinement.
555 *
556  CALL dppt05( uplo, n, nrhs, a, b, lda, x, lda,
557  $ xact, lda, rwork, rwork( nrhs+1 ),
558  $ result( 4 ) )
559  ELSE
560  k1 = 6
561  END IF
562 *
563 * Compare RCOND from DSPSVX with the computed value
564 * in RCONDC.
565 *
566  result( 6 ) = dget06( rcond, rcondc )
567 *
568 * Print information about the tests that did not pass
569 * the threshold.
570 *
571  DO 140 k = k1, 6
572  IF( result( k ).GE.thresh ) THEN
573  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
574  $ CALL aladhd( nout, path )
575  WRITE( nout, fmt = 9998 )'DSPSVX', fact, uplo,
576  $ n, imat, k, result( k )
577  nfail = nfail + 1
578  END IF
579  140 CONTINUE
580  nrun = nrun + 7 - k1
581 *
582  150 CONTINUE
583 *
584  160 CONTINUE
585  170 CONTINUE
586  180 CONTINUE
587 *
588 * Print a summary of the results.
589 *
590  CALL alasvm( path, nout, nfail, nrun, nerrs )
591 *
592  9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
593  $ ', test ', i2, ', ratio =', g12.5 )
594  9998 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N =', i5,
595  $ ', type ', i2, ', test ', i2, ', ratio =', g12.5 )
596  RETURN
597 *
598 * End of DDRVSP
599 *
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:105
dlatb4
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
Definition: dlatb4.f:122
alasvm
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:75
dppt02
subroutine dppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
DPPT02
Definition: dppt02.f:124
dcopy
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
Definition: dcopy.f:84
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
dsptri
subroutine dsptri(UPLO, N, AP, IPIV, WORK, INFO)
DSPTRI
Definition: dsptri.f:111
dlarhs
subroutine dlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
DLARHS
Definition: dlarhs.f:206
dspt01
subroutine dspt01(UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID)
DSPT01
Definition: dspt01.f:112
dlatms
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
Definition: dlatms.f:323
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:112
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, or the element of largest absolute value of a symmetric matrix supplied in packed form.
Definition: dlansp.f:116
dspsv
subroutine dspsv(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
DSPSV computes the solution to system of linear equations A * X = B for OTHER matrices ...
Definition: dspsv.f:164
dppt05
subroutine dppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DPPT05
Definition: dppt05.f:158
dget04
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
Definition: dget04.f:104
aladhd
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:92
dspsvx
subroutine dspsvx(FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
DSPSVX computes the solution to system of linear equations A * X = B for OTHER matrices ...
Definition: dspsvx.f:278
derrvx
subroutine derrvx(PATH, NUNIT)
DERRVX
Definition: derrvx.f:57
dget06
double precision function dget06(RCOND, RCONDC)
DGET06
Definition: dget06.f:57
dsptrf
subroutine dsptrf(UPLO, N, AP, IPIV, INFO)
DSPTRF
Definition: dsptrf.f:161
Here is the call graph for this function:
Here is the caller graph for this function: