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

◆ ddrvgt()

subroutine ddrvgt ( logical, dimension( * )  dotype,
integer  nn,
integer, dimension( * )  nval,
integer  nrhs,
double precision  thresh,
logical  tsterr,
double precision, dimension( * )  a,
double precision, dimension( * )  af,
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 
)

DDRVGT

Purpose:
 DDRVGT tests DGTSV 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 sides, NRHS >= 0.
[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 DOUBLE PRECISION array, dimension (NMAX*4)
[out]AF
          AF is DOUBLE PRECISION array, dimension (NMAX*4)
[out]B
          B is DOUBLE PRECISION array, dimension (NMAX*NRHS)
[out]X
          X is DOUBLE PRECISION array, dimension (NMAX*NRHS)
[out]XACT
          XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS)
[out]WORK
          WORK is DOUBLE PRECISION array, dimension
                      (NMAX*max(3,NRHS))
[out]RWORK
          RWORK is DOUBLE PRECISION array, dimension
                      (max(NMAX,2*NRHS))
[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 137 of file ddrvgt.f.

139*
140* -- LAPACK test routine --
141* -- LAPACK is a software package provided by Univ. of Tennessee, --
142* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
143*
144* .. Scalar Arguments ..
145 LOGICAL TSTERR
146 INTEGER NN, NOUT, NRHS
147 DOUBLE PRECISION THRESH
148* ..
149* .. Array Arguments ..
150 LOGICAL DOTYPE( * )
151 INTEGER IWORK( * ), NVAL( * )
152 DOUBLE PRECISION A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ),
153 $ X( * ), XACT( * )
154* ..
155*
156* =====================================================================
157*
158* .. Parameters ..
159 DOUBLE PRECISION ONE, ZERO
160 parameter( one = 1.0d+0, zero = 0.0d+0 )
161 INTEGER NTYPES
162 parameter( ntypes = 12 )
163 INTEGER NTESTS
164 parameter( ntests = 6 )
165* ..
166* .. Local Scalars ..
167 LOGICAL TRFCON, ZEROT
168 CHARACTER DIST, FACT, TRANS, TYPE
169 CHARACTER*3 PATH
170 INTEGER I, IFACT, IMAT, IN, INFO, ITRAN, IX, IZERO, J,
171 $ K, K1, KL, KOFF, KU, LDA, M, MODE, N, NERRS,
172 $ NFAIL, NIMAT, NRUN, NT
173 DOUBLE PRECISION AINVNM, ANORM, ANORMI, ANORMO, COND, RCOND,
174 $ RCONDC, RCONDI, RCONDO
175* ..
176* .. Local Arrays ..
177 CHARACTER TRANSS( 3 )
178 INTEGER ISEED( 4 ), ISEEDY( 4 )
179 DOUBLE PRECISION RESULT( NTESTS ), Z( 3 )
180* ..
181* .. External Functions ..
182 DOUBLE PRECISION DASUM, DGET06, DLANGT
183 EXTERNAL dasum, dget06, dlangt
184* ..
185* .. External Subroutines ..
186 EXTERNAL aladhd, alaerh, alasvm, dcopy, derrvx, dget04,
187 $ dgtsv, dgtsvx, dgtt01, dgtt02, dgtt05, dgttrf,
188 $ dgttrs, dlacpy, dlagtm, dlarnv, dlaset, dlatb4,
189 $ dlatms, dscal
190* ..
191* .. Intrinsic Functions ..
192 INTRINSIC max
193* ..
194* .. Scalars in Common ..
195 LOGICAL LERR, OK
196 CHARACTER*32 SRNAMT
197 INTEGER INFOT, NUNIT
198* ..
199* .. Common blocks ..
200 COMMON / infoc / infot, nunit, ok, lerr
201 COMMON / srnamc / srnamt
202* ..
203* .. Data statements ..
204 DATA iseedy / 0, 0, 0, 1 / , transs / 'N', 'T',
205 $ 'C' /
206* ..
207* .. Executable Statements ..
208*
209 path( 1: 1 ) = 'Double precision'
210 path( 2: 3 ) = 'GT'
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 derrvx( path, nout )
222 infot = 0
223*
224 DO 140 in = 1, nn
225*
226* Do for each value of N in NVAL.
227*
228 n = nval( in )
229 m = max( n-1, 0 )
230 lda = max( 1, n )
231 nimat = ntypes
232 IF( n.LE.0 )
233 $ nimat = 1
234*
235 DO 130 imat = 1, nimat
236*
237* Do the tests only if DOTYPE( IMAT ) is true.
238*
239 IF( .NOT.dotype( imat ) )
240 $ GO TO 130
241*
242* Set up parameters with DLATB4.
243*
244 CALL dlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
245 $ COND, DIST )
246*
247 zerot = imat.GE.8 .AND. imat.LE.10
248 IF( imat.LE.6 ) THEN
249*
250* Types 1-6: generate matrices of known condition number.
251*
252 koff = max( 2-ku, 3-max( 1, n ) )
253 srnamt = 'DLATMS'
254 CALL dlatms( n, n, dist, iseed, TYPE, RWORK, MODE, COND,
255 $ ANORM, KL, KU, 'Z', AF( KOFF ), 3, WORK,
256 $ INFO )
257*
258* Check the error code from DLATMS.
259*
260 IF( info.NE.0 ) THEN
261 CALL alaerh( path, 'DLATMS', info, 0, ' ', n, n, kl,
262 $ ku, -1, imat, nfail, nerrs, nout )
263 GO TO 130
264 END IF
265 izero = 0
266*
267 IF( n.GT.1 ) THEN
268 CALL dcopy( n-1, af( 4 ), 3, a, 1 )
269 CALL dcopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
270 END IF
271 CALL dcopy( n, af( 2 ), 3, a( m+1 ), 1 )
272 ELSE
273*
274* Types 7-12: generate tridiagonal matrices with
275* unknown condition numbers.
276*
277 IF( .NOT.zerot .OR. .NOT.dotype( 7 ) ) THEN
278*
279* Generate a matrix with elements from [-1,1].
280*
281 CALL dlarnv( 2, iseed, n+2*m, a )
282 IF( anorm.NE.one )
283 $ CALL dscal( n+2*m, anorm, a, 1 )
284 ELSE IF( izero.GT.0 ) THEN
285*
286* Reuse the last matrix by copying back the zeroed out
287* elements.
288*
289 IF( izero.EQ.1 ) THEN
290 a( n ) = z( 2 )
291 IF( n.GT.1 )
292 $ a( 1 ) = z( 3 )
293 ELSE IF( izero.EQ.n ) THEN
294 a( 3*n-2 ) = z( 1 )
295 a( 2*n-1 ) = z( 2 )
296 ELSE
297 a( 2*n-2+izero ) = z( 1 )
298 a( n-1+izero ) = z( 2 )
299 a( izero ) = z( 3 )
300 END IF
301 END IF
302*
303* If IMAT > 7, set one column of the matrix to 0.
304*
305 IF( .NOT.zerot ) THEN
306 izero = 0
307 ELSE IF( imat.EQ.8 ) THEN
308 izero = 1
309 z( 2 ) = a( n )
310 a( n ) = zero
311 IF( n.GT.1 ) THEN
312 z( 3 ) = a( 1 )
313 a( 1 ) = zero
314 END IF
315 ELSE IF( imat.EQ.9 ) THEN
316 izero = n
317 z( 1 ) = a( 3*n-2 )
318 z( 2 ) = a( 2*n-1 )
319 a( 3*n-2 ) = zero
320 a( 2*n-1 ) = zero
321 ELSE
322 izero = ( n+1 ) / 2
323 DO 20 i = izero, n - 1
324 a( 2*n-2+i ) = zero
325 a( n-1+i ) = zero
326 a( i ) = zero
327 20 CONTINUE
328 a( 3*n-2 ) = zero
329 a( 2*n-1 ) = zero
330 END IF
331 END IF
332*
333 DO 120 ifact = 1, 2
334 IF( ifact.EQ.1 ) THEN
335 fact = 'F'
336 ELSE
337 fact = 'N'
338 END IF
339*
340* Compute the condition number for comparison with
341* the value returned by DGTSVX.
342*
343 IF( zerot ) THEN
344 IF( ifact.EQ.1 )
345 $ GO TO 120
346 rcondo = zero
347 rcondi = zero
348*
349 ELSE IF( ifact.EQ.1 ) THEN
350 CALL dcopy( n+2*m, a, 1, af, 1 )
351*
352* Compute the 1-norm and infinity-norm of A.
353*
354 anormo = dlangt( '1', n, a, a( m+1 ), a( n+m+1 ) )
355 anormi = dlangt( 'I', n, a, a( m+1 ), a( n+m+1 ) )
356*
357* Factor the matrix A.
358*
359 CALL dgttrf( n, af, af( m+1 ), af( n+m+1 ),
360 $ af( n+2*m+1 ), iwork, info )
361*
362* Use DGTTRS to solve for one column at a time of
363* inv(A), computing the maximum column sum as we go.
364*
365 ainvnm = zero
366 DO 40 i = 1, n
367 DO 30 j = 1, n
368 x( j ) = zero
369 30 CONTINUE
370 x( i ) = one
371 CALL dgttrs( 'No transpose', n, 1, af, af( m+1 ),
372 $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
373 $ lda, info )
374 ainvnm = max( ainvnm, dasum( n, x, 1 ) )
375 40 CONTINUE
376*
377* Compute the 1-norm condition number of A.
378*
379 IF( anormo.LE.zero .OR. ainvnm.LE.zero ) THEN
380 rcondo = one
381 ELSE
382 rcondo = ( one / anormo ) / ainvnm
383 END IF
384*
385* Use DGTTRS to solve for one column at a time of
386* inv(A'), computing the maximum column sum as we go.
387*
388 ainvnm = zero
389 DO 60 i = 1, n
390 DO 50 j = 1, n
391 x( j ) = zero
392 50 CONTINUE
393 x( i ) = one
394 CALL dgttrs( 'Transpose', n, 1, af, af( m+1 ),
395 $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
396 $ lda, info )
397 ainvnm = max( ainvnm, dasum( n, x, 1 ) )
398 60 CONTINUE
399*
400* Compute the infinity-norm condition number of A.
401*
402 IF( anormi.LE.zero .OR. ainvnm.LE.zero ) THEN
403 rcondi = one
404 ELSE
405 rcondi = ( one / anormi ) / ainvnm
406 END IF
407 END IF
408*
409 DO 110 itran = 1, 3
410 trans = transs( itran )
411 IF( itran.EQ.1 ) THEN
412 rcondc = rcondo
413 ELSE
414 rcondc = rcondi
415 END IF
416*
417* Generate NRHS random solution vectors.
418*
419 ix = 1
420 DO 70 j = 1, nrhs
421 CALL dlarnv( 2, iseed, n, xact( ix ) )
422 ix = ix + lda
423 70 CONTINUE
424*
425* Set the right hand side.
426*
427 CALL dlagtm( trans, n, nrhs, one, a, a( m+1 ),
428 $ a( n+m+1 ), xact, lda, zero, b, lda )
429*
430 IF( ifact.EQ.2 .AND. itran.EQ.1 ) THEN
431*
432* --- Test DGTSV ---
433*
434* Solve the system using Gaussian elimination with
435* partial pivoting.
436*
437 CALL dcopy( n+2*m, a, 1, af, 1 )
438 CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
439*
440 srnamt = 'DGTSV '
441 CALL dgtsv( n, nrhs, af, af( m+1 ), af( n+m+1 ), x,
442 $ lda, info )
443*
444* Check error code from DGTSV .
445*
446 IF( info.NE.izero )
447 $ CALL alaerh( path, 'DGTSV ', info, izero, ' ',
448 $ n, n, 1, 1, nrhs, imat, nfail,
449 $ nerrs, nout )
450 nt = 1
451 IF( izero.EQ.0 ) THEN
452*
453* Check residual of computed solution.
454*
455 CALL dlacpy( 'Full', n, nrhs, b, lda, work,
456 $ lda )
457 CALL dgtt02( trans, n, nrhs, a, a( m+1 ),
458 $ a( n+m+1 ), x, lda, work, lda,
459 $ result( 2 ) )
460*
461* Check solution from generated exact solution.
462*
463 CALL dget04( 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 80 k = 2, 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 )'DGTSV ', n, imat,
476 $ k, result( k )
477 nfail = nfail + 1
478 END IF
479 80 CONTINUE
480 nrun = nrun + nt - 1
481 END IF
482*
483* --- Test DGTSVX ---
484*
485 IF( ifact.GT.1 ) THEN
486*
487* Initialize AF to zero.
488*
489 DO 90 i = 1, 3*n - 2
490 af( i ) = zero
491 90 CONTINUE
492 END IF
493 CALL dlaset( 'Full', n, nrhs, zero, zero, x, lda )
494*
495* Solve the system and compute the condition number and
496* error bounds using DGTSVX.
497*
498 srnamt = 'DGTSVX'
499 CALL dgtsvx( fact, trans, n, nrhs, a, a( m+1 ),
500 $ a( n+m+1 ), af, af( m+1 ), af( n+m+1 ),
501 $ af( n+2*m+1 ), iwork, b, lda, x, lda,
502 $ rcond, rwork, rwork( nrhs+1 ), work,
503 $ iwork( n+1 ), info )
504*
505* Check the error code from DGTSVX.
506*
507 IF( info.NE.izero )
508 $ CALL alaerh( path, 'DGTSVX', info, izero,
509 $ fact // trans, n, n, 1, 1, nrhs, imat,
510 $ nfail, nerrs, nout )
511*
512 IF( ifact.GE.2 ) THEN
513*
514* Reconstruct matrix from factors and compute
515* residual.
516*
517 CALL dgtt01( n, a, a( m+1 ), a( n+m+1 ), af,
518 $ af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
519 $ iwork, work, lda, rwork, result( 1 ) )
520 k1 = 1
521 ELSE
522 k1 = 2
523 END IF
524*
525 IF( info.EQ.0 ) THEN
526 trfcon = .false.
527*
528* Check residual of computed solution.
529*
530 CALL dlacpy( 'Full', n, nrhs, b, lda, work, lda )
531 CALL dgtt02( trans, n, nrhs, a, a( m+1 ),
532 $ a( n+m+1 ), x, lda, work, lda,
533 $ result( 2 ) )
534*
535* Check solution from generated exact solution.
536*
537 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
538 $ result( 3 ) )
539*
540* Check the error bounds from iterative refinement.
541*
542 CALL dgtt05( trans, n, nrhs, a, a( m+1 ),
543 $ a( n+m+1 ), b, lda, x, lda, xact, lda,
544 $ rwork, rwork( nrhs+1 ), result( 4 ) )
545 nt = 5
546 END IF
547*
548* Print information about the tests that did not pass
549* the threshold.
550*
551 DO 100 k = k1, nt
552 IF( result( k ).GE.thresh ) THEN
553 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
554 $ CALL aladhd( nout, path )
555 WRITE( nout, fmt = 9998 )'DGTSVX', fact, trans,
556 $ n, imat, k, result( k )
557 nfail = nfail + 1
558 END IF
559 100 CONTINUE
560*
561* Check the reciprocal of the condition number.
562*
563 result( 6 ) = dget06( rcond, rcondc )
564 IF( result( 6 ).GE.thresh ) THEN
565 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
566 $ CALL aladhd( nout, path )
567 WRITE( nout, fmt = 9998 )'DGTSVX', fact, trans, n,
568 $ imat, k, result( k )
569 nfail = nfail + 1
570 END IF
571 nrun = nrun + nt - k1 + 2
572*
573 110 CONTINUE
574 120 CONTINUE
575 130 CONTINUE
576 140 CONTINUE
577*
578* Print a summary of the results.
579*
580 CALL alasvm( path, nout, nfail, nrun, nerrs )
581*
582 9999 FORMAT( 1x, a, ', N =', i5, ', type ', i2, ', test ', i2,
583 $ ', ratio = ', g12.5 )
584 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', TRANS=''', a1, ''', N =',
585 $ i5, ', type ', i2, ', test ', i2, ', ratio = ', g12.5 )
586 RETURN
587*
588* End of DDRVGT
589*
alasvm
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
Definition alasvm.f:73
aladhd
subroutine aladhd(iounit, path)
ALADHD
Definition aladhd.f:90
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
derrvx
subroutine derrvx(path, nunit)
DERRVX
Definition derrvx.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
dgtt01
subroutine dgtt01(n, dl, d, du, dlf, df, duf, du2, ipiv, work, ldwork, rwork, resid)
DGTT01
Definition dgtt01.f:134
dgtt02
subroutine dgtt02(trans, n, nrhs, dl, d, du, x, ldx, b, ldb, resid)
DGTT02
Definition dgtt02.f:125
dgtt05
subroutine dgtt05(trans, n, nrhs, dl, d, du, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
DGTT05
Definition dgtt05.f:165
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
dasum
double precision function dasum(n, dx, incx)
DASUM
Definition dasum.f:71
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
Definition dcopy.f:82
dgtsv
subroutine dgtsv(n, nrhs, dl, d, du, b, ldb, info)
DGTSV computes the solution to system of linear equations A * X = B for GT matrices
Definition dgtsv.f:127
dgtsvx
subroutine dgtsvx(fact, trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)
DGTSVX computes the solution to system of linear equations A * X = B for GT matrices
Definition dgtsvx.f:293
dgttrf
subroutine dgttrf(n, dl, d, du, du2, ipiv, info)
DGTTRF
Definition dgttrf.f:124
dgttrs
subroutine dgttrs(trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb, info)
DGTTRS
Definition dgttrs.f:138
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
dlagtm
subroutine dlagtm(trans, n, nrhs, alpha, dl, d, du, x, ldx, beta, b, ldb)
DLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix,...
Definition dlagtm.f:145
dlangt
double precision function dlangt(norm, n, dl, d, du)
DLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition dlangt.f:106
dlarnv
subroutine dlarnv(idist, iseed, n, x)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition dlarnv.f:97
dlaset
subroutine dlaset(uplo, m, n, alpha, beta, a, lda)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition dlaset.f:110
dscal
subroutine dscal(n, da, dx, incx)
DSCAL
Definition dscal.f:79
Here is the call graph for this function:
Here is the caller graph for this function: