LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ schkpo()

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

SCHKPO

Purpose:
 SCHKPO tests SPOTRF, -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]NNB
          NNB is INTEGER
          The number of values of NB contained in the vector NBVAL.
[in]NBVAL
          NBVAL is INTEGER array, dimension (NNB)
          The values of the blocksize NB.
[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 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]AINV
          AINV is REAL array, dimension (NMAX*NMAX)
[out]B
          B is REAL array, dimension (NMAX*NSMAX)
          where NSMAX is the largest entry in NSVAL.
[out]X
          X is REAL array, dimension (NMAX*NSMAX)
[out]XACT
          XACT is REAL array, dimension (NMAX*NSMAX)
[out]WORK
          WORK is REAL array, dimension
                      (NMAX*max(3,NSMAX))
[out]RWORK
          RWORK is REAL array, dimension
                      (max(NMAX,2*NSMAX))
[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 169 of file schkpo.f.

172 *
173 * -- LAPACK test routine --
174 * -- LAPACK is a software package provided by Univ. of Tennessee, --
175 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176 *
177 * .. Scalar Arguments ..
178  LOGICAL TSTERR
179  INTEGER NMAX, NN, NNB, NNS, NOUT
180  REAL THRESH
181 * ..
182 * .. Array Arguments ..
183  LOGICAL DOTYPE( * )
184  INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
185  REAL A( * ), AFAC( * ), AINV( * ), B( * ),
186  $ RWORK( * ), WORK( * ), X( * ), XACT( * )
187 * ..
188 *
189 * =====================================================================
190 *
191 * .. Parameters ..
192  REAL ZERO
193  parameter( zero = 0.0e+0 )
194  INTEGER NTYPES
195  parameter( ntypes = 9 )
196  INTEGER NTESTS
197  parameter( ntests = 8 )
198 * ..
199 * .. Local Scalars ..
200  LOGICAL ZEROT
201  CHARACTER DIST, TYPE, UPLO, XTYPE
202  CHARACTER*3 PATH
203  INTEGER I, IMAT, IN, INB, INFO, IOFF, IRHS, IUPLO,
204  $ IZERO, K, KL, KU, LDA, MODE, N, NB, NERRS,
205  $ NFAIL, NIMAT, NRHS, NRUN
206  REAL ANORM, CNDNUM, RCOND, RCONDC
207 * ..
208 * .. Local Arrays ..
209  CHARACTER UPLOS( 2 )
210  INTEGER ISEED( 4 ), ISEEDY( 4 )
211  REAL RESULT( NTESTS )
212 * ..
213 * .. External Functions ..
214  REAL SGET06, SLANSY
215  EXTERNAL sget06, slansy
216 * ..
217 * .. External Subroutines ..
218  EXTERNAL alaerh, alahd, alasum, serrpo, sget04, slacpy,
221  $ xlaenv
222 * ..
223 * .. Scalars in Common ..
224  LOGICAL LERR, OK
225  CHARACTER*32 SRNAMT
226  INTEGER INFOT, NUNIT
227 * ..
228 * .. Common blocks ..
229  COMMON / infoc / infot, nunit, ok, lerr
230  COMMON / srnamc / srnamt
231 * ..
232 * .. Intrinsic Functions ..
233  INTRINSIC max
234 * ..
235 * .. Data statements ..
236  DATA iseedy / 1988, 1989, 1990, 1991 /
237  DATA uplos / 'U', 'L' /
238 * ..
239 * .. Executable Statements ..
240 *
241 * Initialize constants and the random number seed.
242 *
243  path( 1: 1 ) = 'Single precision'
244  path( 2: 3 ) = 'PO'
245  nrun = 0
246  nfail = 0
247  nerrs = 0
248  DO 10 i = 1, 4
249  iseed( i ) = iseedy( i )
250  10 CONTINUE
251 *
252 * Test the error exits
253 *
254  IF( tsterr )
255  $ CALL serrpo( path, nout )
256  infot = 0
257  CALL xlaenv( 2, 2 )
258 *
259 * Do for each value of N in NVAL
260 *
261  DO 120 in = 1, nn
262  n = nval( in )
263  lda = max( n, 1 )
264  xtype = 'N'
265  nimat = ntypes
266  IF( n.LE.0 )
267  $ nimat = 1
268 *
269  izero = 0
270  DO 110 imat = 1, nimat
271 *
272 * Do the tests only if DOTYPE( IMAT ) is true.
273 *
274  IF( .NOT.dotype( imat ) )
275  $ GO TO 110
276 *
277 * Skip types 3, 4, or 5 if the matrix size is too small.
278 *
279  zerot = imat.GE.3 .AND. imat.LE.5
280  IF( zerot .AND. n.LT.imat-2 )
281  $ GO TO 110
282 *
283 * Do first for UPLO = 'U', then for UPLO = 'L'
284 *
285  DO 100 iuplo = 1, 2
286  uplo = uplos( iuplo )
287 *
288 * Set up parameters with SLATB4 and generate a test matrix
289 * with SLATMS.
290 *
291  CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
292  $ CNDNUM, DIST )
293 *
294  srnamt = 'SLATMS'
295  CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE,
296  $ CNDNUM, ANORM, KL, KU, UPLO, 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 100
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  ioff = ( izero-1 )*lda
319 *
320 * Set row and column IZERO of A to 0.
321 *
322  IF( iuplo.EQ.1 ) THEN
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 + lda
330  30 CONTINUE
331  ELSE
332  ioff = izero
333  DO 40 i = 1, izero - 1
334  a( ioff ) = zero
335  ioff = ioff + lda
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 * Do for each value of NB in NBVAL
347 *
348  DO 90 inb = 1, nnb
349  nb = nbval( inb )
350  CALL xlaenv( 1, nb )
351 *
352 * Compute the L*L' or U'*U factorization of the matrix.
353 *
354  CALL slacpy( uplo, n, n, a, lda, afac, lda )
355  srnamt = 'SPOTRF'
356  CALL spotrf( uplo, n, afac, lda, info )
357 *
358 * Check error code from SPOTRF.
359 *
360  IF( info.NE.izero ) THEN
361  CALL alaerh( path, 'SPOTRF', info, izero, uplo, n,
362  $ n, -1, -1, nb, imat, nfail, nerrs,
363  $ nout )
364  GO TO 90
365  END IF
366 *
367 * Skip the tests if INFO is not 0.
368 *
369  IF( info.NE.0 )
370  $ GO TO 90
371 *
372 *+ TEST 1
373 * Reconstruct matrix from factors and compute residual.
374 *
375  CALL slacpy( uplo, n, n, afac, lda, ainv, lda )
376  CALL spot01( uplo, n, a, lda, ainv, lda, rwork,
377  $ result( 1 ) )
378 *
379 *+ TEST 2
380 * Form the inverse and compute the residual.
381 *
382  CALL slacpy( uplo, n, n, afac, lda, ainv, lda )
383  srnamt = 'SPOTRI'
384  CALL spotri( uplo, n, ainv, lda, info )
385 *
386 * Check error code from SPOTRI.
387 *
388  IF( info.NE.0 )
389  $ CALL alaerh( path, 'SPOTRI', info, 0, uplo, n, n,
390  $ -1, -1, -1, imat, nfail, nerrs, nout )
391 *
392  CALL spot03( uplo, n, a, lda, ainv, lda, work, lda,
393  $ rwork, rcondc, result( 2 ) )
394 *
395 * Print information about the tests that did not pass
396 * the threshold.
397 *
398  DO 60 k = 1, 2
399  IF( result( k ).GE.thresh ) THEN
400  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
401  $ CALL alahd( nout, path )
402  WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
403  $ result( k )
404  nfail = nfail + 1
405  END IF
406  60 CONTINUE
407  nrun = nrun + 2
408 *
409 * Skip the rest of the tests unless this is the first
410 * blocksize.
411 *
412  IF( inb.NE.1 )
413  $ GO TO 90
414 *
415  DO 80 irhs = 1, nns
416  nrhs = nsval( irhs )
417 *
418 *+ TEST 3
419 * Solve and compute residual for A * X = B .
420 *
421  srnamt = 'SLARHS'
422  CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
423  $ nrhs, a, lda, xact, lda, b, lda,
424  $ iseed, info )
425  CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
426 *
427  srnamt = 'SPOTRS'
428  CALL spotrs( uplo, n, nrhs, afac, lda, x, lda,
429  $ info )
430 *
431 * Check error code from SPOTRS.
432 *
433  IF( info.NE.0 )
434  $ CALL alaerh( path, 'SPOTRS', info, 0, uplo, n,
435  $ n, -1, -1, nrhs, imat, nfail,
436  $ nerrs, nout )
437 *
438  CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
439  CALL spot02( uplo, n, nrhs, a, lda, x, lda, work,
440  $ lda, rwork, result( 3 ) )
441 *
442 *+ TEST 4
443 * Check solution from generated exact solution.
444 *
445  CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
446  $ result( 4 ) )
447 *
448 *+ TESTS 5, 6, and 7
449 * Use iterative refinement to improve the solution.
450 *
451  srnamt = 'SPORFS'
452  CALL sporfs( uplo, n, nrhs, a, lda, afac, lda, b,
453  $ lda, x, lda, rwork, rwork( nrhs+1 ),
454  $ work, iwork, info )
455 *
456 * Check error code from SPORFS.
457 *
458  IF( info.NE.0 )
459  $ CALL alaerh( path, 'SPORFS', info, 0, uplo, n,
460  $ n, -1, -1, nrhs, imat, nfail,
461  $ nerrs, nout )
462 *
463  CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
464  $ result( 5 ) )
465  CALL spot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
466  $ xact, lda, rwork, rwork( nrhs+1 ),
467  $ result( 6 ) )
468 *
469 * Print information about the tests that did not pass
470 * the threshold.
471 *
472  DO 70 k = 3, 7
473  IF( result( k ).GE.thresh ) THEN
474  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
475  $ CALL alahd( nout, path )
476  WRITE( nout, fmt = 9998 )uplo, n, nrhs,
477  $ imat, k, result( k )
478  nfail = nfail + 1
479  END IF
480  70 CONTINUE
481  nrun = nrun + 5
482  80 CONTINUE
483 *
484 *+ TEST 8
485 * Get an estimate of RCOND = 1/CNDNUM.
486 *
487  anorm = slansy( '1', uplo, n, a, lda, rwork )
488  srnamt = 'SPOCON'
489  CALL spocon( uplo, n, afac, lda, anorm, rcond, work,
490  $ iwork, info )
491 *
492 * Check error code from SPOCON.
493 *
494  IF( info.NE.0 )
495  $ CALL alaerh( path, 'SPOCON', info, 0, uplo, n, n,
496  $ -1, -1, -1, imat, nfail, nerrs, nout )
497 *
498  result( 8 ) = sget06( rcond, rcondc )
499 *
500 * Print the test ratio if it is .GE. THRESH.
501 *
502  IF( result( 8 ).GE.thresh ) THEN
503  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
504  $ CALL alahd( nout, path )
505  WRITE( nout, fmt = 9997 )uplo, n, imat, 8,
506  $ result( 8 )
507  nfail = nfail + 1
508  END IF
509  nrun = nrun + 1
510  90 CONTINUE
511  100 CONTINUE
512  110 CONTINUE
513  120 CONTINUE
514 *
515 * Print a summary of the results.
516 *
517  CALL alasum( path, nout, nfail, nrun, nerrs )
518 *
519  9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
520  $ i2, ', test ', i2, ', ratio =', g12.5 )
521  9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
522  $ i2, ', test(', i2, ') =', g12.5 )
523  9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
524  $ ', test(', i2, ') =', g12.5 )
525  RETURN
526 *
527 * End of SCHKPO
528 *
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
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:73
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:81
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 slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
Definition: slatms.f:321
subroutine spotri(UPLO, N, A, LDA, INFO)
SPOTRI
Definition: spotri.f:95
subroutine spotrf(UPLO, N, A, LDA, INFO)
SPOTRF
Definition: spotrf.f:107
subroutine spocon(UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO)
SPOCON
Definition: spocon.f:121
subroutine sporfs(UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
SPORFS
Definition: sporfs.f:183
subroutine spotrs(UPLO, N, NRHS, A, LDA, B, LDB, INFO)
SPOTRS
Definition: spotrs.f:110
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,...
Definition: slansy.f:122
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 serrpo(PATH, NUNIT)
SERRPO
Definition: serrpo.f:55
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
Definition: slatb4.f:120
subroutine spot01(UPLO, N, A, LDA, AFAC, LDAFAC, RWORK, RESID)
SPOT01
Definition: spot01.f:104
subroutine spot05(UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPOT05
Definition: spot05.f:164
subroutine spot03(UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
SPOT03
Definition: spot03.f:125
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
Definition: sget04.f:102
subroutine spot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SPOT02
Definition: spot02.f:127
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: