LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
serrpo.f
Go to the documentation of this file.
1 *> \brief \b SERRPO
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 SERRPO( 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 *> SERRPO tests the error exits for the REAL routines
25 *> for symmetric positive definite 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 November 2011
52 *
53 *> \ingroup single_lin
54 *
55 * =====================================================================
56  SUBROUTINE serrpo( PATH, NUNIT )
57 *
58 * -- LAPACK test routine (version 3.4.0) --
59 * -- LAPACK is a software package provided by Univ. of Tennessee, --
60 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
61 * November 2011
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 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, spbcon, spbequ, spbrfs, spbtf2,
90  $ spbtrf, spbtrs, spocon, spoequ, sporfs, spotf2,
91  $ spotrf, spotri, spotrs, sppcon, sppequ, spprfs,
92  $ spptrf, spptri, spptrs
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 real
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 ) = 1. / REAL( i+j )
117  af( i, j ) = 1. / REAL( i+j )
118  10 continue
119  b( j ) = 0.
120  r1( j ) = 0.
121  r2( j ) = 0.
122  w( j ) = 0.
123  x( j ) = 0.
124  iw( j ) = j
125  20 continue
126  ok = .true.
127 *
128  IF( lsamen( 2, c2, 'PO' ) ) THEN
129 *
130 * Test error exits of the routines that use the Cholesky
131 * decomposition of a symmetric positive definite matrix.
132 *
133 * SPOTRF
134 *
135  srnamt = 'SPOTRF'
136  infot = 1
137  CALL spotrf( '/', 0, a, 1, info )
138  CALL chkxer( 'SPOTRF', infot, nout, lerr, ok )
139  infot = 2
140  CALL spotrf( 'U', -1, a, 1, info )
141  CALL chkxer( 'SPOTRF', infot, nout, lerr, ok )
142  infot = 4
143  CALL spotrf( 'U', 2, a, 1, info )
144  CALL chkxer( 'SPOTRF', infot, nout, lerr, ok )
145 *
146 * SPOTF2
147 *
148  srnamt = 'SPOTF2'
149  infot = 1
150  CALL spotf2( '/', 0, a, 1, info )
151  CALL chkxer( 'SPOTF2', infot, nout, lerr, ok )
152  infot = 2
153  CALL spotf2( 'U', -1, a, 1, info )
154  CALL chkxer( 'SPOTF2', infot, nout, lerr, ok )
155  infot = 4
156  CALL spotf2( 'U', 2, a, 1, info )
157  CALL chkxer( 'SPOTF2', infot, nout, lerr, ok )
158 *
159 * SPOTRI
160 *
161  srnamt = 'SPOTRI'
162  infot = 1
163  CALL spotri( '/', 0, a, 1, info )
164  CALL chkxer( 'SPOTRI', infot, nout, lerr, ok )
165  infot = 2
166  CALL spotri( 'U', -1, a, 1, info )
167  CALL chkxer( 'SPOTRI', infot, nout, lerr, ok )
168  infot = 4
169  CALL spotri( 'U', 2, a, 1, info )
170  CALL chkxer( 'SPOTRI', infot, nout, lerr, ok )
171 *
172 * SPOTRS
173 *
174  srnamt = 'SPOTRS'
175  infot = 1
176  CALL spotrs( '/', 0, 0, a, 1, b, 1, info )
177  CALL chkxer( 'SPOTRS', infot, nout, lerr, ok )
178  infot = 2
179  CALL spotrs( 'U', -1, 0, a, 1, b, 1, info )
180  CALL chkxer( 'SPOTRS', infot, nout, lerr, ok )
181  infot = 3
182  CALL spotrs( 'U', 0, -1, a, 1, b, 1, info )
183  CALL chkxer( 'SPOTRS', infot, nout, lerr, ok )
184  infot = 5
185  CALL spotrs( 'U', 2, 1, a, 1, b, 2, info )
186  CALL chkxer( 'SPOTRS', infot, nout, lerr, ok )
187  infot = 7
188  CALL spotrs( 'U', 2, 1, a, 2, b, 1, info )
189  CALL chkxer( 'SPOTRS', infot, nout, lerr, ok )
190 *
191 * SPORFS
192 *
193  srnamt = 'SPORFS'
194  infot = 1
195  CALL sporfs( '/', 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w, iw,
196  $ info )
197  CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
198  infot = 2
199  CALL sporfs( 'U', -1, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
200  $ iw, info )
201  CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
202  infot = 3
203  CALL sporfs( 'U', 0, -1, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
204  $ iw, info )
205  CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
206  infot = 5
207  CALL sporfs( 'U', 2, 1, a, 1, af, 2, b, 2, x, 2, r1, r2, w, iw,
208  $ info )
209  CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
210  infot = 7
211  CALL sporfs( 'U', 2, 1, a, 2, af, 1, b, 2, x, 2, r1, r2, w, iw,
212  $ info )
213  CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
214  infot = 9
215  CALL sporfs( 'U', 2, 1, a, 2, af, 2, b, 1, x, 2, r1, r2, w, iw,
216  $ info )
217  CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
218  infot = 11
219  CALL sporfs( 'U', 2, 1, a, 2, af, 2, b, 2, x, 1, r1, r2, w, iw,
220  $ info )
221  CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
222 *
223 * SPOCON
224 *
225  srnamt = 'SPOCON'
226  infot = 1
227  CALL spocon( '/', 0, a, 1, anrm, rcond, w, iw, info )
228  CALL chkxer( 'SPOCON', infot, nout, lerr, ok )
229  infot = 2
230  CALL spocon( 'U', -1, a, 1, anrm, rcond, w, iw, info )
231  CALL chkxer( 'SPOCON', infot, nout, lerr, ok )
232  infot = 4
233  CALL spocon( 'U', 2, a, 1, anrm, rcond, w, iw, info )
234  CALL chkxer( 'SPOCON', infot, nout, lerr, ok )
235 *
236 * SPOEQU
237 *
238  srnamt = 'SPOEQU'
239  infot = 1
240  CALL spoequ( -1, a, 1, r1, rcond, anrm, info )
241  CALL chkxer( 'SPOEQU', infot, nout, lerr, ok )
242  infot = 3
243  CALL spoequ( 2, a, 1, r1, rcond, anrm, info )
244  CALL chkxer( 'SPOEQU', infot, nout, lerr, ok )
245 *
246  ELSE IF( lsamen( 2, c2, 'PP' ) ) THEN
247 *
248 * Test error exits of the routines that use the Cholesky
249 * decomposition of a symmetric positive definite packed matrix.
250 *
251 * SPPTRF
252 *
253  srnamt = 'SPPTRF'
254  infot = 1
255  CALL spptrf( '/', 0, a, info )
256  CALL chkxer( 'SPPTRF', infot, nout, lerr, ok )
257  infot = 2
258  CALL spptrf( 'U', -1, a, info )
259  CALL chkxer( 'SPPTRF', infot, nout, lerr, ok )
260 *
261 * SPPTRI
262 *
263  srnamt = 'SPPTRI'
264  infot = 1
265  CALL spptri( '/', 0, a, info )
266  CALL chkxer( 'SPPTRI', infot, nout, lerr, ok )
267  infot = 2
268  CALL spptri( 'U', -1, a, info )
269  CALL chkxer( 'SPPTRI', infot, nout, lerr, ok )
270 *
271 * SPPTRS
272 *
273  srnamt = 'SPPTRS'
274  infot = 1
275  CALL spptrs( '/', 0, 0, a, b, 1, info )
276  CALL chkxer( 'SPPTRS', infot, nout, lerr, ok )
277  infot = 2
278  CALL spptrs( 'U', -1, 0, a, b, 1, info )
279  CALL chkxer( 'SPPTRS', infot, nout, lerr, ok )
280  infot = 3
281  CALL spptrs( 'U', 0, -1, a, b, 1, info )
282  CALL chkxer( 'SPPTRS', infot, nout, lerr, ok )
283  infot = 6
284  CALL spptrs( 'U', 2, 1, a, b, 1, info )
285  CALL chkxer( 'SPPTRS', infot, nout, lerr, ok )
286 *
287 * SPPRFS
288 *
289  srnamt = 'SPPRFS'
290  infot = 1
291  CALL spprfs( '/', 0, 0, a, af, b, 1, x, 1, r1, r2, w, iw,
292  $ info )
293  CALL chkxer( 'SPPRFS', infot, nout, lerr, ok )
294  infot = 2
295  CALL spprfs( 'U', -1, 0, a, af, b, 1, x, 1, r1, r2, w, iw,
296  $ info )
297  CALL chkxer( 'SPPRFS', infot, nout, lerr, ok )
298  infot = 3
299  CALL spprfs( 'U', 0, -1, a, af, b, 1, x, 1, r1, r2, w, iw,
300  $ info )
301  CALL chkxer( 'SPPRFS', infot, nout, lerr, ok )
302  infot = 7
303  CALL spprfs( 'U', 2, 1, a, af, b, 1, x, 2, r1, r2, w, iw,
304  $ info )
305  CALL chkxer( 'SPPRFS', infot, nout, lerr, ok )
306  infot = 9
307  CALL spprfs( 'U', 2, 1, a, af, b, 2, x, 1, r1, r2, w, iw,
308  $ info )
309  CALL chkxer( 'SPPRFS', infot, nout, lerr, ok )
310 *
311 * SPPCON
312 *
313  srnamt = 'SPPCON'
314  infot = 1
315  CALL sppcon( '/', 0, a, anrm, rcond, w, iw, info )
316  CALL chkxer( 'SPPCON', infot, nout, lerr, ok )
317  infot = 2
318  CALL sppcon( 'U', -1, a, anrm, rcond, w, iw, info )
319  CALL chkxer( 'SPPCON', infot, nout, lerr, ok )
320 *
321 * SPPEQU
322 *
323  srnamt = 'SPPEQU'
324  infot = 1
325  CALL sppequ( '/', 0, a, r1, rcond, anrm, info )
326  CALL chkxer( 'SPPEQU', infot, nout, lerr, ok )
327  infot = 2
328  CALL sppequ( 'U', -1, a, r1, rcond, anrm, info )
329  CALL chkxer( 'SPPEQU', infot, nout, lerr, ok )
330 *
331  ELSE IF( lsamen( 2, c2, 'PB' ) ) THEN
332 *
333 * Test error exits of the routines that use the Cholesky
334 * decomposition of a symmetric positive definite band matrix.
335 *
336 * SPBTRF
337 *
338  srnamt = 'SPBTRF'
339  infot = 1
340  CALL spbtrf( '/', 0, 0, a, 1, info )
341  CALL chkxer( 'SPBTRF', infot, nout, lerr, ok )
342  infot = 2
343  CALL spbtrf( 'U', -1, 0, a, 1, info )
344  CALL chkxer( 'SPBTRF', infot, nout, lerr, ok )
345  infot = 3
346  CALL spbtrf( 'U', 1, -1, a, 1, info )
347  CALL chkxer( 'SPBTRF', infot, nout, lerr, ok )
348  infot = 5
349  CALL spbtrf( 'U', 2, 1, a, 1, info )
350  CALL chkxer( 'SPBTRF', infot, nout, lerr, ok )
351 *
352 * SPBTF2
353 *
354  srnamt = 'SPBTF2'
355  infot = 1
356  CALL spbtf2( '/', 0, 0, a, 1, info )
357  CALL chkxer( 'SPBTF2', infot, nout, lerr, ok )
358  infot = 2
359  CALL spbtf2( 'U', -1, 0, a, 1, info )
360  CALL chkxer( 'SPBTF2', infot, nout, lerr, ok )
361  infot = 3
362  CALL spbtf2( 'U', 1, -1, a, 1, info )
363  CALL chkxer( 'SPBTF2', infot, nout, lerr, ok )
364  infot = 5
365  CALL spbtf2( 'U', 2, 1, a, 1, info )
366  CALL chkxer( 'SPBTF2', infot, nout, lerr, ok )
367 *
368 * SPBTRS
369 *
370  srnamt = 'SPBTRS'
371  infot = 1
372  CALL spbtrs( '/', 0, 0, 0, a, 1, b, 1, info )
373  CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
374  infot = 2
375  CALL spbtrs( 'U', -1, 0, 0, a, 1, b, 1, info )
376  CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
377  infot = 3
378  CALL spbtrs( 'U', 1, -1, 0, a, 1, b, 1, info )
379  CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
380  infot = 4
381  CALL spbtrs( 'U', 0, 0, -1, a, 1, b, 1, info )
382  CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
383  infot = 6
384  CALL spbtrs( 'U', 2, 1, 1, a, 1, b, 1, info )
385  CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
386  infot = 8
387  CALL spbtrs( 'U', 2, 0, 1, a, 1, b, 1, info )
388  CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
389 *
390 * SPBRFS
391 *
392  srnamt = 'SPBRFS'
393  infot = 1
394  CALL spbrfs( '/', 0, 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
395  $ iw, info )
396  CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
397  infot = 2
398  CALL spbrfs( 'U', -1, 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
399  $ iw, info )
400  CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
401  infot = 3
402  CALL spbrfs( 'U', 1, -1, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
403  $ iw, info )
404  CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
405  infot = 4
406  CALL spbrfs( 'U', 0, 0, -1, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
407  $ iw, info )
408  CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
409  infot = 6
410  CALL spbrfs( 'U', 2, 1, 1, a, 1, af, 2, b, 2, x, 2, r1, r2, w,
411  $ iw, info )
412  CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
413  infot = 8
414  CALL spbrfs( 'U', 2, 1, 1, a, 2, af, 1, b, 2, x, 2, r1, r2, w,
415  $ iw, info )
416  CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
417  infot = 10
418  CALL spbrfs( 'U', 2, 0, 1, a, 1, af, 1, b, 1, x, 2, r1, r2, w,
419  $ iw, info )
420  CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
421  infot = 12
422  CALL spbrfs( 'U', 2, 0, 1, a, 1, af, 1, b, 2, x, 1, r1, r2, w,
423  $ iw, info )
424  CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
425 *
426 * SPBCON
427 *
428  srnamt = 'SPBCON'
429  infot = 1
430  CALL spbcon( '/', 0, 0, a, 1, anrm, rcond, w, iw, info )
431  CALL chkxer( 'SPBCON', infot, nout, lerr, ok )
432  infot = 2
433  CALL spbcon( 'U', -1, 0, a, 1, anrm, rcond, w, iw, info )
434  CALL chkxer( 'SPBCON', infot, nout, lerr, ok )
435  infot = 3
436  CALL spbcon( 'U', 1, -1, a, 1, anrm, rcond, w, iw, info )
437  CALL chkxer( 'SPBCON', infot, nout, lerr, ok )
438  infot = 5
439  CALL spbcon( 'U', 2, 1, a, 1, anrm, rcond, w, iw, info )
440  CALL chkxer( 'SPBCON', infot, nout, lerr, ok )
441 *
442 * SPBEQU
443 *
444  srnamt = 'SPBEQU'
445  infot = 1
446  CALL spbequ( '/', 0, 0, a, 1, r1, rcond, anrm, info )
447  CALL chkxer( 'SPBEQU', infot, nout, lerr, ok )
448  infot = 2
449  CALL spbequ( 'U', -1, 0, a, 1, r1, rcond, anrm, info )
450  CALL chkxer( 'SPBEQU', infot, nout, lerr, ok )
451  infot = 3
452  CALL spbequ( 'U', 1, -1, a, 1, r1, rcond, anrm, info )
453  CALL chkxer( 'SPBEQU', infot, nout, lerr, ok )
454  infot = 5
455  CALL spbequ( 'U', 2, 1, a, 1, r1, rcond, anrm, info )
456  CALL chkxer( 'SPBEQU', infot, nout, lerr, ok )
457  END IF
458 *
459 * Print a summary line.
460 *
461  CALL alaesm( path, ok, nout )
462 *
463  return
464 *
465 * End of SERRPO
466 *
467  END