LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
zerrsy.f
Go to the documentation of this file.
1 *> \brief \b ZERRSY
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 *> \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 complex16_lin
54 *
55 * =====================================================================
56  SUBROUTINE zerrsy( 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  DOUBLE PRECISION anrm, rcond
78 * ..
79 * .. Local Arrays ..
80  INTEGER ip( nmax )
81  DOUBLE PRECISION r( nmax ), r1( nmax ), r2( nmax )
82  COMPLEX*16 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, zspcon, zsprfs, zsptrf, zsptri,
91  $ zsptrs, zsycon, zsyrfs, zsytf2, zsytrf, zsytri,
92  $ zsytri2, zsytrs
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 dble, dcmplx
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 ) = dcmplx( 1.d0 / dble( i+j ),
117  $ -1.d0 / dble( i+j ) )
118  af( i, j ) = dcmplx( 1.d0 / dble( i+j ),
119  $ -1.d0 / dble( i+j ) )
120  10 continue
121  b( j ) = 0.d0
122  r1( j ) = 0.d0
123  r2( j ) = 0.d0
124  w( j ) = 0.d0
125  x( j ) = 0.d0
126  ip( j ) = j
127  20 continue
128  anrm = 1.0d0
129  ok = .true.
130 *
131  IF( lsamen( 2, c2, 'SY' ) ) THEN
132 *
133 * Test error exits of the routines that use factorization
134 * of a symmetric indefinite matrix with patrial
135 * (Bunch-Kaufman) pivoting.
136 *
137 * ZSYTRF
138 *
139  srnamt = 'ZSYTRF'
140  infot = 1
141  CALL zsytrf( '/', 0, a, 1, ip, w, 1, info )
142  CALL chkxer( 'ZSYTRF', infot, nout, lerr, ok )
143  infot = 2
144  CALL zsytrf( 'U', -1, a, 1, ip, w, 1, info )
145  CALL chkxer( 'ZSYTRF', infot, nout, lerr, ok )
146  infot = 4
147  CALL zsytrf( 'U', 2, a, 1, ip, w, 4, info )
148  CALL chkxer( 'ZSYTRF', infot, nout, lerr, ok )
149 *
150 * ZSYTF2
151 *
152  srnamt = 'ZSYTF2'
153  infot = 1
154  CALL zsytf2( '/', 0, a, 1, ip, info )
155  CALL chkxer( 'ZSYTF2', infot, nout, lerr, ok )
156  infot = 2
157  CALL zsytf2( 'U', -1, a, 1, ip, info )
158  CALL chkxer( 'ZSYTF2', infot, nout, lerr, ok )
159  infot = 4
160  CALL zsytf2( 'U', 2, a, 1, ip, info )
161  CALL chkxer( 'ZSYTF2', infot, nout, lerr, ok )
162 *
163 * ZSYTRI
164 *
165  srnamt = 'ZSYTRI'
166  infot = 1
167  CALL zsytri( '/', 0, a, 1, ip, w, info )
168  CALL chkxer( 'ZSYTRI', infot, nout, lerr, ok )
169  infot = 2
170  CALL zsytri( 'U', -1, a, 1, ip, w, info )
171  CALL chkxer( 'ZSYTRI', infot, nout, lerr, ok )
172  infot = 4
173  CALL zsytri( 'U', 2, a, 1, ip, w, info )
174  CALL chkxer( 'ZSYTRI', infot, nout, lerr, ok )
175 *
176 * ZSYTRI2
177 *
178  srnamt = 'ZSYTRI2'
179  infot = 1
180  CALL zsytri2( '/', 0, a, 1, ip, w, 1, info )
181  CALL chkxer( 'ZSYTRI2', infot, nout, lerr, ok )
182  infot = 2
183  CALL zsytri2( 'U', -1, a, 1, ip, w, 1, info )
184  CALL chkxer( 'ZSYTRI2', infot, nout, lerr, ok )
185  infot = 4
186  CALL zsytri2( 'U', 2, a, 1, ip, w, 1, info )
187  CALL chkxer( 'ZSYTRI2', infot, nout, lerr, ok )
188 *
189 * ZSYTRS
190 *
191  srnamt = 'ZSYTRS'
192  infot = 1
193  CALL zsytrs( '/', 0, 0, a, 1, ip, b, 1, info )
194  CALL chkxer( 'ZSYTRS', infot, nout, lerr, ok )
195  infot = 2
196  CALL zsytrs( 'U', -1, 0, a, 1, ip, b, 1, info )
197  CALL chkxer( 'ZSYTRS', infot, nout, lerr, ok )
198  infot = 3
199  CALL zsytrs( 'U', 0, -1, a, 1, ip, b, 1, info )
200  CALL chkxer( 'ZSYTRS', infot, nout, lerr, ok )
201  infot = 5
202  CALL zsytrs( 'U', 2, 1, a, 1, ip, b, 2, info )
203  CALL chkxer( 'ZSYTRS', infot, nout, lerr, ok )
204  infot = 8
205  CALL zsytrs( 'U', 2, 1, a, 2, ip, b, 1, info )
206  CALL chkxer( 'ZSYTRS', infot, nout, lerr, ok )
207 *
208 * ZSYRFS
209 *
210  srnamt = 'ZSYRFS'
211  infot = 1
212  CALL zsyrfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
213  $ r, info )
214  CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
215  infot = 2
216  CALL zsyrfs( 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
217  $ w, r, info )
218  CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
219  infot = 3
220  CALL zsyrfs( 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
221  $ w, r, info )
222  CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
223  infot = 5
224  CALL zsyrfs( 'U', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
225  $ r, info )
226  CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
227  infot = 7
228  CALL zsyrfs( 'U', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
229  $ r, info )
230  CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
231  infot = 10
232  CALL zsyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
233  $ r, info )
234  CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
235  infot = 12
236  CALL zsyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
237  $ r, info )
238  CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
239 *
240 * ZSYCON
241 *
242  srnamt = 'ZSYCON'
243  infot = 1
244  CALL zsycon( '/', 0, a, 1, ip, anrm, rcond, w, info )
245  CALL chkxer( 'ZSYCON', infot, nout, lerr, ok )
246  infot = 2
247  CALL zsycon( 'U', -1, a, 1, ip, anrm, rcond, w, info )
248  CALL chkxer( 'ZSYCON', infot, nout, lerr, ok )
249  infot = 4
250  CALL zsycon( 'U', 2, a, 1, ip, anrm, rcond, w, info )
251  CALL chkxer( 'ZSYCON', infot, nout, lerr, ok )
252  infot = 6
253  CALL zsycon( 'U', 1, a, 1, ip, -anrm, rcond, w, info )
254  CALL chkxer( 'ZSYCON', infot, nout, lerr, ok )
255 *
256  ELSE IF( lsamen( 2, c2, 'SP' ) ) THEN
257 *
258 * Test error exits of the routines that use factorization
259 * of a symmetric indefinite packed matrix with patrial
260 * (Bunch-Kaufman) pivoting.
261 *
262 * ZSPTRF
263 *
264  srnamt = 'ZSPTRF'
265  infot = 1
266  CALL zsptrf( '/', 0, a, ip, info )
267  CALL chkxer( 'ZSPTRF', infot, nout, lerr, ok )
268  infot = 2
269  CALL zsptrf( 'U', -1, a, ip, info )
270  CALL chkxer( 'ZSPTRF', infot, nout, lerr, ok )
271 *
272 * ZSPTRI
273 *
274  srnamt = 'ZSPTRI'
275  infot = 1
276  CALL zsptri( '/', 0, a, ip, w, info )
277  CALL chkxer( 'ZSPTRI', infot, nout, lerr, ok )
278  infot = 2
279  CALL zsptri( 'U', -1, a, ip, w, info )
280  CALL chkxer( 'ZSPTRI', infot, nout, lerr, ok )
281 *
282 * ZSPTRS
283 *
284  srnamt = 'ZSPTRS'
285  infot = 1
286  CALL zsptrs( '/', 0, 0, a, ip, b, 1, info )
287  CALL chkxer( 'ZSPTRS', infot, nout, lerr, ok )
288  infot = 2
289  CALL zsptrs( 'U', -1, 0, a, ip, b, 1, info )
290  CALL chkxer( 'ZSPTRS', infot, nout, lerr, ok )
291  infot = 3
292  CALL zsptrs( 'U', 0, -1, a, ip, b, 1, info )
293  CALL chkxer( 'ZSPTRS', infot, nout, lerr, ok )
294  infot = 7
295  CALL zsptrs( 'U', 2, 1, a, ip, b, 1, info )
296  CALL chkxer( 'ZSPTRS', infot, nout, lerr, ok )
297 *
298 * ZSPRFS
299 *
300  srnamt = 'ZSPRFS'
301  infot = 1
302  CALL zsprfs( '/', 0, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
303  $ info )
304  CALL chkxer( 'ZSPRFS', infot, nout, lerr, ok )
305  infot = 2
306  CALL zsprfs( 'U', -1, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
307  $ info )
308  CALL chkxer( 'ZSPRFS', infot, nout, lerr, ok )
309  infot = 3
310  CALL zsprfs( 'U', 0, -1, a, af, ip, b, 1, x, 1, r1, r2, w, r,
311  $ info )
312  CALL chkxer( 'ZSPRFS', infot, nout, lerr, ok )
313  infot = 8
314  CALL zsprfs( 'U', 2, 1, a, af, ip, b, 1, x, 2, r1, r2, w, r,
315  $ info )
316  CALL chkxer( 'ZSPRFS', infot, nout, lerr, ok )
317  infot = 10
318  CALL zsprfs( 'U', 2, 1, a, af, ip, b, 2, x, 1, r1, r2, w, r,
319  $ info )
320  CALL chkxer( 'ZSPRFS', infot, nout, lerr, ok )
321 *
322 * ZSPCON
323 *
324  srnamt = 'ZSPCON'
325  infot = 1
326  CALL zspcon( '/', 0, a, ip, anrm, rcond, w, info )
327  CALL chkxer( 'ZSPCON', infot, nout, lerr, ok )
328  infot = 2
329  CALL zspcon( 'U', -1, a, ip, anrm, rcond, w, info )
330  CALL chkxer( 'ZSPCON', infot, nout, lerr, ok )
331  infot = 5
332  CALL zspcon( 'U', 1, a, ip, -anrm, rcond, w, info )
333  CALL chkxer( 'ZSPCON', infot, nout, lerr, ok )
334  END IF
335 *
336 * Print a summary line.
337 *
338  CALL alaesm( path, ok, nout )
339 *
340  return
341 *
342 * End of ZERRSY
343 *
344  END