LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
cerrsy.f
Go to the documentation of this file.
1 *> \brief \b CERRSY
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 *> \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 April 2012
52 *
53 *> \ingroup complex_lin
54 *
55 * =====================================================================
56  SUBROUTINE cerrsy( PATH, NUNIT )
57 *
58 * -- LAPACK test routine (version 3.4.1) --
59 * -- LAPACK is a software package provided by Univ. of Tennessee, --
60 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
61 * April 2012
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, 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, chkxer, cspcon, csprfs, csptrf, csptri,
91  $ csptrs, csycon, csyrfs, csytf2, csytrf, csytri,
92  $ csytri2, csytrs
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  anrm = 1.0
127  ok = .true.
128 *
129  IF( lsamen( 2, c2, 'SY' ) ) THEN
130 *
131 * Test error exits of the routines that use factorization
132 * of a symmetric indefinite matrix with patrial
133 * (Bunch-Kaufman) pivoting.
134 *
135 * CSYTRF
136 *
137  srnamt = 'CSYTRF'
138  infot = 1
139  CALL csytrf( '/', 0, a, 1, ip, w, 1, info )
140  CALL chkxer( 'CSYTRF', infot, nout, lerr, ok )
141  infot = 2
142  CALL csytrf( 'U', -1, a, 1, ip, w, 1, info )
143  CALL chkxer( 'CSYTRF', infot, nout, lerr, ok )
144  infot = 4
145  CALL csytrf( 'U', 2, a, 1, ip, w, 4, info )
146  CALL chkxer( 'CSYTRF', infot, nout, lerr, ok )
147 *
148 * CSYTF2
149 *
150  srnamt = 'CSYTF2'
151  infot = 1
152  CALL csytf2( '/', 0, a, 1, ip, info )
153  CALL chkxer( 'CSYTF2', infot, nout, lerr, ok )
154  infot = 2
155  CALL csytf2( 'U', -1, a, 1, ip, info )
156  CALL chkxer( 'CSYTF2', infot, nout, lerr, ok )
157  infot = 4
158  CALL csytf2( 'U', 2, a, 1, ip, info )
159  CALL chkxer( 'CSYTF2', infot, nout, lerr, ok )
160 *
161 * CSYTRI
162 *
163  srnamt = 'CSYTRI'
164  infot = 1
165  CALL csytri( '/', 0, a, 1, ip, w, info )
166  CALL chkxer( 'CSYTRI', infot, nout, lerr, ok )
167  infot = 2
168  CALL csytri( 'U', -1, a, 1, ip, w, info )
169  CALL chkxer( 'CSYTRI', infot, nout, lerr, ok )
170  infot = 4
171  CALL csytri( 'U', 2, a, 1, ip, w, info )
172  CALL chkxer( 'CSYTRI', infot, nout, lerr, ok )
173 *
174 * CSYTRI2
175 *
176  srnamt = 'CSYTRI2'
177  infot = 1
178  CALL csytri2( '/', 0, a, 1, ip, w, 1, info )
179  CALL chkxer( 'CSYTRI2', infot, nout, lerr, ok )
180  infot = 2
181  CALL csytri2( 'U', -1, a, 1, ip, w, 1, info )
182  CALL chkxer( 'CSYTRI2', infot, nout, lerr, ok )
183  infot = 4
184  CALL csytri2( 'U', 2, a, 1, ip, w, 1, info )
185  CALL chkxer( 'CSYTRI2', infot, nout, lerr, ok )
186 *
187 * CSYTRS
188 *
189  srnamt = 'CSYTRS'
190  infot = 1
191  CALL csytrs( '/', 0, 0, a, 1, ip, b, 1, info )
192  CALL chkxer( 'CSYTRS', infot, nout, lerr, ok )
193  infot = 2
194  CALL csytrs( 'U', -1, 0, a, 1, ip, b, 1, info )
195  CALL chkxer( 'CSYTRS', infot, nout, lerr, ok )
196  infot = 3
197  CALL csytrs( 'U', 0, -1, a, 1, ip, b, 1, info )
198  CALL chkxer( 'CSYTRS', infot, nout, lerr, ok )
199  infot = 5
200  CALL csytrs( 'U', 2, 1, a, 1, ip, b, 2, info )
201  CALL chkxer( 'CSYTRS', infot, nout, lerr, ok )
202  infot = 8
203  CALL csytrs( 'U', 2, 1, a, 2, ip, b, 1, info )
204  CALL chkxer( 'CSYTRS', infot, nout, lerr, ok )
205 *
206 * CSYRFS
207 *
208  srnamt = 'CSYRFS'
209  infot = 1
210  CALL csyrfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
211  $ r, info )
212  CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
213  infot = 2
214  CALL csyrfs( 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
215  $ w, r, info )
216  CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
217  infot = 3
218  CALL csyrfs( 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
219  $ w, r, info )
220  CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
221  infot = 5
222  CALL csyrfs( 'U', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
223  $ r, info )
224  CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
225  infot = 7
226  CALL csyrfs( 'U', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
227  $ r, info )
228  CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
229  infot = 10
230  CALL csyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
231  $ r, info )
232  CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
233  infot = 12
234  CALL csyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
235  $ r, info )
236  CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
237 *
238 * CSYCON
239 *
240  srnamt = 'CSYCON'
241  infot = 1
242  CALL csycon( '/', 0, a, 1, ip, anrm, rcond, w, info )
243  CALL chkxer( 'CSYCON', infot, nout, lerr, ok )
244  infot = 2
245  CALL csycon( 'U', -1, a, 1, ip, anrm, rcond, w, info )
246  CALL chkxer( 'CSYCON', infot, nout, lerr, ok )
247  infot = 4
248  CALL csycon( 'U', 2, a, 1, ip, anrm, rcond, w, info )
249  CALL chkxer( 'CSYCON', infot, nout, lerr, ok )
250  infot = 6
251  CALL csycon( 'U', 1, a, 1, ip, -anrm, rcond, w, info )
252  CALL chkxer( 'CSYCON', infot, nout, lerr, ok )
253 *
254  ELSE IF( lsamen( 2, c2, 'SP' ) ) THEN
255 *
256 * Test error exits of the routines that use factorization
257 * of a symmetric indefinite packed matrix with patrial
258 * (Bunch-Kaufman) pivoting.
259 *
260 * CSPTRF
261 *
262  srnamt = 'CSPTRF'
263  infot = 1
264  CALL csptrf( '/', 0, a, ip, info )
265  CALL chkxer( 'CSPTRF', infot, nout, lerr, ok )
266  infot = 2
267  CALL csptrf( 'U', -1, a, ip, info )
268  CALL chkxer( 'CSPTRF', infot, nout, lerr, ok )
269 *
270 * CSPTRI
271 *
272  srnamt = 'CSPTRI'
273  infot = 1
274  CALL csptri( '/', 0, a, ip, w, info )
275  CALL chkxer( 'CSPTRI', infot, nout, lerr, ok )
276  infot = 2
277  CALL csptri( 'U', -1, a, ip, w, info )
278  CALL chkxer( 'CSPTRI', infot, nout, lerr, ok )
279 *
280 * CSPTRS
281 *
282  srnamt = 'CSPTRS'
283  infot = 1
284  CALL csptrs( '/', 0, 0, a, ip, b, 1, info )
285  CALL chkxer( 'CSPTRS', infot, nout, lerr, ok )
286  infot = 2
287  CALL csptrs( 'U', -1, 0, a, ip, b, 1, info )
288  CALL chkxer( 'CSPTRS', infot, nout, lerr, ok )
289  infot = 3
290  CALL csptrs( 'U', 0, -1, a, ip, b, 1, info )
291  CALL chkxer( 'CSPTRS', infot, nout, lerr, ok )
292  infot = 7
293  CALL csptrs( 'U', 2, 1, a, ip, b, 1, info )
294  CALL chkxer( 'CSPTRS', infot, nout, lerr, ok )
295 *
296 * CSPRFS
297 *
298  srnamt = 'CSPRFS'
299  infot = 1
300  CALL csprfs( '/', 0, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
301  $ info )
302  CALL chkxer( 'CSPRFS', infot, nout, lerr, ok )
303  infot = 2
304  CALL csprfs( 'U', -1, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
305  $ info )
306  CALL chkxer( 'CSPRFS', infot, nout, lerr, ok )
307  infot = 3
308  CALL csprfs( 'U', 0, -1, a, af, ip, b, 1, x, 1, r1, r2, w, r,
309  $ info )
310  CALL chkxer( 'CSPRFS', infot, nout, lerr, ok )
311  infot = 8
312  CALL csprfs( 'U', 2, 1, a, af, ip, b, 1, x, 2, r1, r2, w, r,
313  $ info )
314  CALL chkxer( 'CSPRFS', infot, nout, lerr, ok )
315  infot = 10
316  CALL csprfs( 'U', 2, 1, a, af, ip, b, 2, x, 1, r1, r2, w, r,
317  $ info )
318  CALL chkxer( 'CSPRFS', infot, nout, lerr, ok )
319 *
320 * CSPCON
321 *
322  srnamt = 'CSPCON'
323  infot = 1
324  CALL cspcon( '/', 0, a, ip, anrm, rcond, w, info )
325  CALL chkxer( 'CSPCON', infot, nout, lerr, ok )
326  infot = 2
327  CALL cspcon( 'U', -1, a, ip, anrm, rcond, w, info )
328  CALL chkxer( 'CSPCON', infot, nout, lerr, ok )
329  infot = 5
330  CALL cspcon( 'U', 1, a, ip, -anrm, rcond, w, info )
331  CALL chkxer( 'CSPCON', infot, nout, lerr, ok )
332  END IF
333 *
334 * Print a summary line.
335 *
336  CALL alaesm( path, ok, nout )
337 *
338  return
339 *
340 * End of CERRSY
341 *
342  END