LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
derrtr.f
Go to the documentation of this file.
1 *> \brief \b DERRTR
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 DERRTR( 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 *> DERRTR tests the error exits for the DOUBLE PRECISION triangular
25 *> routines.
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 derrtr( 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
72  parameter( nmax = 2 )
73 * ..
74 * .. Local Scalars ..
75  CHARACTER*2 c2
76  INTEGER info
77  DOUBLE PRECISION rcond, scale
78 * ..
79 * .. Local Arrays ..
80  INTEGER iw( nmax )
81  DOUBLE PRECISION a( nmax, nmax ), b( nmax ), r1( nmax ),
82  $ r2( nmax ), w( nmax ), x( nmax )
83 * ..
84 * .. External Functions ..
85  LOGICAL lsamen
86  EXTERNAL lsamen
87 * ..
88 * .. External Subroutines ..
89  EXTERNAL alaesm, chkxer, dlatbs, dlatps, dlatrs, dtbcon,
90  $ dtbrfs, dtbtrs, dtpcon, dtprfs, dtptri, dtptrs,
91  $ dtrcon, dtrrfs, dtrti2, dtrtri, dtrtrs
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 * .. Executable Statements ..
103 *
104  nout = nunit
105  WRITE( nout, fmt = * )
106  c2 = path( 2: 3 )
107  a( 1, 1 ) = 1.d0
108  a( 1, 2 ) = 2.d0
109  a( 2, 2 ) = 3.d0
110  a( 2, 1 ) = 4.d0
111  ok = .true.
112 *
113  IF( lsamen( 2, c2, 'TR' ) ) THEN
114 *
115 * Test error exits for the general triangular routines.
116 *
117 * DTRTRI
118 *
119  srnamt = 'DTRTRI'
120  infot = 1
121  CALL dtrtri( '/', 'N', 0, a, 1, info )
122  CALL chkxer( 'DTRTRI', infot, nout, lerr, ok )
123  infot = 2
124  CALL dtrtri( 'U', '/', 0, a, 1, info )
125  CALL chkxer( 'DTRTRI', infot, nout, lerr, ok )
126  infot = 3
127  CALL dtrtri( 'U', 'N', -1, a, 1, info )
128  CALL chkxer( 'DTRTRI', infot, nout, lerr, ok )
129  infot = 5
130  CALL dtrtri( 'U', 'N', 2, a, 1, info )
131  CALL chkxer( 'DTRTRI', infot, nout, lerr, ok )
132 *
133 * DTRTI2
134 *
135  srnamt = 'DTRTI2'
136  infot = 1
137  CALL dtrti2( '/', 'N', 0, a, 1, info )
138  CALL chkxer( 'DTRTI2', infot, nout, lerr, ok )
139  infot = 2
140  CALL dtrti2( 'U', '/', 0, a, 1, info )
141  CALL chkxer( 'DTRTI2', infot, nout, lerr, ok )
142  infot = 3
143  CALL dtrti2( 'U', 'N', -1, a, 1, info )
144  CALL chkxer( 'DTRTI2', infot, nout, lerr, ok )
145  infot = 5
146  CALL dtrti2( 'U', 'N', 2, a, 1, info )
147  CALL chkxer( 'DTRTI2', infot, nout, lerr, ok )
148 *
149 * DTRTRS
150 *
151  srnamt = 'DTRTRS'
152  infot = 1
153  CALL dtrtrs( '/', 'N', 'N', 0, 0, a, 1, x, 1, info )
154  CALL chkxer( 'DTRTRS', infot, nout, lerr, ok )
155  infot = 2
156  CALL dtrtrs( 'U', '/', 'N', 0, 0, a, 1, x, 1, info )
157  CALL chkxer( 'DTRTRS', infot, nout, lerr, ok )
158  infot = 3
159  CALL dtrtrs( 'U', 'N', '/', 0, 0, a, 1, x, 1, info )
160  CALL chkxer( 'DTRTRS', infot, nout, lerr, ok )
161  infot = 4
162  CALL dtrtrs( 'U', 'N', 'N', -1, 0, a, 1, x, 1, info )
163  CALL chkxer( 'DTRTRS', infot, nout, lerr, ok )
164  infot = 5
165  CALL dtrtrs( 'U', 'N', 'N', 0, -1, a, 1, x, 1, info )
166  CALL chkxer( 'DTRTRS', infot, nout, lerr, ok )
167  infot = 7
168  CALL dtrtrs( 'U', 'N', 'N', 2, 1, a, 1, x, 2, info )
169  CALL chkxer( 'DTRTRS', infot, nout, lerr, ok )
170  infot = 9
171  CALL dtrtrs( 'U', 'N', 'N', 2, 1, a, 2, x, 1, info )
172  CALL chkxer( 'DTRTRS', infot, nout, lerr, ok )
173 *
174 * DTRRFS
175 *
176  srnamt = 'DTRRFS'
177  infot = 1
178  CALL dtrrfs( '/', 'N', 'N', 0, 0, a, 1, b, 1, x, 1, r1, r2, w,
179  $ iw, info )
180  CALL chkxer( 'DTRRFS', infot, nout, lerr, ok )
181  infot = 2
182  CALL dtrrfs( 'U', '/', 'N', 0, 0, a, 1, b, 1, x, 1, r1, r2, w,
183  $ iw, info )
184  CALL chkxer( 'DTRRFS', infot, nout, lerr, ok )
185  infot = 3
186  CALL dtrrfs( 'U', 'N', '/', 0, 0, a, 1, b, 1, x, 1, r1, r2, w,
187  $ iw, info )
188  CALL chkxer( 'DTRRFS', infot, nout, lerr, ok )
189  infot = 4
190  CALL dtrrfs( 'U', 'N', 'N', -1, 0, a, 1, b, 1, x, 1, r1, r2, w,
191  $ iw, info )
192  CALL chkxer( 'DTRRFS', infot, nout, lerr, ok )
193  infot = 5
194  CALL dtrrfs( 'U', 'N', 'N', 0, -1, a, 1, b, 1, x, 1, r1, r2, w,
195  $ iw, info )
196  CALL chkxer( 'DTRRFS', infot, nout, lerr, ok )
197  infot = 7
198  CALL dtrrfs( 'U', 'N', 'N', 2, 1, a, 1, b, 2, x, 2, r1, r2, w,
199  $ iw, info )
200  CALL chkxer( 'DTRRFS', infot, nout, lerr, ok )
201  infot = 9
202  CALL dtrrfs( 'U', 'N', 'N', 2, 1, a, 2, b, 1, x, 2, r1, r2, w,
203  $ iw, info )
204  CALL chkxer( 'DTRRFS', infot, nout, lerr, ok )
205  infot = 11
206  CALL dtrrfs( 'U', 'N', 'N', 2, 1, a, 2, b, 2, x, 1, r1, r2, w,
207  $ iw, info )
208  CALL chkxer( 'DTRRFS', infot, nout, lerr, ok )
209 *
210 * DTRCON
211 *
212  srnamt = 'DTRCON'
213  infot = 1
214  CALL dtrcon( '/', 'U', 'N', 0, a, 1, rcond, w, iw, info )
215  CALL chkxer( 'DTRCON', infot, nout, lerr, ok )
216  infot = 2
217  CALL dtrcon( '1', '/', 'N', 0, a, 1, rcond, w, iw, info )
218  CALL chkxer( 'DTRCON', infot, nout, lerr, ok )
219  infot = 3
220  CALL dtrcon( '1', 'U', '/', 0, a, 1, rcond, w, iw, info )
221  CALL chkxer( 'DTRCON', infot, nout, lerr, ok )
222  infot = 4
223  CALL dtrcon( '1', 'U', 'N', -1, a, 1, rcond, w, iw, info )
224  CALL chkxer( 'DTRCON', infot, nout, lerr, ok )
225  infot = 6
226  CALL dtrcon( '1', 'U', 'N', 2, a, 1, rcond, w, iw, info )
227  CALL chkxer( 'DTRCON', infot, nout, lerr, ok )
228 *
229 * DLATRS
230 *
231  srnamt = 'DLATRS'
232  infot = 1
233  CALL dlatrs( '/', 'N', 'N', 'N', 0, a, 1, x, scale, w, info )
234  CALL chkxer( 'DLATRS', infot, nout, lerr, ok )
235  infot = 2
236  CALL dlatrs( 'U', '/', 'N', 'N', 0, a, 1, x, scale, w, info )
237  CALL chkxer( 'DLATRS', infot, nout, lerr, ok )
238  infot = 3
239  CALL dlatrs( 'U', 'N', '/', 'N', 0, a, 1, x, scale, w, info )
240  CALL chkxer( 'DLATRS', infot, nout, lerr, ok )
241  infot = 4
242  CALL dlatrs( 'U', 'N', 'N', '/', 0, a, 1, x, scale, w, info )
243  CALL chkxer( 'DLATRS', infot, nout, lerr, ok )
244  infot = 5
245  CALL dlatrs( 'U', 'N', 'N', 'N', -1, a, 1, x, scale, w, info )
246  CALL chkxer( 'DLATRS', infot, nout, lerr, ok )
247  infot = 7
248  CALL dlatrs( 'U', 'N', 'N', 'N', 2, a, 1, x, scale, w, info )
249  CALL chkxer( 'DLATRS', infot, nout, lerr, ok )
250 *
251  ELSE IF( lsamen( 2, c2, 'TP' ) ) THEN
252 *
253 * Test error exits for the packed triangular routines.
254 *
255 * DTPTRI
256 *
257  srnamt = 'DTPTRI'
258  infot = 1
259  CALL dtptri( '/', 'N', 0, a, info )
260  CALL chkxer( 'DTPTRI', infot, nout, lerr, ok )
261  infot = 2
262  CALL dtptri( 'U', '/', 0, a, info )
263  CALL chkxer( 'DTPTRI', infot, nout, lerr, ok )
264  infot = 3
265  CALL dtptri( 'U', 'N', -1, a, info )
266  CALL chkxer( 'DTPTRI', infot, nout, lerr, ok )
267 *
268 * DTPTRS
269 *
270  srnamt = 'DTPTRS'
271  infot = 1
272  CALL dtptrs( '/', 'N', 'N', 0, 0, a, x, 1, info )
273  CALL chkxer( 'DTPTRS', infot, nout, lerr, ok )
274  infot = 2
275  CALL dtptrs( 'U', '/', 'N', 0, 0, a, x, 1, info )
276  CALL chkxer( 'DTPTRS', infot, nout, lerr, ok )
277  infot = 3
278  CALL dtptrs( 'U', 'N', '/', 0, 0, a, x, 1, info )
279  CALL chkxer( 'DTPTRS', infot, nout, lerr, ok )
280  infot = 4
281  CALL dtptrs( 'U', 'N', 'N', -1, 0, a, x, 1, info )
282  CALL chkxer( 'DTPTRS', infot, nout, lerr, ok )
283  infot = 5
284  CALL dtptrs( 'U', 'N', 'N', 0, -1, a, x, 1, info )
285  CALL chkxer( 'DTPTRS', infot, nout, lerr, ok )
286  infot = 8
287  CALL dtptrs( 'U', 'N', 'N', 2, 1, a, x, 1, info )
288  CALL chkxer( 'DTPTRS', infot, nout, lerr, ok )
289 *
290 * DTPRFS
291 *
292  srnamt = 'DTPRFS'
293  infot = 1
294  CALL dtprfs( '/', 'N', 'N', 0, 0, a, b, 1, x, 1, r1, r2, w, iw,
295  $ info )
296  CALL chkxer( 'DTPRFS', infot, nout, lerr, ok )
297  infot = 2
298  CALL dtprfs( 'U', '/', 'N', 0, 0, a, b, 1, x, 1, r1, r2, w, iw,
299  $ info )
300  CALL chkxer( 'DTPRFS', infot, nout, lerr, ok )
301  infot = 3
302  CALL dtprfs( 'U', 'N', '/', 0, 0, a, b, 1, x, 1, r1, r2, w, iw,
303  $ info )
304  CALL chkxer( 'DTPRFS', infot, nout, lerr, ok )
305  infot = 4
306  CALL dtprfs( 'U', 'N', 'N', -1, 0, a, b, 1, x, 1, r1, r2, w,
307  $ iw, info )
308  CALL chkxer( 'DTPRFS', infot, nout, lerr, ok )
309  infot = 5
310  CALL dtprfs( 'U', 'N', 'N', 0, -1, a, b, 1, x, 1, r1, r2, w,
311  $ iw, info )
312  CALL chkxer( 'DTPRFS', infot, nout, lerr, ok )
313  infot = 8
314  CALL dtprfs( 'U', 'N', 'N', 2, 1, a, b, 1, x, 2, r1, r2, w, iw,
315  $ info )
316  CALL chkxer( 'DTPRFS', infot, nout, lerr, ok )
317  infot = 10
318  CALL dtprfs( 'U', 'N', 'N', 2, 1, a, b, 2, x, 1, r1, r2, w, iw,
319  $ info )
320  CALL chkxer( 'DTPRFS', infot, nout, lerr, ok )
321 *
322 * DTPCON
323 *
324  srnamt = 'DTPCON'
325  infot = 1
326  CALL dtpcon( '/', 'U', 'N', 0, a, rcond, w, iw, info )
327  CALL chkxer( 'DTPCON', infot, nout, lerr, ok )
328  infot = 2
329  CALL dtpcon( '1', '/', 'N', 0, a, rcond, w, iw, info )
330  CALL chkxer( 'DTPCON', infot, nout, lerr, ok )
331  infot = 3
332  CALL dtpcon( '1', 'U', '/', 0, a, rcond, w, iw, info )
333  CALL chkxer( 'DTPCON', infot, nout, lerr, ok )
334  infot = 4
335  CALL dtpcon( '1', 'U', 'N', -1, a, rcond, w, iw, info )
336  CALL chkxer( 'DTPCON', infot, nout, lerr, ok )
337 *
338 * DLATPS
339 *
340  srnamt = 'DLATPS'
341  infot = 1
342  CALL dlatps( '/', 'N', 'N', 'N', 0, a, x, scale, w, info )
343  CALL chkxer( 'DLATPS', infot, nout, lerr, ok )
344  infot = 2
345  CALL dlatps( 'U', '/', 'N', 'N', 0, a, x, scale, w, info )
346  CALL chkxer( 'DLATPS', infot, nout, lerr, ok )
347  infot = 3
348  CALL dlatps( 'U', 'N', '/', 'N', 0, a, x, scale, w, info )
349  CALL chkxer( 'DLATPS', infot, nout, lerr, ok )
350  infot = 4
351  CALL dlatps( 'U', 'N', 'N', '/', 0, a, x, scale, w, info )
352  CALL chkxer( 'DLATPS', infot, nout, lerr, ok )
353  infot = 5
354  CALL dlatps( 'U', 'N', 'N', 'N', -1, a, x, scale, w, info )
355  CALL chkxer( 'DLATPS', infot, nout, lerr, ok )
356 *
357  ELSE IF( lsamen( 2, c2, 'TB' ) ) THEN
358 *
359 * Test error exits for the banded triangular routines.
360 *
361 * DTBTRS
362 *
363  srnamt = 'DTBTRS'
364  infot = 1
365  CALL dtbtrs( '/', 'N', 'N', 0, 0, 0, a, 1, x, 1, info )
366  CALL chkxer( 'DTBTRS', infot, nout, lerr, ok )
367  infot = 2
368  CALL dtbtrs( 'U', '/', 'N', 0, 0, 0, a, 1, x, 1, info )
369  CALL chkxer( 'DTBTRS', infot, nout, lerr, ok )
370  infot = 3
371  CALL dtbtrs( 'U', 'N', '/', 0, 0, 0, a, 1, x, 1, info )
372  CALL chkxer( 'DTBTRS', infot, nout, lerr, ok )
373  infot = 4
374  CALL dtbtrs( 'U', 'N', 'N', -1, 0, 0, a, 1, x, 1, info )
375  CALL chkxer( 'DTBTRS', infot, nout, lerr, ok )
376  infot = 5
377  CALL dtbtrs( 'U', 'N', 'N', 0, -1, 0, a, 1, x, 1, info )
378  CALL chkxer( 'DTBTRS', infot, nout, lerr, ok )
379  infot = 6
380  CALL dtbtrs( 'U', 'N', 'N', 0, 0, -1, a, 1, x, 1, info )
381  CALL chkxer( 'DTBTRS', infot, nout, lerr, ok )
382  infot = 8
383  CALL dtbtrs( 'U', 'N', 'N', 2, 1, 1, a, 1, x, 2, info )
384  CALL chkxer( 'DTBTRS', infot, nout, lerr, ok )
385  infot = 10
386  CALL dtbtrs( 'U', 'N', 'N', 2, 0, 1, a, 1, x, 1, info )
387  CALL chkxer( 'DTBTRS', infot, nout, lerr, ok )
388 *
389 * DTBRFS
390 *
391  srnamt = 'DTBRFS'
392  infot = 1
393  CALL dtbrfs( '/', 'N', 'N', 0, 0, 0, a, 1, b, 1, x, 1, r1, r2,
394  $ w, iw, info )
395  CALL chkxer( 'DTBRFS', infot, nout, lerr, ok )
396  infot = 2
397  CALL dtbrfs( 'U', '/', 'N', 0, 0, 0, a, 1, b, 1, x, 1, r1, r2,
398  $ w, iw, info )
399  CALL chkxer( 'DTBRFS', infot, nout, lerr, ok )
400  infot = 3
401  CALL dtbrfs( 'U', 'N', '/', 0, 0, 0, a, 1, b, 1, x, 1, r1, r2,
402  $ w, iw, info )
403  CALL chkxer( 'DTBRFS', infot, nout, lerr, ok )
404  infot = 4
405  CALL dtbrfs( 'U', 'N', 'N', -1, 0, 0, a, 1, b, 1, x, 1, r1, r2,
406  $ w, iw, info )
407  CALL chkxer( 'DTBRFS', infot, nout, lerr, ok )
408  infot = 5
409  CALL dtbrfs( 'U', 'N', 'N', 0, -1, 0, a, 1, b, 1, x, 1, r1, r2,
410  $ w, iw, info )
411  CALL chkxer( 'DTBRFS', infot, nout, lerr, ok )
412  infot = 6
413  CALL dtbrfs( 'U', 'N', 'N', 0, 0, -1, a, 1, b, 1, x, 1, r1, r2,
414  $ w, iw, info )
415  CALL chkxer( 'DTBRFS', infot, nout, lerr, ok )
416  infot = 8
417  CALL dtbrfs( 'U', 'N', 'N', 2, 1, 1, a, 1, b, 2, x, 2, r1, r2,
418  $ w, iw, info )
419  CALL chkxer( 'DTBRFS', infot, nout, lerr, ok )
420  infot = 10
421  CALL dtbrfs( 'U', 'N', 'N', 2, 1, 1, a, 2, b, 1, x, 2, r1, r2,
422  $ w, iw, info )
423  CALL chkxer( 'DTBRFS', infot, nout, lerr, ok )
424  infot = 12
425  CALL dtbrfs( 'U', 'N', 'N', 2, 1, 1, a, 2, b, 2, x, 1, r1, r2,
426  $ w, iw, info )
427  CALL chkxer( 'DTBRFS', infot, nout, lerr, ok )
428 *
429 * DTBCON
430 *
431  srnamt = 'DTBCON'
432  infot = 1
433  CALL dtbcon( '/', 'U', 'N', 0, 0, a, 1, rcond, w, iw, info )
434  CALL chkxer( 'DTBCON', infot, nout, lerr, ok )
435  infot = 2
436  CALL dtbcon( '1', '/', 'N', 0, 0, a, 1, rcond, w, iw, info )
437  CALL chkxer( 'DTBCON', infot, nout, lerr, ok )
438  infot = 3
439  CALL dtbcon( '1', 'U', '/', 0, 0, a, 1, rcond, w, iw, info )
440  CALL chkxer( 'DTBCON', infot, nout, lerr, ok )
441  infot = 4
442  CALL dtbcon( '1', 'U', 'N', -1, 0, a, 1, rcond, w, iw, info )
443  CALL chkxer( 'DTBCON', infot, nout, lerr, ok )
444  infot = 5
445  CALL dtbcon( '1', 'U', 'N', 0, -1, a, 1, rcond, w, iw, info )
446  CALL chkxer( 'DTBCON', infot, nout, lerr, ok )
447  infot = 7
448  CALL dtbcon( '1', 'U', 'N', 2, 1, a, 1, rcond, w, iw, info )
449  CALL chkxer( 'DTBCON', infot, nout, lerr, ok )
450 *
451 * DLATBS
452 *
453  srnamt = 'DLATBS'
454  infot = 1
455  CALL dlatbs( '/', 'N', 'N', 'N', 0, 0, a, 1, x, scale, w,
456  $ info )
457  CALL chkxer( 'DLATBS', infot, nout, lerr, ok )
458  infot = 2
459  CALL dlatbs( 'U', '/', 'N', 'N', 0, 0, a, 1, x, scale, w,
460  $ info )
461  CALL chkxer( 'DLATBS', infot, nout, lerr, ok )
462  infot = 3
463  CALL dlatbs( 'U', 'N', '/', 'N', 0, 0, a, 1, x, scale, w,
464  $ info )
465  CALL chkxer( 'DLATBS', infot, nout, lerr, ok )
466  infot = 4
467  CALL dlatbs( 'U', 'N', 'N', '/', 0, 0, a, 1, x, scale, w,
468  $ info )
469  CALL chkxer( 'DLATBS', infot, nout, lerr, ok )
470  infot = 5
471  CALL dlatbs( 'U', 'N', 'N', 'N', -1, 0, a, 1, x, scale, w,
472  $ info )
473  CALL chkxer( 'DLATBS', infot, nout, lerr, ok )
474  infot = 6
475  CALL dlatbs( 'U', 'N', 'N', 'N', 1, -1, a, 1, x, scale, w,
476  $ info )
477  CALL chkxer( 'DLATBS', infot, nout, lerr, ok )
478  infot = 8
479  CALL dlatbs( 'U', 'N', 'N', 'N', 2, 1, a, 1, x, scale, w,
480  $ info )
481  CALL chkxer( 'DLATBS', infot, nout, lerr, ok )
482  END IF
483 *
484 * Print a summary line.
485 *
486  CALL alaesm( path, ok, nout )
487 *
488  return
489 *
490 * End of DERRTR
491 *
492  END