LAPACK  3.8.0 LAPACK: Linear Algebra PACKage

## ◆ cdrvpt()

 subroutine cdrvpt ( logical, dimension( * ) DOTYPE, integer NN, integer, dimension( * ) NVAL, integer NRHS, real THRESH, logical TSTERR, complex, dimension( * ) A, real, dimension( * ) D, complex, dimension( * ) E, complex, dimension( * ) B, complex, dimension( * ) X, complex, dimension( * ) XACT, complex, dimension( * ) WORK, real, dimension( * ) RWORK, integer NOUT )

CDRVPT

Purpose:
` CDRVPT tests CPTSV 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.``` [out] A ` A is COMPLEX array, dimension (NMAX*2)` [out] D ` D is REAL array, dimension (NMAX*2)` [out] E ` E is COMPLEX array, dimension (NMAX*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(3,NRHS))``` [out] RWORK ` RWORK is REAL array, dimension (NMAX+2*NRHS)` [in] NOUT ``` NOUT is INTEGER The unit number for output.```
Date
December 2016

Definition at line 142 of file cdrvpt.f.

142 *
143 * -- LAPACK test routine (version 3.7.0) --
144 * -- LAPACK is a software package provided by Univ. of Tennessee, --
145 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
146 * December 2016
147 *
148 * .. Scalar Arguments ..
149  LOGICAL tsterr
150  INTEGER nn, nout, nrhs
151  REAL thresh
152 * ..
153 * .. Array Arguments ..
154  LOGICAL dotype( * )
155  INTEGER nval( * )
156  REAL d( * ), rwork( * )
157  COMPLEX a( * ), b( * ), e( * ), work( * ), x( * ),
158  \$ xact( * )
159 * ..
160 *
161 * =====================================================================
162 *
163 * .. Parameters ..
164  REAL one, zero
165  parameter( one = 1.0e+0, zero = 0.0e+0 )
166  INTEGER ntypes
167  parameter( ntypes = 12 )
168  INTEGER ntests
169  parameter( ntests = 6 )
170 * ..
171 * .. Local Scalars ..
172  LOGICAL zerot
173  CHARACTER dist, fact, type
174  CHARACTER*3 path
175  INTEGER i, ia, ifact, imat, in, info, ix, izero, j, k,
176  \$ k1, kl, ku, lda, mode, n, nerrs, nfail, nimat,
177  \$ nrun, nt
178  REAL ainvnm, anorm, cond, dmax, rcond, rcondc
179 * ..
180 * .. Local Arrays ..
181  INTEGER iseed( 4 ), iseedy( 4 )
182  REAL result( ntests ), z( 3 )
183 * ..
184 * .. External Functions ..
185  INTEGER isamax
186  REAL clanht, scasum, sget06
187  EXTERNAL isamax, clanht, scasum, sget06
188 * ..
189 * .. External Subroutines ..
190  EXTERNAL aladhd, alaerh, alasvm, ccopy, cerrvx, cget04,
194 * ..
195 * .. Intrinsic Functions ..
196  INTRINSIC abs, cmplx, max
197 * ..
198 * .. Scalars in Common ..
199  LOGICAL lerr, ok
200  CHARACTER*32 srnamt
201  INTEGER infot, nunit
202 * ..
203 * .. Common blocks ..
204  COMMON / infoc / infot, nunit, ok, lerr
205  COMMON / srnamc / srnamt
206 * ..
207 * .. Data statements ..
208  DATA iseedy / 0, 0, 0, 1 /
209 * ..
210 * .. Executable Statements ..
211 *
212  path( 1: 1 ) = 'Complex precision'
213  path( 2: 3 ) = 'PT'
214  nrun = 0
215  nfail = 0
216  nerrs = 0
217  DO 10 i = 1, 4
218  iseed( i ) = iseedy( i )
219  10 CONTINUE
220 *
221 * Test the error exits
222 *
223  IF( tsterr )
224  \$ CALL cerrvx( path, nout )
225  infot = 0
226 *
227  DO 120 in = 1, nn
228 *
229 * Do for each value of N in NVAL.
230 *
231  n = nval( in )
232  lda = max( 1, n )
233  nimat = ntypes
234  IF( n.LE.0 )
235  \$ nimat = 1
236 *
237  DO 110 imat = 1, nimat
238 *
239 * Do the tests only if DOTYPE( IMAT ) is true.
240 *
241  IF( n.GT.0 .AND. .NOT.dotype( imat ) )
242  \$ GO TO 110
243 *
244 * Set up parameters with CLATB4.
245 *
246  CALL clatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
247  \$ cond, dist )
248 *
249  zerot = imat.GE.8 .AND. imat.LE.10
250  IF( imat.LE.6 ) THEN
251 *
252 * Type 1-6: generate a symmetric tridiagonal matrix of
253 * known condition number in lower triangular band storage.
254 *
255  srnamt = 'CLATMS'
256  CALL clatms( n, n, dist, iseed, TYPE, rwork, mode, cond,
257  \$ anorm, kl, ku, 'B', a, 2, work, info )
258 *
259 * Check the error code from CLATMS.
260 *
261  IF( info.NE.0 ) THEN
262  CALL alaerh( path, 'CLATMS', info, 0, ' ', n, n, kl,
263  \$ ku, -1, imat, nfail, nerrs, nout )
264  GO TO 110
265  END IF
266  izero = 0
267 *
268 * Copy the matrix to D and E.
269 *
270  ia = 1
271  DO 20 i = 1, n - 1
272  d( i ) = a( ia )
273  e( i ) = a( ia+1 )
274  ia = ia + 2
275  20 CONTINUE
276  IF( n.GT.0 )
277  \$ d( n ) = a( ia )
278  ELSE
279 *
280 * Type 7-12: generate a diagonally dominant matrix with
281 * unknown condition number in the vectors D and E.
282 *
283  IF( .NOT.zerot .OR. .NOT.dotype( 7 ) ) THEN
284 *
285 * Let D and E have values from [-1,1].
286 *
287  CALL slarnv( 2, iseed, n, d )
288  CALL clarnv( 2, iseed, n-1, e )
289 *
290 * Make the tridiagonal matrix diagonally dominant.
291 *
292  IF( n.EQ.1 ) THEN
293  d( 1 ) = abs( d( 1 ) )
294  ELSE
295  d( 1 ) = abs( d( 1 ) ) + abs( e( 1 ) )
296  d( n ) = abs( d( n ) ) + abs( e( n-1 ) )
297  DO 30 i = 2, n - 1
298  d( i ) = abs( d( i ) ) + abs( e( i ) ) +
299  \$ abs( e( i-1 ) )
300  30 CONTINUE
301  END IF
302 *
303 * Scale D and E so the maximum element is ANORM.
304 *
305  ix = isamax( n, d, 1 )
306  dmax = d( ix )
307  CALL sscal( n, anorm / dmax, d, 1 )
308  IF( n.GT.1 )
309  \$ CALL csscal( n-1, anorm / dmax, e, 1 )
310 *
311  ELSE IF( izero.GT.0 ) THEN
312 *
313 * Reuse the last matrix by copying back the zeroed out
314 * elements.
315 *
316  IF( izero.EQ.1 ) THEN
317  d( 1 ) = z( 2 )
318  IF( n.GT.1 )
319  \$ e( 1 ) = z( 3 )
320  ELSE IF( izero.EQ.n ) THEN
321  e( n-1 ) = z( 1 )
322  d( n ) = z( 2 )
323  ELSE
324  e( izero-1 ) = z( 1 )
325  d( izero ) = z( 2 )
326  e( izero ) = z( 3 )
327  END IF
328  END IF
329 *
330 * For types 8-10, set one row and column of the matrix to
331 * zero.
332 *
333  izero = 0
334  IF( imat.EQ.8 ) THEN
335  izero = 1
336  z( 2 ) = d( 1 )
337  d( 1 ) = zero
338  IF( n.GT.1 ) THEN
339  z( 3 ) = e( 1 )
340  e( 1 ) = zero
341  END IF
342  ELSE IF( imat.EQ.9 ) THEN
343  izero = n
344  IF( n.GT.1 ) THEN
345  z( 1 ) = e( n-1 )
346  e( n-1 ) = zero
347  END IF
348  z( 2 ) = d( n )
349  d( n ) = zero
350  ELSE IF( imat.EQ.10 ) THEN
351  izero = ( n+1 ) / 2
352  IF( izero.GT.1 ) THEN
353  z( 1 ) = e( izero-1 )
354  e( izero-1 ) = zero
355  z( 3 ) = e( izero )
356  e( izero ) = zero
357  END IF
358  z( 2 ) = d( izero )
359  d( izero ) = zero
360  END IF
361  END IF
362 *
363 * Generate NRHS random solution vectors.
364 *
365  ix = 1
366  DO 40 j = 1, nrhs
367  CALL clarnv( 2, iseed, n, xact( ix ) )
368  ix = ix + lda
369  40 CONTINUE
370 *
371 * Set the right hand side.
372 *
373  CALL claptm( 'Lower', n, nrhs, one, d, e, xact, lda, zero,
374  \$ b, lda )
375 *
376  DO 100 ifact = 1, 2
377  IF( ifact.EQ.1 ) THEN
378  fact = 'F'
379  ELSE
380  fact = 'N'
381  END IF
382 *
383 * Compute the condition number for comparison with
384 * the value returned by CPTSVX.
385 *
386  IF( zerot ) THEN
387  IF( ifact.EQ.1 )
388  \$ GO TO 100
389  rcondc = zero
390 *
391  ELSE IF( ifact.EQ.1 ) THEN
392 *
393 * Compute the 1-norm of A.
394 *
395  anorm = clanht( '1', n, d, e )
396 *
397  CALL scopy( n, d, 1, d( n+1 ), 1 )
398  IF( n.GT.1 )
399  \$ CALL ccopy( n-1, e, 1, e( n+1 ), 1 )
400 *
401 * Factor the matrix A.
402 *
403  CALL cpttrf( n, d( n+1 ), e( n+1 ), info )
404 *
405 * Use CPTTRS to solve for one column at a time of
406 * inv(A), computing the maximum column sum as we go.
407 *
408  ainvnm = zero
409  DO 60 i = 1, n
410  DO 50 j = 1, n
411  x( j ) = zero
412  50 CONTINUE
413  x( i ) = one
414  CALL cpttrs( 'Lower', n, 1, d( n+1 ), e( n+1 ), x,
415  \$ lda, info )
416  ainvnm = max( ainvnm, scasum( n, x, 1 ) )
417  60 CONTINUE
418 *
419 * Compute the 1-norm condition number of A.
420 *
421  IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
422  rcondc = one
423  ELSE
424  rcondc = ( one / anorm ) / ainvnm
425  END IF
426  END IF
427 *
428  IF( ifact.EQ.2 ) THEN
429 *
430 * --- Test CPTSV --
431 *
432  CALL scopy( n, d, 1, d( n+1 ), 1 )
433  IF( n.GT.1 )
434  \$ CALL ccopy( n-1, e, 1, e( n+1 ), 1 )
435  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
436 *
437 * Factor A as L*D*L' and solve the system A*X = B.
438 *
439  srnamt = 'CPTSV '
440  CALL cptsv( n, nrhs, d( n+1 ), e( n+1 ), x, lda,
441  \$ info )
442 *
443 * Check error code from CPTSV .
444 *
445  IF( info.NE.izero )
446  \$ CALL alaerh( path, 'CPTSV ', info, izero, ' ', n,
447  \$ n, 1, 1, nrhs, imat, nfail, nerrs,
448  \$ nout )
449  nt = 0
450  IF( izero.EQ.0 ) THEN
451 *
452 * Check the factorization by computing the ratio
453 * norm(L*D*L' - A) / (n * norm(A) * EPS )
454 *
455  CALL cptt01( n, d, e, d( n+1 ), e( n+1 ), work,
456  \$ result( 1 ) )
457 *
458 * Compute the residual in the solution.
459 *
460  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
461  CALL cptt02( 'Lower', n, nrhs, d, e, x, lda, work,
462  \$ lda, result( 2 ) )
463 *
464 * Check solution from generated exact solution.
465 *
466  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
467  \$ result( 3 ) )
468  nt = 3
469  END IF
470 *
471 * Print information about the tests that did not pass
472 * the threshold.
473 *
474  DO 70 k = 1, nt
475  IF( result( k ).GE.thresh ) THEN
476  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
477  \$ CALL aladhd( nout, path )
478  WRITE( nout, fmt = 9999 )'CPTSV ', n, imat, k,
479  \$ result( k )
480  nfail = nfail + 1
481  END IF
482  70 CONTINUE
483  nrun = nrun + nt
484  END IF
485 *
486 * --- Test CPTSVX ---
487 *
488  IF( ifact.GT.1 ) THEN
489 *
490 * Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero.
491 *
492  DO 80 i = 1, n - 1
493  d( n+i ) = zero
494  e( n+i ) = zero
495  80 CONTINUE
496  IF( n.GT.0 )
497  \$ d( n+n ) = zero
498  END IF
499 *
500  CALL claset( 'Full', n, nrhs, cmplx( zero ),
501  \$ cmplx( zero ), x, lda )
502 *
503 * Solve the system and compute the condition number and
504 * error bounds using CPTSVX.
505 *
506  srnamt = 'CPTSVX'
507  CALL cptsvx( fact, n, nrhs, d, e, d( n+1 ), e( n+1 ), b,
508  \$ lda, x, lda, rcond, rwork, rwork( nrhs+1 ),
509  \$ work, rwork( 2*nrhs+1 ), info )
510 *
511 * Check the error code from CPTSVX.
512 *
513  IF( info.NE.izero )
514  \$ CALL alaerh( path, 'CPTSVX', info, izero, fact, n, n,
515  \$ 1, 1, nrhs, imat, nfail, nerrs, nout )
516  IF( izero.EQ.0 ) THEN
517  IF( ifact.EQ.2 ) THEN
518 *
519 * Check the factorization by computing the ratio
520 * norm(L*D*L' - A) / (n * norm(A) * EPS )
521 *
522  k1 = 1
523  CALL cptt01( n, d, e, d( n+1 ), e( n+1 ), work,
524  \$ result( 1 ) )
525  ELSE
526  k1 = 2
527  END IF
528 *
529 * Compute the residual in the solution.
530 *
531  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
532  CALL cptt02( 'Lower', n, nrhs, d, e, x, lda, work,
533  \$ lda, result( 2 ) )
534 *
535 * Check solution from generated exact solution.
536 *
537  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
538  \$ result( 3 ) )
539 *
540 * Check error bounds from iterative refinement.
541 *
542  CALL cptt05( n, nrhs, d, e, b, lda, x, lda, xact, lda,
543  \$ rwork, rwork( nrhs+1 ), result( 4 ) )
544  ELSE
545  k1 = 6
546  END IF
547 *
548 * Check the reciprocal of the condition number.
549 *
550  result( 6 ) = sget06( rcond, rcondc )
551 *
552 * Print information about the tests that did not pass
553 * the threshold.
554 *
555  DO 90 k = k1, 6
556  IF( result( k ).GE.thresh ) THEN
557  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
558  \$ CALL aladhd( nout, path )
559  WRITE( nout, fmt = 9998 )'CPTSVX', fact, n, imat,
560  \$ k, result( k )
561  nfail = nfail + 1
562  END IF
563  90 CONTINUE
564  nrun = nrun + 7 - k1
565  100 CONTINUE
566  110 CONTINUE
567  120 CONTINUE
568 *
569 * Print a summary of the results.
570 *
571  CALL alasvm( path, nout, nfail, nrun, nerrs )
572 *
573  9999 FORMAT( 1x, a, ', N =', i5, ', type ', i2, ', test ', i2,
574  \$ ', ratio = ', g12.5 )
575  9998 FORMAT( 1x, a, ', FACT=''', a1, ''', N =', i5, ', type ', i2,
576  \$ ', test ', i2, ', ratio = ', g12.5 )
577  RETURN
578 *
579 * End of CDRVPT
580 *
subroutine cpttrf(N, D, E, INFO)
CPTTRF
Definition: cpttrf.f:94
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:75
subroutine claptm(UPLO, N, NRHS, ALPHA, D, E, X, LDX, BETA, B, LDB)
CLAPTM
Definition: claptm.f:131
real function clanht(NORM, N, D, E)
CLANHT returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian tridiagonal matrix.
Definition: clanht.f:103
subroutine cptt05(N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPTT05
Definition: cptt05.f:152
real function scasum(N, CX, INCX)
SCASUM
Definition: scasum.f:74
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
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:108
subroutine cpttrs(UPLO, N, NRHS, D, E, B, LDB, INFO)
CPTTRS
Definition: cpttrs.f:123
subroutine cerrvx(PATH, NUNIT)
CERRVX
Definition: cerrvx.f:57
subroutine cptsv(N, NRHS, D, E, B, LDB, INFO)
CPTSV computes the solution to system of linear equations A * X = B for PT matrices ...
Definition: cptsv.f:117
subroutine clarnv(IDIST, ISEED, N, X)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: clarnv.f:101
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:57
subroutine cptt02(UPLO, N, NRHS, D, E, X, LDX, B, LDB, RESID)
CPTT02
Definition: cptt02.f:117
integer function isamax(N, SX, INCX)
ISAMAX
Definition: isamax.f:73
subroutine cptt01(N, D, E, DF, EF, WORK, RESID)
CPTT01
Definition: cptt01.f:94
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:105
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: slarnv.f:99
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:334
subroutine sscal(N, SA, SX, INCX)
SSCAL
Definition: sscal.f:81
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:83
subroutine cptsvx(FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
CPTSVX computes the solution to system of linear equations A * X = B for PT matrices ...
Definition: cptsvx.f:236
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:104
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:84
subroutine csscal(N, SA, CX, INCX)
CSSCAL
Definition: csscal.f:80
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:123
Here is the call graph for this function:
Here is the caller graph for this function: