LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
derrhs.f
Go to the documentation of this file.
1 *> \brief \b DERRHS
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 DERRHS( 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 *> DERRHS tests the error exits for DGEBAK, SGEBAL, SGEHRD, DORGHR,
25 *> DORMHR, DHSEQR, SHSEIN, and DTREVC.
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_eig
54 *
55 * =====================================================================
56  SUBROUTINE derrhs( 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 = 3, lw = ( nmax+2 )*( nmax+2 )+nmax )
73 * ..
74 * .. Local Scalars ..
75  CHARACTER*2 c2
76  INTEGER i, ihi, ilo, info, j, m, nt
77 * ..
78 * .. Local Arrays ..
79  LOGICAL sel( nmax )
80  INTEGER ifaill( nmax ), ifailr( nmax )
81  DOUBLE PRECISION a( nmax, nmax ), c( nmax, nmax ), s( nmax ),
82  $ tau( nmax ), vl( nmax, nmax ),
83  $ vr( nmax, nmax ), w( lw ), wi( nmax ),
84  $ wr( nmax )
85 * ..
86 * .. External Functions ..
87  LOGICAL lsamen
88  EXTERNAL lsamen
89 * ..
90 * .. External Subroutines ..
91  EXTERNAL chkxer, dgebak, dgebal, dgehrd, dhsein, dhseqr,
92  $ dorghr, dormhr, dtrevc
93 * ..
94 * .. Intrinsic Functions ..
95  INTRINSIC dble
96 * ..
97 * .. Scalars in Common ..
98  LOGICAL lerr, ok
99  CHARACTER*32 srnamt
100  INTEGER infot, nout
101 * ..
102 * .. Common blocks ..
103  common / infoc / infot, nout, ok, lerr
104  common / srnamc / srnamt
105 * ..
106 * .. Executable Statements ..
107 *
108  nout = nunit
109  WRITE( nout, fmt = * )
110  c2 = path( 2: 3 )
111 *
112 * Set the variables to innocuous values.
113 *
114  DO 20 j = 1, nmax
115  DO 10 i = 1, nmax
116  a( i, j ) = 1.d0 / dble( i+j )
117  10 continue
118  wi( j ) = dble( j )
119  sel( j ) = .true.
120  20 continue
121  ok = .true.
122  nt = 0
123 *
124 * Test error exits of the nonsymmetric eigenvalue routines.
125 *
126  IF( lsamen( 2, c2, 'HS' ) ) THEN
127 *
128 * DGEBAL
129 *
130  srnamt = 'DGEBAL'
131  infot = 1
132  CALL dgebal( '/', 0, a, 1, ilo, ihi, s, info )
133  CALL chkxer( 'DGEBAL', infot, nout, lerr, ok )
134  infot = 2
135  CALL dgebal( 'N', -1, a, 1, ilo, ihi, s, info )
136  CALL chkxer( 'DGEBAL', infot, nout, lerr, ok )
137  infot = 4
138  CALL dgebal( 'N', 2, a, 1, ilo, ihi, s, info )
139  CALL chkxer( 'DGEBAL', infot, nout, lerr, ok )
140  nt = nt + 3
141 *
142 * DGEBAK
143 *
144  srnamt = 'DGEBAK'
145  infot = 1
146  CALL dgebak( '/', 'R', 0, 1, 0, s, 0, a, 1, info )
147  CALL chkxer( 'DGEBAK', infot, nout, lerr, ok )
148  infot = 2
149  CALL dgebak( 'N', '/', 0, 1, 0, s, 0, a, 1, info )
150  CALL chkxer( 'DGEBAK', infot, nout, lerr, ok )
151  infot = 3
152  CALL dgebak( 'N', 'R', -1, 1, 0, s, 0, a, 1, info )
153  CALL chkxer( 'DGEBAK', infot, nout, lerr, ok )
154  infot = 4
155  CALL dgebak( 'N', 'R', 0, 0, 0, s, 0, a, 1, info )
156  CALL chkxer( 'DGEBAK', infot, nout, lerr, ok )
157  infot = 4
158  CALL dgebak( 'N', 'R', 0, 2, 0, s, 0, a, 1, info )
159  CALL chkxer( 'DGEBAK', infot, nout, lerr, ok )
160  infot = 5
161  CALL dgebak( 'N', 'R', 2, 2, 1, s, 0, a, 2, info )
162  CALL chkxer( 'DGEBAK', infot, nout, lerr, ok )
163  infot = 5
164  CALL dgebak( 'N', 'R', 0, 1, 1, s, 0, a, 1, info )
165  CALL chkxer( 'DGEBAK', infot, nout, lerr, ok )
166  infot = 7
167  CALL dgebak( 'N', 'R', 0, 1, 0, s, -1, a, 1, info )
168  CALL chkxer( 'DGEBAK', infot, nout, lerr, ok )
169  infot = 9
170  CALL dgebak( 'N', 'R', 2, 1, 2, s, 0, a, 1, info )
171  CALL chkxer( 'DGEBAK', infot, nout, lerr, ok )
172  nt = nt + 9
173 *
174 * DGEHRD
175 *
176  srnamt = 'DGEHRD'
177  infot = 1
178  CALL dgehrd( -1, 1, 1, a, 1, tau, w, 1, info )
179  CALL chkxer( 'DGEHRD', infot, nout, lerr, ok )
180  infot = 2
181  CALL dgehrd( 0, 0, 0, a, 1, tau, w, 1, info )
182  CALL chkxer( 'DGEHRD', infot, nout, lerr, ok )
183  infot = 2
184  CALL dgehrd( 0, 2, 0, a, 1, tau, w, 1, info )
185  CALL chkxer( 'DGEHRD', infot, nout, lerr, ok )
186  infot = 3
187  CALL dgehrd( 1, 1, 0, a, 1, tau, w, 1, info )
188  CALL chkxer( 'DGEHRD', infot, nout, lerr, ok )
189  infot = 3
190  CALL dgehrd( 0, 1, 1, a, 1, tau, w, 1, info )
191  CALL chkxer( 'DGEHRD', infot, nout, lerr, ok )
192  infot = 5
193  CALL dgehrd( 2, 1, 1, a, 1, tau, w, 2, info )
194  CALL chkxer( 'DGEHRD', infot, nout, lerr, ok )
195  infot = 8
196  CALL dgehrd( 2, 1, 2, a, 2, tau, w, 1, info )
197  CALL chkxer( 'DGEHRD', infot, nout, lerr, ok )
198  nt = nt + 7
199 *
200 * DORGHR
201 *
202  srnamt = 'DORGHR'
203  infot = 1
204  CALL dorghr( -1, 1, 1, a, 1, tau, w, 1, info )
205  CALL chkxer( 'DORGHR', infot, nout, lerr, ok )
206  infot = 2
207  CALL dorghr( 0, 0, 0, a, 1, tau, w, 1, info )
208  CALL chkxer( 'DORGHR', infot, nout, lerr, ok )
209  infot = 2
210  CALL dorghr( 0, 2, 0, a, 1, tau, w, 1, info )
211  CALL chkxer( 'DORGHR', infot, nout, lerr, ok )
212  infot = 3
213  CALL dorghr( 1, 1, 0, a, 1, tau, w, 1, info )
214  CALL chkxer( 'DORGHR', infot, nout, lerr, ok )
215  infot = 3
216  CALL dorghr( 0, 1, 1, a, 1, tau, w, 1, info )
217  CALL chkxer( 'DORGHR', infot, nout, lerr, ok )
218  infot = 5
219  CALL dorghr( 2, 1, 1, a, 1, tau, w, 1, info )
220  CALL chkxer( 'DORGHR', infot, nout, lerr, ok )
221  infot = 8
222  CALL dorghr( 3, 1, 3, a, 3, tau, w, 1, info )
223  CALL chkxer( 'DORGHR', infot, nout, lerr, ok )
224  nt = nt + 7
225 *
226 * DORMHR
227 *
228  srnamt = 'DORMHR'
229  infot = 1
230  CALL dormhr( '/', 'N', 0, 0, 1, 0, a, 1, tau, c, 1, w, 1,
231  $ info )
232  CALL chkxer( 'DORMHR', infot, nout, lerr, ok )
233  infot = 2
234  CALL dormhr( 'L', '/', 0, 0, 1, 0, a, 1, tau, c, 1, w, 1,
235  $ info )
236  CALL chkxer( 'DORMHR', infot, nout, lerr, ok )
237  infot = 3
238  CALL dormhr( 'L', 'N', -1, 0, 1, 0, a, 1, tau, c, 1, w, 1,
239  $ info )
240  CALL chkxer( 'DORMHR', infot, nout, lerr, ok )
241  infot = 4
242  CALL dormhr( 'L', 'N', 0, -1, 1, 0, a, 1, tau, c, 1, w, 1,
243  $ info )
244  CALL chkxer( 'DORMHR', infot, nout, lerr, ok )
245  infot = 5
246  CALL dormhr( 'L', 'N', 0, 0, 0, 0, a, 1, tau, c, 1, w, 1,
247  $ info )
248  CALL chkxer( 'DORMHR', infot, nout, lerr, ok )
249  infot = 5
250  CALL dormhr( 'L', 'N', 0, 0, 2, 0, a, 1, tau, c, 1, w, 1,
251  $ info )
252  CALL chkxer( 'DORMHR', infot, nout, lerr, ok )
253  infot = 5
254  CALL dormhr( 'L', 'N', 1, 2, 2, 1, a, 1, tau, c, 1, w, 2,
255  $ info )
256  CALL chkxer( 'DORMHR', infot, nout, lerr, ok )
257  infot = 5
258  CALL dormhr( 'R', 'N', 2, 1, 2, 1, a, 1, tau, c, 2, w, 2,
259  $ info )
260  CALL chkxer( 'DORMHR', infot, nout, lerr, ok )
261  infot = 6
262  CALL dormhr( 'L', 'N', 1, 1, 1, 0, a, 1, tau, c, 1, w, 1,
263  $ info )
264  CALL chkxer( 'DORMHR', infot, nout, lerr, ok )
265  infot = 6
266  CALL dormhr( 'L', 'N', 0, 1, 1, 1, a, 1, tau, c, 1, w, 1,
267  $ info )
268  CALL chkxer( 'DORMHR', infot, nout, lerr, ok )
269  infot = 6
270  CALL dormhr( 'R', 'N', 1, 0, 1, 1, a, 1, tau, c, 1, w, 1,
271  $ info )
272  CALL chkxer( 'DORMHR', infot, nout, lerr, ok )
273  infot = 8
274  CALL dormhr( 'L', 'N', 2, 1, 1, 1, a, 1, tau, c, 2, w, 1,
275  $ info )
276  CALL chkxer( 'DORMHR', infot, nout, lerr, ok )
277  infot = 8
278  CALL dormhr( 'R', 'N', 1, 2, 1, 1, a, 1, tau, c, 1, w, 1,
279  $ info )
280  CALL chkxer( 'DORMHR', infot, nout, lerr, ok )
281  infot = 11
282  CALL dormhr( 'L', 'N', 2, 1, 1, 1, a, 2, tau, c, 1, w, 1,
283  $ info )
284  CALL chkxer( 'DORMHR', infot, nout, lerr, ok )
285  infot = 13
286  CALL dormhr( 'L', 'N', 1, 2, 1, 1, a, 1, tau, c, 1, w, 1,
287  $ info )
288  CALL chkxer( 'DORMHR', infot, nout, lerr, ok )
289  infot = 13
290  CALL dormhr( 'R', 'N', 2, 1, 1, 1, a, 1, tau, c, 2, w, 1,
291  $ info )
292  CALL chkxer( 'DORMHR', infot, nout, lerr, ok )
293  nt = nt + 16
294 *
295 * DHSEQR
296 *
297  srnamt = 'DHSEQR'
298  infot = 1
299  CALL dhseqr( '/', 'N', 0, 1, 0, a, 1, wr, wi, c, 1, w, 1,
300  $ info )
301  CALL chkxer( 'DHSEQR', infot, nout, lerr, ok )
302  infot = 2
303  CALL dhseqr( 'E', '/', 0, 1, 0, a, 1, wr, wi, c, 1, w, 1,
304  $ info )
305  CALL chkxer( 'DHSEQR', infot, nout, lerr, ok )
306  infot = 3
307  CALL dhseqr( 'E', 'N', -1, 1, 0, a, 1, wr, wi, c, 1, w, 1,
308  $ info )
309  CALL chkxer( 'DHSEQR', infot, nout, lerr, ok )
310  infot = 4
311  CALL dhseqr( 'E', 'N', 0, 0, 0, a, 1, wr, wi, c, 1, w, 1,
312  $ info )
313  CALL chkxer( 'DHSEQR', infot, nout, lerr, ok )
314  infot = 4
315  CALL dhseqr( 'E', 'N', 0, 2, 0, a, 1, wr, wi, c, 1, w, 1,
316  $ info )
317  CALL chkxer( 'DHSEQR', infot, nout, lerr, ok )
318  infot = 5
319  CALL dhseqr( 'E', 'N', 1, 1, 0, a, 1, wr, wi, c, 1, w, 1,
320  $ info )
321  CALL chkxer( 'DHSEQR', infot, nout, lerr, ok )
322  infot = 5
323  CALL dhseqr( 'E', 'N', 1, 1, 2, a, 1, wr, wi, c, 1, w, 1,
324  $ info )
325  CALL chkxer( 'DHSEQR', infot, nout, lerr, ok )
326  infot = 7
327  CALL dhseqr( 'E', 'N', 2, 1, 2, a, 1, wr, wi, c, 2, w, 1,
328  $ info )
329  CALL chkxer( 'DHSEQR', infot, nout, lerr, ok )
330  infot = 11
331  CALL dhseqr( 'E', 'V', 2, 1, 2, a, 2, wr, wi, c, 1, w, 1,
332  $ info )
333  CALL chkxer( 'DHSEQR', infot, nout, lerr, ok )
334  nt = nt + 9
335 *
336 * DHSEIN
337 *
338  srnamt = 'DHSEIN'
339  infot = 1
340  CALL dhsein( '/', 'N', 'N', sel, 0, a, 1, wr, wi, vl, 1, vr, 1,
341  $ 0, m, w, ifaill, ifailr, info )
342  CALL chkxer( 'DHSEIN', infot, nout, lerr, ok )
343  infot = 2
344  CALL dhsein( 'R', '/', 'N', sel, 0, a, 1, wr, wi, vl, 1, vr, 1,
345  $ 0, m, w, ifaill, ifailr, info )
346  CALL chkxer( 'DHSEIN', infot, nout, lerr, ok )
347  infot = 3
348  CALL dhsein( 'R', 'N', '/', sel, 0, a, 1, wr, wi, vl, 1, vr, 1,
349  $ 0, m, w, ifaill, ifailr, info )
350  CALL chkxer( 'DHSEIN', infot, nout, lerr, ok )
351  infot = 5
352  CALL dhsein( 'R', 'N', 'N', sel, -1, a, 1, wr, wi, vl, 1, vr,
353  $ 1, 0, m, w, ifaill, ifailr, info )
354  CALL chkxer( 'DHSEIN', infot, nout, lerr, ok )
355  infot = 7
356  CALL dhsein( 'R', 'N', 'N', sel, 2, a, 1, wr, wi, vl, 1, vr, 2,
357  $ 4, m, w, ifaill, ifailr, info )
358  CALL chkxer( 'DHSEIN', infot, nout, lerr, ok )
359  infot = 11
360  CALL dhsein( 'L', 'N', 'N', sel, 2, a, 2, wr, wi, vl, 1, vr, 1,
361  $ 4, m, w, ifaill, ifailr, info )
362  CALL chkxer( 'DHSEIN', infot, nout, lerr, ok )
363  infot = 13
364  CALL dhsein( 'R', 'N', 'N', sel, 2, a, 2, wr, wi, vl, 1, vr, 1,
365  $ 4, m, w, ifaill, ifailr, info )
366  CALL chkxer( 'DHSEIN', infot, nout, lerr, ok )
367  infot = 14
368  CALL dhsein( 'R', 'N', 'N', sel, 2, a, 2, wr, wi, vl, 1, vr, 2,
369  $ 1, m, w, ifaill, ifailr, info )
370  CALL chkxer( 'DHSEIN', infot, nout, lerr, ok )
371  nt = nt + 8
372 *
373 * DTREVC
374 *
375  srnamt = 'DTREVC'
376  infot = 1
377  CALL dtrevc( '/', 'A', sel, 0, a, 1, vl, 1, vr, 1, 0, m, w,
378  $ info )
379  CALL chkxer( 'DTREVC', infot, nout, lerr, ok )
380  infot = 2
381  CALL dtrevc( 'L', '/', sel, 0, a, 1, vl, 1, vr, 1, 0, m, w,
382  $ info )
383  CALL chkxer( 'DTREVC', infot, nout, lerr, ok )
384  infot = 4
385  CALL dtrevc( 'L', 'A', sel, -1, a, 1, vl, 1, vr, 1, 0, m, w,
386  $ info )
387  CALL chkxer( 'DTREVC', infot, nout, lerr, ok )
388  infot = 6
389  CALL dtrevc( 'L', 'A', sel, 2, a, 1, vl, 2, vr, 1, 4, m, w,
390  $ info )
391  CALL chkxer( 'DTREVC', infot, nout, lerr, ok )
392  infot = 8
393  CALL dtrevc( 'L', 'A', sel, 2, a, 2, vl, 1, vr, 1, 4, m, w,
394  $ info )
395  CALL chkxer( 'DTREVC', infot, nout, lerr, ok )
396  infot = 10
397  CALL dtrevc( 'R', 'A', sel, 2, a, 2, vl, 1, vr, 1, 4, m, w,
398  $ info )
399  CALL chkxer( 'DTREVC', infot, nout, lerr, ok )
400  infot = 11
401  CALL dtrevc( 'L', 'A', sel, 2, a, 2, vl, 2, vr, 1, 1, m, w,
402  $ info )
403  CALL chkxer( 'DTREVC', infot, nout, lerr, ok )
404  nt = nt + 7
405  END IF
406 *
407 * Print a summary line.
408 *
409  IF( ok ) THEN
410  WRITE( nout, fmt = 9999 )path, nt
411  ELSE
412  WRITE( nout, fmt = 9998 )path
413  END IF
414 *
415  9999 format( 1x, a3, ' routines passed the tests of the error exits',
416  $ ' (', i3, ' tests done)' )
417  9998 format( ' *** ', a3, ' routines failed the tests of the error ',
418  $ 'exits ***' )
419 *
420  return
421 *
422 * End of DERRHS
423 *
424  END