LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ dchksp()

subroutine dchksp ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNS,
integer, dimension( * )  NSVAL,
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 
)

DCHKSP

Purpose:
 DCHKSP tests DSPTRF, -TRI, -TRS, -RFS, and -CON
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]NNS
          NNS is INTEGER
          The number of values of NRHS contained in the vector NSVAL.
[in]NSVAL
          NSVAL is INTEGER array, dimension (NNS)
          The values of the number of right hand sides NRHS.
[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*NSMAX)
          where NSMAX is the largest entry in NSVAL.
[out]X
          X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
[out]XACT
          XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
[out]WORK
          WORK is DOUBLE PRECISION array, dimension
                      (NMAX*max(2,NSMAX))
[out]RWORK
          RWORK is DOUBLE PRECISION array,
                                 dimension (NMAX+2*NSMAX)
[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 160 of file dchksp.f.

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