LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
derrsyx.f
Go to the documentation of this file.
1 *> \brief \b DERRSYX
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 DERRSY( 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 *> DERRSY tests the error exits for the DOUBLE PRECISION routines
25 *> for symmetric indefinite matrices.
26 *>
27 *> Note that this file is used only when the XBLAS are available,
28 *> otherwise derrsy.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 double_lin
57 *
58 * =====================================================================
59  SUBROUTINE derrsy( 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 ), iw( nmax )
85  DOUBLE PRECISION a( nmax, nmax ), af( nmax, nmax ), b( nmax ),
86  $ r1( nmax ), r2( nmax ), w( 3*nmax ), x( nmax ),
87  $ s( nmax ), err_bnds_n( nmax, 3 ),
88  $ err_bnds_c( nmax, 3 ), params( 1 )
89 * ..
90 * .. External Functions ..
91  LOGICAL lsamen
92  EXTERNAL lsamen
93 * ..
94 * .. External Subroutines ..
95  EXTERNAL alaesm, chkxer, dspcon, dsprfs, dsptrf, dsptri,
96  $ dsptrs, dsycon, dsyrfs, dsytf2, dsytrf, dsytri,
97  $ dsytri2, dsytrs, dsyrfsx
98 * ..
99 * .. Scalars in Common ..
100  LOGICAL lerr, ok
101  CHARACTER*32 srnamt
102  INTEGER infot, nout
103 * ..
104 * .. Common blocks ..
105  common / infoc / infot, nout, ok, lerr
106  common / srnamc / srnamt
107 * ..
108 * .. Intrinsic Functions ..
109  INTRINSIC dble
110 * ..
111 * .. Executable Statements ..
112 *
113  nout = nunit
114  WRITE( nout, fmt = * )
115  c2 = path( 2: 3 )
116 *
117 * Set the variables to innocuous values.
118 *
119  DO 20 j = 1, nmax
120  DO 10 i = 1, nmax
121  a( i, j ) = 1.d0 / dble( i+j )
122  af( i, j ) = 1.d0 / dble( i+j )
123  10 continue
124  b( j ) = 0.d0
125  r1( j ) = 0.d0
126  r2( j ) = 0.d0
127  w( j ) = 0.d0
128  x( j ) = 0.d0
129  s( j ) = 0.d0
130  ip( j ) = j
131  iw( j ) = j
132  20 continue
133  anrm = 1.0d0
134  rcond = 1.0d0
135  ok = .true.
136 *
137  IF( lsamen( 2, c2, 'SY' ) ) THEN
138 *
139 * Test error exits of the routines that use the Bunch-Kaufman
140 * factorization of a symmetric indefinite matrix.
141 *
142 * DSYTRF
143 *
144  srnamt = 'DSYTRF'
145  infot = 1
146  CALL dsytrf( '/', 0, a, 1, ip, w, 1, info )
147  CALL chkxer( 'DSYTRF', infot, nout, lerr, ok )
148  infot = 2
149  CALL dsytrf( 'U', -1, a, 1, ip, w, 1, info )
150  CALL chkxer( 'DSYTRF', infot, nout, lerr, ok )
151  infot = 4
152  CALL dsytrf( 'U', 2, a, 1, ip, w, 4, info )
153  CALL chkxer( 'DSYTRF', infot, nout, lerr, ok )
154 *
155 * DSYTF2
156 *
157  srnamt = 'DSYTF2'
158  infot = 1
159  CALL dsytf2( '/', 0, a, 1, ip, info )
160  CALL chkxer( 'DSYTF2', infot, nout, lerr, ok )
161  infot = 2
162  CALL dsytf2( 'U', -1, a, 1, ip, info )
163  CALL chkxer( 'DSYTF2', infot, nout, lerr, ok )
164  infot = 4
165  CALL dsytf2( 'U', 2, a, 1, ip, info )
166  CALL chkxer( 'DSYTF2', infot, nout, lerr, ok )
167 *
168 * DSYTRI
169 *
170  srnamt = 'DSYTRI'
171  infot = 1
172  CALL dsytri( '/', 0, a, 1, ip, w, info )
173  CALL chkxer( 'DSYTRI', infot, nout, lerr, ok )
174  infot = 2
175  CALL dsytri( 'U', -1, a, 1, ip, w, info )
176  CALL chkxer( 'DSYTRI', infot, nout, lerr, ok )
177  infot = 4
178  CALL dsytri( 'U', 2, a, 1, ip, w, info )
179  CALL chkxer( 'DSYTRI', infot, nout, lerr, ok )
180 *
181 * DSYTRI2
182 *
183  srnamt = 'DSYTRI2'
184  infot = 1
185  CALL dsytri2( '/', 0, a, 1, ip, w, iw, info )
186  CALL chkxer( 'DSYTRI2', infot, nout, lerr, ok )
187  infot = 2
188  CALL dsytri2( 'U', -1, a, 1, ip, w, iw, info )
189  CALL chkxer( 'DSYTRI2', infot, nout, lerr, ok )
190  infot = 4
191  CALL dsytri2( 'U', 2, a, 1, ip, w, iw, info )
192  CALL chkxer( 'DSYTRI2', infot, nout, lerr, ok )
193 *
194 * DSYTRS
195 *
196  srnamt = 'DSYTRS'
197  infot = 1
198  CALL dsytrs( '/', 0, 0, a, 1, ip, b, 1, info )
199  CALL chkxer( 'DSYTRS', infot, nout, lerr, ok )
200  infot = 2
201  CALL dsytrs( 'U', -1, 0, a, 1, ip, b, 1, info )
202  CALL chkxer( 'DSYTRS', infot, nout, lerr, ok )
203  infot = 3
204  CALL dsytrs( 'U', 0, -1, a, 1, ip, b, 1, info )
205  CALL chkxer( 'DSYTRS', infot, nout, lerr, ok )
206  infot = 5
207  CALL dsytrs( 'U', 2, 1, a, 1, ip, b, 2, info )
208  CALL chkxer( 'DSYTRS', infot, nout, lerr, ok )
209  infot = 8
210  CALL dsytrs( 'U', 2, 1, a, 2, ip, b, 1, info )
211  CALL chkxer( 'DSYTRS', infot, nout, lerr, ok )
212 *
213 * DSYRFS
214 *
215  srnamt = 'DSYRFS'
216  infot = 1
217  CALL dsyrfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
218  $ iw, info )
219  CALL chkxer( 'DSYRFS', infot, nout, lerr, ok )
220  infot = 2
221  CALL dsyrfs( 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
222  $ w, iw, info )
223  CALL chkxer( 'DSYRFS', infot, nout, lerr, ok )
224  infot = 3
225  CALL dsyrfs( 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
226  $ w, iw, info )
227  CALL chkxer( 'DSYRFS', infot, nout, lerr, ok )
228  infot = 5
229  CALL dsyrfs( 'U', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
230  $ iw, info )
231  CALL chkxer( 'DSYRFS', infot, nout, lerr, ok )
232  infot = 7
233  CALL dsyrfs( 'U', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
234  $ iw, info )
235  CALL chkxer( 'DSYRFS', infot, nout, lerr, ok )
236  infot = 10
237  CALL dsyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
238  $ iw, info )
239  CALL chkxer( 'DSYRFS', infot, nout, lerr, ok )
240  infot = 12
241  CALL dsyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
242  $ iw, info )
243  CALL chkxer( 'DSYRFS', infot, nout, lerr, ok )
244 *
245 * DSYRFSX
246 *
247  n_err_bnds = 3
248  nparams = 0
249  srnamt = 'DSYRFSX'
250  infot = 1
251  CALL dsyrfsx( '/', eq, 0, 0, a, 1, af, 1, ip, s, b, 1, x, 1,
252  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
253  $ params, w, iw, info )
254  CALL chkxer( 'DSYRFSX', infot, nout, lerr, ok )
255  infot = 2
256  CALL dsyrfsx( 'U', eq, -1, 0, a, 1, af, 1, ip, s, b, 1, x, 1,
257  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
258  $ params, w, iw, info )
259  CALL chkxer( 'DSYRFSX', infot, nout, lerr, ok )
260  eq = 'N'
261  infot = 3
262  CALL dsyrfsx( 'U', eq, -1, 0, a, 1, af, 1, ip, s, b, 1, x, 1,
263  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
264  $ params, w, iw, info )
265  CALL chkxer( 'DSYRFSX', infot, nout, lerr, ok )
266  infot = 4
267  CALL dsyrfsx( 'U', eq, 0, -1, a, 1, af, 1, ip, s, b, 1, x, 1,
268  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
269  $ params, w, iw, info )
270  CALL chkxer( 'DSYRFSX', infot, nout, lerr, ok )
271  infot = 6
272  CALL dsyrfsx( 'U', eq, 2, 1, a, 1, af, 2, ip, s, b, 2, x, 2,
273  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
274  $ params, w, iw, info )
275  CALL chkxer( 'DSYRFSX', infot, nout, lerr, ok )
276  infot = 8
277  CALL dsyrfsx( 'U', eq, 2, 1, a, 2, af, 1, ip, s, b, 2, x, 2,
278  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
279  $ params, w, iw, info )
280  CALL chkxer( 'DSYRFSX', infot, nout, lerr, ok )
281  infot = 12
282  CALL dsyrfsx( 'U', eq, 2, 1, a, 2, af, 2, ip, s, b, 1, x, 2,
283  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
284  $ params, w, iw, info )
285  CALL chkxer( 'DSYRFSX', infot, nout, lerr, ok )
286  infot = 14
287  CALL dsyrfsx( 'U', eq, 2, 1, a, 2, af, 2, ip, s, b, 2, x, 1,
288  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
289  $ params, w, iw, info )
290  CALL chkxer( 'DSYRFSX', infot, nout, lerr, ok )
291 *
292 * DSYCON
293 *
294  srnamt = 'DSYCON'
295  infot = 1
296  CALL dsycon( '/', 0, a, 1, ip, anrm, rcond, w, iw, info )
297  CALL chkxer( 'DSYCON', infot, nout, lerr, ok )
298  infot = 2
299  CALL dsycon( 'U', -1, a, 1, ip, anrm, rcond, w, iw, info )
300  CALL chkxer( 'DSYCON', infot, nout, lerr, ok )
301  infot = 4
302  CALL dsycon( 'U', 2, a, 1, ip, anrm, rcond, w, iw, info )
303  CALL chkxer( 'DSYCON', infot, nout, lerr, ok )
304  infot = 6
305  CALL dsycon( 'U', 1, a, 1, ip, -1.0d0, rcond, w, iw, info )
306  CALL chkxer( 'DSYCON', infot, nout, lerr, ok )
307 *
308  ELSE IF( lsamen( 2, c2, 'SP' ) ) THEN
309 *
310 * Test error exits of the routines that use the Bunch-Kaufman
311 * factorization of a symmetric indefinite packed matrix.
312 *
313 * DSPTRF
314 *
315  srnamt = 'DSPTRF'
316  infot = 1
317  CALL dsptrf( '/', 0, a, ip, info )
318  CALL chkxer( 'DSPTRF', infot, nout, lerr, ok )
319  infot = 2
320  CALL dsptrf( 'U', -1, a, ip, info )
321  CALL chkxer( 'DSPTRF', infot, nout, lerr, ok )
322 *
323 * DSPTRI
324 *
325  srnamt = 'DSPTRI'
326  infot = 1
327  CALL dsptri( '/', 0, a, ip, w, info )
328  CALL chkxer( 'DSPTRI', infot, nout, lerr, ok )
329  infot = 2
330  CALL dsptri( 'U', -1, a, ip, w, info )
331  CALL chkxer( 'DSPTRI', infot, nout, lerr, ok )
332 *
333 * DSPTRS
334 *
335  srnamt = 'DSPTRS'
336  infot = 1
337  CALL dsptrs( '/', 0, 0, a, ip, b, 1, info )
338  CALL chkxer( 'DSPTRS', infot, nout, lerr, ok )
339  infot = 2
340  CALL dsptrs( 'U', -1, 0, a, ip, b, 1, info )
341  CALL chkxer( 'DSPTRS', infot, nout, lerr, ok )
342  infot = 3
343  CALL dsptrs( 'U', 0, -1, a, ip, b, 1, info )
344  CALL chkxer( 'DSPTRS', infot, nout, lerr, ok )
345  infot = 7
346  CALL dsptrs( 'U', 2, 1, a, ip, b, 1, info )
347  CALL chkxer( 'DSPTRS', infot, nout, lerr, ok )
348 *
349 * DSPRFS
350 *
351  srnamt = 'DSPRFS'
352  infot = 1
353  CALL dsprfs( '/', 0, 0, a, af, ip, b, 1, x, 1, r1, r2, w, iw,
354  $ info )
355  CALL chkxer( 'DSPRFS', infot, nout, lerr, ok )
356  infot = 2
357  CALL dsprfs( 'U', -1, 0, a, af, ip, b, 1, x, 1, r1, r2, w, iw,
358  $ info )
359  CALL chkxer( 'DSPRFS', infot, nout, lerr, ok )
360  infot = 3
361  CALL dsprfs( 'U', 0, -1, a, af, ip, b, 1, x, 1, r1, r2, w, iw,
362  $ info )
363  CALL chkxer( 'DSPRFS', infot, nout, lerr, ok )
364  infot = 8
365  CALL dsprfs( 'U', 2, 1, a, af, ip, b, 1, x, 2, r1, r2, w, iw,
366  $ info )
367  CALL chkxer( 'DSPRFS', infot, nout, lerr, ok )
368  infot = 10
369  CALL dsprfs( 'U', 2, 1, a, af, ip, b, 2, x, 1, r1, r2, w, iw,
370  $ info )
371  CALL chkxer( 'DSPRFS', infot, nout, lerr, ok )
372 *
373 * DSPCON
374 *
375  srnamt = 'DSPCON'
376  infot = 1
377  CALL dspcon( '/', 0, a, ip, anrm, rcond, w, iw, info )
378  CALL chkxer( 'DSPCON', infot, nout, lerr, ok )
379  infot = 2
380  CALL dspcon( 'U', -1, a, ip, anrm, rcond, w, iw, info )
381  CALL chkxer( 'DSPCON', infot, nout, lerr, ok )
382  infot = 5
383  CALL dspcon( 'U', 1, a, ip, -1.0d0, rcond, w, iw, info )
384  CALL chkxer( 'DSPCON', infot, nout, lerr, ok )
385  END IF
386 *
387 * Print a summary line.
388 *
389  CALL alaesm( path, ok, nout )
390 *
391  return
392 *
393 * End of DERRSY
394 *
395  END