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

SDRVSY_RK

Purpose: 
 SDRVSY_RK tests the driver routines SSYSV_RK.
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)
[out]AFAC
          AFAC is REAL array, dimension (NMAX*NMAX)
[out]E
          E is REAL array, dimension (NMAX)
[out]AINV
          AINV is REAL array, dimension (NMAX*NMAX)
[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
December 2016

Definition at line 158 of file sdrvsy_rk.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  REAL thresh
168 * ..
169 * .. Array Arguments ..
170  LOGICAL dotype( * )
171  INTEGER iwork( * ), nval( * )
172  REAL a( * ), afac( * ), ainv( * ), b( * ), e( * ),
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 = 3 )
183  INTEGER nfact
184  parameter ( nfact = 2 )
185 * ..
186 * .. Local Scalars ..
187  LOGICAL zerot
188  CHARACTER dist, fact, TYPE, uplo, xtype
189  CHARACTER*3 path, matpath
190  INTEGER i, i1, i2, ifact, imat, in, info, ioff, iuplo,
191  $ izero, j, k, kl, ku, lda, lwork, mode, n,
192  $ nb, nbmin, nerrs, nfail, nimat, nrun, nt
193  REAL ainvnm, anorm, cndnum, rcondc
194 * ..
195 * .. Local Arrays ..
196  CHARACTER facts( nfact ), uplos( 2 )
197  INTEGER iseed( 4 ), iseedy( 4 )
198  REAL result( ntests )
199 * ..
200 * .. External Functions ..
201  REAL slansy
202  EXTERNAL slansy
203 * ..
204 * .. External Subroutines ..
205  EXTERNAL aladhd, alaerh, alasvm, serrvx, sget04, slacpy,
206  $ slarhs, slatb4, slatms, spot02, ssysv_rk,
207  $ ssyt01_3, ssytrf_rk, ssytri_3, xlaenv
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 uplos / 'U', 'L' / , facts / 'F', 'N' /
224 * ..
225 * .. Executable Statements ..
226 *
227 * Initialize constants and the random number seed.
228 *
229 * Test path
230 *
231  path( 1: 1 ) = 'Single precision'
232  path( 2: 3 ) = 'SK'
233 *
234 * Path to generate matrices
235 *
236  matpath( 1: 1 ) = 'Single precision'
237  matpath( 2: 3 ) = 'SY'
238 *
239  nrun = 0
240  nfail = 0
241  nerrs = 0
242  DO 10 i = 1, 4
243  iseed( i ) = iseedy( i )
244  10 CONTINUE
245  lwork = max( 2*nmax, nmax*nrhs )
246 *
247 * Test the error exits
248 *
249  IF( tsterr )
250  $ CALL serrvx( path, nout )
251  infot = 0
252 *
253 * Set the block size and minimum block size for which the block
254 * routine should be used, which will be later returned by ILAENV.
255 *
256  nb = 1
257  nbmin = 2
258  CALL xlaenv( 1, nb )
259  CALL xlaenv( 2, nbmin )
260 *
261 * Do for each value of N in NVAL
262 *
263  DO 180 in = 1, nn
264  n = nval( in )
265  lda = max( n, 1 )
266  xtype = 'N'
267  nimat = ntypes
268  IF( n.LE.0 )
269  $ nimat = 1
270 *
271  DO 170 imat = 1, nimat
272 *
273 * Do the tests only if DOTYPE( IMAT ) is true.
274 *
275  IF( .NOT.dotype( imat ) )
276  $ GO TO 170
277 *
278 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
279 *
280  zerot = imat.GE.3 .AND. imat.LE.6
281  IF( zerot .AND. n.LT.imat-2 )
282  $ GO TO 170
283 *
284 * Do first for UPLO = 'U', then for UPLO = 'L'
285 *
286  DO 160 iuplo = 1, 2
287  uplo = uplos( iuplo )
288 *
289 * Begin generate the test matrix A.
290 *
291 * Set up parameters with SLATB4 for the matrix generator
292 * based on the type of matrix to be generated.
293 *
294  CALL slatb4( matpath, imat, n, n, TYPE, kl, ku, anorm,
295  $ mode, cndnum, dist )
296 *
297 * Generate a matrix with SLATMS.
298 *
299  srnamt = 'SLATMS'
300  CALL slatms( n, n, dist, iseed, TYPE, rwork, mode,
301  $ cndnum, anorm, kl, ku, uplo, a, lda, work,
302  $ info )
303 *
304 * Check error code from SLATMS and handle error.
305 *
306  IF( info.NE.0 ) THEN
307  CALL alaerh( path, 'SLATMS', info, 0, uplo, n, n, -1,
308  $ -1, -1, imat, nfail, nerrs, nout )
309 *
310 * Skip all tests for this generated matrix
311 *
312  GO TO 160
313  END IF
314 *
315 * For types 3-6, zero one or more rows and columns of the
316 * matrix to test that INFO is returned correctly.
317 *
318  IF( zerot ) THEN
319  IF( imat.EQ.3 ) THEN
320  izero = 1
321  ELSE IF( imat.EQ.4 ) THEN
322  izero = n
323  ELSE
324  izero = n / 2 + 1
325  END IF
326 *
327  IF( imat.LT.6 ) THEN
328 *
329 * Set row and column IZERO to zero.
330 *
331  IF( iuplo.EQ.1 ) THEN
332  ioff = ( izero-1 )*lda
333  DO 20 i = 1, izero - 1
334  a( ioff+i ) = zero
335  20 CONTINUE
336  ioff = ioff + izero
337  DO 30 i = izero, n
338  a( ioff ) = zero
339  ioff = ioff + lda
340  30 CONTINUE
341  ELSE
342  ioff = izero
343  DO 40 i = 1, izero - 1
344  a( ioff ) = zero
345  ioff = ioff + lda
346  40 CONTINUE
347  ioff = ioff - izero
348  DO 50 i = izero, n
349  a( ioff+i ) = zero
350  50 CONTINUE
351  END IF
352  ELSE
353  ioff = 0
354  IF( iuplo.EQ.1 ) THEN
355 *
356 * Set the first IZERO rows and columns to zero.
357 *
358  DO 70 j = 1, n
359  i2 = min( j, izero )
360  DO 60 i = 1, i2
361  a( ioff+i ) = zero
362  60 CONTINUE
363  ioff = ioff + lda
364  70 CONTINUE
365  ELSE
366 *
367 * Set the last IZERO rows and columns to zero.
368 *
369  DO 90 j = 1, n
370  i1 = max( j, izero )
371  DO 80 i = i1, n
372  a( ioff+i ) = zero
373  80 CONTINUE
374  ioff = ioff + lda
375  90 CONTINUE
376  END IF
377  END IF
378  ELSE
379  izero = 0
380  END IF
381 *
382 * End generate the test matrix A.
383 *
384  DO 150 ifact = 1, nfact
385 *
386 * Do first for FACT = 'F', then for other values.
387 *
388  fact = facts( ifact )
389 *
390 * Compute the condition number
391 *
392  IF( zerot ) THEN
393  IF( ifact.EQ.1 )
394  $ GO TO 150
395  rcondc = zero
396 *
397  ELSE IF( ifact.EQ.1 ) THEN
398 *
399 * Compute the 1-norm of A.
400 *
401  anorm = slansy( '1', uplo, n, a, lda, rwork )
402 *
403 * Factor the matrix A.
404 *
405  CALL slacpy( uplo, n, n, a, lda, afac, lda )
406  CALL ssytrf_rk( uplo, n, afac, lda, e, iwork, work,
407  $ lwork, info )
408 *
409 * Compute inv(A) and take its norm.
410 *
411  CALL slacpy( uplo, n, n, afac, lda, ainv, lda )
412  lwork = (n+nb+1)*(nb+3)
413 *
414 * We need to copute the invesrse to compute
415 * RCONDC that is used later in TEST3.
416 *
417  CALL ssytri_3( uplo, n, ainv, lda, e, iwork,
418  $ work, lwork, info )
419  ainvnm = slansy( '1', uplo, n, ainv, lda, rwork )
420 *
421 * Compute the 1-norm condition number of A.
422 *
423  IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
424  rcondc = one
425  ELSE
426  rcondc = ( one / anorm ) / ainvnm
427  END IF
428  END IF
429 *
430 * Form an exact solution and set the right hand side.
431 *
432  srnamt = 'SLARHS'
433  CALL slarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
434  $ nrhs, a, lda, xact, lda, b, lda, iseed,
435  $ info )
436  xtype = 'C'
437 *
438 * --- Test SSYSV_RK ---
439 *
440  IF( ifact.EQ.2 ) THEN
441  CALL slacpy( uplo, n, n, a, lda, afac, lda )
442  CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
443 *
444 * Factor the matrix and solve the system using
445 * SSYSV_RK.
446 *
447  srnamt = 'SSYSV_RK'
448  CALL ssysv_rk( uplo, n, nrhs, afac, lda, e, iwork,
449  $ x, lda, work, lwork, info )
450 *
451 * Adjust the expected value of INFO to account for
452 * pivoting.
453 *
454  k = izero
455  IF( k.GT.0 ) THEN
456  100 CONTINUE
457  IF( iwork( k ).LT.0 ) THEN
458  IF( iwork( k ).NE.-k ) THEN
459  k = -iwork( k )
460  GO TO 100
461  END IF
462  ELSE IF( iwork( k ).NE.k ) THEN
463  k = iwork( k )
464  GO TO 100
465  END IF
466  END IF
467 *
468 * Check error code from SSYSV_RK and handle error.
469 *
470  IF( info.NE.k ) THEN
471  CALL alaerh( path, 'SSYSV_RK', info, k, uplo,
472  $ n, n, -1, -1, nrhs, imat, nfail,
473  $ nerrs, nout )
474  GO TO 120
475  ELSE IF( info.NE.0 ) THEN
476  GO TO 120
477  END IF
478 *
479 *+ TEST 1 Reconstruct matrix from factors and compute
480 * residual.
481 *
482  CALL ssyt01_3( uplo, n, a, lda, afac, lda, e,
483  $ iwork, ainv, lda, rwork,
484  $ result( 1 ) )
485 *
486 *+ TEST 2 Compute residual of the computed solution.
487 *
488  CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
489  CALL spot02( uplo, n, nrhs, a, lda, x, lda, work,
490  $ lda, rwork, result( 2 ) )
491 *
492 *+ TEST 3
493 * Check solution from generated exact solution.
494 *
495  CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
496  $ result( 3 ) )
497  nt = 3
498 *
499 * Print information about the tests that did not pass
500 * the threshold.
501 *
502  DO 110 k = 1, nt
503  IF( result( k ).GE.thresh ) THEN
504  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
505  $ CALL aladhd( nout, path )
506  WRITE( nout, fmt = 9999 )'SSYSV_RK', uplo,
507  $ n, imat, k, result( k )
508  nfail = nfail + 1
509  END IF
510  110 CONTINUE
511  nrun = nrun + nt
512  120 CONTINUE
513  END IF
514 *
515  150 CONTINUE
516 *
517  160 CONTINUE
518  170 CONTINUE
519  180 CONTINUE
520 *
521 * Print a summary of the results.
522 *
523  CALL alasvm( path, nout, nfail, nrun, nerrs )
524 *
525  9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
526  $ ', test ', i2, ', ratio =', g12.5 )
527  RETURN
528 *
529 * End of SDRVSY_RK
530 *
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
ssytrf_rk
subroutine ssytrf_rk(UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO)
SSYTRF_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Ka...
Definition: ssytrf_rk.f:261
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
xlaenv
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
slatms
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
Definition: slatms.f:323
ssytri_3
subroutine ssytri_3(UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO)
SSYTRI_3
Definition: ssytri_3.f:172
sget04
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
Definition: sget04.f:104
aladhd
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:92
ssysv_rk
subroutine ssysv_rk(UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, WORK, LWORK, INFO)
SSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices ...
Definition: ssysv_rk.f:230
serrvx
subroutine serrvx(PATH, NUNIT)
SERRVX
Definition: serrvx.f:57
ssyt01_3
subroutine ssyt01_3(UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, LDC, RWORK, RESID)
SSYT01_3
Definition: ssyt01_3.f:142
spot02
subroutine spot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SPOT02
Definition: spot02.f:129
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
slansy
real function slansy(NORM, UPLO, N, A, LDA, WORK)
SLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix.
Definition: slansy.f:124

Here is the call graph for this function:

Here is the caller graph for this function: