LAPACK  3.10.0 LAPACK: Linear Algebra PACKage

## ◆ zdrvpt()

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

ZDRVPT

Purpose:
` ZDRVPT tests ZPTSV 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 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.``` [out] A ` A is COMPLEX*16 array, dimension (NMAX*2)` [out] D ` D is DOUBLE PRECISION array, dimension (NMAX*2)` [out] E ` E is COMPLEX*16 array, dimension (NMAX*2)` [out] B ` B is COMPLEX*16 array, dimension (NMAX*NRHS)` [out] X ` X is COMPLEX*16 array, dimension (NMAX*NRHS)` [out] XACT ` XACT is COMPLEX*16 array, dimension (NMAX*NRHS)` [out] WORK ``` WORK is COMPLEX*16 array, dimension (NMAX*max(3,NRHS))``` [out] RWORK ` RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)` [in] NOUT ``` NOUT is INTEGER The unit number for output.```

Definition at line 138 of file zdrvpt.f.

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