LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
serrsy.f
Go to the documentation of this file.
1 *> \brief \b SERRSY
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 SERRSY( 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 *> SERRSY tests the error exits for the REAL 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 single_lin
54 *
55 * =====================================================================
56  SUBROUTINE serrsy( 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 ), iw( nmax )
81  REAL 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, sspcon, ssprfs, ssptrf, ssptri,
90  $ ssptrs, ssycon, ssyrfs, ssytf2, ssytrf, ssytri,
91  $ ssytri2, ssytrs
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 real
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. / REAL( i+j )
116  af( i, j ) = 1. / REAL( i+j )
117  10 continue
118  b( j ) = 0.
119  r1( j ) = 0.
120  r2( j ) = 0.
121  w( j ) = 0.
122  x( j ) = 0.
123  ip( j ) = j
124  iw( j ) = j
125  20 continue
126  anrm = 1.0
127  rcond = 1.0
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 * SSYTRF
137 *
138  srnamt = 'SSYTRF'
139  infot = 1
140  CALL ssytrf( '/', 0, a, 1, ip, w, 1, info )
141  CALL chkxer( 'SSYTRF', infot, nout, lerr, ok )
142  infot = 2
143  CALL ssytrf( 'U', -1, a, 1, ip, w, 1, info )
144  CALL chkxer( 'SSYTRF', infot, nout, lerr, ok )
145  infot = 4
146  CALL ssytrf( 'U', 2, a, 1, ip, w, 4, info )
147  CALL chkxer( 'SSYTRF', infot, nout, lerr, ok )
148 *
149 * SSYTF2
150 *
151  srnamt = 'SSYTF2'
152  infot = 1
153  CALL ssytf2( '/', 0, a, 1, ip, info )
154  CALL chkxer( 'SSYTF2', infot, nout, lerr, ok )
155  infot = 2
156  CALL ssytf2( 'U', -1, a, 1, ip, info )
157  CALL chkxer( 'SSYTF2', infot, nout, lerr, ok )
158  infot = 4
159  CALL ssytf2( 'U', 2, a, 1, ip, info )
160  CALL chkxer( 'SSYTF2', infot, nout, lerr, ok )
161 *
162 * SSYTRI
163 *
164  srnamt = 'SSYTRI'
165  infot = 1
166  CALL ssytri( '/', 0, a, 1, ip, w, info )
167  CALL chkxer( 'SSYTRI', infot, nout, lerr, ok )
168  infot = 2
169  CALL ssytri( 'U', -1, a, 1, ip, w, info )
170  CALL chkxer( 'SSYTRI', infot, nout, lerr, ok )
171  infot = 4
172  CALL ssytri( 'U', 2, a, 1, ip, w, info )
173  CALL chkxer( 'SSYTRI', infot, nout, lerr, ok )
174 *
175 * SSYTRI2
176 *
177  srnamt = 'SSYTRI2'
178  infot = 1
179  CALL ssytri2( '/', 0, a, 1, ip, w, iw(1), info )
180  CALL chkxer( 'SSYTRI2', infot, nout, lerr, ok )
181  infot = 2
182  CALL ssytri2( 'U', -1, a, 1, ip, w, iw(1), info )
183  CALL chkxer( 'SSYTRI2', infot, nout, lerr, ok )
184  infot = 4
185  CALL ssytri2( 'U', 2, a, 1, ip, w, iw(1), info )
186  CALL chkxer( 'SSYTRI2', infot, nout, lerr, ok )
187 *
188 * SSYTRS
189 *
190  srnamt = 'SSYTRS'
191  infot = 1
192  CALL ssytrs( '/', 0, 0, a, 1, ip, b, 1, info )
193  CALL chkxer( 'SSYTRS', infot, nout, lerr, ok )
194  infot = 2
195  CALL ssytrs( 'U', -1, 0, a, 1, ip, b, 1, info )
196  CALL chkxer( 'SSYTRS', infot, nout, lerr, ok )
197  infot = 3
198  CALL ssytrs( 'U', 0, -1, a, 1, ip, b, 1, info )
199  CALL chkxer( 'SSYTRS', infot, nout, lerr, ok )
200  infot = 5
201  CALL ssytrs( 'U', 2, 1, a, 1, ip, b, 2, info )
202  CALL chkxer( 'SSYTRS', infot, nout, lerr, ok )
203  infot = 8
204  CALL ssytrs( 'U', 2, 1, a, 2, ip, b, 1, info )
205  CALL chkxer( 'SSYTRS', infot, nout, lerr, ok )
206 *
207 * SSYRFS
208 *
209  srnamt = 'SSYRFS'
210  infot = 1
211  CALL ssyrfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
212  $ iw, info )
213  CALL chkxer( 'SSYRFS', infot, nout, lerr, ok )
214  infot = 2
215  CALL ssyrfs( 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
216  $ w, iw, info )
217  CALL chkxer( 'SSYRFS', infot, nout, lerr, ok )
218  infot = 3
219  CALL ssyrfs( 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
220  $ w, iw, info )
221  CALL chkxer( 'SSYRFS', infot, nout, lerr, ok )
222  infot = 5
223  CALL ssyrfs( 'U', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
224  $ iw, info )
225  CALL chkxer( 'SSYRFS', infot, nout, lerr, ok )
226  infot = 7
227  CALL ssyrfs( 'U', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
228  $ iw, info )
229  CALL chkxer( 'SSYRFS', infot, nout, lerr, ok )
230  infot = 10
231  CALL ssyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
232  $ iw, info )
233  CALL chkxer( 'SSYRFS', infot, nout, lerr, ok )
234  infot = 12
235  CALL ssyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
236  $ iw, info )
237  CALL chkxer( 'SSYRFS', infot, nout, lerr, ok )
238 *
239 * SSYCON
240 *
241  srnamt = 'SSYCON'
242  infot = 1
243  CALL ssycon( '/', 0, a, 1, ip, anrm, rcond, w, iw, info )
244  CALL chkxer( 'SSYCON', infot, nout, lerr, ok )
245  infot = 2
246  CALL ssycon( 'U', -1, a, 1, ip, anrm, rcond, w, iw, info )
247  CALL chkxer( 'SSYCON', infot, nout, lerr, ok )
248  infot = 4
249  CALL ssycon( 'U', 2, a, 1, ip, anrm, rcond, w, iw, info )
250  CALL chkxer( 'SSYCON', infot, nout, lerr, ok )
251  infot = 6
252  CALL ssycon( 'U', 1, a, 1, ip, -1.0, rcond, w, iw, info )
253  CALL chkxer( 'SSYCON', 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 * SSPTRF
262 *
263  srnamt = 'SSPTRF'
264  infot = 1
265  CALL ssptrf( '/', 0, a, ip, info )
266  CALL chkxer( 'SSPTRF', infot, nout, lerr, ok )
267  infot = 2
268  CALL ssptrf( 'U', -1, a, ip, info )
269  CALL chkxer( 'SSPTRF', infot, nout, lerr, ok )
270 *
271 * SSPTRI
272 *
273  srnamt = 'SSPTRI'
274  infot = 1
275  CALL ssptri( '/', 0, a, ip, w, info )
276  CALL chkxer( 'SSPTRI', infot, nout, lerr, ok )
277  infot = 2
278  CALL ssptri( 'U', -1, a, ip, w, info )
279  CALL chkxer( 'SSPTRI', infot, nout, lerr, ok )
280 *
281 * SSPTRS
282 *
283  srnamt = 'SSPTRS'
284  infot = 1
285  CALL ssptrs( '/', 0, 0, a, ip, b, 1, info )
286  CALL chkxer( 'SSPTRS', infot, nout, lerr, ok )
287  infot = 2
288  CALL ssptrs( 'U', -1, 0, a, ip, b, 1, info )
289  CALL chkxer( 'SSPTRS', infot, nout, lerr, ok )
290  infot = 3
291  CALL ssptrs( 'U', 0, -1, a, ip, b, 1, info )
292  CALL chkxer( 'SSPTRS', infot, nout, lerr, ok )
293  infot = 7
294  CALL ssptrs( 'U', 2, 1, a, ip, b, 1, info )
295  CALL chkxer( 'SSPTRS', infot, nout, lerr, ok )
296 *
297 * SSPRFS
298 *
299  srnamt = 'SSPRFS'
300  infot = 1
301  CALL ssprfs( '/', 0, 0, a, af, ip, b, 1, x, 1, r1, r2, w, iw,
302  $ info )
303  CALL chkxer( 'SSPRFS', infot, nout, lerr, ok )
304  infot = 2
305  CALL ssprfs( 'U', -1, 0, a, af, ip, b, 1, x, 1, r1, r2, w, iw,
306  $ info )
307  CALL chkxer( 'SSPRFS', infot, nout, lerr, ok )
308  infot = 3
309  CALL ssprfs( 'U', 0, -1, a, af, ip, b, 1, x, 1, r1, r2, w, iw,
310  $ info )
311  CALL chkxer( 'SSPRFS', infot, nout, lerr, ok )
312  infot = 8
313  CALL ssprfs( 'U', 2, 1, a, af, ip, b, 1, x, 2, r1, r2, w, iw,
314  $ info )
315  CALL chkxer( 'SSPRFS', infot, nout, lerr, ok )
316  infot = 10
317  CALL ssprfs( 'U', 2, 1, a, af, ip, b, 2, x, 1, r1, r2, w, iw,
318  $ info )
319  CALL chkxer( 'SSPRFS', infot, nout, lerr, ok )
320 *
321 * SSPCON
322 *
323  srnamt = 'SSPCON'
324  infot = 1
325  CALL sspcon( '/', 0, a, ip, anrm, rcond, w, iw, info )
326  CALL chkxer( 'SSPCON', infot, nout, lerr, ok )
327  infot = 2
328  CALL sspcon( 'U', -1, a, ip, anrm, rcond, w, iw, info )
329  CALL chkxer( 'SSPCON', infot, nout, lerr, ok )
330  infot = 5
331  CALL sspcon( 'U', 1, a, ip, -1.0, rcond, w, iw, info )
332  CALL chkxer( 'SSPCON', 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 SERRSY
342 *
343  END