LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
serrge.f
Go to the documentation of this file.
1 *> \brief \b SERRGE
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 SERRGE( 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 *> SERRGE tests the error exits for the REAL routines
25 *> for general matrices.
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_lin
54 *
55 * =====================================================================
56  SUBROUTINE serrge( 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 = 4, lw = 3*nmax )
73 * ..
74 * .. Local Scalars ..
75  CHARACTER*2 c2
76  INTEGER i, info, j
77  REAL anrm, ccond, rcond
78 * ..
79 * .. Local Arrays ..
80  INTEGER ip( nmax ), iw( nmax )
81  REAL a( nmax, nmax ), af( nmax, nmax ), b( nmax ),
82  $ r1( nmax ), r2( nmax ), w( lw ), x( nmax )
83 * ..
84 * .. External Functions ..
85  LOGICAL lsamen
86  EXTERNAL lsamen
87 * ..
88 * .. External Subroutines ..
89  EXTERNAL alaesm, chkxer, sgbcon, sgbequ, sgbrfs, sgbtf2,
90  $ sgbtrf, sgbtrs, sgecon, sgeequ, sgerfs, sgetf2,
91  $ sgetrf, sgetri, sgetrs
92 * ..
93 * .. Scalars in Common ..
94  LOGICAL lerr, ok
95  CHARACTER*32 srnamt
96  INTEGER infot, nout
97 * ..
98 * .. Common blocks ..
99  common / infoc / infot, nout, ok, lerr
100  common / srnamc / srnamt
101 * ..
102 * .. Intrinsic Functions ..
103  INTRINSIC real
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  af( i, j ) = 1. / REAL( i+j )
117  10 continue
118  b( j ) = 0.
119  r1( j ) = 0.
120  r2( j ) = 0.
121  w( j ) = 0.
122  x( j ) = 0.
123  ip( j ) = j
124  iw( j ) = j
125  20 continue
126  ok = .true.
127 *
128  IF( lsamen( 2, c2, 'GE' ) ) THEN
129 *
130 * Test error exits of the routines that use the LU decomposition
131 * of a general matrix.
132 *
133 * SGETRF
134 *
135  srnamt = 'SGETRF'
136  infot = 1
137  CALL sgetrf( -1, 0, a, 1, ip, info )
138  CALL chkxer( 'SGETRF', infot, nout, lerr, ok )
139  infot = 2
140  CALL sgetrf( 0, -1, a, 1, ip, info )
141  CALL chkxer( 'SGETRF', infot, nout, lerr, ok )
142  infot = 4
143  CALL sgetrf( 2, 1, a, 1, ip, info )
144  CALL chkxer( 'SGETRF', infot, nout, lerr, ok )
145 *
146 * SGETF2
147 *
148  srnamt = 'SGETF2'
149  infot = 1
150  CALL sgetf2( -1, 0, a, 1, ip, info )
151  CALL chkxer( 'SGETF2', infot, nout, lerr, ok )
152  infot = 2
153  CALL sgetf2( 0, -1, a, 1, ip, info )
154  CALL chkxer( 'SGETF2', infot, nout, lerr, ok )
155  infot = 4
156  CALL sgetf2( 2, 1, a, 1, ip, info )
157  CALL chkxer( 'SGETF2', infot, nout, lerr, ok )
158 *
159 * SGETRI
160 *
161  srnamt = 'SGETRI'
162  infot = 1
163  CALL sgetri( -1, a, 1, ip, w, lw, info )
164  CALL chkxer( 'SGETRI', infot, nout, lerr, ok )
165  infot = 3
166  CALL sgetri( 2, a, 1, ip, w, lw, info )
167  CALL chkxer( 'SGETRI', infot, nout, lerr, ok )
168 *
169 * SGETRS
170 *
171  srnamt = 'SGETRS'
172  infot = 1
173  CALL sgetrs( '/', 0, 0, a, 1, ip, b, 1, info )
174  CALL chkxer( 'SGETRS', infot, nout, lerr, ok )
175  infot = 2
176  CALL sgetrs( 'N', -1, 0, a, 1, ip, b, 1, info )
177  CALL chkxer( 'SGETRS', infot, nout, lerr, ok )
178  infot = 3
179  CALL sgetrs( 'N', 0, -1, a, 1, ip, b, 1, info )
180  CALL chkxer( 'SGETRS', infot, nout, lerr, ok )
181  infot = 5
182  CALL sgetrs( 'N', 2, 1, a, 1, ip, b, 2, info )
183  CALL chkxer( 'SGETRS', infot, nout, lerr, ok )
184  infot = 8
185  CALL sgetrs( 'N', 2, 1, a, 2, ip, b, 1, info )
186  CALL chkxer( 'SGETRS', infot, nout, lerr, ok )
187 *
188 * SGERFS
189 *
190  srnamt = 'SGERFS'
191  infot = 1
192  CALL sgerfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
193  $ iw, info )
194  CALL chkxer( 'SGERFS', infot, nout, lerr, ok )
195  infot = 2
196  CALL sgerfs( 'N', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
197  $ w, iw, info )
198  CALL chkxer( 'SGERFS', infot, nout, lerr, ok )
199  infot = 3
200  CALL sgerfs( 'N', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
201  $ w, iw, info )
202  CALL chkxer( 'SGERFS', infot, nout, lerr, ok )
203  infot = 5
204  CALL sgerfs( 'N', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
205  $ iw, info )
206  CALL chkxer( 'SGERFS', infot, nout, lerr, ok )
207  infot = 7
208  CALL sgerfs( 'N', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
209  $ iw, info )
210  CALL chkxer( 'SGERFS', infot, nout, lerr, ok )
211  infot = 10
212  CALL sgerfs( 'N', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
213  $ iw, info )
214  CALL chkxer( 'SGERFS', infot, nout, lerr, ok )
215  infot = 12
216  CALL sgerfs( 'N', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
217  $ iw, info )
218  CALL chkxer( 'SGERFS', infot, nout, lerr, ok )
219 *
220 * SGECON
221 *
222  srnamt = 'SGECON'
223  infot = 1
224  CALL sgecon( '/', 0, a, 1, anrm, rcond, w, iw, info )
225  CALL chkxer( 'SGECON', infot, nout, lerr, ok )
226  infot = 2
227  CALL sgecon( '1', -1, a, 1, anrm, rcond, w, iw, info )
228  CALL chkxer( 'SGECON', infot, nout, lerr, ok )
229  infot = 4
230  CALL sgecon( '1', 2, a, 1, anrm, rcond, w, iw, info )
231  CALL chkxer( 'SGECON', infot, nout, lerr, ok )
232 *
233 * SGEEQU
234 *
235  srnamt = 'SGEEQU'
236  infot = 1
237  CALL sgeequ( -1, 0, a, 1, r1, r2, rcond, ccond, anrm, info )
238  CALL chkxer( 'SGEEQU', infot, nout, lerr, ok )
239  infot = 2
240  CALL sgeequ( 0, -1, a, 1, r1, r2, rcond, ccond, anrm, info )
241  CALL chkxer( 'SGEEQU', infot, nout, lerr, ok )
242  infot = 4
243  CALL sgeequ( 2, 2, a, 1, r1, r2, rcond, ccond, anrm, info )
244  CALL chkxer( 'SGEEQU', infot, nout, lerr, ok )
245 *
246  ELSE IF( lsamen( 2, c2, 'GB' ) ) THEN
247 *
248 * Test error exits of the routines that use the LU decomposition
249 * of a general band matrix.
250 *
251 * SGBTRF
252 *
253  srnamt = 'SGBTRF'
254  infot = 1
255  CALL sgbtrf( -1, 0, 0, 0, a, 1, ip, info )
256  CALL chkxer( 'SGBTRF', infot, nout, lerr, ok )
257  infot = 2
258  CALL sgbtrf( 0, -1, 0, 0, a, 1, ip, info )
259  CALL chkxer( 'SGBTRF', infot, nout, lerr, ok )
260  infot = 3
261  CALL sgbtrf( 1, 1, -1, 0, a, 1, ip, info )
262  CALL chkxer( 'SGBTRF', infot, nout, lerr, ok )
263  infot = 4
264  CALL sgbtrf( 1, 1, 0, -1, a, 1, ip, info )
265  CALL chkxer( 'SGBTRF', infot, nout, lerr, ok )
266  infot = 6
267  CALL sgbtrf( 2, 2, 1, 1, a, 3, ip, info )
268  CALL chkxer( 'SGBTRF', infot, nout, lerr, ok )
269 *
270 * SGBTF2
271 *
272  srnamt = 'SGBTF2'
273  infot = 1
274  CALL sgbtf2( -1, 0, 0, 0, a, 1, ip, info )
275  CALL chkxer( 'SGBTF2', infot, nout, lerr, ok )
276  infot = 2
277  CALL sgbtf2( 0, -1, 0, 0, a, 1, ip, info )
278  CALL chkxer( 'SGBTF2', infot, nout, lerr, ok )
279  infot = 3
280  CALL sgbtf2( 1, 1, -1, 0, a, 1, ip, info )
281  CALL chkxer( 'SGBTF2', infot, nout, lerr, ok )
282  infot = 4
283  CALL sgbtf2( 1, 1, 0, -1, a, 1, ip, info )
284  CALL chkxer( 'SGBTF2', infot, nout, lerr, ok )
285  infot = 6
286  CALL sgbtf2( 2, 2, 1, 1, a, 3, ip, info )
287  CALL chkxer( 'SGBTF2', infot, nout, lerr, ok )
288 *
289 * SGBTRS
290 *
291  srnamt = 'SGBTRS'
292  infot = 1
293  CALL sgbtrs( '/', 0, 0, 0, 1, a, 1, ip, b, 1, info )
294  CALL chkxer( 'SGBTRS', infot, nout, lerr, ok )
295  infot = 2
296  CALL sgbtrs( 'N', -1, 0, 0, 1, a, 1, ip, b, 1, info )
297  CALL chkxer( 'SGBTRS', infot, nout, lerr, ok )
298  infot = 3
299  CALL sgbtrs( 'N', 1, -1, 0, 1, a, 1, ip, b, 1, info )
300  CALL chkxer( 'SGBTRS', infot, nout, lerr, ok )
301  infot = 4
302  CALL sgbtrs( 'N', 1, 0, -1, 1, a, 1, ip, b, 1, info )
303  CALL chkxer( 'SGBTRS', infot, nout, lerr, ok )
304  infot = 5
305  CALL sgbtrs( 'N', 1, 0, 0, -1, a, 1, ip, b, 1, info )
306  CALL chkxer( 'SGBTRS', infot, nout, lerr, ok )
307  infot = 7
308  CALL sgbtrs( 'N', 2, 1, 1, 1, a, 3, ip, b, 2, info )
309  CALL chkxer( 'SGBTRS', infot, nout, lerr, ok )
310  infot = 10
311  CALL sgbtrs( 'N', 2, 0, 0, 1, a, 1, ip, b, 1, info )
312  CALL chkxer( 'SGBTRS', infot, nout, lerr, ok )
313 *
314 * SGBRFS
315 *
316  srnamt = 'SGBRFS'
317  infot = 1
318  CALL sgbrfs( '/', 0, 0, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
319  $ r2, w, iw, info )
320  CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
321  infot = 2
322  CALL sgbrfs( 'N', -1, 0, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
323  $ r2, w, iw, info )
324  CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
325  infot = 3
326  CALL sgbrfs( 'N', 1, -1, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
327  $ r2, w, iw, info )
328  CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
329  infot = 4
330  CALL sgbrfs( 'N', 1, 0, -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
331  $ r2, w, iw, info )
332  CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
333  infot = 5
334  CALL sgbrfs( 'N', 1, 0, 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1,
335  $ r2, w, iw, info )
336  CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
337  infot = 7
338  CALL sgbrfs( 'N', 2, 1, 1, 1, a, 2, af, 4, ip, b, 2, x, 2, r1,
339  $ r2, w, iw, info )
340  CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
341  infot = 9
342  CALL sgbrfs( 'N', 2, 1, 1, 1, a, 3, af, 3, ip, b, 2, x, 2, r1,
343  $ r2, w, iw, info )
344  CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
345  infot = 12
346  CALL sgbrfs( 'N', 2, 0, 0, 1, a, 1, af, 1, ip, b, 1, x, 2, r1,
347  $ r2, w, iw, info )
348  CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
349  infot = 14
350  CALL sgbrfs( 'N', 2, 0, 0, 1, a, 1, af, 1, ip, b, 2, x, 1, r1,
351  $ r2, w, iw, info )
352  CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
353 *
354 * SGBCON
355 *
356  srnamt = 'SGBCON'
357  infot = 1
358  CALL sgbcon( '/', 0, 0, 0, a, 1, ip, anrm, rcond, w, iw, info )
359  CALL chkxer( 'SGBCON', infot, nout, lerr, ok )
360  infot = 2
361  CALL sgbcon( '1', -1, 0, 0, a, 1, ip, anrm, rcond, w, iw,
362  $ info )
363  CALL chkxer( 'SGBCON', infot, nout, lerr, ok )
364  infot = 3
365  CALL sgbcon( '1', 1, -1, 0, a, 1, ip, anrm, rcond, w, iw,
366  $ info )
367  CALL chkxer( 'SGBCON', infot, nout, lerr, ok )
368  infot = 4
369  CALL sgbcon( '1', 1, 0, -1, a, 1, ip, anrm, rcond, w, iw,
370  $ info )
371  CALL chkxer( 'SGBCON', infot, nout, lerr, ok )
372  infot = 6
373  CALL sgbcon( '1', 2, 1, 1, a, 3, ip, anrm, rcond, w, iw, info )
374  CALL chkxer( 'SGBCON', infot, nout, lerr, ok )
375 *
376 * SGBEQU
377 *
378  srnamt = 'SGBEQU'
379  infot = 1
380  CALL sgbequ( -1, 0, 0, 0, a, 1, r1, r2, rcond, ccond, anrm,
381  $ info )
382  CALL chkxer( 'SGBEQU', infot, nout, lerr, ok )
383  infot = 2
384  CALL sgbequ( 0, -1, 0, 0, a, 1, r1, r2, rcond, ccond, anrm,
385  $ info )
386  CALL chkxer( 'SGBEQU', infot, nout, lerr, ok )
387  infot = 3
388  CALL sgbequ( 1, 1, -1, 0, a, 1, r1, r2, rcond, ccond, anrm,
389  $ info )
390  CALL chkxer( 'SGBEQU', infot, nout, lerr, ok )
391  infot = 4
392  CALL sgbequ( 1, 1, 0, -1, a, 1, r1, r2, rcond, ccond, anrm,
393  $ info )
394  CALL chkxer( 'SGBEQU', infot, nout, lerr, ok )
395  infot = 6
396  CALL sgbequ( 2, 2, 1, 1, a, 2, r1, r2, rcond, ccond, anrm,
397  $ info )
398  CALL chkxer( 'SGBEQU', infot, nout, lerr, ok )
399  END IF
400 *
401 * Print a summary line.
402 *
403  CALL alaesm( path, ok, nout )
404 *
405  return
406 *
407 * End of SERRGE
408 *
409  END