LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
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, STRSYL3, 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, strsyl3
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 STRSYL3
145*
146 srnamt = 'STRSYL3'
147 infot = 1
148 CALL strsyl3( 'X', 'N', 1, 0, 0, a, 1, b, 1, c, 1, scale,
149 $ iwork, nmax, work, nmax, info )
150 CALL chkxer( 'STRSYL3', infot, nout, lerr, ok )
151 infot = 2
152 CALL strsyl3( 'N', 'X', 1, 0, 0, a, 1, b, 1, c, 1, scale,
153 $ iwork, nmax, work, nmax, info )
154 CALL chkxer( 'STRSYL3', infot, nout, lerr, ok )
155 infot = 3
156 CALL strsyl3( 'N', 'N', 0, 0, 0, a, 1, b, 1, c, 1, scale,
157 $ iwork, nmax, work, nmax, info )
158 CALL chkxer( 'STRSYL3', infot, nout, lerr, ok )
159 infot = 4
160 CALL strsyl3( 'N', 'N', 1, -1, 0, a, 1, b, 1, c, 1, scale,
161 $ iwork, nmax, work, nmax, info )
162 CALL chkxer( 'STRSYL3', infot, nout, lerr, ok )
163 infot = 5
164 CALL strsyl3( 'N', 'N', 1, 0, -1, a, 1, b, 1, c, 1, scale,
165 $ iwork, nmax, work, nmax, info )
166 CALL chkxer( 'STRSYL3', infot, nout, lerr, ok )
167 infot = 7
168 CALL strsyl3( 'N', 'N', 1, 2, 0, a, 1, b, 1, c, 2, scale,
169 $ iwork, nmax, work, nmax, info )
170 CALL chkxer( 'STRSYL3', infot, nout, lerr, ok )
171 infot = 9
172 CALL strsyl3( 'N', 'N', 1, 0, 2, a, 1, b, 1, c, 1, scale,
173 $ iwork, nmax, work, nmax, info )
174 CALL chkxer( 'STRSYL3', infot, nout, lerr, ok )
175 infot = 11
176 CALL strsyl3( 'N', 'N', 1, 2, 0, a, 2, b, 1, c, 1, scale,
177 $ iwork, nmax, work, nmax, info )
178 CALL chkxer( 'STRSYL3', infot, nout, lerr, ok )
179 nt = nt + 8
180*
181* Test STREXC
182*
183 srnamt = 'STREXC'
184 ifst = 1
185 ilst = 1
186 infot = 1
187 CALL strexc( 'X', 1, a, 1, b, 1, ifst, ilst, work, info )
188 CALL chkxer( 'STREXC', infot, nout, lerr, ok )
189 infot = 2
190 CALL strexc( 'N', -1, a, 1, b, 1, ifst, ilst, work, info )
191 CALL chkxer( 'STREXC', infot, nout, lerr, ok )
192 infot = 4
193 ilst = 2
194 CALL strexc( 'N', 2, a, 1, b, 1, ifst, ilst, work, info )
195 CALL chkxer( 'STREXC', infot, nout, lerr, ok )
196 infot = 6
197 CALL strexc( 'V', 2, a, 2, b, 1, ifst, ilst, work, info )
198 CALL chkxer( 'STREXC', infot, nout, lerr, ok )
199 infot = 7
200 ifst = 0
201 ilst = 1
202 CALL strexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
203 CALL chkxer( 'STREXC', infot, nout, lerr, ok )
204 infot = 7
205 ifst = 2
206 CALL strexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
207 CALL chkxer( 'STREXC', infot, nout, lerr, ok )
208 infot = 8
209 ifst = 1
210 ilst = 0
211 CALL strexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
212 CALL chkxer( 'STREXC', infot, nout, lerr, ok )
213 infot = 8
214 ilst = 2
215 CALL strexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
216 CALL chkxer( 'STREXC', infot, nout, lerr, ok )
217 nt = nt + 8
218*
219* Test STRSNA
220*
221 srnamt = 'STRSNA'
222 infot = 1
223 CALL strsna( 'X', 'A', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
224 $ work, 1, iwork, info )
225 CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
226 infot = 2
227 CALL strsna( 'B', 'X', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
228 $ work, 1, iwork, info )
229 CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
230 infot = 4
231 CALL strsna( 'B', 'A', sel, -1, a, 1, b, 1, c, 1, s, sep, 1, m,
232 $ work, 1, iwork, info )
233 CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
234 infot = 6
235 CALL strsna( 'V', 'A', sel, 2, a, 1, b, 1, c, 1, s, sep, 2, m,
236 $ work, 2, iwork, info )
237 CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
238 infot = 8
239 CALL strsna( 'B', 'A', sel, 2, a, 2, b, 1, c, 2, s, sep, 2, m,
240 $ work, 2, iwork, info )
241 CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
242 infot = 10
243 CALL strsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 1, s, sep, 2, m,
244 $ work, 2, iwork, info )
245 CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
246 infot = 13
247 CALL strsna( 'B', 'A', sel, 1, a, 1, b, 1, c, 1, s, sep, 0, m,
248 $ work, 1, iwork, info )
249 CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
250 infot = 13
251 CALL strsna( 'B', 'S', sel, 2, a, 2, b, 2, c, 2, s, sep, 1, m,
252 $ work, 2, iwork, info )
253 CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
254 infot = 16
255 CALL strsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 2, s, sep, 2, m,
256 $ work, 1, iwork, info )
257 CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
258 nt = nt + 9
259*
260* Test STRSEN
261*
262 sel( 1 ) = .false.
263 srnamt = 'STRSEN'
264 infot = 1
265 CALL strsen( 'X', 'N', sel, 0, a, 1, b, 1, wr, wi, m, s( 1 ),
266 $ sep( 1 ), work, 1, iwork, 1, info )
267 CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
268 infot = 2
269 CALL strsen( 'N', 'X', sel, 0, a, 1, b, 1, wr, wi, m, s( 1 ),
270 $ sep( 1 ), work, 1, iwork, 1, info )
271 CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
272 infot = 4
273 CALL strsen( 'N', 'N', sel, -1, a, 1, b, 1, wr, wi, m, s( 1 ),
274 $ sep( 1 ), work, 1, iwork, 1, info )
275 CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
276 infot = 6
277 CALL strsen( 'N', 'N', sel, 2, a, 1, b, 1, wr, wi, m, s( 1 ),
278 $ sep( 1 ), work, 2, iwork, 1, info )
279 CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
280 infot = 8
281 CALL strsen( 'N', 'V', sel, 2, a, 2, b, 1, wr, wi, m, s( 1 ),
282 $ sep( 1 ), work, 1, iwork, 1, info )
283 CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
284 infot = 15
285 CALL strsen( 'N', 'V', sel, 2, a, 2, b, 2, wr, wi, m, s( 1 ),
286 $ sep( 1 ), work, 0, iwork, 1, info )
287 CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
288 infot = 15
289 CALL strsen( 'E', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
290 $ sep( 1 ), work, 1, iwork, 1, info )
291 CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
292 infot = 15
293 CALL strsen( 'V', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
294 $ sep( 1 ), work, 3, iwork, 2, info )
295 CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
296 infot = 17
297 CALL strsen( 'E', 'V', sel, 2, a, 2, b, 2, wr, wi, m, s( 1 ),
298 $ sep( 1 ), work, 1, iwork, 0, info )
299 CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
300 infot = 17
301 CALL strsen( 'V', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
302 $ sep( 1 ), work, 4, iwork, 1, info )
303 CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
304 nt = nt + 10
305*
306* Print a summary line.
307*
308 IF( ok ) THEN
309 WRITE( nout, fmt = 9999 )path, nt
310 ELSE
311 WRITE( nout, fmt = 9998 )path
312 END IF
313*
314 RETURN
315 9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits (',
316 $ i3, ' tests done)' )
317 9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ex',
318 $ 'its ***' )
319*
320* End of SERREC
321*
322 END
chkxer
subroutine chkxer(srnamt, infot, nout, lerr, ok)
Definition cblat2.f:3224
strexc
subroutine strexc(compq, n, t, ldt, q, ldq, ifst, ilst, work, info)
STREXC
Definition strexc.f:146
strsen
subroutine strsen(job, compq, select, n, t, ldt, q, ldq, wr, wi, m, s, sep, work, lwork, iwork, liwork, info)
STRSEN
Definition strsen.f:313
strsna
subroutine strsna(job, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, s, sep, mm, m, work, ldwork, iwork, info)
STRSNA
Definition strsna.f:264
strsyl3
subroutine strsyl3(trana, tranb, isgn, m, n, a, lda, b, ldb, c, ldc, scale, iwork, liwork, swork, ldswork, info)
STRSYL3
Definition strsyl3.f:199
strsyl
subroutine strsyl(trana, tranb, isgn, m, n, a, lda, b, ldb, c, ldc, scale, info)
STRSYL
Definition strsyl.f:162
serrec
subroutine serrec(path, nunit)
SERREC
Definition serrec.f:56