LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ sdrvpp()

subroutine sdrvpp ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NRHS,
real  THRESH,
logical  TSTERR,
integer  NMAX,
real, dimension( * )  A,
real, dimension( * )  AFAC,
real, dimension( * )  ASAV,
real, dimension( * )  B,
real, dimension( * )  BSAV,
real, dimension( * )  X,
real, dimension( * )  XACT,
real, dimension( * )  S,
real, dimension( * )  WORK,
real, dimension( * )  RWORK,
integer, dimension( * )  IWORK,
integer  NOUT 
)

SDRVPP

Purpose:
 SDRVPP tests the driver routines SPPSV 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]ASAV
          ASAV is REAL array, dimension
                      (NMAX*(NMAX+1)/2)
[out]B
          B is REAL array, dimension (NMAX*NRHS)
[out]BSAV
          BSAV 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]S
          S is REAL array, dimension (NMAX)
[out]WORK
          WORK is REAL array, dimension
                      (NMAX*max(3,NRHS))
[out]RWORK
          RWORK is REAL 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 sdrvpp.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  REAL THRESH
176 * ..
177 * .. Array Arguments ..
178  LOGICAL DOTYPE( * )
179  INTEGER IWORK( * ), NVAL( * )
180  REAL A( * ), AFAC( * ), ASAV( * ), B( * ),
181  $ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
182  $ X( * ), XACT( * )
183 * ..
184 *
185 * =====================================================================
186 *
187 * .. Parameters ..
188  REAL ONE, ZERO
189  parameter( one = 1.0e+0, zero = 0.0e+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  REAL 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  REAL RESULT( NTESTS )
209 * ..
210 * .. External Functions ..
211  LOGICAL LSAME
212  REAL SGET06, SLANSP
213  EXTERNAL lsame, sget06, slansp
214 * ..
215 * .. External Subroutines ..
216  EXTERNAL aladhd, alaerh, alasvm, scopy, serrvx, sget04,
219  $ spptrf, spptri
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 ) = 'Single 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 serrvx( 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 SLATB4 and generate a test matrix
288 * with SLATMS.
289 *
290  CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
291  $ CNDNUM, DIST )
292  rcondc = one / cndnum
293 *
294  srnamt = 'SLATMS'
295  CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE,
296  $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
297  $ INFO )
298 *
299 * Check error code from SLATMS.
300 *
301  IF( info.NE.0 ) THEN
302  CALL alaerh( path, 'SLATMS', 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 scopy( 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 SPPSVX (FACT = 'N' reuses
373 * the condition number from the previous iteration
374 * with FACT = 'F').
375 *
376  CALL scopy( 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 sppequ( 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 slaqsp( 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 SGET04.
397 *
398  IF( equil )
399  $ roldc = rcondc
400 *
401 * Compute the 1-norm of A.
402 *
403  anorm = slansp( '1', uplo, n, afac, rwork )
404 *
405 * Factor the matrix A.
406 *
407  CALL spptrf( uplo, n, afac, info )
408 *
409 * Form the inverse of A.
410 *
411  CALL scopy( npp, afac, 1, a, 1 )
412  CALL spptri( uplo, n, a, info )
413 *
414 * Compute the 1-norm condition number of A.
415 *
416  ainvnm = slansp( '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 scopy( npp, asav, 1, a, 1 )
427 *
428 * Form an exact solution and set the right hand side.
429 *
430  srnamt = 'SLARHS'
431  CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
432  $ nrhs, a, lda, xact, lda, b, lda,
433  $ iseed, info )
434  xtype = 'C'
435  CALL slacpy( 'Full', n, nrhs, b, lda, bsav, lda )
436 *
437  IF( nofact ) THEN
438 *
439 * --- Test SPPSV ---
440 *
441 * Compute the L*L' or U'*U factorization of the
442 * matrix and solve the system.
443 *
444  CALL scopy( npp, a, 1, afac, 1 )
445  CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
446 *
447  srnamt = 'SPPSV '
448  CALL sppsv( uplo, n, nrhs, afac, x, lda, info )
449 *
450 * Check error code from SPPSV .
451 *
452  IF( info.NE.izero ) THEN
453  CALL alaerh( path, 'SPPSV ', 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 sppt01( uplo, n, a, afac, rwork,
465  $ result( 1 ) )
466 *
467 * Compute residual of the computed solution.
468 *
469  CALL slacpy( 'Full', n, nrhs, b, lda, work,
470  $ lda )
471  CALL sppt02( uplo, n, nrhs, a, x, lda, work,
472  $ lda, rwork, result( 2 ) )
473 *
474 * Check solution from generated exact solution.
475 *
476  CALL sget04( 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 )'SPPSV ', 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 SPPSVX ---
497 *
498  IF( .NOT.prefac .AND. npp.GT.0 )
499  $ CALL slaset( 'Full', npp, 1, zero, zero, afac,
500  $ npp )
501  CALL slaset( '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 slaqsp( 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 SPPSVX.
512 *
513  srnamt = 'SPPSVX'
514  CALL sppsvx( 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 SPPSVX.
519 *
520  IF( info.NE.izero ) THEN
521  CALL alaerh( path, 'SPPSVX', 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 sppt01( 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 slacpy( 'Full', n, nrhs, bsav, lda, work,
543  $ lda )
544  CALL sppt02( 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 sget04( n, nrhs, x, lda, xact, lda,
553  $ rcondc, result( 3 ) )
554  ELSE
555  CALL sget04( 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 sppt05( 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 SPPSVX with the computed value
570 * in RCONDC.
571 *
572  result( 6 ) = sget06( 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 )'SPPSVX', fact,
583  $ uplo, n, equed, imat, k, result( k )
584  ELSE
585  WRITE( nout, fmt = 9998 )'SPPSVX', 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 SDRVPP
613 *
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:110
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
Definition: slacpy.f:103
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:53
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:73
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:90
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:147
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
Definition: slatms.f:321
real function slansp(NORM, UPLO, N, AP, WORK)
SLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition: slansp.f:114
subroutine slaqsp(UPLO, N, AP, S, SCOND, AMAX, EQUED)
SLAQSP scales a symmetric/Hermitian matrix in packed storage, using scaling factors computed by sppeq...
Definition: slaqsp.f:125
subroutine spptrf(UPLO, N, AP, INFO)
SPPTRF
Definition: spptrf.f:119
subroutine sppequ(UPLO, N, AP, S, SCOND, AMAX, INFO)
SPPEQU
Definition: sppequ.f:116
subroutine spptri(UPLO, N, AP, INFO)
SPPTRI
Definition: spptri.f:93
subroutine sppsvx(FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
SPPSVX computes the solution to system of linear equations A * X = B for OTHER matrices
Definition: sppsvx.f:311
subroutine sppsv(UPLO, N, NRHS, AP, B, LDB, INFO)
SPPSV computes the solution to system of linear equations A * X = B for OTHER matrices
Definition: sppsv.f:144
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:82
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
Definition: slarhs.f:205
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
Definition: slatb4.f:120
subroutine sppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPPT05
Definition: sppt05.f:156
subroutine serrvx(PATH, NUNIT)
SERRVX
Definition: serrvx.f:55
subroutine sppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
SPPT02
Definition: sppt02.f:122
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
Definition: sget04.f:102
subroutine sppt01(UPLO, N, A, AFAC, RWORK, RESID)
SPPT01
Definition: sppt01.f:93
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:55
Here is the call graph for this function:
Here is the caller graph for this function: