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

◆ 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.

Definition at line 153 of file ddrvsp.f.

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