LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
derrge.f
Go to the documentation of this file.
1 *> \brief \b DERRGE
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 DERRGE( PATH, NUNIT )
12 *
13 * .. Scalar Arguments ..
14 * CHARACTER*3 PATH
15 * INTEGER NUNIT
16 * ..
17 *
18 *
19 *> \par Purpose:
20 * =============
21 *>
22 *> \verbatim
23 *>
24 *> DERRGE tests the error exits for the DOUBLE PRECISION routines
25 *> for general matrices.
26 *> \endverbatim
27 *
28 * Arguments:
29 * ==========
30 *
31 *> \param[in] PATH
32 *> \verbatim
33 *> PATH is CHARACTER*3
34 *> The LAPACK path name for the routines to be tested.
35 *> \endverbatim
36 *>
37 *> \param[in] NUNIT
38 *> \verbatim
39 *> NUNIT is INTEGER
40 *> The unit number for output.
41 *> \endverbatim
42 *
43 * Authors:
44 * ========
45 *
46 *> \author Univ. of Tennessee
47 *> \author Univ. of California Berkeley
48 *> \author Univ. of Colorado Denver
49 *> \author NAG Ltd.
50 *
51 *> \date November 2011
52 *
53 *> \ingroup double_lin
54 *
55 * =====================================================================
56  SUBROUTINE derrge( PATH, NUNIT )
57 *
58 * -- LAPACK test routine (version 3.4.0) --
59 * -- LAPACK is a software package provided by Univ. of Tennessee, --
60 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
61 * November 2011
62 *
63 * .. Scalar Arguments ..
64  CHARACTER*3 path
65  INTEGER nunit
66 * ..
67 *
68 * =====================================================================
69 *
70 * .. Parameters ..
71  INTEGER nmax, lw
72  parameter( nmax = 4, lw = 3*nmax )
73 * ..
74 * .. Local Scalars ..
75  CHARACTER*2 c2
76  INTEGER i, info, j
77  DOUBLE PRECISION anrm, ccond, rcond
78 * ..
79 * .. Local Arrays ..
80  INTEGER ip( nmax ), iw( nmax )
81  DOUBLE PRECISION a( nmax, nmax ), af( nmax, nmax ), b( nmax ),
82  $ r1( nmax ), r2( nmax ), w( lw ), x( nmax )
83 * ..
84 * .. External Functions ..
85  LOGICAL lsamen
86  EXTERNAL lsamen
87 * ..
88 * .. External Subroutines ..
89  EXTERNAL alaesm, chkxer, dgbcon, dgbequ, dgbrfs, dgbtf2,
90  $ dgbtrf, dgbtrs, dgecon, dgeequ, dgerfs, dgetf2,
91  $ dgetrf, dgetri, dgetrs
92 * ..
93 * .. Scalars in Common ..
94  LOGICAL lerr, ok
95  CHARACTER*32 srnamt
96  INTEGER infot, nout
97 * ..
98 * .. Common blocks ..
99  common / infoc / infot, nout, ok, lerr
100  common / srnamc / srnamt
101 * ..
102 * .. Intrinsic Functions ..
103  INTRINSIC dble
104 * ..
105 * .. Executable Statements ..
106 *
107  nout = nunit
108  WRITE( nout, fmt = * )
109  c2 = path( 2: 3 )
110 *
111 * Set the variables to innocuous values.
112 *
113  DO 20 j = 1, nmax
114  DO 10 i = 1, nmax
115  a( i, j ) = 1.d0 / dble( i+j )
116  af( i, j ) = 1.d0 / dble( i+j )
117  10 continue
118  b( j ) = 0.d0
119  r1( j ) = 0.d0
120  r2( j ) = 0.d0
121  w( j ) = 0.d0
122  x( j ) = 0.d0
123  ip( j ) = j
124  iw( j ) = j
125  20 continue
126  ok = .true.
127 *
128  IF( lsamen( 2, c2, 'GE' ) ) THEN
129 *
130 * Test error exits of the routines that use the LU decomposition
131 * of a general matrix.
132 *
133 * DGETRF
134 *
135  srnamt = 'DGETRF'
136  infot = 1
137  CALL dgetrf( -1, 0, a, 1, ip, info )
138  CALL chkxer( 'DGETRF', infot, nout, lerr, ok )
139  infot = 2
140  CALL dgetrf( 0, -1, a, 1, ip, info )
141  CALL chkxer( 'DGETRF', infot, nout, lerr, ok )
142  infot = 4
143  CALL dgetrf( 2, 1, a, 1, ip, info )
144  CALL chkxer( 'DGETRF', infot, nout, lerr, ok )
145 *
146 * DGETF2
147 *
148  srnamt = 'DGETF2'
149  infot = 1
150  CALL dgetf2( -1, 0, a, 1, ip, info )
151  CALL chkxer( 'DGETF2', infot, nout, lerr, ok )
152  infot = 2
153  CALL dgetf2( 0, -1, a, 1, ip, info )
154  CALL chkxer( 'DGETF2', infot, nout, lerr, ok )
155  infot = 4
156  CALL dgetf2( 2, 1, a, 1, ip, info )
157  CALL chkxer( 'DGETF2', infot, nout, lerr, ok )
158 *
159 * DGETRI
160 *
161  srnamt = 'DGETRI'
162  infot = 1
163  CALL dgetri( -1, a, 1, ip, w, lw, info )
164  CALL chkxer( 'DGETRI', infot, nout, lerr, ok )
165  infot = 3
166  CALL dgetri( 2, a, 1, ip, w, lw, info )
167  CALL chkxer( 'DGETRI', infot, nout, lerr, ok )
168 *
169 * DGETRS
170 *
171  srnamt = 'DGETRS'
172  infot = 1
173  CALL dgetrs( '/', 0, 0, a, 1, ip, b, 1, info )
174  CALL chkxer( 'DGETRS', infot, nout, lerr, ok )
175  infot = 2
176  CALL dgetrs( 'N', -1, 0, a, 1, ip, b, 1, info )
177  CALL chkxer( 'DGETRS', infot, nout, lerr, ok )
178  infot = 3
179  CALL dgetrs( 'N', 0, -1, a, 1, ip, b, 1, info )
180  CALL chkxer( 'DGETRS', infot, nout, lerr, ok )
181  infot = 5
182  CALL dgetrs( 'N', 2, 1, a, 1, ip, b, 2, info )
183  CALL chkxer( 'DGETRS', infot, nout, lerr, ok )
184  infot = 8
185  CALL dgetrs( 'N', 2, 1, a, 2, ip, b, 1, info )
186  CALL chkxer( 'DGETRS', infot, nout, lerr, ok )
187 *
188 * DGERFS
189 *
190  srnamt = 'DGERFS'
191  infot = 1
192  CALL dgerfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
193  $ iw, info )
194  CALL chkxer( 'DGERFS', infot, nout, lerr, ok )
195  infot = 2
196  CALL dgerfs( 'N', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
197  $ w, iw, info )
198  CALL chkxer( 'DGERFS', infot, nout, lerr, ok )
199  infot = 3
200  CALL dgerfs( 'N', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
201  $ w, iw, info )
202  CALL chkxer( 'DGERFS', infot, nout, lerr, ok )
203  infot = 5
204  CALL dgerfs( 'N', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
205  $ iw, info )
206  CALL chkxer( 'DGERFS', infot, nout, lerr, ok )
207  infot = 7
208  CALL dgerfs( 'N', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
209  $ iw, info )
210  CALL chkxer( 'DGERFS', infot, nout, lerr, ok )
211  infot = 10
212  CALL dgerfs( 'N', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
213  $ iw, info )
214  CALL chkxer( 'DGERFS', infot, nout, lerr, ok )
215  infot = 12
216  CALL dgerfs( 'N', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
217  $ iw, info )
218  CALL chkxer( 'DGERFS', infot, nout, lerr, ok )
219 *
220 * DGECON
221 *
222  srnamt = 'DGECON'
223  infot = 1
224  CALL dgecon( '/', 0, a, 1, anrm, rcond, w, iw, info )
225  CALL chkxer( 'DGECON', infot, nout, lerr, ok )
226  infot = 2
227  CALL dgecon( '1', -1, a, 1, anrm, rcond, w, iw, info )
228  CALL chkxer( 'DGECON', infot, nout, lerr, ok )
229  infot = 4
230  CALL dgecon( '1', 2, a, 1, anrm, rcond, w, iw, info )
231  CALL chkxer( 'DGECON', infot, nout, lerr, ok )
232 *
233 * DGEEQU
234 *
235  srnamt = 'DGEEQU'
236  infot = 1
237  CALL dgeequ( -1, 0, a, 1, r1, r2, rcond, ccond, anrm, info )
238  CALL chkxer( 'DGEEQU', infot, nout, lerr, ok )
239  infot = 2
240  CALL dgeequ( 0, -1, a, 1, r1, r2, rcond, ccond, anrm, info )
241  CALL chkxer( 'DGEEQU', infot, nout, lerr, ok )
242  infot = 4
243  CALL dgeequ( 2, 2, a, 1, r1, r2, rcond, ccond, anrm, info )
244  CALL chkxer( 'DGEEQU', infot, nout, lerr, ok )
245 *
246  ELSE IF( lsamen( 2, c2, 'GB' ) ) THEN
247 *
248 * Test error exits of the routines that use the LU decomposition
249 * of a general band matrix.
250 *
251 * DGBTRF
252 *
253  srnamt = 'DGBTRF'
254  infot = 1
255  CALL dgbtrf( -1, 0, 0, 0, a, 1, ip, info )
256  CALL chkxer( 'DGBTRF', infot, nout, lerr, ok )
257  infot = 2
258  CALL dgbtrf( 0, -1, 0, 0, a, 1, ip, info )
259  CALL chkxer( 'DGBTRF', infot, nout, lerr, ok )
260  infot = 3
261  CALL dgbtrf( 1, 1, -1, 0, a, 1, ip, info )
262  CALL chkxer( 'DGBTRF', infot, nout, lerr, ok )
263  infot = 4
264  CALL dgbtrf( 1, 1, 0, -1, a, 1, ip, info )
265  CALL chkxer( 'DGBTRF', infot, nout, lerr, ok )
266  infot = 6
267  CALL dgbtrf( 2, 2, 1, 1, a, 3, ip, info )
268  CALL chkxer( 'DGBTRF', infot, nout, lerr, ok )
269 *
270 * DGBTF2
271 *
272  srnamt = 'DGBTF2'
273  infot = 1
274  CALL dgbtf2( -1, 0, 0, 0, a, 1, ip, info )
275  CALL chkxer( 'DGBTF2', infot, nout, lerr, ok )
276  infot = 2
277  CALL dgbtf2( 0, -1, 0, 0, a, 1, ip, info )
278  CALL chkxer( 'DGBTF2', infot, nout, lerr, ok )
279  infot = 3
280  CALL dgbtf2( 1, 1, -1, 0, a, 1, ip, info )
281  CALL chkxer( 'DGBTF2', infot, nout, lerr, ok )
282  infot = 4
283  CALL dgbtf2( 1, 1, 0, -1, a, 1, ip, info )
284  CALL chkxer( 'DGBTF2', infot, nout, lerr, ok )
285  infot = 6
286  CALL dgbtf2( 2, 2, 1, 1, a, 3, ip, info )
287  CALL chkxer( 'DGBTF2', infot, nout, lerr, ok )
288 *
289 * DGBTRS
290 *
291  srnamt = 'DGBTRS'
292  infot = 1
293  CALL dgbtrs( '/', 0, 0, 0, 1, a, 1, ip, b, 1, info )
294  CALL chkxer( 'DGBTRS', infot, nout, lerr, ok )
295  infot = 2
296  CALL dgbtrs( 'N', -1, 0, 0, 1, a, 1, ip, b, 1, info )
297  CALL chkxer( 'DGBTRS', infot, nout, lerr, ok )
298  infot = 3
299  CALL dgbtrs( 'N', 1, -1, 0, 1, a, 1, ip, b, 1, info )
300  CALL chkxer( 'DGBTRS', infot, nout, lerr, ok )
301  infot = 4
302  CALL dgbtrs( 'N', 1, 0, -1, 1, a, 1, ip, b, 1, info )
303  CALL chkxer( 'DGBTRS', infot, nout, lerr, ok )
304  infot = 5
305  CALL dgbtrs( 'N', 1, 0, 0, -1, a, 1, ip, b, 1, info )
306  CALL chkxer( 'DGBTRS', infot, nout, lerr, ok )
307  infot = 7
308  CALL dgbtrs( 'N', 2, 1, 1, 1, a, 3, ip, b, 2, info )
309  CALL chkxer( 'DGBTRS', infot, nout, lerr, ok )
310  infot = 10
311  CALL dgbtrs( 'N', 2, 0, 0, 1, a, 1, ip, b, 1, info )
312  CALL chkxer( 'DGBTRS', infot, nout, lerr, ok )
313 *
314 * DGBRFS
315 *
316  srnamt = 'DGBRFS'
317  infot = 1
318  CALL dgbrfs( '/', 0, 0, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
319  $ r2, w, iw, info )
320  CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
321  infot = 2
322  CALL dgbrfs( 'N', -1, 0, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
323  $ r2, w, iw, info )
324  CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
325  infot = 3
326  CALL dgbrfs( 'N', 1, -1, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
327  $ r2, w, iw, info )
328  CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
329  infot = 4
330  CALL dgbrfs( 'N', 1, 0, -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
331  $ r2, w, iw, info )
332  CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
333  infot = 5
334  CALL dgbrfs( 'N', 1, 0, 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1,
335  $ r2, w, iw, info )
336  CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
337  infot = 7
338  CALL dgbrfs( 'N', 2, 1, 1, 1, a, 2, af, 4, ip, b, 2, x, 2, r1,
339  $ r2, w, iw, info )
340  CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
341  infot = 9
342  CALL dgbrfs( 'N', 2, 1, 1, 1, a, 3, af, 3, ip, b, 2, x, 2, r1,
343  $ r2, w, iw, info )
344  CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
345  infot = 12
346  CALL dgbrfs( 'N', 2, 0, 0, 1, a, 1, af, 1, ip, b, 1, x, 2, r1,
347  $ r2, w, iw, info )
348  CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
349  infot = 14
350  CALL dgbrfs( 'N', 2, 0, 0, 1, a, 1, af, 1, ip, b, 2, x, 1, r1,
351  $ r2, w, iw, info )
352  CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
353 *
354 * DGBCON
355 *
356  srnamt = 'DGBCON'
357  infot = 1
358  CALL dgbcon( '/', 0, 0, 0, a, 1, ip, anrm, rcond, w, iw, info )
359  CALL chkxer( 'DGBCON', infot, nout, lerr, ok )
360  infot = 2
361  CALL dgbcon( '1', -1, 0, 0, a, 1, ip, anrm, rcond, w, iw,
362  $ info )
363  CALL chkxer( 'DGBCON', infot, nout, lerr, ok )
364  infot = 3
365  CALL dgbcon( '1', 1, -1, 0, a, 1, ip, anrm, rcond, w, iw,
366  $ info )
367  CALL chkxer( 'DGBCON', infot, nout, lerr, ok )
368  infot = 4
369  CALL dgbcon( '1', 1, 0, -1, a, 1, ip, anrm, rcond, w, iw,
370  $ info )
371  CALL chkxer( 'DGBCON', infot, nout, lerr, ok )
372  infot = 6
373  CALL dgbcon( '1', 2, 1, 1, a, 3, ip, anrm, rcond, w, iw, info )
374  CALL chkxer( 'DGBCON', infot, nout, lerr, ok )
375 *
376 * DGBEQU
377 *
378  srnamt = 'DGBEQU'
379  infot = 1
380  CALL dgbequ( -1, 0, 0, 0, a, 1, r1, r2, rcond, ccond, anrm,
381  $ info )
382  CALL chkxer( 'DGBEQU', infot, nout, lerr, ok )
383  infot = 2
384  CALL dgbequ( 0, -1, 0, 0, a, 1, r1, r2, rcond, ccond, anrm,
385  $ info )
386  CALL chkxer( 'DGBEQU', infot, nout, lerr, ok )
387  infot = 3
388  CALL dgbequ( 1, 1, -1, 0, a, 1, r1, r2, rcond, ccond, anrm,
389  $ info )
390  CALL chkxer( 'DGBEQU', infot, nout, lerr, ok )
391  infot = 4
392  CALL dgbequ( 1, 1, 0, -1, a, 1, r1, r2, rcond, ccond, anrm,
393  $ info )
394  CALL chkxer( 'DGBEQU', infot, nout, lerr, ok )
395  infot = 6
396  CALL dgbequ( 2, 2, 1, 1, a, 2, r1, r2, rcond, ccond, anrm,
397  $ info )
398  CALL chkxer( 'DGBEQU', infot, nout, lerr, ok )
399  END IF
400 *
401 * Print a summary line.
402 *
403  CALL alaesm( path, ok, nout )
404 *
405  return
406 *
407 * End of DERRGE
408 *
409  END