LAPACK  3.10.0
LAPACK: Linear Algebra PACKage
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 *> \ingroup single_eig
53 *
54 * =====================================================================
55  SUBROUTINE serrec( PATH, NUNIT )
56 *
57 * -- LAPACK test routine --
58 * -- LAPACK is a software package provided by Univ. of Tennessee, --
59 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
60 *
61 * .. Scalar Arguments ..
62  CHARACTER*3 PATH
63  INTEGER NUNIT
64 * ..
65 *
66 * =====================================================================
67 *
68 * .. Parameters ..
69  INTEGER NMAX
70  REAL ONE, ZERO
71  parameter( nmax = 4, one = 1.0e0, zero = 0.0e0 )
72 * ..
73 * .. Local Scalars ..
74  INTEGER I, IFST, ILST, INFO, J, M, NT
75  REAL SCALE
76 * ..
77 * .. Local Arrays ..
78  LOGICAL SEL( NMAX )
79  INTEGER IWORK( NMAX )
80  REAL A( NMAX, NMAX ), B( NMAX, NMAX ),
81  $ C( NMAX, NMAX ), S( NMAX ), SEP( NMAX ),
82  $ WI( NMAX ), WORK( NMAX ), WR( NMAX )
83 * ..
84 * .. External Subroutines ..
85  EXTERNAL chkxer, strexc, strsen, strsna, strsyl
86 * ..
87 * .. Scalars in Common ..
88  LOGICAL LERR, OK
89  CHARACTER*32 SRNAMT
90  INTEGER INFOT, NOUT
91 * ..
92 * .. Common blocks ..
93  COMMON / infoc / infot, nout, ok, lerr
94  COMMON / srnamc / srnamt
95 * ..
96 * .. Executable Statements ..
97 *
98  nout = nunit
99  ok = .true.
100  nt = 0
101 *
102 * Initialize A, B and SEL
103 *
104  DO 20 j = 1, nmax
105  DO 10 i = 1, nmax
106  a( i, j ) = zero
107  b( i, j ) = zero
108  10 CONTINUE
109  20 CONTINUE
110  DO 30 i = 1, nmax
111  a( i, i ) = one
112  sel( i ) = .true.
113  30 CONTINUE
114 *
115 * Test STRSYL
116 *
117  srnamt = 'STRSYL'
118  infot = 1
119  CALL strsyl( 'X', 'N', 1, 0, 0, a, 1, b, 1, c, 1, scale, info )
120  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
121  infot = 2
122  CALL strsyl( 'N', 'X', 1, 0, 0, a, 1, b, 1, c, 1, scale, info )
123  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
124  infot = 3
125  CALL strsyl( 'N', 'N', 0, 0, 0, a, 1, b, 1, c, 1, scale, info )
126  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
127  infot = 4
128  CALL strsyl( 'N', 'N', 1, -1, 0, a, 1, b, 1, c, 1, scale, info )
129  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
130  infot = 5
131  CALL strsyl( 'N', 'N', 1, 0, -1, a, 1, b, 1, c, 1, scale, info )
132  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
133  infot = 7
134  CALL strsyl( 'N', 'N', 1, 2, 0, a, 1, b, 1, c, 2, scale, info )
135  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
136  infot = 9
137  CALL strsyl( 'N', 'N', 1, 0, 2, a, 1, b, 1, c, 1, scale, info )
138  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
139  infot = 11
140  CALL strsyl( 'N', 'N', 1, 2, 0, a, 2, b, 1, c, 1, scale, info )
141  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
142  nt = nt + 8
143 *
144 * Test STREXC
145 *
146  srnamt = 'STREXC'
147  ifst = 1
148  ilst = 1
149  infot = 1
150  CALL strexc( 'X', 1, a, 1, b, 1, ifst, ilst, work, info )
151  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
152  infot = 2
153  CALL strexc( 'N', -1, a, 1, b, 1, ifst, ilst, work, info )
154  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
155  infot = 4
156  ilst = 2
157  CALL strexc( 'N', 2, a, 1, b, 1, ifst, ilst, work, info )
158  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
159  infot = 6
160  CALL strexc( 'V', 2, a, 2, b, 1, ifst, ilst, work, info )
161  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
162  infot = 7
163  ifst = 0
164  ilst = 1
165  CALL strexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
166  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
167  infot = 7
168  ifst = 2
169  CALL strexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
170  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
171  infot = 8
172  ifst = 1
173  ilst = 0
174  CALL strexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
175  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
176  infot = 8
177  ilst = 2
178  CALL strexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
179  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
180  nt = nt + 8
181 *
182 * Test STRSNA
183 *
184  srnamt = 'STRSNA'
185  infot = 1
186  CALL strsna( 'X', 'A', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
187  $ work, 1, iwork, info )
188  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
189  infot = 2
190  CALL strsna( 'B', 'X', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
191  $ work, 1, iwork, info )
192  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
193  infot = 4
194  CALL strsna( 'B', 'A', sel, -1, a, 1, b, 1, c, 1, s, sep, 1, m,
195  $ work, 1, iwork, info )
196  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
197  infot = 6
198  CALL strsna( 'V', 'A', sel, 2, a, 1, b, 1, c, 1, s, sep, 2, m,
199  $ work, 2, iwork, info )
200  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
201  infot = 8
202  CALL strsna( 'B', 'A', sel, 2, a, 2, b, 1, c, 2, s, sep, 2, m,
203  $ work, 2, iwork, info )
204  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
205  infot = 10
206  CALL strsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 1, s, sep, 2, m,
207  $ work, 2, iwork, info )
208  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
209  infot = 13
210  CALL strsna( 'B', 'A', sel, 1, a, 1, b, 1, c, 1, s, sep, 0, m,
211  $ work, 1, iwork, info )
212  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
213  infot = 13
214  CALL strsna( 'B', 'S', sel, 2, a, 2, b, 2, c, 2, s, sep, 1, m,
215  $ work, 2, iwork, info )
216  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
217  infot = 16
218  CALL strsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 2, s, sep, 2, m,
219  $ work, 1, iwork, info )
220  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
221  nt = nt + 9
222 *
223 * Test STRSEN
224 *
225  sel( 1 ) = .false.
226  srnamt = 'STRSEN'
227  infot = 1
228  CALL strsen( 'X', 'N', sel, 0, a, 1, b, 1, wr, wi, m, s( 1 ),
229  $ sep( 1 ), work, 1, iwork, 1, info )
230  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
231  infot = 2
232  CALL strsen( 'N', 'X', sel, 0, a, 1, b, 1, wr, wi, m, s( 1 ),
233  $ sep( 1 ), work, 1, iwork, 1, info )
234  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
235  infot = 4
236  CALL strsen( 'N', 'N', sel, -1, a, 1, b, 1, wr, wi, m, s( 1 ),
237  $ sep( 1 ), work, 1, iwork, 1, info )
238  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
239  infot = 6
240  CALL strsen( 'N', 'N', sel, 2, a, 1, b, 1, wr, wi, m, s( 1 ),
241  $ sep( 1 ), work, 2, iwork, 1, info )
242  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
243  infot = 8
244  CALL strsen( 'N', 'V', sel, 2, a, 2, b, 1, wr, wi, m, s( 1 ),
245  $ sep( 1 ), work, 1, iwork, 1, info )
246  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
247  infot = 15
248  CALL strsen( 'N', 'V', sel, 2, a, 2, b, 2, wr, wi, m, s( 1 ),
249  $ sep( 1 ), work, 0, iwork, 1, info )
250  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
251  infot = 15
252  CALL strsen( 'E', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
253  $ sep( 1 ), work, 1, iwork, 1, info )
254  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
255  infot = 15
256  CALL strsen( 'V', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
257  $ sep( 1 ), work, 3, iwork, 2, info )
258  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
259  infot = 17
260  CALL strsen( 'E', 'V', sel, 2, a, 2, b, 2, wr, wi, m, s( 1 ),
261  $ sep( 1 ), work, 1, iwork, 0, info )
262  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
263  infot = 17
264  CALL strsen( 'V', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
265  $ sep( 1 ), work, 4, iwork, 1, info )
266  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
267  nt = nt + 10
268 *
269 * Print a summary line.
270 *
271  IF( ok ) THEN
272  WRITE( nout, fmt = 9999 )path, nt
273  ELSE
274  WRITE( nout, fmt = 9998 )path
275  END IF
276 *
277  RETURN
278  9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits (',
279  $ i3, ' tests done)' )
280  9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ex',
281  $ 'its ***' )
282 *
283 * End of SERREC
284 *
285  END
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
Definition: cblat2.f:3196
subroutine strexc(COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO)
STREXC
Definition: strexc.f:148
subroutine strsna(JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO)
STRSNA
Definition: strsna.f:265
subroutine strsen(JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO)
STRSEN
Definition: strsen.f:314
subroutine strsyl(TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO)
STRSYL
Definition: strsyl.f:164
subroutine serrec(PATH, NUNIT)
SERREC
Definition: serrec.f:56