LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
serrec.f
Go to the documentation of this file.
1 *> \brief \b SERREC
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 SERREC( 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 *> SERREC tests the error exits for the routines for eigen- condition
25 *> estimation for REAL matrices:
26 *> STRSYL, STREXC, STRSNA and STRSEN.
27 *> \endverbatim
28 *
29 * Arguments:
30 * ==========
31 *
32 *> \param[in] PATH
33 *> \verbatim
34 *> PATH is CHARACTER*3
35 *> The LAPACK path name for the routines to be tested.
36 *> \endverbatim
37 *>
38 *> \param[in] NUNIT
39 *> \verbatim
40 *> NUNIT is INTEGER
41 *> The unit number for output.
42 *> \endverbatim
43 *
44 * Authors:
45 * ========
46 *
47 *> \author Univ. of Tennessee
48 *> \author Univ. of California Berkeley
49 *> \author Univ. of Colorado Denver
50 *> \author NAG Ltd.
51 *
52 *> \date November 2011
53 *
54 *> \ingroup single_eig
55 *
56 * =====================================================================
57  SUBROUTINE serrec( PATH, NUNIT )
58 *
59 * -- LAPACK test routine (version 3.4.0) --
60 * -- LAPACK is a software package provided by Univ. of Tennessee, --
61 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
62 * November 2011
63 *
64 * .. Scalar Arguments ..
65  CHARACTER*3 path
66  INTEGER nunit
67 * ..
68 *
69 * =====================================================================
70 *
71 * .. Parameters ..
72  INTEGER nmax
73  REAL one, zero
74  parameter( nmax = 4, one = 1.0e0, zero = 0.0e0 )
75 * ..
76 * .. Local Scalars ..
77  INTEGER i, ifst, ilst, info, j, m, nt
78  REAL scale
79 * ..
80 * .. Local Arrays ..
81  LOGICAL sel( nmax )
82  INTEGER iwork( nmax )
83  REAL a( nmax, nmax ), b( nmax, nmax ),
84  $ c( nmax, nmax ), s( nmax ), sep( nmax ),
85  $ wi( nmax ), work( nmax ), wr( nmax )
86 * ..
87 * .. External Subroutines ..
88  EXTERNAL chkxer, strexc, strsen, strsna, strsyl
89 * ..
90 * .. Scalars in Common ..
91  LOGICAL lerr, ok
92  CHARACTER*32 srnamt
93  INTEGER infot, nout
94 * ..
95 * .. Common blocks ..
96  common / infoc / infot, nout, ok, lerr
97  common / srnamc / srnamt
98 * ..
99 * .. Executable Statements ..
100 *
101  nout = nunit
102  ok = .true.
103  nt = 0
104 *
105 * Initialize A, B and SEL
106 *
107  DO 20 j = 1, nmax
108  DO 10 i = 1, nmax
109  a( i, j ) = zero
110  b( i, j ) = zero
111  10 continue
112  20 continue
113  DO 30 i = 1, nmax
114  a( i, i ) = one
115  sel( i ) = .true.
116  30 continue
117 *
118 * Test STRSYL
119 *
120  srnamt = 'STRSYL'
121  infot = 1
122  CALL strsyl( 'X', 'N', 1, 0, 0, a, 1, b, 1, c, 1, scale, info )
123  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
124  infot = 2
125  CALL strsyl( 'N', 'X', 1, 0, 0, a, 1, b, 1, c, 1, scale, info )
126  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
127  infot = 3
128  CALL strsyl( 'N', 'N', 0, 0, 0, a, 1, b, 1, c, 1, scale, info )
129  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
130  infot = 4
131  CALL strsyl( 'N', 'N', 1, -1, 0, a, 1, b, 1, c, 1, scale, info )
132  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
133  infot = 5
134  CALL strsyl( 'N', 'N', 1, 0, -1, a, 1, b, 1, c, 1, scale, info )
135  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
136  infot = 7
137  CALL strsyl( 'N', 'N', 1, 2, 0, a, 1, b, 1, c, 2, scale, info )
138  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
139  infot = 9
140  CALL strsyl( 'N', 'N', 1, 0, 2, a, 1, b, 1, c, 1, scale, info )
141  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
142  infot = 11
143  CALL strsyl( 'N', 'N', 1, 2, 0, a, 2, b, 1, c, 1, scale, info )
144  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
145  nt = nt + 8
146 *
147 * Test STREXC
148 *
149  srnamt = 'STREXC'
150  ifst = 1
151  ilst = 1
152  infot = 1
153  CALL strexc( 'X', 1, a, 1, b, 1, ifst, ilst, work, info )
154  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
155  infot = 7
156  CALL strexc( 'N', 0, a, 1, b, 1, ifst, ilst, work, info )
157  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
158  infot = 4
159  ilst = 2
160  CALL strexc( 'N', 2, a, 1, b, 1, ifst, ilst, work, info )
161  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
162  infot = 6
163  CALL strexc( 'V', 2, a, 2, b, 1, ifst, ilst, work, info )
164  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
165  infot = 7
166  ifst = 0
167  ilst = 1
168  CALL strexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
169  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
170  infot = 7
171  ifst = 2
172  CALL strexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
173  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
174  infot = 8
175  ifst = 1
176  ilst = 0
177  CALL strexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
178  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
179  infot = 8
180  ilst = 2
181  CALL strexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
182  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
183  nt = nt + 8
184 *
185 * Test STRSNA
186 *
187  srnamt = 'STRSNA'
188  infot = 1
189  CALL strsna( 'X', 'A', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
190  $ work, 1, iwork, info )
191  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
192  infot = 2
193  CALL strsna( 'B', 'X', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
194  $ work, 1, iwork, info )
195  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
196  infot = 4
197  CALL strsna( 'B', 'A', sel, -1, a, 1, b, 1, c, 1, s, sep, 1, m,
198  $ work, 1, iwork, info )
199  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
200  infot = 6
201  CALL strsna( 'V', 'A', sel, 2, a, 1, b, 1, c, 1, s, sep, 2, m,
202  $ work, 2, iwork, info )
203  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
204  infot = 8
205  CALL strsna( 'B', 'A', sel, 2, a, 2, b, 1, c, 2, s, sep, 2, m,
206  $ work, 2, iwork, info )
207  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
208  infot = 10
209  CALL strsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 1, s, sep, 2, m,
210  $ work, 2, iwork, info )
211  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
212  infot = 13
213  CALL strsna( 'B', 'A', sel, 1, a, 1, b, 1, c, 1, s, sep, 0, m,
214  $ work, 1, iwork, info )
215  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
216  infot = 13
217  CALL strsna( 'B', 'S', sel, 2, a, 2, b, 2, c, 2, s, sep, 1, m,
218  $ work, 2, iwork, info )
219  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
220  infot = 16
221  CALL strsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 2, s, sep, 2, m,
222  $ work, 1, iwork, info )
223  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
224  nt = nt + 9
225 *
226 * Test STRSEN
227 *
228  sel( 1 ) = .false.
229  srnamt = 'STRSEN'
230  infot = 1
231  CALL strsen( 'X', 'N', sel, 0, a, 1, b, 1, wr, wi, m, s( 1 ),
232  $ sep( 1 ), work, 1, iwork, 1, info )
233  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
234  infot = 2
235  CALL strsen( 'N', 'X', sel, 0, a, 1, b, 1, wr, wi, m, s( 1 ),
236  $ sep( 1 ), work, 1, iwork, 1, info )
237  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
238  infot = 4
239  CALL strsen( 'N', 'N', sel, -1, a, 1, b, 1, wr, wi, m, s( 1 ),
240  $ sep( 1 ), work, 1, iwork, 1, info )
241  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
242  infot = 6
243  CALL strsen( 'N', 'N', sel, 2, a, 1, b, 1, wr, wi, m, s( 1 ),
244  $ sep( 1 ), work, 2, iwork, 1, info )
245  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
246  infot = 8
247  CALL strsen( 'N', 'V', sel, 2, a, 2, b, 1, wr, wi, m, s( 1 ),
248  $ sep( 1 ), work, 1, iwork, 1, info )
249  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
250  infot = 15
251  CALL strsen( 'N', 'V', sel, 2, a, 2, b, 2, wr, wi, m, s( 1 ),
252  $ sep( 1 ), work, 0, iwork, 1, info )
253  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
254  infot = 15
255  CALL strsen( 'E', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
256  $ sep( 1 ), work, 1, iwork, 1, info )
257  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
258  infot = 15
259  CALL strsen( 'V', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
260  $ sep( 1 ), work, 3, iwork, 2, info )
261  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
262  infot = 17
263  CALL strsen( 'E', 'V', sel, 2, a, 2, b, 2, wr, wi, m, s( 1 ),
264  $ sep( 1 ), work, 1, iwork, 0, info )
265  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
266  infot = 17
267  CALL strsen( 'V', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
268  $ sep( 1 ), work, 4, iwork, 1, info )
269  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
270  nt = nt + 10
271 *
272 * Print a summary line.
273 *
274  IF( ok ) THEN
275  WRITE( nout, fmt = 9999 )path, nt
276  ELSE
277  WRITE( nout, fmt = 9998 )path
278  END IF
279 *
280  return
281  9999 format( 1x, a3, ' routines passed the tests of the error exits (',
282  $ i3, ' tests done)' )
283  9998 format( ' *** ', a3, ' routines failed the tests of the error ex',
284  $ 'its ***' )
285 *
286 * End of SERREC
287 *
288  END