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

◆ 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,
211 $ dlacpy, dlarhs, dlatb4, dlatms, dppt02, dppt03,
212 $ dppt05, dspcon, dsprfs, dspt01, dsptrf, dsptri,
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*
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.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
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
alahd
subroutine alahd(iounit, path)
ALAHD
Definition alahd.f:107
derrsy
subroutine derrsy(path, nunit)
DERRSY
Definition derrsy.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
dppt03
subroutine dppt03(uplo, n, a, ainv, work, ldwork, rwork, rcond, resid)
DPPT03
Definition dppt03.f:110
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
dspcon
subroutine dspcon(uplo, n, ap, ipiv, anorm, rcond, work, iwork, info)
DSPCON
Definition dspcon.f:125
dsprfs
subroutine dsprfs(uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
DSPRFS
Definition dsprfs.f:179
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
dsptrs
subroutine dsptrs(uplo, n, nrhs, ap, ipiv, b, ldb, info)
DSPTRS
Definition dsptrs.f:115
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
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
Here is the call graph for this function:
Here is the caller graph for this function: