LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
zerrsyx.f
Go to the documentation of this file.
1 *> \brief \b ZERRSYX
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 ZERRSY( 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 *> ZERRSY tests the error exits for the COMPLEX*16 routines
25 *> for symmetric indefinite matrices.
26 *>
27 *> Note that this file is used only when the XBLAS are available,
28 *> otherwise zerrsy.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 complex16_lin
57 *
58 * =====================================================================
59  SUBROUTINE zerrsy( 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  DOUBLE PRECISION anrm, rcond, berr
82 * ..
83 * .. Local Arrays ..
84  INTEGER ip( nmax )
85  DOUBLE PRECISION r( nmax ), r1( nmax ), r2( nmax ),
86  $ s( nmax ), err_bnds_n( nmax, 3 ),
87  $ err_bnds_c( nmax, 3 ), params( 1 )
88  COMPLEX*16 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, zspcon, zsprfs, zsptrf, zsptri,
97  $ zsptrs, zsycon, zsyrfs, zsytf2, zsytrf, zsytri,
98  $ zsytri2, zsytrs, zsyrfsx
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 dble, dcmplx
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 ) = dcmplx( 1.d0 / dble( i+j ),
123  $ -1.d0 / dble( i+j ) )
124  af( i, j ) = dcmplx( 1.d0 / dble( i+j ),
125  $ -1.d0 / dble( i+j ) )
126  10 continue
127  b( j ) = 0.d0
128  r1( j ) = 0.d0
129  r2( j ) = 0.d0
130  w( j ) = 0.d0
131  x( j ) = 0.d0
132  s( j ) = 0.d0
133  ip( j ) = j
134  20 continue
135  anrm = 1.0d0
136  ok = .true.
137 *
138 * Test error exits of the routines that use the diagonal pivoting
139 * factorization of a symmetric indefinite matrix.
140 *
141  IF( lsamen( 2, c2, 'SY' ) ) THEN
142 *
143 * ZSYTRF
144 *
145  srnamt = 'ZSYTRF'
146  infot = 1
147  CALL zsytrf( '/', 0, a, 1, ip, w, 1, info )
148  CALL chkxer( 'ZSYTRF', infot, nout, lerr, ok )
149  infot = 2
150  CALL zsytrf( 'U', -1, a, 1, ip, w, 1, info )
151  CALL chkxer( 'ZSYTRF', infot, nout, lerr, ok )
152  infot = 4
153  CALL zsytrf( 'U', 2, a, 1, ip, w, 4, info )
154  CALL chkxer( 'ZSYTRF', infot, nout, lerr, ok )
155 *
156 * ZSYTF2
157 *
158  srnamt = 'ZSYTF2'
159  infot = 1
160  CALL zsytf2( '/', 0, a, 1, ip, info )
161  CALL chkxer( 'ZSYTF2', infot, nout, lerr, ok )
162  infot = 2
163  CALL zsytf2( 'U', -1, a, 1, ip, info )
164  CALL chkxer( 'ZSYTF2', infot, nout, lerr, ok )
165  infot = 4
166  CALL zsytf2( 'U', 2, a, 1, ip, info )
167  CALL chkxer( 'ZSYTF2', infot, nout, lerr, ok )
168 *
169 * ZSYTRI
170 *
171  srnamt = 'ZSYTRI'
172  infot = 1
173  CALL zsytri( '/', 0, a, 1, ip, w, info )
174  CALL chkxer( 'ZSYTRI', infot, nout, lerr, ok )
175  infot = 2
176  CALL zsytri( 'U', -1, a, 1, ip, w, info )
177  CALL chkxer( 'ZSYTRI', infot, nout, lerr, ok )
178  infot = 4
179  CALL zsytri( 'U', 2, a, 1, ip, w, info )
180  CALL chkxer( 'ZSYTRI', infot, nout, lerr, ok )
181 *
182 * ZSYTRI2
183 *
184  srnamt = 'ZSYTRI2'
185  infot = 1
186  CALL zsytri2( '/', 0, a, 1, ip, w, 1, info )
187  CALL chkxer( 'ZSYTRI2', infot, nout, lerr, ok )
188  infot = 2
189  CALL zsytri2( 'U', -1, a, 1, ip, w, 1, info )
190  CALL chkxer( 'ZSYTRI2', infot, nout, lerr, ok )
191  infot = 4
192  CALL zsytri2( 'U', 2, a, 1, ip, w, 1, info )
193  CALL chkxer( 'ZSYTRI2', infot, nout, lerr, ok )
194 *
195 * ZSYTRS
196 *
197  srnamt = 'ZSYTRS'
198  infot = 1
199  CALL zsytrs( '/', 0, 0, a, 1, ip, b, 1, info )
200  CALL chkxer( 'ZSYTRS', infot, nout, lerr, ok )
201  infot = 2
202  CALL zsytrs( 'U', -1, 0, a, 1, ip, b, 1, info )
203  CALL chkxer( 'ZSYTRS', infot, nout, lerr, ok )
204  infot = 3
205  CALL zsytrs( 'U', 0, -1, a, 1, ip, b, 1, info )
206  CALL chkxer( 'ZSYTRS', infot, nout, lerr, ok )
207  infot = 5
208  CALL zsytrs( 'U', 2, 1, a, 1, ip, b, 2, info )
209  CALL chkxer( 'ZSYTRS', infot, nout, lerr, ok )
210  infot = 8
211  CALL zsytrs( 'U', 2, 1, a, 2, ip, b, 1, info )
212  CALL chkxer( 'ZSYTRS', infot, nout, lerr, ok )
213 *
214 * ZSYRFS
215 *
216  srnamt = 'ZSYRFS'
217  infot = 1
218  CALL zsyrfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
219  $ r, info )
220  CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
221  infot = 2
222  CALL zsyrfs( 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
223  $ w, r, info )
224  CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
225  infot = 3
226  CALL zsyrfs( 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
227  $ w, r, info )
228  CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
229  infot = 5
230  CALL zsyrfs( 'U', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
231  $ r, info )
232  CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
233  infot = 7
234  CALL zsyrfs( 'U', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
235  $ r, info )
236  CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
237  infot = 10
238  CALL zsyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
239  $ r, info )
240  CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
241  infot = 12
242  CALL zsyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
243  $ r, info )
244  CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
245 *
246 * ZSYRFSX
247 *
248  n_err_bnds = 3
249  nparams = 0
250  srnamt = 'ZSYRFSX'
251  infot = 1
252  CALL zsyrfsx( '/', eq, 0, 0, a, 1, af, 1, ip, s, b, 1, x, 1,
253  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
254  $ params, w, r, info )
255  CALL chkxer( 'ZSYRFSX', infot, nout, lerr, ok )
256  infot = 2
257  CALL zsyrfsx( 'U', eq, -1, 0, a, 1, af, 1, ip, s, b, 1, x, 1,
258  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
259  $ params, w, r, info )
260  CALL chkxer( 'ZSYRFSX', infot, nout, lerr, ok )
261  eq = 'N'
262  infot = 3
263  CALL zsyrfsx( 'U', eq, -1, 0, a, 1, af, 1, ip, s, b, 1, x, 1,
264  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
265  $ params, w, r, info )
266  CALL chkxer( 'ZSYRFSX', infot, nout, lerr, ok )
267  infot = 4
268  CALL zsyrfsx( 'U', eq, 0, -1, a, 1, af, 1, ip, s, b, 1, x, 1,
269  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
270  $ params, w, r, info )
271  CALL chkxer( 'ZSYRFSX', infot, nout, lerr, ok )
272  infot = 6
273  CALL zsyrfsx( 'U', eq, 2, 1, a, 1, af, 2, ip, s, b, 2, x, 2,
274  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
275  $ params, w, r, info )
276  CALL chkxer( 'ZSYRFSX', infot, nout, lerr, ok )
277  infot = 8
278  CALL zsyrfsx( 'U', eq, 2, 1, a, 2, af, 1, ip, s, b, 2, x, 2,
279  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
280  $ params, w, r, info )
281  CALL chkxer( 'ZSYRFSX', infot, nout, lerr, ok )
282  infot = 12
283  CALL zsyrfsx( 'U', eq, 2, 1, a, 2, af, 2, ip, s, b, 1, x, 2,
284  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
285  $ params, w, r, info )
286  CALL chkxer( 'ZSYRFSX', infot, nout, lerr, ok )
287  infot = 14
288  CALL zsyrfsx( 'U', eq, 2, 1, a, 2, af, 2, ip, s, b, 2, x, 1,
289  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
290  $ params, w, r, info )
291  CALL chkxer( 'ZSYRFSX', infot, nout, lerr, ok )
292 *
293 * ZSYCON
294 *
295  srnamt = 'ZSYCON'
296  infot = 1
297  CALL zsycon( '/', 0, a, 1, ip, anrm, rcond, w, info )
298  CALL chkxer( 'ZSYCON', infot, nout, lerr, ok )
299  infot = 2
300  CALL zsycon( 'U', -1, a, 1, ip, anrm, rcond, w, info )
301  CALL chkxer( 'ZSYCON', infot, nout, lerr, ok )
302  infot = 4
303  CALL zsycon( 'U', 2, a, 1, ip, anrm, rcond, w, info )
304  CALL chkxer( 'ZSYCON', infot, nout, lerr, ok )
305  infot = 6
306  CALL zsycon( 'U', 1, a, 1, ip, -anrm, rcond, w, info )
307  CALL chkxer( 'ZSYCON', infot, nout, lerr, ok )
308 *
309 * Test error exits of the routines that use the diagonal pivoting
310 * factorization of a symmetric indefinite packed matrix.
311 *
312  ELSE IF( lsamen( 2, c2, 'SP' ) ) THEN
313 *
314 * ZSPTRF
315 *
316  srnamt = 'ZSPTRF'
317  infot = 1
318  CALL zsptrf( '/', 0, a, ip, info )
319  CALL chkxer( 'ZSPTRF', infot, nout, lerr, ok )
320  infot = 2
321  CALL zsptrf( 'U', -1, a, ip, info )
322  CALL chkxer( 'ZSPTRF', infot, nout, lerr, ok )
323 *
324 * ZSPTRI
325 *
326  srnamt = 'ZSPTRI'
327  infot = 1
328  CALL zsptri( '/', 0, a, ip, w, info )
329  CALL chkxer( 'ZSPTRI', infot, nout, lerr, ok )
330  infot = 2
331  CALL zsptri( 'U', -1, a, ip, w, info )
332  CALL chkxer( 'ZSPTRI', infot, nout, lerr, ok )
333 *
334 * ZSPTRS
335 *
336  srnamt = 'ZSPTRS'
337  infot = 1
338  CALL zsptrs( '/', 0, 0, a, ip, b, 1, info )
339  CALL chkxer( 'ZSPTRS', infot, nout, lerr, ok )
340  infot = 2
341  CALL zsptrs( 'U', -1, 0, a, ip, b, 1, info )
342  CALL chkxer( 'ZSPTRS', infot, nout, lerr, ok )
343  infot = 3
344  CALL zsptrs( 'U', 0, -1, a, ip, b, 1, info )
345  CALL chkxer( 'ZSPTRS', infot, nout, lerr, ok )
346  infot = 7
347  CALL zsptrs( 'U', 2, 1, a, ip, b, 1, info )
348  CALL chkxer( 'ZSPTRS', infot, nout, lerr, ok )
349 *
350 * ZSPRFS
351 *
352  srnamt = 'ZSPRFS'
353  infot = 1
354  CALL zsprfs( '/', 0, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
355  $ info )
356  CALL chkxer( 'ZSPRFS', infot, nout, lerr, ok )
357  infot = 2
358  CALL zsprfs( 'U', -1, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
359  $ info )
360  CALL chkxer( 'ZSPRFS', infot, nout, lerr, ok )
361  infot = 3
362  CALL zsprfs( 'U', 0, -1, a, af, ip, b, 1, x, 1, r1, r2, w, r,
363  $ info )
364  CALL chkxer( 'ZSPRFS', infot, nout, lerr, ok )
365  infot = 8
366  CALL zsprfs( 'U', 2, 1, a, af, ip, b, 1, x, 2, r1, r2, w, r,
367  $ info )
368  CALL chkxer( 'ZSPRFS', infot, nout, lerr, ok )
369  infot = 10
370  CALL zsprfs( 'U', 2, 1, a, af, ip, b, 2, x, 1, r1, r2, w, r,
371  $ info )
372  CALL chkxer( 'ZSPRFS', infot, nout, lerr, ok )
373 *
374 * ZSPCON
375 *
376  srnamt = 'ZSPCON'
377  infot = 1
378  CALL zspcon( '/', 0, a, ip, anrm, rcond, w, info )
379  CALL chkxer( 'ZSPCON', infot, nout, lerr, ok )
380  infot = 2
381  CALL zspcon( 'U', -1, a, ip, anrm, rcond, w, info )
382  CALL chkxer( 'ZSPCON', infot, nout, lerr, ok )
383  infot = 5
384  CALL zspcon( 'U', 1, a, ip, -anrm, rcond, w, info )
385  CALL chkxer( 'ZSPCON', infot, nout, lerr, ok )
386  END IF
387 *
388 * Print a summary line.
389 *
390  CALL alaesm( path, ok, nout )
391 *
392  return
393 *
394 * End of ZERRSY
395 *
396  END