LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine sdrvsp ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NRHS,
real  THRESH,
logical  TSTERR,
integer  NMAX,
real, dimension( * )  A,
real, dimension( * )  AFAC,
real, dimension( * )  AINV,
real, dimension( * )  B,
real, dimension( * )  X,
real, dimension( * )  XACT,
real, dimension( * )  WORK,
real, dimension( * )  RWORK,
integer, dimension( * )  IWORK,
integer  NOUT 
)

SDRVSP

Purpose: 
 SDRVSP tests the driver routines SSPSV 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 REAL
          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 REAL array, dimension
                      (NMAX*(NMAX+1)/2)
[out]AFAC
          AFAC is REAL array, dimension
                      (NMAX*(NMAX+1)/2)
[out]AINV
          AINV is REAL array, dimension
                      (NMAX*(NMAX+1)/2)
[out]B
          B is REAL array, dimension (NMAX*NRHS)
[out]X
          X is REAL array, dimension (NMAX*NRHS)
[out]XACT
          XACT is REAL array, dimension (NMAX*NRHS)
[out]WORK
          WORK is REAL array, dimension
                      (NMAX*max(2,NRHS))
[out]RWORK
          RWORK is REAL 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
November 2011

Definition at line 158 of file sdrvsp.f.

158 *
159 * -- LAPACK test routine (version 3.4.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 * November 2011
163 *
164 * .. Scalar Arguments ..
165  LOGICAL tsterr
166  INTEGER nmax, nn, nout, nrhs
167  REAL thresh
168 * ..
169 * .. Array Arguments ..
170  LOGICAL dotype( * )
171  INTEGER iwork( * ), nval( * )
172  REAL a( * ), afac( * ), ainv( * ), b( * ),
173  $ rwork( * ), work( * ), x( * ), xact( * )
174 * ..
175 *
176 * =====================================================================
177 *
178 * .. Parameters ..
179  REAL one, zero
180  parameter ( one = 1.0e+0, zero = 0.0e+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  REAL ainvnm, anorm, cndnum, rcond, rcondc
194 * ..
195 * .. Local Arrays ..
196  CHARACTER facts( nfact )
197  INTEGER iseed( 4 ), iseedy( 4 )
198  REAL result( ntests )
199 * ..
200 * .. External Functions ..
201  REAL sget06, slansp
202  EXTERNAL sget06, slansp
203 * ..
204 * .. External Subroutines ..
205  EXTERNAL aladhd, alaerh, alasvm, scopy, serrvx, sget04,
206  $ slacpy, slarhs, slaset, slatb4, slatms, sppt02,
207  $ sppt05, sspsv, sspsvx, sspt01, ssptrf, ssptri
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 ) = 'Single 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 serrvx( 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 SLATB4 and generate a test matrix
281 * with SLATMS.
282 *
283  CALL slatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
284  $ cndnum, dist )
285 *
286  srnamt = 'SLATMS'
287  CALL slatms( n, n, dist, iseed, TYPE, rwork, mode,
288  $ cndnum, anorm, kl, ku, packit, a, lda, work,
289  $ info )
290 *
291 * Check error code from SLATMS.
292 *
293  IF( info.NE.0 ) THEN
294  CALL alaerh( path, 'SLATMS', 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 SSPSVX.
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 = slansp( '1', uplo, n, a, rwork )
385 *
386 * Factor the matrix A.
387 *
388  CALL scopy( npp, a, 1, afac, 1 )
389  CALL ssptrf( uplo, n, afac, iwork, info )
390 *
391 * Compute inv(A) and take its norm.
392 *
393  CALL scopy( npp, afac, 1, ainv, 1 )
394  CALL ssptri( uplo, n, ainv, iwork, work, info )
395  ainvnm = slansp( '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 = 'SLARHS'
409  CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
410  $ nrhs, a, lda, xact, lda, b, lda, iseed,
411  $ info )
412  xtype = 'C'
413 *
414 * --- Test SSPSV ---
415 *
416  IF( ifact.EQ.2 ) THEN
417  CALL scopy( npp, a, 1, afac, 1 )
418  CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
419 *
420 * Factor the matrix and solve the system using SSPSV.
421 *
422  srnamt = 'SSPSV '
423  CALL sspsv( 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 SSPSV .
444 *
445  IF( info.NE.k ) THEN
446  CALL alaerh( path, 'SSPSV ', 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 sspt01( uplo, n, a, afac, iwork, ainv, lda,
458  $ rwork, result( 1 ) )
459 *
460 * Compute residual of the computed solution.
461 *
462  CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
463  CALL sppt02( uplo, n, nrhs, a, x, lda, work, lda,
464  $ rwork, result( 2 ) )
465 *
466 * Check solution from generated exact solution.
467 *
468  CALL sget04( 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 )'SSPSV ', 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 SSPSVX ---
489 *
490  IF( ifact.EQ.2 .AND. npp.GT.0 )
491  $ CALL slaset( 'Full', npp, 1, zero, zero, afac,
492  $ npp )
493  CALL slaset( 'Full', n, nrhs, zero, zero, x, lda )
494 *
495 * Solve the system and compute the condition number and
496 * error bounds using SSPSVX.
497 *
498  srnamt = 'SSPSVX'
499  CALL sspsvx( 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 SSPSVX.
522 *
523  IF( info.NE.k ) THEN
524  CALL alaerh( path, 'SSPSVX', 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 sspt01( 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 slacpy( 'Full', n, nrhs, b, lda, work, lda )
546  CALL sppt02( 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 sget04( n, nrhs, x, lda, xact, lda, rcondc,
552  $ result( 3 ) )
553 *
554 * Check the error bounds from iterative refinement.
555 *
556  CALL sppt05( 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 SSPSVX with the computed value
564 * in RCONDC.
565 *
566  result( 6 ) = sget06( 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 )'SSPSVX', 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 SDRVSP
599 *
alasvm
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:75
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
slatb4
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
Definition: slatb4.f:122
slarhs
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
Definition: slarhs.f:206
sppt05
subroutine sppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPPT05
Definition: sppt05.f:158
sget06
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:57
slacpy
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
Definition: slacpy.f:105
sspsvx
subroutine sspsvx(FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
SSPSVX computes the solution to system of linear equations A * X = B for OTHER matrices ...
Definition: sspsvx.f:279
sspsv
subroutine sspsv(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
SSPSV computes the solution to system of linear equations A * X = B for OTHER matrices ...
Definition: sspsv.f:164
slatms
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
Definition: slatms.f:323
slaset
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: slaset.f:112
sget04
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
Definition: sget04.f:104
ssptri
subroutine ssptri(UPLO, N, AP, IPIV, WORK, INFO)
SSPTRI
Definition: ssptri.f:111
aladhd
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:80
ssptrf
subroutine ssptrf(UPLO, N, AP, IPIV, INFO)
SSPTRF
Definition: ssptrf.f:159
serrvx
subroutine serrvx(PATH, NUNIT)
SERRVX
Definition: serrvx.f:57
slansp
real function slansp(NORM, UPLO, N, AP, WORK)
SLANSP 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: slansp.f:116
sppt02
subroutine sppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
SPPT02
Definition: sppt02.f:124
sspt01
subroutine sspt01(UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID)
SSPT01
Definition: sspt01.f:112
scopy
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:53

Here is the call graph for this function:

Here is the caller graph for this function: