LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ cdrvsp()

subroutine cdrvsp ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NRHS,
real  THRESH,
logical  TSTERR,
integer  NMAX,
complex, dimension( * )  A,
complex, dimension( * )  AFAC,
complex, dimension( * )  AINV,
complex, dimension( * )  B,
complex, dimension( * )  X,
complex, dimension( * )  XACT,
complex, dimension( * )  WORK,
real, dimension( * )  RWORK,
integer, dimension( * )  IWORK,
integer  NOUT 
)

CDRVSP

Purpose:
 CDRVSP tests the driver routines CSPSV 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 COMPLEX array, dimension
                      (NMAX*(NMAX+1)/2)
[out]AFAC
          AFAC is COMPLEX array, dimension
                      (NMAX*(NMAX+1)/2)
[out]AINV
          AINV is COMPLEX array, dimension
                      (NMAX*(NMAX+1)/2)
[out]B
          B is COMPLEX array, dimension (NMAX*NRHS)
[out]X
          X is COMPLEX array, dimension (NMAX*NRHS)
[out]XACT
          XACT is COMPLEX array, dimension (NMAX*NRHS)
[out]WORK
          WORK is COMPLEX array, dimension
                      (NMAX*max(2,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 154 of file cdrvsp.f.

157 *
158 * -- LAPACK test routine --
159 * -- LAPACK is a software package provided by Univ. of Tennessee, --
160 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
161 *
162 * .. Scalar Arguments ..
163  LOGICAL TSTERR
164  INTEGER NMAX, NN, NOUT, NRHS
165  REAL THRESH
166 * ..
167 * .. Array Arguments ..
168  LOGICAL DOTYPE( * )
169  INTEGER IWORK( * ), NVAL( * )
170  REAL RWORK( * )
171  COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
172  $ WORK( * ), X( * ), XACT( * )
173 * ..
174 *
175 * =====================================================================
176 *
177 * .. Parameters ..
178  REAL ONE, ZERO
179  parameter( one = 1.0e+0, zero = 0.0e+0 )
180  INTEGER NTYPES, NTESTS
181  parameter( ntypes = 11, ntests = 6 )
182  INTEGER NFACT
183  parameter( nfact = 2 )
184 * ..
185 * .. Local Scalars ..
186  LOGICAL ZEROT
187  CHARACTER DIST, FACT, PACKIT, TYPE, UPLO, XTYPE
188  CHARACTER*3 PATH
189  INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
190  $ IZERO, J, K, K1, KL, KU, LDA, MODE, N, NB,
191  $ NBMIN, NERRS, NFAIL, NIMAT, NPP, NRUN, NT
192  REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC
193 * ..
194 * .. Local Arrays ..
195  CHARACTER FACTS( NFACT )
196  INTEGER ISEED( 4 ), ISEEDY( 4 )
197  REAL RESULT( NTESTS )
198 * ..
199 * .. External Functions ..
200  REAL CLANSP, SGET06
201  EXTERNAL clansp, sget06
202 * ..
203 * .. External Subroutines ..
204  EXTERNAL aladhd, alaerh, alasvm, ccopy, cerrvx, cget04,
207  $ csptri, 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 cmplx, max, min
220 * ..
221 * .. Data statements ..
222  DATA iseedy / 1988, 1989, 1990, 1991 /
223  DATA facts / 'F', 'N' /
224 * ..
225 * .. Executable Statements ..
226 *
227 * Initialize constants and the random number seed.
228 *
229  path( 1: 1 ) = 'Complex precision'
230  path( 2: 3 ) = 'SP'
231  nrun = 0
232  nfail = 0
233  nerrs = 0
234  DO 10 i = 1, 4
235  iseed( i ) = iseedy( i )
236  10 CONTINUE
237 *
238 * Test the error exits
239 *
240  IF( tsterr )
241  $ CALL cerrvx( path, nout )
242  infot = 0
243 *
244 * Set the block size and minimum block size for testing.
245 *
246  nb = 1
247  nbmin = 2
248  CALL xlaenv( 1, nb )
249  CALL xlaenv( 2, nbmin )
250 *
251 * Do for each value of N in NVAL
252 *
253  DO 180 in = 1, nn
254  n = nval( in )
255  lda = max( n, 1 )
256  npp = n*( n+1 ) / 2
257  xtype = 'N'
258  nimat = ntypes
259  IF( n.LE.0 )
260  $ nimat = 1
261 *
262  DO 170 imat = 1, nimat
263 *
264 * Do the tests only if DOTYPE( IMAT ) is true.
265 *
266  IF( .NOT.dotype( imat ) )
267  $ GO TO 170
268 *
269 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
270 *
271  zerot = imat.GE.3 .AND. imat.LE.6
272  IF( zerot .AND. n.LT.imat-2 )
273  $ GO TO 170
274 *
275 * Do first for UPLO = 'U', then for UPLO = 'L'
276 *
277  DO 160 iuplo = 1, 2
278  IF( iuplo.EQ.1 ) THEN
279  uplo = 'U'
280  packit = 'C'
281  ELSE
282  uplo = 'L'
283  packit = 'R'
284  END IF
285 *
286  IF( imat.NE.ntypes ) THEN
287 *
288 * Set up parameters with CLATB4 and generate a test
289 * matrix with CLATMS.
290 *
291  CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
292  $ MODE, CNDNUM, DIST )
293 *
294  srnamt = 'CLATMS'
295  CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
296  $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA,
297  $ WORK, INFO )
298 *
299 * Check error code from CLATMS.
300 *
301  IF( info.NE.0 ) THEN
302  CALL alaerh( path, 'CLATMS', info, 0, uplo, n, n,
303  $ -1, -1, -1, imat, nfail, nerrs, nout )
304  GO TO 160
305  END IF
306 *
307 * For types 3-6, zero one or more rows and columns of
308 * the matrix to 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  IF( imat.LT.6 ) THEN
320 *
321 * Set row and column IZERO to zero.
322 *
323  IF( iuplo.EQ.1 ) THEN
324  ioff = ( izero-1 )*izero / 2
325  DO 20 i = 1, izero - 1
326  a( ioff+i ) = zero
327  20 CONTINUE
328  ioff = ioff + izero
329  DO 30 i = izero, n
330  a( ioff ) = zero
331  ioff = ioff + i
332  30 CONTINUE
333  ELSE
334  ioff = izero
335  DO 40 i = 1, izero - 1
336  a( ioff ) = zero
337  ioff = ioff + n - i
338  40 CONTINUE
339  ioff = ioff - izero
340  DO 50 i = izero, n
341  a( ioff+i ) = zero
342  50 CONTINUE
343  END IF
344  ELSE
345  IF( iuplo.EQ.1 ) THEN
346 *
347 * Set the first IZERO rows and columns to zero.
348 *
349  ioff = 0
350  DO 70 j = 1, n
351  i2 = min( j, izero )
352  DO 60 i = 1, i2
353  a( ioff+i ) = zero
354  60 CONTINUE
355  ioff = ioff + j
356  70 CONTINUE
357  ELSE
358 *
359 * Set the last IZERO rows and columns to zero.
360 *
361  ioff = 0
362  DO 90 j = 1, n
363  i1 = max( j, izero )
364  DO 80 i = i1, n
365  a( ioff+i ) = zero
366  80 CONTINUE
367  ioff = ioff + n - j
368  90 CONTINUE
369  END IF
370  END IF
371  ELSE
372  izero = 0
373  END IF
374  ELSE
375 *
376 * Use a special block diagonal matrix to test alternate
377 * code for the 2-by-2 blocks.
378 *
379  CALL clatsp( uplo, n, a, iseed )
380  END IF
381 *
382  DO 150 ifact = 1, nfact
383 *
384 * Do first for FACT = 'F', then for other values.
385 *
386  fact = facts( ifact )
387 *
388 * Compute the condition number for comparison with
389 * the value returned by CSPSVX.
390 *
391  IF( zerot ) THEN
392  IF( ifact.EQ.1 )
393  $ GO TO 150
394  rcondc = zero
395 *
396  ELSE IF( ifact.EQ.1 ) THEN
397 *
398 * Compute the 1-norm of A.
399 *
400  anorm = clansp( '1', uplo, n, a, rwork )
401 *
402 * Factor the matrix A.
403 *
404  CALL ccopy( npp, a, 1, afac, 1 )
405  CALL csptrf( uplo, n, afac, iwork, info )
406 *
407 * Compute inv(A) and take its norm.
408 *
409  CALL ccopy( npp, afac, 1, ainv, 1 )
410  CALL csptri( uplo, n, ainv, iwork, work, info )
411  ainvnm = clansp( '1', uplo, n, ainv, rwork )
412 *
413 * Compute the 1-norm condition number of A.
414 *
415  IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
416  rcondc = one
417  ELSE
418  rcondc = ( one / anorm ) / ainvnm
419  END IF
420  END IF
421 *
422 * Form an exact solution and set the right hand side.
423 *
424  srnamt = 'CLARHS'
425  CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
426  $ nrhs, a, lda, xact, lda, b, lda, iseed,
427  $ info )
428  xtype = 'C'
429 *
430 * --- Test CSPSV ---
431 *
432  IF( ifact.EQ.2 ) THEN
433  CALL ccopy( npp, a, 1, afac, 1 )
434  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
435 *
436 * Factor the matrix and solve the system using CSPSV.
437 *
438  srnamt = 'CSPSV '
439  CALL cspsv( uplo, n, nrhs, afac, iwork, x, lda,
440  $ info )
441 *
442 * Adjust the expected value of INFO to account for
443 * pivoting.
444 *
445  k = izero
446  IF( k.GT.0 ) THEN
447  100 CONTINUE
448  IF( iwork( k ).LT.0 ) THEN
449  IF( iwork( k ).NE.-k ) THEN
450  k = -iwork( k )
451  GO TO 100
452  END IF
453  ELSE IF( iwork( k ).NE.k ) THEN
454  k = iwork( k )
455  GO TO 100
456  END IF
457  END IF
458 *
459 * Check error code from CSPSV .
460 *
461  IF( info.NE.k ) THEN
462  CALL alaerh( path, 'CSPSV ', info, k, uplo, n,
463  $ n, -1, -1, nrhs, imat, nfail,
464  $ nerrs, nout )
465  GO TO 120
466  ELSE IF( info.NE.0 ) THEN
467  GO TO 120
468  END IF
469 *
470 * Reconstruct matrix from factors and compute
471 * residual.
472 *
473  CALL cspt01( uplo, n, a, afac, iwork, ainv, lda,
474  $ rwork, result( 1 ) )
475 *
476 * Compute residual of the computed solution.
477 *
478  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
479  CALL cspt02( uplo, n, nrhs, a, x, lda, work, lda,
480  $ rwork, result( 2 ) )
481 *
482 * Check solution from generated exact solution.
483 *
484  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
485  $ result( 3 ) )
486  nt = 3
487 *
488 * Print information about the tests that did not pass
489 * the threshold.
490 *
491  DO 110 k = 1, nt
492  IF( result( k ).GE.thresh ) THEN
493  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
494  $ CALL aladhd( nout, path )
495  WRITE( nout, fmt = 9999 )'CSPSV ', uplo, n,
496  $ imat, k, result( k )
497  nfail = nfail + 1
498  END IF
499  110 CONTINUE
500  nrun = nrun + nt
501  120 CONTINUE
502  END IF
503 *
504 * --- Test CSPSVX ---
505 *
506  IF( ifact.EQ.2 .AND. npp.GT.0 )
507  $ CALL claset( 'Full', npp, 1, cmplx( zero ),
508  $ cmplx( zero ), afac, npp )
509  CALL claset( 'Full', n, nrhs, cmplx( zero ),
510  $ cmplx( zero ), x, lda )
511 *
512 * Solve the system and compute the condition number and
513 * error bounds using CSPSVX.
514 *
515  srnamt = 'CSPSVX'
516  CALL cspsvx( fact, uplo, n, nrhs, a, afac, iwork, b,
517  $ lda, x, lda, rcond, rwork,
518  $ rwork( nrhs+1 ), work, rwork( 2*nrhs+1 ),
519  $ info )
520 *
521 * Adjust the expected value of INFO to account for
522 * pivoting.
523 *
524  k = izero
525  IF( k.GT.0 ) THEN
526  130 CONTINUE
527  IF( iwork( k ).LT.0 ) THEN
528  IF( iwork( k ).NE.-k ) THEN
529  k = -iwork( k )
530  GO TO 130
531  END IF
532  ELSE IF( iwork( k ).NE.k ) THEN
533  k = iwork( k )
534  GO TO 130
535  END IF
536  END IF
537 *
538 * Check the error code from CSPSVX.
539 *
540  IF( info.NE.k ) THEN
541  CALL alaerh( path, 'CSPSVX', info, k, fact // uplo,
542  $ n, n, -1, -1, nrhs, imat, nfail,
543  $ nerrs, nout )
544  GO TO 150
545  END IF
546 *
547  IF( info.EQ.0 ) THEN
548  IF( ifact.GE.2 ) THEN
549 *
550 * Reconstruct matrix from factors and compute
551 * residual.
552 *
553  CALL cspt01( uplo, n, a, afac, iwork, ainv, lda,
554  $ rwork( 2*nrhs+1 ), result( 1 ) )
555  k1 = 1
556  ELSE
557  k1 = 2
558  END IF
559 *
560 * Compute residual of the computed solution.
561 *
562  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
563  CALL cspt02( uplo, n, nrhs, a, x, lda, work, lda,
564  $ rwork( 2*nrhs+1 ), result( 2 ) )
565 *
566 * Check solution from generated exact solution.
567 *
568  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
569  $ result( 3 ) )
570 *
571 * Check the error bounds from iterative refinement.
572 *
573  CALL cppt05( uplo, n, nrhs, a, b, lda, x, lda,
574  $ xact, lda, rwork, rwork( nrhs+1 ),
575  $ result( 4 ) )
576  ELSE
577  k1 = 6
578  END IF
579 *
580 * Compare RCOND from CSPSVX with the computed value
581 * in RCONDC.
582 *
583  result( 6 ) = sget06( rcond, rcondc )
584 *
585 * Print information about the tests that did not pass
586 * the threshold.
587 *
588  DO 140 k = k1, 6
589  IF( result( k ).GE.thresh ) THEN
590  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
591  $ CALL aladhd( nout, path )
592  WRITE( nout, fmt = 9998 )'CSPSVX', fact, uplo,
593  $ n, imat, k, result( k )
594  nfail = nfail + 1
595  END IF
596  140 CONTINUE
597  nrun = nrun + 7 - k1
598 *
599  150 CONTINUE
600 *
601  160 CONTINUE
602  170 CONTINUE
603  180 CONTINUE
604 *
605 * Print a summary of the results.
606 *
607  CALL alasvm( path, nout, nfail, nrun, nerrs )
608 *
609  9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
610  $ ', test ', i2, ', ratio =', g12.5 )
611  9998 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N =', i5,
612  $ ', type ', i2, ', test ', i2, ', ratio =', g12.5 )
613  RETURN
614 *
615 * End of CDRVSP
616 *
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:73
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:81
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 ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:81
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
Definition: clarhs.f:208
subroutine clatsp(UPLO, N, X, ISEED)
CLATSP
Definition: clatsp.f:84
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:121
subroutine cspt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
CSPT02
Definition: cspt02.f:123
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:102
subroutine cspt01(UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID)
CSPT01
Definition: cspt01.f:112
subroutine cppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPPT05
Definition: cppt05.f:157
subroutine cerrvx(PATH, NUNIT)
CERRVX
Definition: cerrvx.f:55
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:332
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition: claset.f:106
real function clansp(NORM, UPLO, N, AP, WORK)
CLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition: clansp.f:115
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:103
subroutine csptri(UPLO, N, AP, IPIV, WORK, INFO)
CSPTRI
Definition: csptri.f:109
subroutine csptrf(UPLO, N, AP, IPIV, INFO)
CSPTRF
Definition: csptrf.f:158
subroutine cspsvx(FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
CSPSVX computes the solution to system of linear equations A * X = B for OTHER matrices
Definition: cspsvx.f:277
subroutine cspsv(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
CSPSV computes the solution to system of linear equations A * X = B for OTHER matrices
Definition: cspsv.f:162
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: