LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
serrpox.f
Go to the documentation of this file.
1 *> \brief \b SERRPOX
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 *>
27 *> Note that this file is used only when the XBLAS are available,
28 *> otherwise serrpo.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 single_lin
57 *
58 * =====================================================================
59  SUBROUTINE serrpo( 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  REAL anrm, rcond, berr
82 * ..
83 * .. Local Arrays ..
84  INTEGER iw( nmax )
85  REAL 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, spbcon, spbequ, spbrfs, spbtf2,
96  $ spbtrf, spbtrs, spocon, spoequ, sporfs, spotf2,
97  $ spotrf, spotri, spotrs, sppcon, sppequ, spprfs,
98  $ spptrf, spptri, spptrs, spoequb, sporfsx
99 * ..
100 * .. Scalars in Common ..
101  LOGICAL lerr, ok
102  CHARACTER*32 srnamt
103  INTEGER infot, nout
104 * ..
105 * .. Common blocks ..
106  common / infoc / infot, nout, ok, lerr
107  common / srnamc / srnamt
108 * ..
109 * .. Intrinsic Functions ..
110  INTRINSIC real
111 * ..
112 * .. Executable Statements ..
113 *
114  nout = nunit
115  WRITE( nout, fmt = * )
116  c2 = path( 2: 3 )
117 *
118 * Set the variables to innocuous values.
119 *
120  DO 20 j = 1, nmax
121  DO 10 i = 1, nmax
122  a( i, j ) = 1. / REAL( i+j )
123  af( i, j ) = 1. / REAL( i+j )
124  10 continue
125  b( j ) = 0.
126  r1( j ) = 0.
127  r2( j ) = 0.
128  w( j ) = 0.
129  x( j ) = 0.
130  s( j ) = 0.
131  iw( j ) = j
132  20 continue
133  ok = .true.
134 *
135  IF( lsamen( 2, c2, 'PO' ) ) THEN
136 *
137 * Test error exits of the routines that use the Cholesky
138 * decomposition of a symmetric positive definite matrix.
139 *
140 * SPOTRF
141 *
142  srnamt = 'SPOTRF'
143  infot = 1
144  CALL spotrf( '/', 0, a, 1, info )
145  CALL chkxer( 'SPOTRF', infot, nout, lerr, ok )
146  infot = 2
147  CALL spotrf( 'U', -1, a, 1, info )
148  CALL chkxer( 'SPOTRF', infot, nout, lerr, ok )
149  infot = 4
150  CALL spotrf( 'U', 2, a, 1, info )
151  CALL chkxer( 'SPOTRF', infot, nout, lerr, ok )
152 *
153 * SPOTF2
154 *
155  srnamt = 'SPOTF2'
156  infot = 1
157  CALL spotf2( '/', 0, a, 1, info )
158  CALL chkxer( 'SPOTF2', infot, nout, lerr, ok )
159  infot = 2
160  CALL spotf2( 'U', -1, a, 1, info )
161  CALL chkxer( 'SPOTF2', infot, nout, lerr, ok )
162  infot = 4
163  CALL spotf2( 'U', 2, a, 1, info )
164  CALL chkxer( 'SPOTF2', infot, nout, lerr, ok )
165 *
166 * SPOTRI
167 *
168  srnamt = 'SPOTRI'
169  infot = 1
170  CALL spotri( '/', 0, a, 1, info )
171  CALL chkxer( 'SPOTRI', infot, nout, lerr, ok )
172  infot = 2
173  CALL spotri( 'U', -1, a, 1, info )
174  CALL chkxer( 'SPOTRI', infot, nout, lerr, ok )
175  infot = 4
176  CALL spotri( 'U', 2, a, 1, info )
177  CALL chkxer( 'SPOTRI', infot, nout, lerr, ok )
178 *
179 * SPOTRS
180 *
181  srnamt = 'SPOTRS'
182  infot = 1
183  CALL spotrs( '/', 0, 0, a, 1, b, 1, info )
184  CALL chkxer( 'SPOTRS', infot, nout, lerr, ok )
185  infot = 2
186  CALL spotrs( 'U', -1, 0, a, 1, b, 1, info )
187  CALL chkxer( 'SPOTRS', infot, nout, lerr, ok )
188  infot = 3
189  CALL spotrs( 'U', 0, -1, a, 1, b, 1, info )
190  CALL chkxer( 'SPOTRS', infot, nout, lerr, ok )
191  infot = 5
192  CALL spotrs( 'U', 2, 1, a, 1, b, 2, info )
193  CALL chkxer( 'SPOTRS', infot, nout, lerr, ok )
194  infot = 7
195  CALL spotrs( 'U', 2, 1, a, 2, b, 1, info )
196  CALL chkxer( 'SPOTRS', infot, nout, lerr, ok )
197 *
198 * SPORFS
199 *
200  srnamt = 'SPORFS'
201  infot = 1
202  CALL sporfs( '/', 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w, iw,
203  $ info )
204  CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
205  infot = 2
206  CALL sporfs( 'U', -1, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
207  $ iw, info )
208  CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
209  infot = 3
210  CALL sporfs( 'U', 0, -1, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
211  $ iw, info )
212  CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
213  infot = 5
214  CALL sporfs( 'U', 2, 1, a, 1, af, 2, b, 2, x, 2, r1, r2, w, iw,
215  $ info )
216  CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
217  infot = 7
218  CALL sporfs( 'U', 2, 1, a, 2, af, 1, b, 2, x, 2, r1, r2, w, iw,
219  $ info )
220  CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
221  infot = 9
222  CALL sporfs( 'U', 2, 1, a, 2, af, 2, b, 1, x, 2, r1, r2, w, iw,
223  $ info )
224  CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
225  infot = 11
226  CALL sporfs( 'U', 2, 1, a, 2, af, 2, b, 2, x, 1, r1, r2, w, iw,
227  $ info )
228  CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
229 *
230 * SPORFSX
231 *
232  n_err_bnds = 3
233  nparams = 0
234  srnamt = 'SPORFSX'
235  infot = 1
236  CALL sporfsx( '/', eq, 0, 0, a, 1, af, 1, s, b, 1, x, 1,
237  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
238  $ params, w, iw, info )
239  CALL chkxer( 'SPORFSX', infot, nout, lerr, ok )
240  infot = 2
241  CALL sporfsx( 'U', eq, -1, 0, a, 1, af, 1, s, b, 1, x, 1,
242  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
243  $ params, w, iw, info )
244  CALL chkxer( 'SPORFSX', infot, nout, lerr, ok )
245  eq = 'N'
246  infot = 3
247  CALL sporfsx( 'U', eq, -1, 0, a, 1, af, 1, s, b, 1, x, 1,
248  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
249  $ params, w, iw, info )
250  CALL chkxer( 'SPORFSX', infot, nout, lerr, ok )
251  infot = 4
252  CALL sporfsx( 'U', eq, 0, -1, a, 1, af, 1, s, b, 1, x, 1,
253  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
254  $ params, w, iw, info )
255  CALL chkxer( 'SPORFSX', infot, nout, lerr, ok )
256  infot = 6
257  CALL sporfsx( 'U', eq, 2, 1, a, 1, af, 2, s, b, 2, x, 2,
258  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
259  $ params, w, iw, info )
260  CALL chkxer( 'SPORFSX', infot, nout, lerr, ok )
261  infot = 8
262  CALL sporfsx( 'U', eq, 2, 1, a, 2, af, 1, s, b, 2, x, 2,
263  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
264  $ params, w, iw, info )
265  CALL chkxer( 'SPORFSX', infot, nout, lerr, ok )
266  infot = 11
267  CALL sporfsx( 'U', eq, 2, 1, a, 2, af, 2, s, b, 1, x, 2,
268  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
269  $ params, w, iw, info )
270  CALL chkxer( 'SPORFSX', infot, nout, lerr, ok )
271  infot = 13
272  CALL sporfsx( 'U', eq, 2, 1, a, 2, af, 2, s, b, 2, x, 1,
273  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
274  $ params, w, iw, info )
275  CALL chkxer( 'SPORFSX', infot, nout, lerr, ok )
276 *
277 * SPOCON
278 *
279  srnamt = 'SPOCON'
280  infot = 1
281  CALL spocon( '/', 0, a, 1, anrm, rcond, w, iw, info )
282  CALL chkxer( 'SPOCON', infot, nout, lerr, ok )
283  infot = 2
284  CALL spocon( 'U', -1, a, 1, anrm, rcond, w, iw, info )
285  CALL chkxer( 'SPOCON', infot, nout, lerr, ok )
286  infot = 4
287  CALL spocon( 'U', 2, a, 1, anrm, rcond, w, iw, info )
288  CALL chkxer( 'SPOCON', infot, nout, lerr, ok )
289 *
290 * SPOEQU
291 *
292  srnamt = 'SPOEQU'
293  infot = 1
294  CALL spoequ( -1, a, 1, r1, rcond, anrm, info )
295  CALL chkxer( 'SPOEQU', infot, nout, lerr, ok )
296  infot = 3
297  CALL spoequ( 2, a, 1, r1, rcond, anrm, info )
298  CALL chkxer( 'SPOEQU', infot, nout, lerr, ok )
299 *
300 * SPOEQUB
301 *
302  srnamt = 'SPOEQUB'
303  infot = 1
304  CALL spoequb( -1, a, 1, r1, rcond, anrm, info )
305  CALL chkxer( 'SPOEQUB', infot, nout, lerr, ok )
306  infot = 3
307  CALL spoequb( 2, a, 1, r1, rcond, anrm, info )
308  CALL chkxer( 'SPOEQUB', infot, nout, lerr, ok )
309 *
310  ELSE IF( lsamen( 2, c2, 'PP' ) ) THEN
311 *
312 * Test error exits of the routines that use the Cholesky
313 * decomposition of a symmetric positive definite packed matrix.
314 *
315 * SPPTRF
316 *
317  srnamt = 'SPPTRF'
318  infot = 1
319  CALL spptrf( '/', 0, a, info )
320  CALL chkxer( 'SPPTRF', infot, nout, lerr, ok )
321  infot = 2
322  CALL spptrf( 'U', -1, a, info )
323  CALL chkxer( 'SPPTRF', infot, nout, lerr, ok )
324 *
325 * SPPTRI
326 *
327  srnamt = 'SPPTRI'
328  infot = 1
329  CALL spptri( '/', 0, a, info )
330  CALL chkxer( 'SPPTRI', infot, nout, lerr, ok )
331  infot = 2
332  CALL spptri( 'U', -1, a, info )
333  CALL chkxer( 'SPPTRI', infot, nout, lerr, ok )
334 *
335 * SPPTRS
336 *
337  srnamt = 'SPPTRS'
338  infot = 1
339  CALL spptrs( '/', 0, 0, a, b, 1, info )
340  CALL chkxer( 'SPPTRS', infot, nout, lerr, ok )
341  infot = 2
342  CALL spptrs( 'U', -1, 0, a, b, 1, info )
343  CALL chkxer( 'SPPTRS', infot, nout, lerr, ok )
344  infot = 3
345  CALL spptrs( 'U', 0, -1, a, b, 1, info )
346  CALL chkxer( 'SPPTRS', infot, nout, lerr, ok )
347  infot = 6
348  CALL spptrs( 'U', 2, 1, a, b, 1, info )
349  CALL chkxer( 'SPPTRS', infot, nout, lerr, ok )
350 *
351 * SPPRFS
352 *
353  srnamt = 'SPPRFS'
354  infot = 1
355  CALL spprfs( '/', 0, 0, a, af, b, 1, x, 1, r1, r2, w, iw,
356  $ info )
357  CALL chkxer( 'SPPRFS', infot, nout, lerr, ok )
358  infot = 2
359  CALL spprfs( 'U', -1, 0, a, af, b, 1, x, 1, r1, r2, w, iw,
360  $ info )
361  CALL chkxer( 'SPPRFS', infot, nout, lerr, ok )
362  infot = 3
363  CALL spprfs( 'U', 0, -1, a, af, b, 1, x, 1, r1, r2, w, iw,
364  $ info )
365  CALL chkxer( 'SPPRFS', infot, nout, lerr, ok )
366  infot = 7
367  CALL spprfs( 'U', 2, 1, a, af, b, 1, x, 2, r1, r2, w, iw,
368  $ info )
369  CALL chkxer( 'SPPRFS', infot, nout, lerr, ok )
370  infot = 9
371  CALL spprfs( 'U', 2, 1, a, af, b, 2, x, 1, r1, r2, w, iw,
372  $ info )
373  CALL chkxer( 'SPPRFS', infot, nout, lerr, ok )
374 *
375 * SPPCON
376 *
377  srnamt = 'SPPCON'
378  infot = 1
379  CALL sppcon( '/', 0, a, anrm, rcond, w, iw, info )
380  CALL chkxer( 'SPPCON', infot, nout, lerr, ok )
381  infot = 2
382  CALL sppcon( 'U', -1, a, anrm, rcond, w, iw, info )
383  CALL chkxer( 'SPPCON', infot, nout, lerr, ok )
384 *
385 * SPPEQU
386 *
387  srnamt = 'SPPEQU'
388  infot = 1
389  CALL sppequ( '/', 0, a, r1, rcond, anrm, info )
390  CALL chkxer( 'SPPEQU', infot, nout, lerr, ok )
391  infot = 2
392  CALL sppequ( 'U', -1, a, r1, rcond, anrm, info )
393  CALL chkxer( 'SPPEQU', infot, nout, lerr, ok )
394 *
395  ELSE IF( lsamen( 2, c2, 'PB' ) ) THEN
396 *
397 * Test error exits of the routines that use the Cholesky
398 * decomposition of a symmetric positive definite band matrix.
399 *
400 * SPBTRF
401 *
402  srnamt = 'SPBTRF'
403  infot = 1
404  CALL spbtrf( '/', 0, 0, a, 1, info )
405  CALL chkxer( 'SPBTRF', infot, nout, lerr, ok )
406  infot = 2
407  CALL spbtrf( 'U', -1, 0, a, 1, info )
408  CALL chkxer( 'SPBTRF', infot, nout, lerr, ok )
409  infot = 3
410  CALL spbtrf( 'U', 1, -1, a, 1, info )
411  CALL chkxer( 'SPBTRF', infot, nout, lerr, ok )
412  infot = 5
413  CALL spbtrf( 'U', 2, 1, a, 1, info )
414  CALL chkxer( 'SPBTRF', infot, nout, lerr, ok )
415 *
416 * SPBTF2
417 *
418  srnamt = 'SPBTF2'
419  infot = 1
420  CALL spbtf2( '/', 0, 0, a, 1, info )
421  CALL chkxer( 'SPBTF2', infot, nout, lerr, ok )
422  infot = 2
423  CALL spbtf2( 'U', -1, 0, a, 1, info )
424  CALL chkxer( 'SPBTF2', infot, nout, lerr, ok )
425  infot = 3
426  CALL spbtf2( 'U', 1, -1, a, 1, info )
427  CALL chkxer( 'SPBTF2', infot, nout, lerr, ok )
428  infot = 5
429  CALL spbtf2( 'U', 2, 1, a, 1, info )
430  CALL chkxer( 'SPBTF2', infot, nout, lerr, ok )
431 *
432 * SPBTRS
433 *
434  srnamt = 'SPBTRS'
435  infot = 1
436  CALL spbtrs( '/', 0, 0, 0, a, 1, b, 1, info )
437  CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
438  infot = 2
439  CALL spbtrs( 'U', -1, 0, 0, a, 1, b, 1, info )
440  CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
441  infot = 3
442  CALL spbtrs( 'U', 1, -1, 0, a, 1, b, 1, info )
443  CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
444  infot = 4
445  CALL spbtrs( 'U', 0, 0, -1, a, 1, b, 1, info )
446  CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
447  infot = 6
448  CALL spbtrs( 'U', 2, 1, 1, a, 1, b, 1, info )
449  CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
450  infot = 8
451  CALL spbtrs( 'U', 2, 0, 1, a, 1, b, 1, info )
452  CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
453 *
454 * SPBRFS
455 *
456  srnamt = 'SPBRFS'
457  infot = 1
458  CALL spbrfs( '/', 0, 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
459  $ iw, info )
460  CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
461  infot = 2
462  CALL spbrfs( 'U', -1, 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
463  $ iw, info )
464  CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
465  infot = 3
466  CALL spbrfs( 'U', 1, -1, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
467  $ iw, info )
468  CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
469  infot = 4
470  CALL spbrfs( 'U', 0, 0, -1, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
471  $ iw, info )
472  CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
473  infot = 6
474  CALL spbrfs( 'U', 2, 1, 1, a, 1, af, 2, b, 2, x, 2, r1, r2, w,
475  $ iw, info )
476  CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
477  infot = 8
478  CALL spbrfs( 'U', 2, 1, 1, a, 2, af, 1, b, 2, x, 2, r1, r2, w,
479  $ iw, info )
480  CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
481  infot = 10
482  CALL spbrfs( 'U', 2, 0, 1, a, 1, af, 1, b, 1, x, 2, r1, r2, w,
483  $ iw, info )
484  CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
485  infot = 12
486  CALL spbrfs( 'U', 2, 0, 1, a, 1, af, 1, b, 2, x, 1, r1, r2, w,
487  $ iw, info )
488  CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
489 *
490 * SPBCON
491 *
492  srnamt = 'SPBCON'
493  infot = 1
494  CALL spbcon( '/', 0, 0, a, 1, anrm, rcond, w, iw, info )
495  CALL chkxer( 'SPBCON', infot, nout, lerr, ok )
496  infot = 2
497  CALL spbcon( 'U', -1, 0, a, 1, anrm, rcond, w, iw, info )
498  CALL chkxer( 'SPBCON', infot, nout, lerr, ok )
499  infot = 3
500  CALL spbcon( 'U', 1, -1, a, 1, anrm, rcond, w, iw, info )
501  CALL chkxer( 'SPBCON', infot, nout, lerr, ok )
502  infot = 5
503  CALL spbcon( 'U', 2, 1, a, 1, anrm, rcond, w, iw, info )
504  CALL chkxer( 'SPBCON', infot, nout, lerr, ok )
505 *
506 * SPBEQU
507 *
508  srnamt = 'SPBEQU'
509  infot = 1
510  CALL spbequ( '/', 0, 0, a, 1, r1, rcond, anrm, info )
511  CALL chkxer( 'SPBEQU', infot, nout, lerr, ok )
512  infot = 2
513  CALL spbequ( 'U', -1, 0, a, 1, r1, rcond, anrm, info )
514  CALL chkxer( 'SPBEQU', infot, nout, lerr, ok )
515  infot = 3
516  CALL spbequ( 'U', 1, -1, a, 1, r1, rcond, anrm, info )
517  CALL chkxer( 'SPBEQU', infot, nout, lerr, ok )
518  infot = 5
519  CALL spbequ( 'U', 2, 1, a, 1, r1, rcond, anrm, info )
520  CALL chkxer( 'SPBEQU', infot, nout, lerr, ok )
521  END IF
522 *
523 * Print a summary line.
524 *
525  CALL alaesm( path, ok, nout )
526 *
527  return
528 *
529 * End of SERRPO
530 *
531  END