LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
cerrsyx.f
Go to the documentation of this file.
1 *> \brief \b CERRSYX
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 CERRSY( 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 *> CERRSY tests the error exits for the COMPLEX routines
25 *> for symmetric indefinite matrices.
26 *>
27 *> Note that this file is used only when the XBLAS are available,
28 *> otherwise cerrsy.f defines this subroutine.
29 *> \endverbatim
30 *
31 * Arguments:
32 * ==========
33 *
34 *> \param[in] PATH
35 *> \verbatim
36 *> PATH is CHARACTER*3
37 *> The LAPACK path name for the routines to be tested.
38 *> \endverbatim
39 *>
40 *> \param[in] NUNIT
41 *> \verbatim
42 *> NUNIT is INTEGER
43 *> The unit number for output.
44 *> \endverbatim
45 *
46 * Authors:
47 * ========
48 *
49 *> \author Univ. of Tennessee
50 *> \author Univ. of California Berkeley
51 *> \author Univ. of Colorado Denver
52 *> \author NAG Ltd.
53 *
54 *> \date November 2011
55 *
56 *> \ingroup complex_lin
57 *
58 * =====================================================================
59  SUBROUTINE cerrsy( PATH, NUNIT )
60 *
61 * -- LAPACK test routine (version 3.4.0) --
62 * -- LAPACK is a software package provided by Univ. of Tennessee, --
63 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
64 * November 2011
65 *
66 * .. Scalar Arguments ..
67  CHARACTER*3 path
68  INTEGER nunit
69 * ..
70 *
71 * =====================================================================
72 *
73 * .. Parameters ..
74  INTEGER nmax
75  parameter( nmax = 4 )
76 * ..
77 * .. Local Scalars ..
78  CHARACTER eq
79  CHARACTER*2 c2
80  INTEGER i, info, j, n_err_bnds, nparams
81  REAL anrm, rcond, berr
82 * ..
83 * .. Local Arrays ..
84  INTEGER ip( nmax )
85  REAL r( nmax ), r1( nmax ), r2( nmax ),
86  $ s( nmax ), err_bnds_n( nmax, 3 ),
87  $ err_bnds_c( nmax, 3 ), params( 1 )
88  COMPLEX a( nmax, nmax ), af( nmax, nmax ), b( nmax ),
89  $ w( 2*nmax ), x( nmax )
90 * ..
91 * .. External Functions ..
92  LOGICAL lsamen
93  EXTERNAL lsamen
94 * ..
95 * .. External Subroutines ..
96  EXTERNAL alaesm, chkxer, cspcon, csprfs, csptrf, csptri,
97  $ csptrs, csycon, csyrfs, csytf2, csytrf, csytri,
98  $ csytri2, csytrs, csyrfsx
99 * ..
100 * .. Scalars in Common ..
101  LOGICAL lerr, ok
102  CHARACTER*32 srnamt
103  INTEGER infot, nout
104 * ..
105 * .. Common blocks ..
106  common / infoc / infot, nout, ok, lerr
107  common / srnamc / srnamt
108 * ..
109 * .. Intrinsic Functions ..
110  INTRINSIC cmplx, real
111 * ..
112 * .. Executable Statements ..
113 *
114  nout = nunit
115  WRITE( nout, fmt = * )
116  c2 = path( 2: 3 )
117 *
118 * Set the variables to innocuous values.
119 *
120  DO 20 j = 1, nmax
121  DO 10 i = 1, nmax
122  a( i, j ) = cmplx( 1. / REAL( I+J ), -1. / REAL( I+J ) )
123  af( i, j ) = cmplx( 1. / REAL( I+J ), -1. / REAL( I+J ) )
124  10 continue
125  b( j ) = 0.
126  r1( j ) = 0.
127  r2( j ) = 0.
128  w( j ) = 0.
129  x( j ) = 0.
130  s( j ) = 0.
131  ip( j ) = j
132  20 continue
133  anrm = 1.0
134  ok = .true.
135 *
136 * Test error exits of the routines that use the diagonal pivoting
137 * factorization of a symmetric indefinite matrix.
138 *
139  IF( lsamen( 2, c2, 'SY' ) ) THEN
140 *
141 * CSYTRF
142 *
143  srnamt = 'CSYTRF'
144  infot = 1
145  CALL csytrf( '/', 0, a, 1, ip, w, 1, info )
146  CALL chkxer( 'CSYTRF', infot, nout, lerr, ok )
147  infot = 2
148  CALL csytrf( 'U', -1, a, 1, ip, w, 1, info )
149  CALL chkxer( 'CSYTRF', infot, nout, lerr, ok )
150  infot = 4
151  CALL csytrf( 'U', 2, a, 1, ip, w, 4, info )
152  CALL chkxer( 'CSYTRF', infot, nout, lerr, ok )
153 *
154 * CSYTF2
155 *
156  srnamt = 'CSYTF2'
157  infot = 1
158  CALL csytf2( '/', 0, a, 1, ip, info )
159  CALL chkxer( 'CSYTF2', infot, nout, lerr, ok )
160  infot = 2
161  CALL csytf2( 'U', -1, a, 1, ip, info )
162  CALL chkxer( 'CSYTF2', infot, nout, lerr, ok )
163  infot = 4
164  CALL csytf2( 'U', 2, a, 1, ip, info )
165  CALL chkxer( 'CSYTF2', infot, nout, lerr, ok )
166 *
167 * CSYTRI
168 *
169  srnamt = 'CSYTRI'
170  infot = 1
171  CALL csytri( '/', 0, a, 1, ip, w, info )
172  CALL chkxer( 'CSYTRI', infot, nout, lerr, ok )
173  infot = 2
174  CALL csytri( 'U', -1, a, 1, ip, w, info )
175  CALL chkxer( 'CSYTRI', infot, nout, lerr, ok )
176  infot = 4
177  CALL csytri( 'U', 2, a, 1, ip, w, info )
178  CALL chkxer( 'CSYTRI', infot, nout, lerr, ok )
179 *
180 * CSYTRI2
181 *
182  srnamt = 'CSYTRI2'
183  infot = 1
184  CALL csytri2( '/', 0, a, 1, ip, w, 1, info )
185  CALL chkxer( 'CSYTRI2', infot, nout, lerr, ok )
186  infot = 2
187  CALL csytri2( 'U', -1, a, 1, ip, w, 1, info )
188  CALL chkxer( 'CSYTRI2', infot, nout, lerr, ok )
189  infot = 4
190  CALL csytri2( 'U', 2, a, 1, ip, w, 1, info )
191  CALL chkxer( 'CSYTRI2', infot, nout, lerr, ok )
192 *
193 * CSYTRS
194 *
195  srnamt = 'CSYTRS'
196  infot = 1
197  CALL csytrs( '/', 0, 0, a, 1, ip, b, 1, info )
198  CALL chkxer( 'CSYTRS', infot, nout, lerr, ok )
199  infot = 2
200  CALL csytrs( 'U', -1, 0, a, 1, ip, b, 1, info )
201  CALL chkxer( 'CSYTRS', infot, nout, lerr, ok )
202  infot = 3
203  CALL csytrs( 'U', 0, -1, a, 1, ip, b, 1, info )
204  CALL chkxer( 'CSYTRS', infot, nout, lerr, ok )
205  infot = 5
206  CALL csytrs( 'U', 2, 1, a, 1, ip, b, 2, info )
207  CALL chkxer( 'CSYTRS', infot, nout, lerr, ok )
208  infot = 8
209  CALL csytrs( 'U', 2, 1, a, 2, ip, b, 1, info )
210  CALL chkxer( 'CSYTRS', infot, nout, lerr, ok )
211 *
212 * CSYRFS
213 *
214  srnamt = 'CSYRFS'
215  infot = 1
216  CALL csyrfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
217  $ r, info )
218  CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
219  infot = 2
220  CALL csyrfs( 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
221  $ w, r, info )
222  CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
223  infot = 3
224  CALL csyrfs( 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
225  $ w, r, info )
226  CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
227  infot = 5
228  CALL csyrfs( 'U', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
229  $ r, info )
230  CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
231  infot = 7
232  CALL csyrfs( 'U', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
233  $ r, info )
234  CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
235  infot = 10
236  CALL csyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
237  $ r, info )
238  CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
239  infot = 12
240  CALL csyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
241  $ r, info )
242  CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
243 *
244 * CSYRFSX
245 *
246  n_err_bnds = 3
247  nparams = 0
248  srnamt = 'CSYRFSX'
249  infot = 1
250  CALL csyrfsx( '/', eq, 0, 0, a, 1, af, 1, ip, s, b, 1, x, 1,
251  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
252  $ params, w, r, info )
253  CALL chkxer( 'CSYRFSX', infot, nout, lerr, ok )
254  infot = 2
255  CALL csyrfsx( 'U', eq, -1, 0, a, 1, af, 1, ip, s, b, 1, x, 1,
256  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
257  $ params, w, r, info )
258  CALL chkxer( 'CSYRFSX', infot, nout, lerr, ok )
259  eq = 'N'
260  infot = 3
261  CALL csyrfsx( 'U', eq, -1, 0, a, 1, af, 1, ip, s, b, 1, x, 1,
262  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
263  $ params, w, r, info )
264  CALL chkxer( 'CSYRFSX', infot, nout, lerr, ok )
265  infot = 4
266  CALL csyrfsx( 'U', eq, 0, -1, a, 1, af, 1, ip, s, b, 1, x, 1,
267  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
268  $ params, w, r, info )
269  CALL chkxer( 'CSYRFSX', infot, nout, lerr, ok )
270  infot = 6
271  CALL csyrfsx( 'U', eq, 2, 1, a, 1, af, 2, ip, s, b, 2, x, 2,
272  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
273  $ params, w, r, info )
274  CALL chkxer( 'CSYRFSX', infot, nout, lerr, ok )
275  infot = 8
276  CALL csyrfsx( 'U', eq, 2, 1, a, 2, af, 1, ip, s, b, 2, x, 2,
277  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
278  $ params, w, r, info )
279  CALL chkxer( 'CSYRFSX', infot, nout, lerr, ok )
280  infot = 12
281  CALL csyrfsx( 'U', eq, 2, 1, a, 2, af, 2, ip, s, b, 1, x, 2,
282  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
283  $ params, w, r, info )
284  CALL chkxer( 'CSYRFSX', infot, nout, lerr, ok )
285  infot = 14
286  CALL csyrfsx( 'U', eq, 2, 1, a, 2, af, 2, ip, s, b, 2, x, 1,
287  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
288  $ params, w, r, info )
289  CALL chkxer( 'CSYRFSX', infot, nout, lerr, ok )
290 *
291 * CSYCON
292 *
293  srnamt = 'CSYCON'
294  infot = 1
295  CALL csycon( '/', 0, a, 1, ip, anrm, rcond, w, info )
296  CALL chkxer( 'CSYCON', infot, nout, lerr, ok )
297  infot = 2
298  CALL csycon( 'U', -1, a, 1, ip, anrm, rcond, w, info )
299  CALL chkxer( 'CSYCON', infot, nout, lerr, ok )
300  infot = 4
301  CALL csycon( 'U', 2, a, 1, ip, anrm, rcond, w, info )
302  CALL chkxer( 'CSYCON', infot, nout, lerr, ok )
303  infot = 6
304  CALL csycon( 'U', 1, a, 1, ip, -anrm, rcond, w, info )
305  CALL chkxer( 'CSYCON', infot, nout, lerr, ok )
306 *
307 * Test error exits of the routines that use the diagonal pivoting
308 * factorization of a symmetric indefinite packed matrix.
309 *
310  ELSE IF( lsamen( 2, c2, 'SP' ) ) THEN
311 *
312 * CSPTRF
313 *
314  srnamt = 'CSPTRF'
315  infot = 1
316  CALL csptrf( '/', 0, a, ip, info )
317  CALL chkxer( 'CSPTRF', infot, nout, lerr, ok )
318  infot = 2
319  CALL csptrf( 'U', -1, a, ip, info )
320  CALL chkxer( 'CSPTRF', infot, nout, lerr, ok )
321 *
322 * CSPTRI
323 *
324  srnamt = 'CSPTRI'
325  infot = 1
326  CALL csptri( '/', 0, a, ip, w, info )
327  CALL chkxer( 'CSPTRI', infot, nout, lerr, ok )
328  infot = 2
329  CALL csptri( 'U', -1, a, ip, w, info )
330  CALL chkxer( 'CSPTRI', infot, nout, lerr, ok )
331 *
332 * CSPTRS
333 *
334  srnamt = 'CSPTRS'
335  infot = 1
336  CALL csptrs( '/', 0, 0, a, ip, b, 1, info )
337  CALL chkxer( 'CSPTRS', infot, nout, lerr, ok )
338  infot = 2
339  CALL csptrs( 'U', -1, 0, a, ip, b, 1, info )
340  CALL chkxer( 'CSPTRS', infot, nout, lerr, ok )
341  infot = 3
342  CALL csptrs( 'U', 0, -1, a, ip, b, 1, info )
343  CALL chkxer( 'CSPTRS', infot, nout, lerr, ok )
344  infot = 7
345  CALL csptrs( 'U', 2, 1, a, ip, b, 1, info )
346  CALL chkxer( 'CSPTRS', infot, nout, lerr, ok )
347 *
348 * CSPRFS
349 *
350  srnamt = 'CSPRFS'
351  infot = 1
352  CALL csprfs( '/', 0, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
353  $ info )
354  CALL chkxer( 'CSPRFS', infot, nout, lerr, ok )
355  infot = 2
356  CALL csprfs( 'U', -1, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
357  $ info )
358  CALL chkxer( 'CSPRFS', infot, nout, lerr, ok )
359  infot = 3
360  CALL csprfs( 'U', 0, -1, a, af, ip, b, 1, x, 1, r1, r2, w, r,
361  $ info )
362  CALL chkxer( 'CSPRFS', infot, nout, lerr, ok )
363  infot = 8
364  CALL csprfs( 'U', 2, 1, a, af, ip, b, 1, x, 2, r1, r2, w, r,
365  $ info )
366  CALL chkxer( 'CSPRFS', infot, nout, lerr, ok )
367  infot = 10
368  CALL csprfs( 'U', 2, 1, a, af, ip, b, 2, x, 1, r1, r2, w, r,
369  $ info )
370  CALL chkxer( 'CSPRFS', infot, nout, lerr, ok )
371 *
372 * CSPCON
373 *
374  srnamt = 'CSPCON'
375  infot = 1
376  CALL cspcon( '/', 0, a, ip, anrm, rcond, w, info )
377  CALL chkxer( 'CSPCON', infot, nout, lerr, ok )
378  infot = 2
379  CALL cspcon( 'U', -1, a, ip, anrm, rcond, w, info )
380  CALL chkxer( 'CSPCON', infot, nout, lerr, ok )
381  infot = 5
382  CALL cspcon( 'U', 1, a, ip, -anrm, rcond, w, info )
383  CALL chkxer( 'CSPCON', infot, nout, lerr, ok )
384  END IF
385 *
386 * Print a summary line.
387 *
388  CALL alaesm( path, ok, nout )
389 *
390  return
391 *
392 * End of CERRSY
393 *
394  END