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