LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
cerrge.f
Go to the documentation of this file.
1 *> \brief \b CERRGE
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 CERRGE( 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 *> CERRGE tests the error exits for the COMPLEX 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 complex_lin
54 *
55 * =====================================================================
56  SUBROUTINE cerrge( 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
72  parameter( nmax = 4 )
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 )
81  REAL r( nmax ), r1( nmax ), r2( nmax )
82  COMPLEX a( nmax, nmax ), af( nmax, nmax ), b( nmax ),
83  $ w( 2*nmax ), x( nmax )
84 * ..
85 * .. External Functions ..
86  LOGICAL lsamen
87  EXTERNAL lsamen
88 * ..
89 * .. External Subroutines ..
90  EXTERNAL alaesm, cgbcon, cgbequ, cgbrfs, cgbtf2, cgbtrf,
91  $ cgbtrs, cgecon, cgeequ, cgerfs, cgetf2, cgetrf,
92  $ cgetri, cgetrs, chkxer
93 * ..
94 * .. Scalars in Common ..
95  LOGICAL lerr, ok
96  CHARACTER*32 srnamt
97  INTEGER infot, nout
98 * ..
99 * .. Common blocks ..
100  common / infoc / infot, nout, ok, lerr
101  common / srnamc / srnamt
102 * ..
103 * .. Intrinsic Functions ..
104  INTRINSIC cmplx, real
105 * ..
106 * .. Executable Statements ..
107 *
108  nout = nunit
109  WRITE( nout, fmt = * )
110  c2 = path( 2: 3 )
111 *
112 * Set the variables to innocuous values.
113 *
114  DO 20 j = 1, nmax
115  DO 10 i = 1, nmax
116  a( i, j ) = cmplx( 1. / REAL( I+J ), -1. / REAL( I+J ) )
117  af( i, j ) = cmplx( 1. / REAL( I+J ), -1. / REAL( I+J ) )
118  10 continue
119  b( j ) = 0.
120  r1( j ) = 0.
121  r2( j ) = 0.
122  w( j ) = 0.
123  x( j ) = 0.
124  ip( j ) = j
125  20 continue
126  ok = .true.
127 *
128 * Test error exits of the routines that use the LU decomposition
129 * of a general matrix.
130 *
131  IF( lsamen( 2, c2, 'GE' ) ) THEN
132 *
133 * CGETRF
134 *
135  srnamt = 'CGETRF'
136  infot = 1
137  CALL cgetrf( -1, 0, a, 1, ip, info )
138  CALL chkxer( 'CGETRF', infot, nout, lerr, ok )
139  infot = 2
140  CALL cgetrf( 0, -1, a, 1, ip, info )
141  CALL chkxer( 'CGETRF', infot, nout, lerr, ok )
142  infot = 4
143  CALL cgetrf( 2, 1, a, 1, ip, info )
144  CALL chkxer( 'CGETRF', infot, nout, lerr, ok )
145 *
146 * CGETF2
147 *
148  srnamt = 'CGETF2'
149  infot = 1
150  CALL cgetf2( -1, 0, a, 1, ip, info )
151  CALL chkxer( 'CGETF2', infot, nout, lerr, ok )
152  infot = 2
153  CALL cgetf2( 0, -1, a, 1, ip, info )
154  CALL chkxer( 'CGETF2', infot, nout, lerr, ok )
155  infot = 4
156  CALL cgetf2( 2, 1, a, 1, ip, info )
157  CALL chkxer( 'CGETF2', infot, nout, lerr, ok )
158 *
159 * CGETRI
160 *
161  srnamt = 'CGETRI'
162  infot = 1
163  CALL cgetri( -1, a, 1, ip, w, 1, info )
164  CALL chkxer( 'CGETRI', infot, nout, lerr, ok )
165  infot = 3
166  CALL cgetri( 2, a, 1, ip, w, 2, info )
167  CALL chkxer( 'CGETRI', infot, nout, lerr, ok )
168  infot = 6
169  CALL cgetri( 2, a, 2, ip, w, 1, info )
170  CALL chkxer( 'CGETRI', infot, nout, lerr, ok )
171 *
172 * CGETRS
173 *
174  srnamt = 'CGETRS'
175  infot = 1
176  CALL cgetrs( '/', 0, 0, a, 1, ip, b, 1, info )
177  CALL chkxer( 'CGETRS', infot, nout, lerr, ok )
178  infot = 2
179  CALL cgetrs( 'N', -1, 0, a, 1, ip, b, 1, info )
180  CALL chkxer( 'CGETRS', infot, nout, lerr, ok )
181  infot = 3
182  CALL cgetrs( 'N', 0, -1, a, 1, ip, b, 1, info )
183  CALL chkxer( 'CGETRS', infot, nout, lerr, ok )
184  infot = 5
185  CALL cgetrs( 'N', 2, 1, a, 1, ip, b, 2, info )
186  CALL chkxer( 'CGETRS', infot, nout, lerr, ok )
187  infot = 8
188  CALL cgetrs( 'N', 2, 1, a, 2, ip, b, 1, info )
189  CALL chkxer( 'CGETRS', infot, nout, lerr, ok )
190 *
191 * CGERFS
192 *
193  srnamt = 'CGERFS'
194  infot = 1
195  CALL cgerfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
196  $ r, info )
197  CALL chkxer( 'CGERFS', infot, nout, lerr, ok )
198  infot = 2
199  CALL cgerfs( 'N', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
200  $ w, r, info )
201  CALL chkxer( 'CGERFS', infot, nout, lerr, ok )
202  infot = 3
203  CALL cgerfs( 'N', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
204  $ w, r, info )
205  CALL chkxer( 'CGERFS', infot, nout, lerr, ok )
206  infot = 5
207  CALL cgerfs( 'N', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
208  $ r, info )
209  CALL chkxer( 'CGERFS', infot, nout, lerr, ok )
210  infot = 7
211  CALL cgerfs( 'N', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
212  $ r, info )
213  CALL chkxer( 'CGERFS', infot, nout, lerr, ok )
214  infot = 10
215  CALL cgerfs( 'N', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
216  $ r, info )
217  CALL chkxer( 'CGERFS', infot, nout, lerr, ok )
218  infot = 12
219  CALL cgerfs( 'N', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
220  $ r, info )
221  CALL chkxer( 'CGERFS', infot, nout, lerr, ok )
222 *
223 * CGECON
224 *
225  srnamt = 'CGECON'
226  infot = 1
227  CALL cgecon( '/', 0, a, 1, anrm, rcond, w, r, info )
228  CALL chkxer( 'CGECON', infot, nout, lerr, ok )
229  infot = 2
230  CALL cgecon( '1', -1, a, 1, anrm, rcond, w, r, info )
231  CALL chkxer( 'CGECON', infot, nout, lerr, ok )
232  infot = 4
233  CALL cgecon( '1', 2, a, 1, anrm, rcond, w, r, info )
234  CALL chkxer( 'CGECON', infot, nout, lerr, ok )
235 *
236 * CGEEQU
237 *
238  srnamt = 'CGEEQU'
239  infot = 1
240  CALL cgeequ( -1, 0, a, 1, r1, r2, rcond, ccond, anrm, info )
241  CALL chkxer( 'CGEEQU', infot, nout, lerr, ok )
242  infot = 2
243  CALL cgeequ( 0, -1, a, 1, r1, r2, rcond, ccond, anrm, info )
244  CALL chkxer( 'CGEEQU', infot, nout, lerr, ok )
245  infot = 4
246  CALL cgeequ( 2, 2, a, 1, r1, r2, rcond, ccond, anrm, info )
247  CALL chkxer( 'CGEEQU', infot, nout, lerr, ok )
248 *
249 * Test error exits of the routines that use the LU decomposition
250 * of a general band matrix.
251 *
252  ELSE IF( lsamen( 2, c2, 'GB' ) ) THEN
253 *
254 * CGBTRF
255 *
256  srnamt = 'CGBTRF'
257  infot = 1
258  CALL cgbtrf( -1, 0, 0, 0, a, 1, ip, info )
259  CALL chkxer( 'CGBTRF', infot, nout, lerr, ok )
260  infot = 2
261  CALL cgbtrf( 0, -1, 0, 0, a, 1, ip, info )
262  CALL chkxer( 'CGBTRF', infot, nout, lerr, ok )
263  infot = 3
264  CALL cgbtrf( 1, 1, -1, 0, a, 1, ip, info )
265  CALL chkxer( 'CGBTRF', infot, nout, lerr, ok )
266  infot = 4
267  CALL cgbtrf( 1, 1, 0, -1, a, 1, ip, info )
268  CALL chkxer( 'CGBTRF', infot, nout, lerr, ok )
269  infot = 6
270  CALL cgbtrf( 2, 2, 1, 1, a, 3, ip, info )
271  CALL chkxer( 'CGBTRF', infot, nout, lerr, ok )
272 *
273 * CGBTF2
274 *
275  srnamt = 'CGBTF2'
276  infot = 1
277  CALL cgbtf2( -1, 0, 0, 0, a, 1, ip, info )
278  CALL chkxer( 'CGBTF2', infot, nout, lerr, ok )
279  infot = 2
280  CALL cgbtf2( 0, -1, 0, 0, a, 1, ip, info )
281  CALL chkxer( 'CGBTF2', infot, nout, lerr, ok )
282  infot = 3
283  CALL cgbtf2( 1, 1, -1, 0, a, 1, ip, info )
284  CALL chkxer( 'CGBTF2', infot, nout, lerr, ok )
285  infot = 4
286  CALL cgbtf2( 1, 1, 0, -1, a, 1, ip, info )
287  CALL chkxer( 'CGBTF2', infot, nout, lerr, ok )
288  infot = 6
289  CALL cgbtf2( 2, 2, 1, 1, a, 3, ip, info )
290  CALL chkxer( 'CGBTF2', infot, nout, lerr, ok )
291 *
292 * CGBTRS
293 *
294  srnamt = 'CGBTRS'
295  infot = 1
296  CALL cgbtrs( '/', 0, 0, 0, 1, a, 1, ip, b, 1, info )
297  CALL chkxer( 'CGBTRS', infot, nout, lerr, ok )
298  infot = 2
299  CALL cgbtrs( 'N', -1, 0, 0, 1, a, 1, ip, b, 1, info )
300  CALL chkxer( 'CGBTRS', infot, nout, lerr, ok )
301  infot = 3
302  CALL cgbtrs( 'N', 1, -1, 0, 1, a, 1, ip, b, 1, info )
303  CALL chkxer( 'CGBTRS', infot, nout, lerr, ok )
304  infot = 4
305  CALL cgbtrs( 'N', 1, 0, -1, 1, a, 1, ip, b, 1, info )
306  CALL chkxer( 'CGBTRS', infot, nout, lerr, ok )
307  infot = 5
308  CALL cgbtrs( 'N', 1, 0, 0, -1, a, 1, ip, b, 1, info )
309  CALL chkxer( 'CGBTRS', infot, nout, lerr, ok )
310  infot = 7
311  CALL cgbtrs( 'N', 2, 1, 1, 1, a, 3, ip, b, 2, info )
312  CALL chkxer( 'CGBTRS', infot, nout, lerr, ok )
313  infot = 10
314  CALL cgbtrs( 'N', 2, 0, 0, 1, a, 1, ip, b, 1, info )
315  CALL chkxer( 'CGBTRS', infot, nout, lerr, ok )
316 *
317 * CGBRFS
318 *
319  srnamt = 'CGBRFS'
320  infot = 1
321  CALL cgbrfs( '/', 0, 0, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
322  $ r2, w, r, info )
323  CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
324  infot = 2
325  CALL cgbrfs( 'N', -1, 0, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
326  $ r2, w, r, info )
327  CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
328  infot = 3
329  CALL cgbrfs( 'N', 1, -1, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
330  $ r2, w, r, info )
331  CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
332  infot = 4
333  CALL cgbrfs( 'N', 1, 0, -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
334  $ r2, w, r, info )
335  CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
336  infot = 5
337  CALL cgbrfs( 'N', 1, 0, 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1,
338  $ r2, w, r, info )
339  CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
340  infot = 7
341  CALL cgbrfs( 'N', 2, 1, 1, 1, a, 2, af, 4, ip, b, 2, x, 2, r1,
342  $ r2, w, r, info )
343  CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
344  infot = 9
345  CALL cgbrfs( 'N', 2, 1, 1, 1, a, 3, af, 3, ip, b, 2, x, 2, r1,
346  $ r2, w, r, info )
347  CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
348  infot = 12
349  CALL cgbrfs( 'N', 2, 0, 0, 1, a, 1, af, 1, ip, b, 1, x, 2, r1,
350  $ r2, w, r, info )
351  CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
352  infot = 14
353  CALL cgbrfs( 'N', 2, 0, 0, 1, a, 1, af, 1, ip, b, 2, x, 1, r1,
354  $ r2, w, r, info )
355  CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
356 *
357 * CGBCON
358 *
359  srnamt = 'CGBCON'
360  infot = 1
361  CALL cgbcon( '/', 0, 0, 0, a, 1, ip, anrm, rcond, w, r, info )
362  CALL chkxer( 'CGBCON', infot, nout, lerr, ok )
363  infot = 2
364  CALL cgbcon( '1', -1, 0, 0, a, 1, ip, anrm, rcond, w, r, info )
365  CALL chkxer( 'CGBCON', infot, nout, lerr, ok )
366  infot = 3
367  CALL cgbcon( '1', 1, -1, 0, a, 1, ip, anrm, rcond, w, r, info )
368  CALL chkxer( 'CGBCON', infot, nout, lerr, ok )
369  infot = 4
370  CALL cgbcon( '1', 1, 0, -1, a, 1, ip, anrm, rcond, w, r, info )
371  CALL chkxer( 'CGBCON', infot, nout, lerr, ok )
372  infot = 6
373  CALL cgbcon( '1', 2, 1, 1, a, 3, ip, anrm, rcond, w, r, info )
374  CALL chkxer( 'CGBCON', infot, nout, lerr, ok )
375 *
376 * CGBEQU
377 *
378  srnamt = 'CGBEQU'
379  infot = 1
380  CALL cgbequ( -1, 0, 0, 0, a, 1, r1, r2, rcond, ccond, anrm,
381  $ info )
382  CALL chkxer( 'CGBEQU', infot, nout, lerr, ok )
383  infot = 2
384  CALL cgbequ( 0, -1, 0, 0, a, 1, r1, r2, rcond, ccond, anrm,
385  $ info )
386  CALL chkxer( 'CGBEQU', infot, nout, lerr, ok )
387  infot = 3
388  CALL cgbequ( 1, 1, -1, 0, a, 1, r1, r2, rcond, ccond, anrm,
389  $ info )
390  CALL chkxer( 'CGBEQU', infot, nout, lerr, ok )
391  infot = 4
392  CALL cgbequ( 1, 1, 0, -1, a, 1, r1, r2, rcond, ccond, anrm,
393  $ info )
394  CALL chkxer( 'CGBEQU', infot, nout, lerr, ok )
395  infot = 6
396  CALL cgbequ( 2, 2, 1, 1, a, 2, r1, r2, rcond, ccond, anrm,
397  $ info )
398  CALL chkxer( 'CGBEQU', 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 CERRGE
408 *
409  END