LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
cerrpo.f
Go to the documentation of this file.
1 *> \brief \b CERRPO
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 CERRPO( 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 *> CERRPO tests the error exits for the COMPLEX routines
25 *> for Hermitian 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 complex_lin
54 *
55 * =====================================================================
56  SUBROUTINE cerrpo( 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  REAL r( nmax ), r1( nmax ), r2( nmax )
81  COMPLEX a( nmax, nmax ), af( nmax, nmax ), b( nmax ),
82  $ w( 2*nmax ), x( nmax )
83 * ..
84 * .. External Functions ..
85  LOGICAL lsamen
86  EXTERNAL lsamen
87 * ..
88 * .. External Subroutines ..
89  EXTERNAL alaesm, chkxer, cpbcon, cpbequ, cpbrfs, cpbtf2,
90  $ cpbtrf, cpbtrs, cpocon, cpoequ, cporfs, cpotf2,
91  $ cpotrf, cpotri, cpotrs, cppcon, cppequ, cpprfs,
92  $ cpptrf, cpptri, cpptrs
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 cmplx, 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 ) = cmplx( 1. / REAL( I+J ), -1. / REAL( I+J ) )
117  af( i, j ) = cmplx( 1. / REAL( 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  20 continue
125  anrm = 1.
126  ok = .true.
127 *
128 * Test error exits of the routines that use the Cholesky
129 * decomposition of a Hermitian positive definite matrix.
130 *
131  IF( lsamen( 2, c2, 'PO' ) ) THEN
132 *
133 * CPOTRF
134 *
135  srnamt = 'CPOTRF'
136  infot = 1
137  CALL cpotrf( '/', 0, a, 1, info )
138  CALL chkxer( 'CPOTRF', infot, nout, lerr, ok )
139  infot = 2
140  CALL cpotrf( 'U', -1, a, 1, info )
141  CALL chkxer( 'CPOTRF', infot, nout, lerr, ok )
142  infot = 4
143  CALL cpotrf( 'U', 2, a, 1, info )
144  CALL chkxer( 'CPOTRF', infot, nout, lerr, ok )
145 *
146 * CPOTF2
147 *
148  srnamt = 'CPOTF2'
149  infot = 1
150  CALL cpotf2( '/', 0, a, 1, info )
151  CALL chkxer( 'CPOTF2', infot, nout, lerr, ok )
152  infot = 2
153  CALL cpotf2( 'U', -1, a, 1, info )
154  CALL chkxer( 'CPOTF2', infot, nout, lerr, ok )
155  infot = 4
156  CALL cpotf2( 'U', 2, a, 1, info )
157  CALL chkxer( 'CPOTF2', infot, nout, lerr, ok )
158 *
159 * CPOTRI
160 *
161  srnamt = 'CPOTRI'
162  infot = 1
163  CALL cpotri( '/', 0, a, 1, info )
164  CALL chkxer( 'CPOTRI', infot, nout, lerr, ok )
165  infot = 2
166  CALL cpotri( 'U', -1, a, 1, info )
167  CALL chkxer( 'CPOTRI', infot, nout, lerr, ok )
168  infot = 4
169  CALL cpotri( 'U', 2, a, 1, info )
170  CALL chkxer( 'CPOTRI', infot, nout, lerr, ok )
171 *
172 * CPOTRS
173 *
174  srnamt = 'CPOTRS'
175  infot = 1
176  CALL cpotrs( '/', 0, 0, a, 1, b, 1, info )
177  CALL chkxer( 'CPOTRS', infot, nout, lerr, ok )
178  infot = 2
179  CALL cpotrs( 'U', -1, 0, a, 1, b, 1, info )
180  CALL chkxer( 'CPOTRS', infot, nout, lerr, ok )
181  infot = 3
182  CALL cpotrs( 'U', 0, -1, a, 1, b, 1, info )
183  CALL chkxer( 'CPOTRS', infot, nout, lerr, ok )
184  infot = 5
185  CALL cpotrs( 'U', 2, 1, a, 1, b, 2, info )
186  CALL chkxer( 'CPOTRS', infot, nout, lerr, ok )
187  infot = 7
188  CALL cpotrs( 'U', 2, 1, a, 2, b, 1, info )
189  CALL chkxer( 'CPOTRS', infot, nout, lerr, ok )
190 *
191 * CPORFS
192 *
193  srnamt = 'CPORFS'
194  infot = 1
195  CALL cporfs( '/', 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w, r,
196  $ info )
197  CALL chkxer( 'CPORFS', infot, nout, lerr, ok )
198  infot = 2
199  CALL cporfs( 'U', -1, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w, r,
200  $ info )
201  CALL chkxer( 'CPORFS', infot, nout, lerr, ok )
202  infot = 3
203  CALL cporfs( 'U', 0, -1, a, 1, af, 1, b, 1, x, 1, r1, r2, w, r,
204  $ info )
205  CALL chkxer( 'CPORFS', infot, nout, lerr, ok )
206  infot = 5
207  CALL cporfs( 'U', 2, 1, a, 1, af, 2, b, 2, x, 2, r1, r2, w, r,
208  $ info )
209  CALL chkxer( 'CPORFS', infot, nout, lerr, ok )
210  infot = 7
211  CALL cporfs( 'U', 2, 1, a, 2, af, 1, b, 2, x, 2, r1, r2, w, r,
212  $ info )
213  CALL chkxer( 'CPORFS', infot, nout, lerr, ok )
214  infot = 9
215  CALL cporfs( 'U', 2, 1, a, 2, af, 2, b, 1, x, 2, r1, r2, w, r,
216  $ info )
217  CALL chkxer( 'CPORFS', infot, nout, lerr, ok )
218  infot = 11
219  CALL cporfs( 'U', 2, 1, a, 2, af, 2, b, 2, x, 1, r1, r2, w, r,
220  $ info )
221  CALL chkxer( 'CPORFS', infot, nout, lerr, ok )
222 *
223 * CPOCON
224 *
225  srnamt = 'CPOCON'
226  infot = 1
227  CALL cpocon( '/', 0, a, 1, anrm, rcond, w, r, info )
228  CALL chkxer( 'CPOCON', infot, nout, lerr, ok )
229  infot = 2
230  CALL cpocon( 'U', -1, a, 1, anrm, rcond, w, r, info )
231  CALL chkxer( 'CPOCON', infot, nout, lerr, ok )
232  infot = 4
233  CALL cpocon( 'U', 2, a, 1, anrm, rcond, w, r, info )
234  CALL chkxer( 'CPOCON', infot, nout, lerr, ok )
235  infot = 5
236  CALL cpocon( 'U', 1, a, 1, -anrm, rcond, w, r, info )
237  CALL chkxer( 'CPOCON', infot, nout, lerr, ok )
238 *
239 * CPOEQU
240 *
241  srnamt = 'CPOEQU'
242  infot = 1
243  CALL cpoequ( -1, a, 1, r1, rcond, anrm, info )
244  CALL chkxer( 'CPOEQU', infot, nout, lerr, ok )
245  infot = 3
246  CALL cpoequ( 2, a, 1, r1, rcond, anrm, info )
247  CALL chkxer( 'CPOEQU', infot, nout, lerr, ok )
248 *
249 * Test error exits of the routines that use the Cholesky
250 * decomposition of a Hermitian positive definite packed matrix.
251 *
252  ELSE IF( lsamen( 2, c2, 'PP' ) ) THEN
253 *
254 * CPPTRF
255 *
256  srnamt = 'CPPTRF'
257  infot = 1
258  CALL cpptrf( '/', 0, a, info )
259  CALL chkxer( 'CPPTRF', infot, nout, lerr, ok )
260  infot = 2
261  CALL cpptrf( 'U', -1, a, info )
262  CALL chkxer( 'CPPTRF', infot, nout, lerr, ok )
263 *
264 * CPPTRI
265 *
266  srnamt = 'CPPTRI'
267  infot = 1
268  CALL cpptri( '/', 0, a, info )
269  CALL chkxer( 'CPPTRI', infot, nout, lerr, ok )
270  infot = 2
271  CALL cpptri( 'U', -1, a, info )
272  CALL chkxer( 'CPPTRI', infot, nout, lerr, ok )
273 *
274 * CPPTRS
275 *
276  srnamt = 'CPPTRS'
277  infot = 1
278  CALL cpptrs( '/', 0, 0, a, b, 1, info )
279  CALL chkxer( 'CPPTRS', infot, nout, lerr, ok )
280  infot = 2
281  CALL cpptrs( 'U', -1, 0, a, b, 1, info )
282  CALL chkxer( 'CPPTRS', infot, nout, lerr, ok )
283  infot = 3
284  CALL cpptrs( 'U', 0, -1, a, b, 1, info )
285  CALL chkxer( 'CPPTRS', infot, nout, lerr, ok )
286  infot = 6
287  CALL cpptrs( 'U', 2, 1, a, b, 1, info )
288  CALL chkxer( 'CPPTRS', infot, nout, lerr, ok )
289 *
290 * CPPRFS
291 *
292  srnamt = 'CPPRFS'
293  infot = 1
294  CALL cpprfs( '/', 0, 0, a, af, b, 1, x, 1, r1, r2, w, r, info )
295  CALL chkxer( 'CPPRFS', infot, nout, lerr, ok )
296  infot = 2
297  CALL cpprfs( 'U', -1, 0, a, af, b, 1, x, 1, r1, r2, w, r,
298  $ info )
299  CALL chkxer( 'CPPRFS', infot, nout, lerr, ok )
300  infot = 3
301  CALL cpprfs( 'U', 0, -1, a, af, b, 1, x, 1, r1, r2, w, r,
302  $ info )
303  CALL chkxer( 'CPPRFS', infot, nout, lerr, ok )
304  infot = 7
305  CALL cpprfs( 'U', 2, 1, a, af, b, 1, x, 2, r1, r2, w, r, info )
306  CALL chkxer( 'CPPRFS', infot, nout, lerr, ok )
307  infot = 9
308  CALL cpprfs( 'U', 2, 1, a, af, b, 2, x, 1, r1, r2, w, r, info )
309  CALL chkxer( 'CPPRFS', infot, nout, lerr, ok )
310 *
311 * CPPCON
312 *
313  srnamt = 'CPPCON'
314  infot = 1
315  CALL cppcon( '/', 0, a, anrm, rcond, w, r, info )
316  CALL chkxer( 'CPPCON', infot, nout, lerr, ok )
317  infot = 2
318  CALL cppcon( 'U', -1, a, anrm, rcond, w, r, info )
319  CALL chkxer( 'CPPCON', infot, nout, lerr, ok )
320  infot = 4
321  CALL cppcon( 'U', 1, a, -anrm, rcond, w, r, info )
322  CALL chkxer( 'CPPCON', infot, nout, lerr, ok )
323 *
324 * CPPEQU
325 *
326  srnamt = 'CPPEQU'
327  infot = 1
328  CALL cppequ( '/', 0, a, r1, rcond, anrm, info )
329  CALL chkxer( 'CPPEQU', infot, nout, lerr, ok )
330  infot = 2
331  CALL cppequ( 'U', -1, a, r1, rcond, anrm, info )
332  CALL chkxer( 'CPPEQU', infot, nout, lerr, ok )
333 *
334 * Test error exits of the routines that use the Cholesky
335 * decomposition of a Hermitian positive definite band matrix.
336 *
337  ELSE IF( lsamen( 2, c2, 'PB' ) ) THEN
338 *
339 * CPBTRF
340 *
341  srnamt = 'CPBTRF'
342  infot = 1
343  CALL cpbtrf( '/', 0, 0, a, 1, info )
344  CALL chkxer( 'CPBTRF', infot, nout, lerr, ok )
345  infot = 2
346  CALL cpbtrf( 'U', -1, 0, a, 1, info )
347  CALL chkxer( 'CPBTRF', infot, nout, lerr, ok )
348  infot = 3
349  CALL cpbtrf( 'U', 1, -1, a, 1, info )
350  CALL chkxer( 'CPBTRF', infot, nout, lerr, ok )
351  infot = 5
352  CALL cpbtrf( 'U', 2, 1, a, 1, info )
353  CALL chkxer( 'CPBTRF', infot, nout, lerr, ok )
354 *
355 * CPBTF2
356 *
357  srnamt = 'CPBTF2'
358  infot = 1
359  CALL cpbtf2( '/', 0, 0, a, 1, info )
360  CALL chkxer( 'CPBTF2', infot, nout, lerr, ok )
361  infot = 2
362  CALL cpbtf2( 'U', -1, 0, a, 1, info )
363  CALL chkxer( 'CPBTF2', infot, nout, lerr, ok )
364  infot = 3
365  CALL cpbtf2( 'U', 1, -1, a, 1, info )
366  CALL chkxer( 'CPBTF2', infot, nout, lerr, ok )
367  infot = 5
368  CALL cpbtf2( 'U', 2, 1, a, 1, info )
369  CALL chkxer( 'CPBTF2', infot, nout, lerr, ok )
370 *
371 * CPBTRS
372 *
373  srnamt = 'CPBTRS'
374  infot = 1
375  CALL cpbtrs( '/', 0, 0, 0, a, 1, b, 1, info )
376  CALL chkxer( 'CPBTRS', infot, nout, lerr, ok )
377  infot = 2
378  CALL cpbtrs( 'U', -1, 0, 0, a, 1, b, 1, info )
379  CALL chkxer( 'CPBTRS', infot, nout, lerr, ok )
380  infot = 3
381  CALL cpbtrs( 'U', 1, -1, 0, a, 1, b, 1, info )
382  CALL chkxer( 'CPBTRS', infot, nout, lerr, ok )
383  infot = 4
384  CALL cpbtrs( 'U', 0, 0, -1, a, 1, b, 1, info )
385  CALL chkxer( 'CPBTRS', infot, nout, lerr, ok )
386  infot = 6
387  CALL cpbtrs( 'U', 2, 1, 1, a, 1, b, 1, info )
388  CALL chkxer( 'CPBTRS', infot, nout, lerr, ok )
389  infot = 8
390  CALL cpbtrs( 'U', 2, 0, 1, a, 1, b, 1, info )
391  CALL chkxer( 'CPBTRS', infot, nout, lerr, ok )
392 *
393 * CPBRFS
394 *
395  srnamt = 'CPBRFS'
396  infot = 1
397  CALL cpbrfs( '/', 0, 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
398  $ r, info )
399  CALL chkxer( 'CPBRFS', infot, nout, lerr, ok )
400  infot = 2
401  CALL cpbrfs( 'U', -1, 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
402  $ r, info )
403  CALL chkxer( 'CPBRFS', infot, nout, lerr, ok )
404  infot = 3
405  CALL cpbrfs( 'U', 1, -1, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
406  $ r, info )
407  CALL chkxer( 'CPBRFS', infot, nout, lerr, ok )
408  infot = 4
409  CALL cpbrfs( 'U', 0, 0, -1, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
410  $ r, info )
411  CALL chkxer( 'CPBRFS', infot, nout, lerr, ok )
412  infot = 6
413  CALL cpbrfs( 'U', 2, 1, 1, a, 1, af, 2, b, 2, x, 2, r1, r2, w,
414  $ r, info )
415  CALL chkxer( 'CPBRFS', infot, nout, lerr, ok )
416  infot = 8
417  CALL cpbrfs( 'U', 2, 1, 1, a, 2, af, 1, b, 2, x, 2, r1, r2, w,
418  $ r, info )
419  CALL chkxer( 'CPBRFS', infot, nout, lerr, ok )
420  infot = 10
421  CALL cpbrfs( 'U', 2, 0, 1, a, 1, af, 1, b, 1, x, 2, r1, r2, w,
422  $ r, info )
423  CALL chkxer( 'CPBRFS', infot, nout, lerr, ok )
424  infot = 12
425  CALL cpbrfs( 'U', 2, 0, 1, a, 1, af, 1, b, 2, x, 1, r1, r2, w,
426  $ r, info )
427  CALL chkxer( 'CPBRFS', infot, nout, lerr, ok )
428 *
429 * CPBCON
430 *
431  srnamt = 'CPBCON'
432  infot = 1
433  CALL cpbcon( '/', 0, 0, a, 1, anrm, rcond, w, r, info )
434  CALL chkxer( 'CPBCON', infot, nout, lerr, ok )
435  infot = 2
436  CALL cpbcon( 'U', -1, 0, a, 1, anrm, rcond, w, r, info )
437  CALL chkxer( 'CPBCON', infot, nout, lerr, ok )
438  infot = 3
439  CALL cpbcon( 'U', 1, -1, a, 1, anrm, rcond, w, r, info )
440  CALL chkxer( 'CPBCON', infot, nout, lerr, ok )
441  infot = 5
442  CALL cpbcon( 'U', 2, 1, a, 1, anrm, rcond, w, r, info )
443  CALL chkxer( 'CPBCON', infot, nout, lerr, ok )
444  infot = 6
445  CALL cpbcon( 'U', 1, 0, a, 1, -anrm, rcond, w, r, info )
446  CALL chkxer( 'CPBCON', infot, nout, lerr, ok )
447 *
448 * CPBEQU
449 *
450  srnamt = 'CPBEQU'
451  infot = 1
452  CALL cpbequ( '/', 0, 0, a, 1, r1, rcond, anrm, info )
453  CALL chkxer( 'CPBEQU', infot, nout, lerr, ok )
454  infot = 2
455  CALL cpbequ( 'U', -1, 0, a, 1, r1, rcond, anrm, info )
456  CALL chkxer( 'CPBEQU', infot, nout, lerr, ok )
457  infot = 3
458  CALL cpbequ( 'U', 1, -1, a, 1, r1, rcond, anrm, info )
459  CALL chkxer( 'CPBEQU', infot, nout, lerr, ok )
460  infot = 5
461  CALL cpbequ( 'U', 2, 1, a, 1, r1, rcond, anrm, info )
462  CALL chkxer( 'CPBEQU', infot, nout, lerr, ok )
463  END IF
464 *
465 * Print a summary line.
466 *
467  CALL alaesm( path, ok, nout )
468 *
469  return
470 *
471 * End of CERRPO
472 *
473  END