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