LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
derrpox.f
Go to the documentation of this file.
1 *> \brief \b DERRPOX
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 DERRPO( 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 *> DERRPO tests the error exits for the DOUBLE PRECISION routines
25 *> for symmetric positive definite matrices.
26 *>
27 *> Note that this file is used only when the XBLAS are available,
28 *> otherwise derrpo.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 derrpo( 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 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, dpbcon, dpbequ, dpbrfs, dpbtf2,
96  $ dpbtrf, dpbtrs, dpocon, dpoequ, dporfs, dpotf2,
97  $ dpotrf, dpotri, dpotrs, dppcon, dppequ, dpprfs,
98  $ dpptrf, dpptri, dpptrs, dpoequb, dporfsx
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 dble
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.d0 / dble( i+j )
123  af( i, j ) = 1.d0 / dble( i+j )
124  10 continue
125  b( j ) = 0.d0
126  r1( j ) = 0.d0
127  r2( j ) = 0.d0
128  w( j ) = 0.d0
129  x( j ) = 0.d0
130  s( j ) = 0.d0
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 * DPOTRF
141 *
142  srnamt = 'DPOTRF'
143  infot = 1
144  CALL dpotrf( '/', 0, a, 1, info )
145  CALL chkxer( 'DPOTRF', infot, nout, lerr, ok )
146  infot = 2
147  CALL dpotrf( 'U', -1, a, 1, info )
148  CALL chkxer( 'DPOTRF', infot, nout, lerr, ok )
149  infot = 4
150  CALL dpotrf( 'U', 2, a, 1, info )
151  CALL chkxer( 'DPOTRF', infot, nout, lerr, ok )
152 *
153 * DPOTF2
154 *
155  srnamt = 'DPOTF2'
156  infot = 1
157  CALL dpotf2( '/', 0, a, 1, info )
158  CALL chkxer( 'DPOTF2', infot, nout, lerr, ok )
159  infot = 2
160  CALL dpotf2( 'U', -1, a, 1, info )
161  CALL chkxer( 'DPOTF2', infot, nout, lerr, ok )
162  infot = 4
163  CALL dpotf2( 'U', 2, a, 1, info )
164  CALL chkxer( 'DPOTF2', infot, nout, lerr, ok )
165 *
166 * DPOTRI
167 *
168  srnamt = 'DPOTRI'
169  infot = 1
170  CALL dpotri( '/', 0, a, 1, info )
171  CALL chkxer( 'DPOTRI', infot, nout, lerr, ok )
172  infot = 2
173  CALL dpotri( 'U', -1, a, 1, info )
174  CALL chkxer( 'DPOTRI', infot, nout, lerr, ok )
175  infot = 4
176  CALL dpotri( 'U', 2, a, 1, info )
177  CALL chkxer( 'DPOTRI', infot, nout, lerr, ok )
178 *
179 * DPOTRS
180 *
181  srnamt = 'DPOTRS'
182  infot = 1
183  CALL dpotrs( '/', 0, 0, a, 1, b, 1, info )
184  CALL chkxer( 'DPOTRS', infot, nout, lerr, ok )
185  infot = 2
186  CALL dpotrs( 'U', -1, 0, a, 1, b, 1, info )
187  CALL chkxer( 'DPOTRS', infot, nout, lerr, ok )
188  infot = 3
189  CALL dpotrs( 'U', 0, -1, a, 1, b, 1, info )
190  CALL chkxer( 'DPOTRS', infot, nout, lerr, ok )
191  infot = 5
192  CALL dpotrs( 'U', 2, 1, a, 1, b, 2, info )
193  CALL chkxer( 'DPOTRS', infot, nout, lerr, ok )
194  infot = 7
195  CALL dpotrs( 'U', 2, 1, a, 2, b, 1, info )
196  CALL chkxer( 'DPOTRS', infot, nout, lerr, ok )
197 *
198 * DPORFS
199 *
200  srnamt = 'DPORFS'
201  infot = 1
202  CALL dporfs( '/', 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w, iw,
203  $ info )
204  CALL chkxer( 'DPORFS', infot, nout, lerr, ok )
205  infot = 2
206  CALL dporfs( 'U', -1, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
207  $ iw, info )
208  CALL chkxer( 'DPORFS', infot, nout, lerr, ok )
209  infot = 3
210  CALL dporfs( 'U', 0, -1, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
211  $ iw, info )
212  CALL chkxer( 'DPORFS', infot, nout, lerr, ok )
213  infot = 5
214  CALL dporfs( 'U', 2, 1, a, 1, af, 2, b, 2, x, 2, r1, r2, w, iw,
215  $ info )
216  CALL chkxer( 'DPORFS', infot, nout, lerr, ok )
217  infot = 7
218  CALL dporfs( 'U', 2, 1, a, 2, af, 1, b, 2, x, 2, r1, r2, w, iw,
219  $ info )
220  CALL chkxer( 'DPORFS', infot, nout, lerr, ok )
221  infot = 9
222  CALL dporfs( 'U', 2, 1, a, 2, af, 2, b, 1, x, 2, r1, r2, w, iw,
223  $ info )
224  CALL chkxer( 'DPORFS', infot, nout, lerr, ok )
225  infot = 11
226  CALL dporfs( 'U', 2, 1, a, 2, af, 2, b, 2, x, 1, r1, r2, w, iw,
227  $ info )
228  CALL chkxer( 'DPORFS', infot, nout, lerr, ok )
229 *
230 * DPORFSX
231 *
232  n_err_bnds = 3
233  nparams = 0
234  srnamt = 'DPORFSX'
235  infot = 1
236  CALL dporfsx( '/', 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( 'DPORFSX', infot, nout, lerr, ok )
240  infot = 2
241  CALL dporfsx( '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( 'DPORFSX', infot, nout, lerr, ok )
245  eq = 'N'
246  infot = 3
247  CALL dporfsx( '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( 'DPORFSX', infot, nout, lerr, ok )
251  infot = 4
252  CALL dporfsx( '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( 'DPORFSX', infot, nout, lerr, ok )
256  infot = 6
257  CALL dporfsx( '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( 'DPORFSX', infot, nout, lerr, ok )
261  infot = 8
262  CALL dporfsx( '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( 'DPORFSX', infot, nout, lerr, ok )
266  infot = 11
267  CALL dporfsx( '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( 'DPORFSX', infot, nout, lerr, ok )
271  infot = 13
272  CALL dporfsx( '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( 'DPORFSX', infot, nout, lerr, ok )
276 *
277 * DPOCON
278 *
279  srnamt = 'DPOCON'
280  infot = 1
281  CALL dpocon( '/', 0, a, 1, anrm, rcond, w, iw, info )
282  CALL chkxer( 'DPOCON', infot, nout, lerr, ok )
283  infot = 2
284  CALL dpocon( 'U', -1, a, 1, anrm, rcond, w, iw, info )
285  CALL chkxer( 'DPOCON', infot, nout, lerr, ok )
286  infot = 4
287  CALL dpocon( 'U', 2, a, 1, anrm, rcond, w, iw, info )
288  CALL chkxer( 'DPOCON', infot, nout, lerr, ok )
289 *
290 * DPOEQU
291 *
292  srnamt = 'DPOEQU'
293  infot = 1
294  CALL dpoequ( -1, a, 1, r1, rcond, anrm, info )
295  CALL chkxer( 'DPOEQU', infot, nout, lerr, ok )
296  infot = 3
297  CALL dpoequ( 2, a, 1, r1, rcond, anrm, info )
298  CALL chkxer( 'DPOEQU', infot, nout, lerr, ok )
299 *
300 * DPOEQUB
301 *
302  srnamt = 'DPOEQUB'
303  infot = 1
304  CALL dpoequb( -1, a, 1, r1, rcond, anrm, info )
305  CALL chkxer( 'DPOEQUB', infot, nout, lerr, ok )
306  infot = 3
307  CALL dpoequb( 2, a, 1, r1, rcond, anrm, info )
308  CALL chkxer( 'DPOEQUB', 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 * DPPTRF
316 *
317  srnamt = 'DPPTRF'
318  infot = 1
319  CALL dpptrf( '/', 0, a, info )
320  CALL chkxer( 'DPPTRF', infot, nout, lerr, ok )
321  infot = 2
322  CALL dpptrf( 'U', -1, a, info )
323  CALL chkxer( 'DPPTRF', infot, nout, lerr, ok )
324 *
325 * DPPTRI
326 *
327  srnamt = 'DPPTRI'
328  infot = 1
329  CALL dpptri( '/', 0, a, info )
330  CALL chkxer( 'DPPTRI', infot, nout, lerr, ok )
331  infot = 2
332  CALL dpptri( 'U', -1, a, info )
333  CALL chkxer( 'DPPTRI', infot, nout, lerr, ok )
334 *
335 * DPPTRS
336 *
337  srnamt = 'DPPTRS'
338  infot = 1
339  CALL dpptrs( '/', 0, 0, a, b, 1, info )
340  CALL chkxer( 'DPPTRS', infot, nout, lerr, ok )
341  infot = 2
342  CALL dpptrs( 'U', -1, 0, a, b, 1, info )
343  CALL chkxer( 'DPPTRS', infot, nout, lerr, ok )
344  infot = 3
345  CALL dpptrs( 'U', 0, -1, a, b, 1, info )
346  CALL chkxer( 'DPPTRS', infot, nout, lerr, ok )
347  infot = 6
348  CALL dpptrs( 'U', 2, 1, a, b, 1, info )
349  CALL chkxer( 'DPPTRS', infot, nout, lerr, ok )
350 *
351 * DPPRFS
352 *
353  srnamt = 'DPPRFS'
354  infot = 1
355  CALL dpprfs( '/', 0, 0, a, af, b, 1, x, 1, r1, r2, w, iw,
356  $ info )
357  CALL chkxer( 'DPPRFS', infot, nout, lerr, ok )
358  infot = 2
359  CALL dpprfs( 'U', -1, 0, a, af, b, 1, x, 1, r1, r2, w, iw,
360  $ info )
361  CALL chkxer( 'DPPRFS', infot, nout, lerr, ok )
362  infot = 3
363  CALL dpprfs( 'U', 0, -1, a, af, b, 1, x, 1, r1, r2, w, iw,
364  $ info )
365  CALL chkxer( 'DPPRFS', infot, nout, lerr, ok )
366  infot = 7
367  CALL dpprfs( 'U', 2, 1, a, af, b, 1, x, 2, r1, r2, w, iw,
368  $ info )
369  CALL chkxer( 'DPPRFS', infot, nout, lerr, ok )
370  infot = 9
371  CALL dpprfs( 'U', 2, 1, a, af, b, 2, x, 1, r1, r2, w, iw,
372  $ info )
373  CALL chkxer( 'DPPRFS', infot, nout, lerr, ok )
374 *
375 * DPPCON
376 *
377  srnamt = 'DPPCON'
378  infot = 1
379  CALL dppcon( '/', 0, a, anrm, rcond, w, iw, info )
380  CALL chkxer( 'DPPCON', infot, nout, lerr, ok )
381  infot = 2
382  CALL dppcon( 'U', -1, a, anrm, rcond, w, iw, info )
383  CALL chkxer( 'DPPCON', infot, nout, lerr, ok )
384 *
385 * DPPEQU
386 *
387  srnamt = 'DPPEQU'
388  infot = 1
389  CALL dppequ( '/', 0, a, r1, rcond, anrm, info )
390  CALL chkxer( 'DPPEQU', infot, nout, lerr, ok )
391  infot = 2
392  CALL dppequ( 'U', -1, a, r1, rcond, anrm, info )
393  CALL chkxer( 'DPPEQU', 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 * DPBTRF
401 *
402  srnamt = 'DPBTRF'
403  infot = 1
404  CALL dpbtrf( '/', 0, 0, a, 1, info )
405  CALL chkxer( 'DPBTRF', infot, nout, lerr, ok )
406  infot = 2
407  CALL dpbtrf( 'U', -1, 0, a, 1, info )
408  CALL chkxer( 'DPBTRF', infot, nout, lerr, ok )
409  infot = 3
410  CALL dpbtrf( 'U', 1, -1, a, 1, info )
411  CALL chkxer( 'DPBTRF', infot, nout, lerr, ok )
412  infot = 5
413  CALL dpbtrf( 'U', 2, 1, a, 1, info )
414  CALL chkxer( 'DPBTRF', infot, nout, lerr, ok )
415 *
416 * DPBTF2
417 *
418  srnamt = 'DPBTF2'
419  infot = 1
420  CALL dpbtf2( '/', 0, 0, a, 1, info )
421  CALL chkxer( 'DPBTF2', infot, nout, lerr, ok )
422  infot = 2
423  CALL dpbtf2( 'U', -1, 0, a, 1, info )
424  CALL chkxer( 'DPBTF2', infot, nout, lerr, ok )
425  infot = 3
426  CALL dpbtf2( 'U', 1, -1, a, 1, info )
427  CALL chkxer( 'DPBTF2', infot, nout, lerr, ok )
428  infot = 5
429  CALL dpbtf2( 'U', 2, 1, a, 1, info )
430  CALL chkxer( 'DPBTF2', infot, nout, lerr, ok )
431 *
432 * DPBTRS
433 *
434  srnamt = 'DPBTRS'
435  infot = 1
436  CALL dpbtrs( '/', 0, 0, 0, a, 1, b, 1, info )
437  CALL chkxer( 'DPBTRS', infot, nout, lerr, ok )
438  infot = 2
439  CALL dpbtrs( 'U', -1, 0, 0, a, 1, b, 1, info )
440  CALL chkxer( 'DPBTRS', infot, nout, lerr, ok )
441  infot = 3
442  CALL dpbtrs( 'U', 1, -1, 0, a, 1, b, 1, info )
443  CALL chkxer( 'DPBTRS', infot, nout, lerr, ok )
444  infot = 4
445  CALL dpbtrs( 'U', 0, 0, -1, a, 1, b, 1, info )
446  CALL chkxer( 'DPBTRS', infot, nout, lerr, ok )
447  infot = 6
448  CALL dpbtrs( 'U', 2, 1, 1, a, 1, b, 1, info )
449  CALL chkxer( 'DPBTRS', infot, nout, lerr, ok )
450  infot = 8
451  CALL dpbtrs( 'U', 2, 0, 1, a, 1, b, 1, info )
452  CALL chkxer( 'DPBTRS', infot, nout, lerr, ok )
453 *
454 * DPBRFS
455 *
456  srnamt = 'DPBRFS'
457  infot = 1
458  CALL dpbrfs( '/', 0, 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
459  $ iw, info )
460  CALL chkxer( 'DPBRFS', infot, nout, lerr, ok )
461  infot = 2
462  CALL dpbrfs( 'U', -1, 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
463  $ iw, info )
464  CALL chkxer( 'DPBRFS', infot, nout, lerr, ok )
465  infot = 3
466  CALL dpbrfs( 'U', 1, -1, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
467  $ iw, info )
468  CALL chkxer( 'DPBRFS', infot, nout, lerr, ok )
469  infot = 4
470  CALL dpbrfs( 'U', 0, 0, -1, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
471  $ iw, info )
472  CALL chkxer( 'DPBRFS', infot, nout, lerr, ok )
473  infot = 6
474  CALL dpbrfs( 'U', 2, 1, 1, a, 1, af, 2, b, 2, x, 2, r1, r2, w,
475  $ iw, info )
476  CALL chkxer( 'DPBRFS', infot, nout, lerr, ok )
477  infot = 8
478  CALL dpbrfs( 'U', 2, 1, 1, a, 2, af, 1, b, 2, x, 2, r1, r2, w,
479  $ iw, info )
480  CALL chkxer( 'DPBRFS', infot, nout, lerr, ok )
481  infot = 10
482  CALL dpbrfs( 'U', 2, 0, 1, a, 1, af, 1, b, 1, x, 2, r1, r2, w,
483  $ iw, info )
484  CALL chkxer( 'DPBRFS', infot, nout, lerr, ok )
485  infot = 12
486  CALL dpbrfs( 'U', 2, 0, 1, a, 1, af, 1, b, 2, x, 1, r1, r2, w,
487  $ iw, info )
488  CALL chkxer( 'DPBRFS', infot, nout, lerr, ok )
489 *
490 * DPBCON
491 *
492  srnamt = 'DPBCON'
493  infot = 1
494  CALL dpbcon( '/', 0, 0, a, 1, anrm, rcond, w, iw, info )
495  CALL chkxer( 'DPBCON', infot, nout, lerr, ok )
496  infot = 2
497  CALL dpbcon( 'U', -1, 0, a, 1, anrm, rcond, w, iw, info )
498  CALL chkxer( 'DPBCON', infot, nout, lerr, ok )
499  infot = 3
500  CALL dpbcon( 'U', 1, -1, a, 1, anrm, rcond, w, iw, info )
501  CALL chkxer( 'DPBCON', infot, nout, lerr, ok )
502  infot = 5
503  CALL dpbcon( 'U', 2, 1, a, 1, anrm, rcond, w, iw, info )
504  CALL chkxer( 'DPBCON', infot, nout, lerr, ok )
505 *
506 * DPBEQU
507 *
508  srnamt = 'DPBEQU'
509  infot = 1
510  CALL dpbequ( '/', 0, 0, a, 1, r1, rcond, anrm, info )
511  CALL chkxer( 'DPBEQU', infot, nout, lerr, ok )
512  infot = 2
513  CALL dpbequ( 'U', -1, 0, a, 1, r1, rcond, anrm, info )
514  CALL chkxer( 'DPBEQU', infot, nout, lerr, ok )
515  infot = 3
516  CALL dpbequ( 'U', 1, -1, a, 1, r1, rcond, anrm, info )
517  CALL chkxer( 'DPBEQU', infot, nout, lerr, ok )
518  infot = 5
519  CALL dpbequ( 'U', 2, 1, a, 1, r1, rcond, anrm, info )
520  CALL chkxer( 'DPBEQU', 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 DERRPO
530 *
531  END