LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
zerrhe.f
Go to the documentation of this file.
1 *> \brief \b ZERRHE
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 ZERRHE( 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 *> ZERRHE tests the error exits for the COMPLEX*16 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 complex16_lin
54 *
55 * =====================================================================
56  SUBROUTINE zerrhe( 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  DOUBLE PRECISION anrm, rcond
79 * ..
80 * .. Local Arrays ..
81  INTEGER ip( nmax )
82  DOUBLE PRECISION r( nmax ), r1( nmax ), r2( nmax )
83  COMPLEX*16 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, chkxer, zhecon, zherfs, zhetf2, zhetrf,
92  $ zhetri, zhetri2, zhetrs, zhpcon, zhprfs,
93  $ zhptrf, zhptri, zhptrs
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 dble, dcmplx
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 ) = dcmplx( 1.d0 / dble( i+j ),
118  $ -1.d0 / dble( i+j ) )
119  af( i, j ) = dcmplx( 1.d0 / dble( i+j ),
120  $ -1.d0 / dble( i+j ) )
121  10 continue
122  b( j ) = 0.d0
123  r1( j ) = 0.d0
124  r2( j ) = 0.d0
125  w( j ) = 0.d0
126  x( j ) = 0.d0
127  ip( j ) = j
128  20 continue
129  anrm = 1.0d0
130  ok = .true.
131 *
132 * Test error exits of the routines that use the diagonal pivoting
133 * factorization of a Hermitian indefinite matrix.
134 *
135  IF( lsamen( 2, c2, 'HE' ) ) THEN
136 *
137 * ZHETRF
138 *
139  srnamt = 'ZHETRF'
140  infot = 1
141  CALL zhetrf( '/', 0, a, 1, ip, w, 1, info )
142  CALL chkxer( 'ZHETRF', infot, nout, lerr, ok )
143  infot = 2
144  CALL zhetrf( 'U', -1, a, 1, ip, w, 1, info )
145  CALL chkxer( 'ZHETRF', infot, nout, lerr, ok )
146  infot = 4
147  CALL zhetrf( 'U', 2, a, 1, ip, w, 4, info )
148  CALL chkxer( 'ZHETRF', infot, nout, lerr, ok )
149 *
150 * ZHETF2
151 *
152  srnamt = 'ZHETF2'
153  infot = 1
154  CALL zhetf2( '/', 0, a, 1, ip, info )
155  CALL chkxer( 'ZHETF2', infot, nout, lerr, ok )
156  infot = 2
157  CALL zhetf2( 'U', -1, a, 1, ip, info )
158  CALL chkxer( 'ZHETF2', infot, nout, lerr, ok )
159  infot = 4
160  CALL zhetf2( 'U', 2, a, 1, ip, info )
161  CALL chkxer( 'ZHETF2', infot, nout, lerr, ok )
162 *
163 * ZHETRI
164 *
165  srnamt = 'ZHETRI'
166  infot = 1
167  CALL zhetri( '/', 0, a, 1, ip, w, info )
168  CALL chkxer( 'ZHETRI', infot, nout, lerr, ok )
169  infot = 2
170  CALL zhetri( 'U', -1, a, 1, ip, w, info )
171  CALL chkxer( 'ZHETRI', infot, nout, lerr, ok )
172  infot = 4
173  CALL zhetri( 'U', 2, a, 1, ip, w, info )
174  CALL chkxer( 'ZHETRI', infot, nout, lerr, ok )
175 *
176 * ZHETRI2
177 *
178  srnamt = 'ZHETRI2'
179  infot = 1
180  CALL zhetri2( '/', 0, a, 1, ip, w, 1, info )
181  CALL chkxer( 'ZHETRI2', infot, nout, lerr, ok )
182  infot = 2
183  CALL zhetri2( 'U', -1, a, 1, ip, w, 1, info )
184  CALL chkxer( 'ZHETRI2', infot, nout, lerr, ok )
185  infot = 4
186  CALL zhetri2( 'U', 2, a, 1, ip, w, 1, info )
187  CALL chkxer( 'ZHETRI2', infot, nout, lerr, ok )
188 *
189 * ZHETRS
190 *
191  srnamt = 'ZHETRS'
192  infot = 1
193  CALL zhetrs( '/', 0, 0, a, 1, ip, b, 1, info )
194  CALL chkxer( 'ZHETRS', infot, nout, lerr, ok )
195  infot = 2
196  CALL zhetrs( 'U', -1, 0, a, 1, ip, b, 1, info )
197  CALL chkxer( 'ZHETRS', infot, nout, lerr, ok )
198  infot = 3
199  CALL zhetrs( 'U', 0, -1, a, 1, ip, b, 1, info )
200  CALL chkxer( 'ZHETRS', infot, nout, lerr, ok )
201  infot = 5
202  CALL zhetrs( 'U', 2, 1, a, 1, ip, b, 2, info )
203  CALL chkxer( 'ZHETRS', infot, nout, lerr, ok )
204  infot = 8
205  CALL zhetrs( 'U', 2, 1, a, 2, ip, b, 1, info )
206  CALL chkxer( 'ZHETRS', infot, nout, lerr, ok )
207 *
208 * ZHERFS
209 *
210  srnamt = 'ZHERFS'
211  infot = 1
212  CALL zherfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
213  $ r, info )
214  CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
215  infot = 2
216  CALL zherfs( 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
217  $ w, r, info )
218  CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
219  infot = 3
220  CALL zherfs( 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
221  $ w, r, info )
222  CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
223  infot = 5
224  CALL zherfs( 'U', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
225  $ r, info )
226  CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
227  infot = 7
228  CALL zherfs( 'U', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
229  $ r, info )
230  CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
231  infot = 10
232  CALL zherfs( 'U', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
233  $ r, info )
234  CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
235  infot = 12
236  CALL zherfs( 'U', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
237  $ r, info )
238  CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
239 *
240 * ZHECON
241 *
242  srnamt = 'ZHECON'
243  infot = 1
244  CALL zhecon( '/', 0, a, 1, ip, anrm, rcond, w, info )
245  CALL chkxer( 'ZHECON', infot, nout, lerr, ok )
246  infot = 2
247  CALL zhecon( 'U', -1, a, 1, ip, anrm, rcond, w, info )
248  CALL chkxer( 'ZHECON', infot, nout, lerr, ok )
249  infot = 4
250  CALL zhecon( 'U', 2, a, 1, ip, anrm, rcond, w, info )
251  CALL chkxer( 'ZHECON', infot, nout, lerr, ok )
252  infot = 6
253  CALL zhecon( 'U', 1, a, 1, ip, -anrm, rcond, w, info )
254  CALL chkxer( 'ZHECON', infot, nout, lerr, ok )
255 *
256 * Test error exits of the routines that use the diagonal pivoting
257 * factorization of a Hermitian indefinite packed matrix.
258 *
259  ELSE IF( lsamen( 2, c2, 'HP' ) ) THEN
260 *
261 * ZHPTRF
262 *
263  srnamt = 'ZHPTRF'
264  infot = 1
265  CALL zhptrf( '/', 0, a, ip, info )
266  CALL chkxer( 'ZHPTRF', infot, nout, lerr, ok )
267  infot = 2
268  CALL zhptrf( 'U', -1, a, ip, info )
269  CALL chkxer( 'ZHPTRF', infot, nout, lerr, ok )
270 *
271 * ZHPTRI
272 *
273  srnamt = 'ZHPTRI'
274  infot = 1
275  CALL zhptri( '/', 0, a, ip, w, info )
276  CALL chkxer( 'ZHPTRI', infot, nout, lerr, ok )
277  infot = 2
278  CALL zhptri( 'U', -1, a, ip, w, info )
279  CALL chkxer( 'ZHPTRI', infot, nout, lerr, ok )
280 *
281 * ZHPTRS
282 *
283  srnamt = 'ZHPTRS'
284  infot = 1
285  CALL zhptrs( '/', 0, 0, a, ip, b, 1, info )
286  CALL chkxer( 'ZHPTRS', infot, nout, lerr, ok )
287  infot = 2
288  CALL zhptrs( 'U', -1, 0, a, ip, b, 1, info )
289  CALL chkxer( 'ZHPTRS', infot, nout, lerr, ok )
290  infot = 3
291  CALL zhptrs( 'U', 0, -1, a, ip, b, 1, info )
292  CALL chkxer( 'ZHPTRS', infot, nout, lerr, ok )
293  infot = 7
294  CALL zhptrs( 'U', 2, 1, a, ip, b, 1, info )
295  CALL chkxer( 'ZHPTRS', infot, nout, lerr, ok )
296 *
297 * ZHPRFS
298 *
299  srnamt = 'ZHPRFS'
300  infot = 1
301  CALL zhprfs( '/', 0, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
302  $ info )
303  CALL chkxer( 'ZHPRFS', infot, nout, lerr, ok )
304  infot = 2
305  CALL zhprfs( 'U', -1, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
306  $ info )
307  CALL chkxer( 'ZHPRFS', infot, nout, lerr, ok )
308  infot = 3
309  CALL zhprfs( 'U', 0, -1, a, af, ip, b, 1, x, 1, r1, r2, w, r,
310  $ info )
311  CALL chkxer( 'ZHPRFS', infot, nout, lerr, ok )
312  infot = 8
313  CALL zhprfs( 'U', 2, 1, a, af, ip, b, 1, x, 2, r1, r2, w, r,
314  $ info )
315  CALL chkxer( 'ZHPRFS', infot, nout, lerr, ok )
316  infot = 10
317  CALL zhprfs( 'U', 2, 1, a, af, ip, b, 2, x, 1, r1, r2, w, r,
318  $ info )
319  CALL chkxer( 'ZHPRFS', infot, nout, lerr, ok )
320 *
321 * ZHPCON
322 *
323  srnamt = 'ZHPCON'
324  infot = 1
325  CALL zhpcon( '/', 0, a, ip, anrm, rcond, w, info )
326  CALL chkxer( 'ZHPCON', infot, nout, lerr, ok )
327  infot = 2
328  CALL zhpcon( 'U', -1, a, ip, anrm, rcond, w, info )
329  CALL chkxer( 'ZHPCON', infot, nout, lerr, ok )
330  infot = 5
331  CALL zhpcon( 'U', 1, a, ip, -anrm, rcond, w, info )
332  CALL chkxer( 'ZHPCON', infot, nout, lerr, ok )
333  END IF
334 *
335 * Print a summary line.
336 *
337  CALL alaesm( path, ok, nout )
338 *
339  return
340 *
341 * End of ZERRHE
342 *
343  END