LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
cerrhe.f
Go to the documentation of this file.
1 *> \brief \b CERRHE
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 CERRHE( 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 *> CERRHE tests the error exits for the COMPLEX routines
25 *> for Hermitian indefinite 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 cerrhe( 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 *
71 * .. Parameters ..
72  INTEGER nmax
73  parameter( nmax = 4 )
74 * ..
75 * .. Local Scalars ..
76  CHARACTER*2 c2
77  INTEGER i, info, j
78  REAL anrm, rcond
79 * ..
80 * .. Local Arrays ..
81  INTEGER ip( nmax )
82  REAL r( nmax ), r1( nmax ), r2( nmax )
83  COMPLEX a( nmax, nmax ), af( nmax, nmax ), b( nmax ),
84  $ w( 2*nmax ), x( nmax )
85 * ..
86 * .. External Functions ..
87  LOGICAL lsamen
88  EXTERNAL lsamen
89 * ..
90 * .. External Subroutines ..
91  EXTERNAL alaesm, checon, cherfs, chetf2, chetrf, chetri,
92  $ chetri2, chetrs, chkxer, chpcon, chprfs,
93  $ chptrf, chptri, chptrs
94 * ..
95 * .. Scalars in Common ..
96  LOGICAL lerr, ok
97  CHARACTER*32 srnamt
98  INTEGER infot, nout
99 * ..
100 * .. Common blocks ..
101  common / infoc / infot, nout, ok, lerr
102  common / srnamc / srnamt
103 * ..
104 * .. Intrinsic Functions ..
105  INTRINSIC cmplx, real
106 * ..
107 * .. Executable Statements ..
108 *
109  nout = nunit
110  WRITE( nout, fmt = * )
111  c2 = path( 2: 3 )
112 *
113 * Set the variables to innocuous values.
114 *
115  DO 20 j = 1, nmax
116  DO 10 i = 1, nmax
117  a( i, j ) = cmplx( 1. / REAL( I+J ), -1. / REAL( I+J ) )
118  af( i, j ) = cmplx( 1. / REAL( I+J ), -1. / REAL( I+J ) )
119  10 continue
120  b( j ) = 0.
121  r1( j ) = 0.
122  r2( j ) = 0.
123  w( j ) = 0.
124  x( j ) = 0.
125  ip( j ) = j
126  20 continue
127  anrm = 1.0
128  ok = .true.
129 *
130 * Test error exits of the routines that use the diagonal pivoting
131 * factorization of a Hermitian indefinite matrix.
132 *
133  IF( lsamen( 2, c2, 'HE' ) ) THEN
134 *
135 * CHETRF
136 *
137  srnamt = 'CHETRF'
138  infot = 1
139  CALL chetrf( '/', 0, a, 1, ip, w, 1, info )
140  CALL chkxer( 'CHETRF', infot, nout, lerr, ok )
141  infot = 2
142  CALL chetrf( 'U', -1, a, 1, ip, w, 1, info )
143  CALL chkxer( 'CHETRF', infot, nout, lerr, ok )
144  infot = 4
145  CALL chetrf( 'U', 2, a, 1, ip, w, 4, info )
146  CALL chkxer( 'CHETRF', infot, nout, lerr, ok )
147 *
148 * CHETF2
149 *
150  srnamt = 'CHETF2'
151  infot = 1
152  CALL chetf2( '/', 0, a, 1, ip, info )
153  CALL chkxer( 'CHETF2', infot, nout, lerr, ok )
154  infot = 2
155  CALL chetf2( 'U', -1, a, 1, ip, info )
156  CALL chkxer( 'CHETF2', infot, nout, lerr, ok )
157  infot = 4
158  CALL chetf2( 'U', 2, a, 1, ip, info )
159  CALL chkxer( 'CHETF2', infot, nout, lerr, ok )
160 *
161 * CHETRI
162 *
163  srnamt = 'CHETRI'
164  infot = 1
165  CALL chetri( '/', 0, a, 1, ip, w, info )
166  CALL chkxer( 'CHETRI', infot, nout, lerr, ok )
167  infot = 2
168  CALL chetri( 'U', -1, a, 1, ip, w, info )
169  CALL chkxer( 'CHETRI', infot, nout, lerr, ok )
170  infot = 4
171  CALL chetri( 'U', 2, a, 1, ip, w, info )
172  CALL chkxer( 'CHETRI', infot, nout, lerr, ok )
173 *
174 * CHETRI2
175 *
176  srnamt = 'CHETRI2'
177  infot = 1
178  CALL chetri2( '/', 0, a, 1, ip, w, 1, info )
179  CALL chkxer( 'CHETRI2', infot, nout, lerr, ok )
180  infot = 2
181  CALL chetri2( 'U', -1, a, 1, ip, w, 1, info )
182  CALL chkxer( 'CHETRI2', infot, nout, lerr, ok )
183  infot = 4
184  CALL chetri2( 'U', 2, a, 1, ip, w, 1, info )
185  CALL chkxer( 'CHETRI2', infot, nout, lerr, ok )
186 *
187 * CHETRS
188 *
189  srnamt = 'CHETRS'
190  infot = 1
191  CALL chetrs( '/', 0, 0, a, 1, ip, b, 1, info )
192  CALL chkxer( 'CHETRS', infot, nout, lerr, ok )
193  infot = 2
194  CALL chetrs( 'U', -1, 0, a, 1, ip, b, 1, info )
195  CALL chkxer( 'CHETRS', infot, nout, lerr, ok )
196  infot = 3
197  CALL chetrs( 'U', 0, -1, a, 1, ip, b, 1, info )
198  CALL chkxer( 'CHETRS', infot, nout, lerr, ok )
199  infot = 5
200  CALL chetrs( 'U', 2, 1, a, 1, ip, b, 2, info )
201  CALL chkxer( 'CHETRS', infot, nout, lerr, ok )
202  infot = 8
203  CALL chetrs( 'U', 2, 1, a, 2, ip, b, 1, info )
204  CALL chkxer( 'CHETRS', infot, nout, lerr, ok )
205 *
206 * CHERFS
207 *
208  srnamt = 'CHERFS'
209  infot = 1
210  CALL cherfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
211  $ r, info )
212  CALL chkxer( 'CHERFS', infot, nout, lerr, ok )
213  infot = 2
214  CALL cherfs( 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
215  $ w, r, info )
216  CALL chkxer( 'CHERFS', infot, nout, lerr, ok )
217  infot = 3
218  CALL cherfs( 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
219  $ w, r, info )
220  CALL chkxer( 'CHERFS', infot, nout, lerr, ok )
221  infot = 5
222  CALL cherfs( 'U', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
223  $ r, info )
224  CALL chkxer( 'CHERFS', infot, nout, lerr, ok )
225  infot = 7
226  CALL cherfs( 'U', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
227  $ r, info )
228  CALL chkxer( 'CHERFS', infot, nout, lerr, ok )
229  infot = 10
230  CALL cherfs( 'U', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
231  $ r, info )
232  CALL chkxer( 'CHERFS', infot, nout, lerr, ok )
233  infot = 12
234  CALL cherfs( 'U', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
235  $ r, info )
236  CALL chkxer( 'CHERFS', infot, nout, lerr, ok )
237 *
238 * CHECON
239 *
240  srnamt = 'CHECON'
241  infot = 1
242  CALL checon( '/', 0, a, 1, ip, anrm, rcond, w, info )
243  CALL chkxer( 'CHECON', infot, nout, lerr, ok )
244  infot = 2
245  CALL checon( 'U', -1, a, 1, ip, anrm, rcond, w, info )
246  CALL chkxer( 'CHECON', infot, nout, lerr, ok )
247  infot = 4
248  CALL checon( 'U', 2, a, 1, ip, anrm, rcond, w, info )
249  CALL chkxer( 'CHECON', infot, nout, lerr, ok )
250  infot = 6
251  CALL checon( 'U', 1, a, 1, ip, -anrm, rcond, w, info )
252  CALL chkxer( 'CHECON', infot, nout, lerr, ok )
253 *
254 * Test error exits of the routines that use the diagonal pivoting
255 * factorization of a Hermitian indefinite packed matrix.
256 *
257  ELSE IF( lsamen( 2, c2, 'HP' ) ) THEN
258 *
259 * CHPTRF
260 *
261  srnamt = 'CHPTRF'
262  infot = 1
263  CALL chptrf( '/', 0, a, ip, info )
264  CALL chkxer( 'CHPTRF', infot, nout, lerr, ok )
265  infot = 2
266  CALL chptrf( 'U', -1, a, ip, info )
267  CALL chkxer( 'CHPTRF', infot, nout, lerr, ok )
268 *
269 * CHPTRI
270 *
271  srnamt = 'CHPTRI'
272  infot = 1
273  CALL chptri( '/', 0, a, ip, w, info )
274  CALL chkxer( 'CHPTRI', infot, nout, lerr, ok )
275  infot = 2
276  CALL chptri( 'U', -1, a, ip, w, info )
277  CALL chkxer( 'CHPTRI', infot, nout, lerr, ok )
278 *
279 * CHPTRS
280 *
281  srnamt = 'CHPTRS'
282  infot = 1
283  CALL chptrs( '/', 0, 0, a, ip, b, 1, info )
284  CALL chkxer( 'CHPTRS', infot, nout, lerr, ok )
285  infot = 2
286  CALL chptrs( 'U', -1, 0, a, ip, b, 1, info )
287  CALL chkxer( 'CHPTRS', infot, nout, lerr, ok )
288  infot = 3
289  CALL chptrs( 'U', 0, -1, a, ip, b, 1, info )
290  CALL chkxer( 'CHPTRS', infot, nout, lerr, ok )
291  infot = 7
292  CALL chptrs( 'U', 2, 1, a, ip, b, 1, info )
293  CALL chkxer( 'CHPTRS', infot, nout, lerr, ok )
294 *
295 * CHPRFS
296 *
297  srnamt = 'CHPRFS'
298  infot = 1
299  CALL chprfs( '/', 0, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
300  $ info )
301  CALL chkxer( 'CHPRFS', infot, nout, lerr, ok )
302  infot = 2
303  CALL chprfs( 'U', -1, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
304  $ info )
305  CALL chkxer( 'CHPRFS', infot, nout, lerr, ok )
306  infot = 3
307  CALL chprfs( 'U', 0, -1, a, af, ip, b, 1, x, 1, r1, r2, w, r,
308  $ info )
309  CALL chkxer( 'CHPRFS', infot, nout, lerr, ok )
310  infot = 8
311  CALL chprfs( 'U', 2, 1, a, af, ip, b, 1, x, 2, r1, r2, w, r,
312  $ info )
313  CALL chkxer( 'CHPRFS', infot, nout, lerr, ok )
314  infot = 10
315  CALL chprfs( 'U', 2, 1, a, af, ip, b, 2, x, 1, r1, r2, w, r,
316  $ info )
317  CALL chkxer( 'CHPRFS', infot, nout, lerr, ok )
318 *
319 * CHPCON
320 *
321  srnamt = 'CHPCON'
322  infot = 1
323  CALL chpcon( '/', 0, a, ip, anrm, rcond, w, info )
324  CALL chkxer( 'CHPCON', infot, nout, lerr, ok )
325  infot = 2
326  CALL chpcon( 'U', -1, a, ip, anrm, rcond, w, info )
327  CALL chkxer( 'CHPCON', infot, nout, lerr, ok )
328  infot = 5
329  CALL chpcon( 'U', 1, a, ip, -anrm, rcond, w, info )
330  CALL chkxer( 'CHPCON', infot, nout, lerr, ok )
331  END IF
332 *
333 * Print a summary line.
334 *
335  CALL alaesm( path, ok, nout )
336 *
337  return
338 *
339 * End of CERRHE
340 *
341  END