LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
derrpo.f
Go to the documentation of this file.
1 *> \brief \b DERRPO
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 *> \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 double_lin
54 *
55 * =====================================================================
56  SUBROUTINE derrpo( 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  DOUBLE PRECISION anrm, rcond
78 * ..
79 * .. Local Arrays ..
80  INTEGER 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, dpbcon, dpbequ, dpbrfs, dpbtf2,
90  $ dpbtrf, dpbtrs, dpocon, dpoequ, dporfs, dpotf2,
91  $ dpotrf, dpotri, dpotrs, dppcon, dppequ, dpprfs,
92  $ dpptrf, dpptri, dpptrs
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 dble
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.d0 / dble( i+j )
117  af( i, j ) = 1.d0 / dble( i+j )
118  10 continue
119  b( j ) = 0.d0
120  r1( j ) = 0.d0
121  r2( j ) = 0.d0
122  w( j ) = 0.d0
123  x( j ) = 0.d0
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 * DPOTRF
134 *
135  srnamt = 'DPOTRF'
136  infot = 1
137  CALL dpotrf( '/', 0, a, 1, info )
138  CALL chkxer( 'DPOTRF', infot, nout, lerr, ok )
139  infot = 2
140  CALL dpotrf( 'U', -1, a, 1, info )
141  CALL chkxer( 'DPOTRF', infot, nout, lerr, ok )
142  infot = 4
143  CALL dpotrf( 'U', 2, a, 1, info )
144  CALL chkxer( 'DPOTRF', infot, nout, lerr, ok )
145 *
146 * DPOTF2
147 *
148  srnamt = 'DPOTF2'
149  infot = 1
150  CALL dpotf2( '/', 0, a, 1, info )
151  CALL chkxer( 'DPOTF2', infot, nout, lerr, ok )
152  infot = 2
153  CALL dpotf2( 'U', -1, a, 1, info )
154  CALL chkxer( 'DPOTF2', infot, nout, lerr, ok )
155  infot = 4
156  CALL dpotf2( 'U', 2, a, 1, info )
157  CALL chkxer( 'DPOTF2', infot, nout, lerr, ok )
158 *
159 * DPOTRI
160 *
161  srnamt = 'DPOTRI'
162  infot = 1
163  CALL dpotri( '/', 0, a, 1, info )
164  CALL chkxer( 'DPOTRI', infot, nout, lerr, ok )
165  infot = 2
166  CALL dpotri( 'U', -1, a, 1, info )
167  CALL chkxer( 'DPOTRI', infot, nout, lerr, ok )
168  infot = 4
169  CALL dpotri( 'U', 2, a, 1, info )
170  CALL chkxer( 'DPOTRI', infot, nout, lerr, ok )
171 *
172 * DPOTRS
173 *
174  srnamt = 'DPOTRS'
175  infot = 1
176  CALL dpotrs( '/', 0, 0, a, 1, b, 1, info )
177  CALL chkxer( 'DPOTRS', infot, nout, lerr, ok )
178  infot = 2
179  CALL dpotrs( 'U', -1, 0, a, 1, b, 1, info )
180  CALL chkxer( 'DPOTRS', infot, nout, lerr, ok )
181  infot = 3
182  CALL dpotrs( 'U', 0, -1, a, 1, b, 1, info )
183  CALL chkxer( 'DPOTRS', infot, nout, lerr, ok )
184  infot = 5
185  CALL dpotrs( 'U', 2, 1, a, 1, b, 2, info )
186  CALL chkxer( 'DPOTRS', infot, nout, lerr, ok )
187  infot = 7
188  CALL dpotrs( 'U', 2, 1, a, 2, b, 1, info )
189  CALL chkxer( 'DPOTRS', infot, nout, lerr, ok )
190 *
191 * DPORFS
192 *
193  srnamt = 'DPORFS'
194  infot = 1
195  CALL dporfs( '/', 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w, iw,
196  $ info )
197  CALL chkxer( 'DPORFS', infot, nout, lerr, ok )
198  infot = 2
199  CALL dporfs( 'U', -1, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
200  $ iw, info )
201  CALL chkxer( 'DPORFS', infot, nout, lerr, ok )
202  infot = 3
203  CALL dporfs( 'U', 0, -1, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
204  $ iw, info )
205  CALL chkxer( 'DPORFS', infot, nout, lerr, ok )
206  infot = 5
207  CALL dporfs( 'U', 2, 1, a, 1, af, 2, b, 2, x, 2, r1, r2, w, iw,
208  $ info )
209  CALL chkxer( 'DPORFS', infot, nout, lerr, ok )
210  infot = 7
211  CALL dporfs( 'U', 2, 1, a, 2, af, 1, b, 2, x, 2, r1, r2, w, iw,
212  $ info )
213  CALL chkxer( 'DPORFS', infot, nout, lerr, ok )
214  infot = 9
215  CALL dporfs( 'U', 2, 1, a, 2, af, 2, b, 1, x, 2, r1, r2, w, iw,
216  $ info )
217  CALL chkxer( 'DPORFS', infot, nout, lerr, ok )
218  infot = 11
219  CALL dporfs( 'U', 2, 1, a, 2, af, 2, b, 2, x, 1, r1, r2, w, iw,
220  $ info )
221  CALL chkxer( 'DPORFS', infot, nout, lerr, ok )
222 *
223 * DPOCON
224 *
225  srnamt = 'DPOCON'
226  infot = 1
227  CALL dpocon( '/', 0, a, 1, anrm, rcond, w, iw, info )
228  CALL chkxer( 'DPOCON', infot, nout, lerr, ok )
229  infot = 2
230  CALL dpocon( 'U', -1, a, 1, anrm, rcond, w, iw, info )
231  CALL chkxer( 'DPOCON', infot, nout, lerr, ok )
232  infot = 4
233  CALL dpocon( 'U', 2, a, 1, anrm, rcond, w, iw, info )
234  CALL chkxer( 'DPOCON', infot, nout, lerr, ok )
235 *
236 * DPOEQU
237 *
238  srnamt = 'DPOEQU'
239  infot = 1
240  CALL dpoequ( -1, a, 1, r1, rcond, anrm, info )
241  CALL chkxer( 'DPOEQU', infot, nout, lerr, ok )
242  infot = 3
243  CALL dpoequ( 2, a, 1, r1, rcond, anrm, info )
244  CALL chkxer( 'DPOEQU', 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 * DPPTRF
252 *
253  srnamt = 'DPPTRF'
254  infot = 1
255  CALL dpptrf( '/', 0, a, info )
256  CALL chkxer( 'DPPTRF', infot, nout, lerr, ok )
257  infot = 2
258  CALL dpptrf( 'U', -1, a, info )
259  CALL chkxer( 'DPPTRF', infot, nout, lerr, ok )
260 *
261 * DPPTRI
262 *
263  srnamt = 'DPPTRI'
264  infot = 1
265  CALL dpptri( '/', 0, a, info )
266  CALL chkxer( 'DPPTRI', infot, nout, lerr, ok )
267  infot = 2
268  CALL dpptri( 'U', -1, a, info )
269  CALL chkxer( 'DPPTRI', infot, nout, lerr, ok )
270 *
271 * DPPTRS
272 *
273  srnamt = 'DPPTRS'
274  infot = 1
275  CALL dpptrs( '/', 0, 0, a, b, 1, info )
276  CALL chkxer( 'DPPTRS', infot, nout, lerr, ok )
277  infot = 2
278  CALL dpptrs( 'U', -1, 0, a, b, 1, info )
279  CALL chkxer( 'DPPTRS', infot, nout, lerr, ok )
280  infot = 3
281  CALL dpptrs( 'U', 0, -1, a, b, 1, info )
282  CALL chkxer( 'DPPTRS', infot, nout, lerr, ok )
283  infot = 6
284  CALL dpptrs( 'U', 2, 1, a, b, 1, info )
285  CALL chkxer( 'DPPTRS', infot, nout, lerr, ok )
286 *
287 * DPPRFS
288 *
289  srnamt = 'DPPRFS'
290  infot = 1
291  CALL dpprfs( '/', 0, 0, a, af, b, 1, x, 1, r1, r2, w, iw,
292  $ info )
293  CALL chkxer( 'DPPRFS', infot, nout, lerr, ok )
294  infot = 2
295  CALL dpprfs( 'U', -1, 0, a, af, b, 1, x, 1, r1, r2, w, iw,
296  $ info )
297  CALL chkxer( 'DPPRFS', infot, nout, lerr, ok )
298  infot = 3
299  CALL dpprfs( 'U', 0, -1, a, af, b, 1, x, 1, r1, r2, w, iw,
300  $ info )
301  CALL chkxer( 'DPPRFS', infot, nout, lerr, ok )
302  infot = 7
303  CALL dpprfs( 'U', 2, 1, a, af, b, 1, x, 2, r1, r2, w, iw,
304  $ info )
305  CALL chkxer( 'DPPRFS', infot, nout, lerr, ok )
306  infot = 9
307  CALL dpprfs( 'U', 2, 1, a, af, b, 2, x, 1, r1, r2, w, iw,
308  $ info )
309  CALL chkxer( 'DPPRFS', infot, nout, lerr, ok )
310 *
311 * DPPCON
312 *
313  srnamt = 'DPPCON'
314  infot = 1
315  CALL dppcon( '/', 0, a, anrm, rcond, w, iw, info )
316  CALL chkxer( 'DPPCON', infot, nout, lerr, ok )
317  infot = 2
318  CALL dppcon( 'U', -1, a, anrm, rcond, w, iw, info )
319  CALL chkxer( 'DPPCON', infot, nout, lerr, ok )
320 *
321 * DPPEQU
322 *
323  srnamt = 'DPPEQU'
324  infot = 1
325  CALL dppequ( '/', 0, a, r1, rcond, anrm, info )
326  CALL chkxer( 'DPPEQU', infot, nout, lerr, ok )
327  infot = 2
328  CALL dppequ( 'U', -1, a, r1, rcond, anrm, info )
329  CALL chkxer( 'DPPEQU', 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 * DPBTRF
337 *
338  srnamt = 'DPBTRF'
339  infot = 1
340  CALL dpbtrf( '/', 0, 0, a, 1, info )
341  CALL chkxer( 'DPBTRF', infot, nout, lerr, ok )
342  infot = 2
343  CALL dpbtrf( 'U', -1, 0, a, 1, info )
344  CALL chkxer( 'DPBTRF', infot, nout, lerr, ok )
345  infot = 3
346  CALL dpbtrf( 'U', 1, -1, a, 1, info )
347  CALL chkxer( 'DPBTRF', infot, nout, lerr, ok )
348  infot = 5
349  CALL dpbtrf( 'U', 2, 1, a, 1, info )
350  CALL chkxer( 'DPBTRF', infot, nout, lerr, ok )
351 *
352 * DPBTF2
353 *
354  srnamt = 'DPBTF2'
355  infot = 1
356  CALL dpbtf2( '/', 0, 0, a, 1, info )
357  CALL chkxer( 'DPBTF2', infot, nout, lerr, ok )
358  infot = 2
359  CALL dpbtf2( 'U', -1, 0, a, 1, info )
360  CALL chkxer( 'DPBTF2', infot, nout, lerr, ok )
361  infot = 3
362  CALL dpbtf2( 'U', 1, -1, a, 1, info )
363  CALL chkxer( 'DPBTF2', infot, nout, lerr, ok )
364  infot = 5
365  CALL dpbtf2( 'U', 2, 1, a, 1, info )
366  CALL chkxer( 'DPBTF2', infot, nout, lerr, ok )
367 *
368 * DPBTRS
369 *
370  srnamt = 'DPBTRS'
371  infot = 1
372  CALL dpbtrs( '/', 0, 0, 0, a, 1, b, 1, info )
373  CALL chkxer( 'DPBTRS', infot, nout, lerr, ok )
374  infot = 2
375  CALL dpbtrs( 'U', -1, 0, 0, a, 1, b, 1, info )
376  CALL chkxer( 'DPBTRS', infot, nout, lerr, ok )
377  infot = 3
378  CALL dpbtrs( 'U', 1, -1, 0, a, 1, b, 1, info )
379  CALL chkxer( 'DPBTRS', infot, nout, lerr, ok )
380  infot = 4
381  CALL dpbtrs( 'U', 0, 0, -1, a, 1, b, 1, info )
382  CALL chkxer( 'DPBTRS', infot, nout, lerr, ok )
383  infot = 6
384  CALL dpbtrs( 'U', 2, 1, 1, a, 1, b, 1, info )
385  CALL chkxer( 'DPBTRS', infot, nout, lerr, ok )
386  infot = 8
387  CALL dpbtrs( 'U', 2, 0, 1, a, 1, b, 1, info )
388  CALL chkxer( 'DPBTRS', infot, nout, lerr, ok )
389 *
390 * DPBRFS
391 *
392  srnamt = 'DPBRFS'
393  infot = 1
394  CALL dpbrfs( '/', 0, 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
395  $ iw, info )
396  CALL chkxer( 'DPBRFS', infot, nout, lerr, ok )
397  infot = 2
398  CALL dpbrfs( 'U', -1, 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
399  $ iw, info )
400  CALL chkxer( 'DPBRFS', infot, nout, lerr, ok )
401  infot = 3
402  CALL dpbrfs( 'U', 1, -1, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
403  $ iw, info )
404  CALL chkxer( 'DPBRFS', infot, nout, lerr, ok )
405  infot = 4
406  CALL dpbrfs( 'U', 0, 0, -1, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
407  $ iw, info )
408  CALL chkxer( 'DPBRFS', infot, nout, lerr, ok )
409  infot = 6
410  CALL dpbrfs( 'U', 2, 1, 1, a, 1, af, 2, b, 2, x, 2, r1, r2, w,
411  $ iw, info )
412  CALL chkxer( 'DPBRFS', infot, nout, lerr, ok )
413  infot = 8
414  CALL dpbrfs( 'U', 2, 1, 1, a, 2, af, 1, b, 2, x, 2, r1, r2, w,
415  $ iw, info )
416  CALL chkxer( 'DPBRFS', infot, nout, lerr, ok )
417  infot = 10
418  CALL dpbrfs( 'U', 2, 0, 1, a, 1, af, 1, b, 1, x, 2, r1, r2, w,
419  $ iw, info )
420  CALL chkxer( 'DPBRFS', infot, nout, lerr, ok )
421  infot = 12
422  CALL dpbrfs( 'U', 2, 0, 1, a, 1, af, 1, b, 2, x, 1, r1, r2, w,
423  $ iw, info )
424  CALL chkxer( 'DPBRFS', infot, nout, lerr, ok )
425 *
426 * DPBCON
427 *
428  srnamt = 'DPBCON'
429  infot = 1
430  CALL dpbcon( '/', 0, 0, a, 1, anrm, rcond, w, iw, info )
431  CALL chkxer( 'DPBCON', infot, nout, lerr, ok )
432  infot = 2
433  CALL dpbcon( 'U', -1, 0, a, 1, anrm, rcond, w, iw, info )
434  CALL chkxer( 'DPBCON', infot, nout, lerr, ok )
435  infot = 3
436  CALL dpbcon( 'U', 1, -1, a, 1, anrm, rcond, w, iw, info )
437  CALL chkxer( 'DPBCON', infot, nout, lerr, ok )
438  infot = 5
439  CALL dpbcon( 'U', 2, 1, a, 1, anrm, rcond, w, iw, info )
440  CALL chkxer( 'DPBCON', infot, nout, lerr, ok )
441 *
442 * DPBEQU
443 *
444  srnamt = 'DPBEQU'
445  infot = 1
446  CALL dpbequ( '/', 0, 0, a, 1, r1, rcond, anrm, info )
447  CALL chkxer( 'DPBEQU', infot, nout, lerr, ok )
448  infot = 2
449  CALL dpbequ( 'U', -1, 0, a, 1, r1, rcond, anrm, info )
450  CALL chkxer( 'DPBEQU', infot, nout, lerr, ok )
451  infot = 3
452  CALL dpbequ( 'U', 1, -1, a, 1, r1, rcond, anrm, info )
453  CALL chkxer( 'DPBEQU', infot, nout, lerr, ok )
454  infot = 5
455  CALL dpbequ( 'U', 2, 1, a, 1, r1, rcond, anrm, info )
456  CALL chkxer( 'DPBEQU', 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 DERRPO
466 *
467  END