LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
ddrvab.f
Go to the documentation of this file.
1 *> \brief \b DDRVAB
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * SUBROUTINE DDRVAB( DOTYPE, NM, MVAL, NNS,
12 * NSVAL, THRESH, NMAX, A, AFAC, B,
13 * X, WORK, RWORK, SWORK, IWORK, NOUT )
14 *
15 * .. Scalar Arguments ..
16 * INTEGER NM, NMAX, NNS, NOUT
17 * DOUBLE PRECISION THRESH
18 * ..
19 * .. Array Arguments ..
20 * LOGICAL DOTYPE( * )
21 * INTEGER MVAL( * ), NSVAL( * ), IWORK( * )
22 * REAL SWORK(*)
23 * DOUBLE PRECISION A( * ), AFAC( * ), B( * ),
24 * $ RWORK( * ), WORK( * ), X( * )
25 * ..
26 *
27 *
28 *> \par Purpose:
29 * =============
30 *>
31 *> \verbatim
32 *>
33 *> DDRVAB tests DSGESV
34 *> \endverbatim
35 *
36 * Arguments:
37 * ==========
38 *
39 *> \param[in] DOTYPE
40 *> \verbatim
41 *> DOTYPE is LOGICAL array, dimension (NTYPES)
42 *> The matrix types to be used for testing. Matrices of type j
43 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
44 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
45 *> \endverbatim
46 *>
47 *> \param[in] NM
48 *> \verbatim
49 *> NM is INTEGER
50 *> The number of values of M contained in the vector MVAL.
51 *> \endverbatim
52 *>
53 *> \param[in] MVAL
54 *> \verbatim
55 *> MVAL is INTEGER array, dimension (NM)
56 *> The values of the matrix row dimension M.
57 *> \endverbatim
58 *>
59 *> \param[in] NNS
60 *> \verbatim
61 *> NNS is INTEGER
62 *> The number of values of NRHS contained in the vector NSVAL.
63 *> \endverbatim
64 *>
65 *> \param[in] NSVAL
66 *> \verbatim
67 *> NSVAL is INTEGER array, dimension (NNS)
68 *> The values of the number of right hand sides NRHS.
69 *> \endverbatim
70 *>
71 *> \param[in] THRESH
72 *> \verbatim
73 *> THRESH is DOUBLE PRECISION
74 *> The threshold value for the test ratios. A result is
75 *> included in the output file if RESULT >= THRESH. To have
76 *> every test ratio printed, use THRESH = 0.
77 *> \endverbatim
78 *>
79 *> \param[in] NMAX
80 *> \verbatim
81 *> NMAX is INTEGER
82 *> The maximum value permitted for M or N, used in dimensioning
83 *> the work arrays.
84 *> \endverbatim
85 *>
86 *> \param[out] A
87 *> \verbatim
88 *> A is DOUBLE PRECISION array, dimension (NMAX*NMAX)
89 *> \endverbatim
90 *>
91 *> \param[out] AFAC
92 *> \verbatim
93 *> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX)
94 *> \endverbatim
95 *>
96 *> \param[out] B
97 *> \verbatim
98 *> B is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
99 *> where NSMAX is the largest entry in NSVAL.
100 *> \endverbatim
101 *>
102 *> \param[out] X
103 *> \verbatim
104 *> X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
105 *> \endverbatim
106 *>
107 *> \param[out] WORK
108 *> \verbatim
109 *> WORK is DOUBLE PRECISION array, dimension
110 *> (NMAX*max(3,NSMAX))
111 *> \endverbatim
112 *>
113 *> \param[out] RWORK
114 *> \verbatim
115 *> RWORK is DOUBLE PRECISION array, dimension
116 *> (max(2*NMAX,2*NSMAX+NWORK))
117 *> \endverbatim
118 *>
119 *> \param[out] SWORK
120 *> \verbatim
121 *> SWORK is REAL array, dimension
122 *> (NMAX*(NSMAX+NMAX))
123 *> \endverbatim
124 *>
125 *> \param[out] IWORK
126 *> \verbatim
127 *> IWORK is INTEGER array, dimension
128 *> NMAX
129 *> \endverbatim
130 *>
131 *> \param[in] NOUT
132 *> \verbatim
133 *> NOUT is INTEGER
134 *> The unit number for output.
135 *> \endverbatim
136 *
137 * Authors:
138 * ========
139 *
140 *> \author Univ. of Tennessee
141 *> \author Univ. of California Berkeley
142 *> \author Univ. of Colorado Denver
143 *> \author NAG Ltd.
144 *
145 *> \date November 2011
146 *
147 *> \ingroup double_lin
148 *
149 * =====================================================================
150  SUBROUTINE ddrvab( DOTYPE, NM, MVAL, NNS,
151  $ nsval, thresh, nmax, a, afac, b,
152  $ x, work, rwork, swork, iwork, nout )
153 *
154 * -- LAPACK test routine (version 3.4.0) --
155 * -- LAPACK is a software package provided by Univ. of Tennessee, --
156 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
157 * November 2011
158 *
159 * .. Scalar Arguments ..
160  INTEGER nm, nmax, nns, nout
161  DOUBLE PRECISION thresh
162 * ..
163 * .. Array Arguments ..
164  LOGICAL dotype( * )
165  INTEGER mval( * ), nsval( * ), iwork( * )
166  REAL swork(*)
167  DOUBLE PRECISION a( * ), afac( * ), b( * ),
168  $ rwork( * ), work( * ), x( * )
169 * ..
170 *
171 * =====================================================================
172 *
173 * .. Parameters ..
174  DOUBLE PRECISION zero
175  parameter( zero = 0.0d+0 )
176  INTEGER ntypes
177  parameter( ntypes = 11 )
178  INTEGER ntests
179  parameter( ntests = 1 )
180 * ..
181 * .. Local Scalars ..
182  LOGICAL zerot
183  CHARACTER dist, trans, type, xtype
184  CHARACTER*3 path
185  INTEGER i, im, imat, info, ioff, irhs,
186  $ izero, kl, ku, lda, m, mode, n,
187  $ nerrs, nfail, nimat, nrhs, nrun
188  DOUBLE PRECISION anorm, cndnum
189 * ..
190 * .. Local Arrays ..
191  INTEGER iseed( 4 ), iseedy( 4 )
192  DOUBLE PRECISION result( ntests )
193 * ..
194 * .. Local Variables ..
195  INTEGER iter, kase
196 * ..
197 * .. External Subroutines ..
198  EXTERNAL alaerh, alahd, dget08, dlacpy, dlarhs, dlaset,
199  $ dlatb4, dlatms
200 * ..
201 * .. Intrinsic Functions ..
202  INTRINSIC dble, max, min, sqrt
203 * ..
204 * .. Scalars in Common ..
205  LOGICAL lerr, ok
206  CHARACTER*32 srnamt
207  INTEGER infot, nunit
208 * ..
209 * .. Common blocks ..
210  common / infoc / infot, nunit, ok, lerr
211  common / srnamc / srnamt
212 * ..
213 * .. Data statements ..
214  DATA iseedy / 2006, 2007, 2008, 2009 /
215 * ..
216 * .. Executable Statements ..
217 *
218 * Initialize constants and the random number seed.
219 *
220  kase = 0
221  path( 1: 1 ) = 'Double precision'
222  path( 2: 3 ) = 'GE'
223  nrun = 0
224  nfail = 0
225  nerrs = 0
226  DO 10 i = 1, 4
227  iseed( i ) = iseedy( i )
228  10 continue
229 *
230  infot = 0
231 *
232 * Do for each value of M in MVAL
233 *
234  DO 120 im = 1, nm
235  m = mval( im )
236  lda = max( 1, m )
237 *
238  n = m
239  nimat = ntypes
240  IF( m.LE.0 .OR. n.LE.0 )
241  $ nimat = 1
242 *
243  DO 100 imat = 1, nimat
244 *
245 * Do the tests only if DOTYPE( IMAT ) is true.
246 *
247  IF( .NOT.dotype( imat ) )
248  $ go to 100
249 *
250 * Skip types 5, 6, or 7 if the matrix size is too small.
251 *
252  zerot = imat.GE.5 .AND. imat.LE.7
253  IF( zerot .AND. n.LT.imat-4 )
254  $ go to 100
255 *
256 * Set up parameters with DLATB4 and generate a test matrix
257 * with DLATMS.
258 *
259  CALL dlatb4( path, imat, m, n, type, kl, ku, anorm, mode,
260  $ cndnum, dist )
261 *
262  srnamt = 'DLATMS'
263  CALL dlatms( m, n, dist, iseed, type, rwork, mode,
264  $ cndnum, anorm, kl, ku, 'No packing', a, lda,
265  $ work, info )
266 *
267 * Check error code from DLATMS.
268 *
269  IF( info.NE.0 ) THEN
270  CALL alaerh( path, 'DLATMS', info, 0, ' ', m, n, -1,
271  $ -1, -1, imat, nfail, nerrs, nout )
272  go to 100
273  END IF
274 *
275 * For types 5-7, zero one or more columns of the matrix to
276 * test that INFO is returned correctly.
277 *
278  IF( zerot ) THEN
279  IF( imat.EQ.5 ) THEN
280  izero = 1
281  ELSE IF( imat.EQ.6 ) THEN
282  izero = min( m, n )
283  ELSE
284  izero = min( m, n ) / 2 + 1
285  END IF
286  ioff = ( izero-1 )*lda
287  IF( imat.LT.7 ) THEN
288  DO 20 i = 1, m
289  a( ioff+i ) = zero
290  20 continue
291  ELSE
292  CALL dlaset( 'Full', m, n-izero+1, zero, zero,
293  $ a( ioff+1 ), lda )
294  END IF
295  ELSE
296  izero = 0
297  END IF
298 *
299  DO 60 irhs = 1, nns
300  nrhs = nsval( irhs )
301  xtype = 'N'
302  trans = 'N'
303 *
304  srnamt = 'DLARHS'
305  CALL dlarhs( path, xtype, ' ', trans, n, n, kl,
306  $ ku, nrhs, a, lda, x, lda, b,
307  $ lda, iseed, info )
308 *
309  srnamt = 'DSGESV'
310 *
311  kase = kase + 1
312 *
313  CALL dlacpy( 'Full', m, n, a, lda, afac, lda )
314 *
315  CALL dsgesv( n, nrhs, a, lda, iwork, b, lda, x, lda,
316  $ work, swork, iter, info)
317 *
318  IF (iter.LT.0) THEN
319  CALL dlacpy( 'Full', m, n, afac, lda, a, lda )
320  ENDIF
321 *
322 * Check error code from DSGESV. This should be the same as
323 * the one of DGETRF.
324 *
325  IF( info.NE.izero ) THEN
326 *
327  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
328  $ CALL alahd( nout, path )
329  nerrs = nerrs + 1
330 *
331  IF( info.NE.izero .AND. izero.NE.0 ) THEN
332  WRITE( nout, fmt = 9988 )'DSGESV',info,
333  $ izero,m,imat
334  ELSE
335  WRITE( nout, fmt = 9975 )'DSGESV',info,
336  $ m, imat
337  END IF
338  END IF
339 *
340 * Skip the remaining test if the matrix is singular.
341 *
342  IF( info.NE.0 )
343  $ go to 100
344 *
345 * Check the quality of the solution
346 *
347  CALL dlacpy( 'Full', n, nrhs, b, lda, work, lda )
348 *
349  CALL dget08( trans, n, n, nrhs, a, lda, x, lda, work,
350  $ lda, rwork, result( 1 ) )
351 *
352 * Check if the test passes the tesing.
353 * Print information about the tests that did not
354 * pass the testing.
355 *
356 * If iterative refinement has been used and claimed to
357 * be successful (ITER>0), we want
358 * NORMI(B - A*X)/(NORMI(A)*NORMI(X)*EPS*SRQT(N)) < 1
359 *
360 * If double precision has been used (ITER<0), we want
361 * NORMI(B - A*X)/(NORMI(A)*NORMI(X)*EPS) < THRES
362 * (Cf. the linear solver testing routines)
363 *
364  IF ((thresh.LE.0.0e+00)
365  $ .OR.((iter.GE.0).AND.(n.GT.0)
366  $ .AND.(result(1).GE.sqrt(dble(n))))
367  $ .OR.((iter.LT.0).AND.(result(1).GE.thresh))) THEN
368 *
369  IF( nfail.EQ.0 .AND. nerrs.EQ.0 ) THEN
370  WRITE( nout, fmt = 8999 )'DGE'
371  WRITE( nout, fmt = '( '' Matrix types:'' )' )
372  WRITE( nout, fmt = 8979 )
373  WRITE( nout, fmt = '( '' Test ratios:'' )' )
374  WRITE( nout, fmt = 8960 )1
375  WRITE( nout, fmt = '( '' Messages:'' )' )
376  END IF
377 *
378  WRITE( nout, fmt = 9998 )trans, n, nrhs,
379  $ imat, 1, result( 1 )
380  nfail = nfail + 1
381  END IF
382  nrun = nrun + 1
383  60 continue
384  100 continue
385  120 continue
386 *
387 * Print a summary of the results.
388 *
389  IF( nfail.GT.0 ) THEN
390  WRITE( nout, fmt = 9996 )'DSGESV', nfail, nrun
391  ELSE
392  WRITE( nout, fmt = 9995 )'DSGESV', nrun
393  END IF
394  IF( nerrs.GT.0 ) THEN
395  WRITE( nout, fmt = 9994 )nerrs
396  END IF
397 *
398  9998 format( ' TRANS=''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
399  $ i2, ', test(', i2, ') =', g12.5 )
400  9996 format( 1x, a6, ': ', i6, ' out of ', i6,
401  $ ' tests failed to pass the threshold' )
402  9995 format( /1x, 'All tests for ', a6,
403  $ ' routines passed the threshold ( ', i6, ' tests run)' )
404  9994 format( 6x, i6, ' error messages recorded' )
405 *
406 * SUBNAM, INFO, INFOE, M, IMAT
407 *
408  9988 format( ' *** ', a6, ' returned with INFO =', i5, ' instead of ',
409  $ i5, / ' ==> M =', i5, ', type ',
410  $ i2 )
411 *
412 * SUBNAM, INFO, M, IMAT
413 *
414  9975 format( ' *** Error code from ', a6, '=', i5, ' for M=', i5,
415  $ ', type ', i2 )
416  8999 format( / 1x, a3, ': General dense matrices' )
417  8979 format( 4x, '1. Diagonal', 24x, '7. Last n/2 columns zero', / 4x,
418  $ '2. Upper triangular', 16x,
419  $ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4x,
420  $ '3. Lower triangular', 16x, '9. Random, CNDNUM = 0.1/EPS',
421  $ / 4x, '4. Random, CNDNUM = 2', 13x,
422  $ '10. Scaled near underflow', / 4x, '5. First column zero',
423  $ 14x, '11. Scaled near overflow', / 4x,
424  $ '6. Last column zero' )
425  8960 format( 3x, i2, ': norm_1( B - A * X ) / ',
426  $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF',
427  $ / 4x, 'or norm_1( B - A * X ) / ',
428  $ '( norm_1(A) * norm_1(X) * EPS ) > THRES if DGETRF' )
429  return
430 *
431 * End of DDRVAB
432 *
433  END