LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
zerrhex.f
Go to the documentation of this file.
1 *> \brief \b ZERRHEX
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 *>
27 *> Note that this file is used only when the XBLAS are available,
28 *> otherwise zerrhe.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 complex16_lin
57 *
58 * =====================================================================
59  SUBROUTINE zerrhe( 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 *
74 * .. Parameters ..
75  INTEGER nmax
76  parameter( nmax = 4 )
77 * ..
78 * .. Local Scalars ..
79  CHARACTER eq
80  CHARACTER*2 c2
81  INTEGER i, info, j, n_err_bnds, nparams
82  DOUBLE PRECISION anrm, rcond, berr
83 * ..
84 * .. Local Arrays ..
85  INTEGER ip( nmax )
86  DOUBLE PRECISION r( nmax ), r1( nmax ), r2( nmax ),
87  $ s( nmax ), err_bnds_n( nmax, 3 ),
88  $ err_bnds_c( nmax, 3 ), params( 1 )
89  COMPLEX*16 a( nmax, nmax ), af( nmax, nmax ), b( nmax ),
90  $ w( 2*nmax ), x( nmax )
91 * ..
92 * .. External Functions ..
93  LOGICAL lsamen
94  EXTERNAL lsamen
95 * ..
96 * .. External Subroutines ..
97  EXTERNAL alaesm, chkxer, zhecon, zherfs, zhetf2, zhetrf,
98  $ zhetri, zhetri2, zhetrs, zhpcon, zhprfs,
99  $ zhptrf, zhptri, zhptrs, zherfsx
100 * ..
101 * .. Scalars in Common ..
102  LOGICAL lerr, ok
103  CHARACTER*32 srnamt
104  INTEGER infot, nout
105 * ..
106 * .. Common blocks ..
107  common / infoc / infot, nout, ok, lerr
108  common / srnamc / srnamt
109 * ..
110 * .. Intrinsic Functions ..
111  INTRINSIC dble, dcmplx
112 * ..
113 * .. Executable Statements ..
114 *
115  nout = nunit
116  WRITE( nout, fmt = * )
117  c2 = path( 2: 3 )
118 *
119 * Set the variables to innocuous values.
120 *
121  DO 20 j = 1, nmax
122  DO 10 i = 1, nmax
123  a( i, j ) = dcmplx( 1.d0 / dble( i+j ),
124  $ -1.d0 / dble( i+j ) )
125  af( i, j ) = dcmplx( 1.d0 / dble( i+j ),
126  $ -1.d0 / dble( i+j ) )
127  10 continue
128  b( j ) = 0.d0
129  r1( j ) = 0.d0
130  r2( j ) = 0.d0
131  w( j ) = 0.d0
132  x( j ) = 0.d0
133  s( j ) = 0.d0
134  ip( j ) = j
135  20 continue
136  anrm = 1.0d0
137  ok = .true.
138 *
139 * Test error exits of the routines that use the diagonal pivoting
140 * factorization of a Hermitian indefinite matrix.
141 *
142  IF( lsamen( 2, c2, 'HE' ) ) THEN
143 *
144 * ZHETRF
145 *
146  srnamt = 'ZHETRF'
147  infot = 1
148  CALL zhetrf( '/', 0, a, 1, ip, w, 1, info )
149  CALL chkxer( 'ZHETRF', infot, nout, lerr, ok )
150  infot = 2
151  CALL zhetrf( 'U', -1, a, 1, ip, w, 1, info )
152  CALL chkxer( 'ZHETRF', infot, nout, lerr, ok )
153  infot = 4
154  CALL zhetrf( 'U', 2, a, 1, ip, w, 4, info )
155  CALL chkxer( 'ZHETRF', infot, nout, lerr, ok )
156 *
157 * ZHETF2
158 *
159  srnamt = 'ZHETF2'
160  infot = 1
161  CALL zhetf2( '/', 0, a, 1, ip, info )
162  CALL chkxer( 'ZHETF2', infot, nout, lerr, ok )
163  infot = 2
164  CALL zhetf2( 'U', -1, a, 1, ip, info )
165  CALL chkxer( 'ZHETF2', infot, nout, lerr, ok )
166  infot = 4
167  CALL zhetf2( 'U', 2, a, 1, ip, info )
168  CALL chkxer( 'ZHETF2', infot, nout, lerr, ok )
169 *
170 * ZHETRI
171 *
172  srnamt = 'ZHETRI'
173  infot = 1
174  CALL zhetri( '/', 0, a, 1, ip, w, info )
175  CALL chkxer( 'ZHETRI', infot, nout, lerr, ok )
176  infot = 2
177  CALL zhetri( 'U', -1, a, 1, ip, w, info )
178  CALL chkxer( 'ZHETRI', infot, nout, lerr, ok )
179  infot = 4
180  CALL zhetri( 'U', 2, a, 1, ip, w, info )
181  CALL chkxer( 'ZHETRI', infot, nout, lerr, ok )
182 *
183 * ZHETRI2
184 *
185  srnamt = 'ZHETRI2'
186  infot = 1
187  CALL zhetri2( '/', 0, a, 1, ip, w, 1, info )
188  CALL chkxer( 'ZHETRI2', infot, nout, lerr, ok )
189  infot = 2
190  CALL zhetri2( 'U', -1, a, 1, ip, w, 1, info )
191  CALL chkxer( 'ZHETRI2', infot, nout, lerr, ok )
192  infot = 4
193  CALL zhetri2( 'U', 2, a, 1, ip, w, 1, info )
194  CALL chkxer( 'ZHETRI2', infot, nout, lerr, ok )
195 *
196 * ZHETRS
197 *
198  srnamt = 'ZHETRS'
199  infot = 1
200  CALL zhetrs( '/', 0, 0, a, 1, ip, b, 1, info )
201  CALL chkxer( 'ZHETRS', infot, nout, lerr, ok )
202  infot = 2
203  CALL zhetrs( 'U', -1, 0, a, 1, ip, b, 1, info )
204  CALL chkxer( 'ZHETRS', infot, nout, lerr, ok )
205  infot = 3
206  CALL zhetrs( 'U', 0, -1, a, 1, ip, b, 1, info )
207  CALL chkxer( 'ZHETRS', infot, nout, lerr, ok )
208  infot = 5
209  CALL zhetrs( 'U', 2, 1, a, 1, ip, b, 2, info )
210  CALL chkxer( 'ZHETRS', infot, nout, lerr, ok )
211  infot = 8
212  CALL zhetrs( 'U', 2, 1, a, 2, ip, b, 1, info )
213  CALL chkxer( 'ZHETRS', infot, nout, lerr, ok )
214 *
215 * ZHERFS
216 *
217  srnamt = 'ZHERFS'
218  infot = 1
219  CALL zherfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
220  $ r, info )
221  CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
222  infot = 2
223  CALL zherfs( 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
224  $ w, r, info )
225  CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
226  infot = 3
227  CALL zherfs( 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
228  $ w, r, info )
229  CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
230  infot = 5
231  CALL zherfs( 'U', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
232  $ r, info )
233  CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
234  infot = 7
235  CALL zherfs( 'U', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
236  $ r, info )
237  CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
238  infot = 10
239  CALL zherfs( 'U', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
240  $ r, info )
241  CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
242  infot = 12
243  CALL zherfs( 'U', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
244  $ r, info )
245  CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
246 *
247 * ZHERFSX
248 *
249  n_err_bnds = 3
250  nparams = 0
251  srnamt = 'ZHERFSX'
252  infot = 1
253  CALL zherfsx( '/', eq, 0, 0, a, 1, af, 1, ip, s, b, 1, x, 1,
254  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
255  $ params, w, r, info )
256  CALL chkxer( 'ZHERFSX', infot, nout, lerr, ok )
257  infot = 2
258  CALL zherfsx( 'U', eq, -1, 0, a, 1, af, 1, ip, s, b, 1, x, 1,
259  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
260  $ params, w, r, info )
261  CALL chkxer( 'ZHERFSX', infot, nout, lerr, ok )
262  eq = 'N'
263  infot = 3
264  CALL zherfsx( 'U', eq, -1, 0, a, 1, af, 1, ip, s, b, 1, x, 1,
265  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
266  $ params, w, r, info )
267  CALL chkxer( 'ZHERFSX', infot, nout, lerr, ok )
268  infot = 4
269  CALL zherfsx( 'U', eq, 0, -1, a, 1, af, 1, ip, s, b, 1, x, 1,
270  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
271  $ params, w, r, info )
272  CALL chkxer( 'ZHERFSX', infot, nout, lerr, ok )
273  infot = 6
274  CALL zherfsx( 'U', eq, 2, 1, a, 1, af, 2, ip, s, b, 2, x, 2,
275  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
276  $ params, w, r, info )
277  CALL chkxer( 'ZHERFSX', infot, nout, lerr, ok )
278  infot = 8
279  CALL zherfsx( 'U', eq, 2, 1, a, 2, af, 1, ip, s, b, 2, x, 2,
280  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
281  $ params, w, r, info )
282  CALL chkxer( 'ZHERFSX', infot, nout, lerr, ok )
283  infot = 12
284  CALL zherfsx( 'U', eq, 2, 1, a, 2, af, 2, ip, s, b, 1, x, 2,
285  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
286  $ params, w, r, info )
287  CALL chkxer( 'ZHERFSX', infot, nout, lerr, ok )
288  infot = 14
289  CALL zherfsx( 'U', eq, 2, 1, a, 2, af, 2, ip, s, b, 2, x, 1,
290  $ rcond, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams,
291  $ params, w, r, info )
292  CALL chkxer( 'ZHERFSX', infot, nout, lerr, ok )
293 *
294 * ZHECON
295 *
296  srnamt = 'ZHECON'
297  infot = 1
298  CALL zhecon( '/', 0, a, 1, ip, anrm, rcond, w, info )
299  CALL chkxer( 'ZHECON', infot, nout, lerr, ok )
300  infot = 2
301  CALL zhecon( 'U', -1, a, 1, ip, anrm, rcond, w, info )
302  CALL chkxer( 'ZHECON', infot, nout, lerr, ok )
303  infot = 4
304  CALL zhecon( 'U', 2, a, 1, ip, anrm, rcond, w, info )
305  CALL chkxer( 'ZHECON', infot, nout, lerr, ok )
306  infot = 6
307  CALL zhecon( 'U', 1, a, 1, ip, -anrm, rcond, w, info )
308  CALL chkxer( 'ZHECON', infot, nout, lerr, ok )
309 *
310 * Test error exits of the routines that use the diagonal pivoting
311 * factorization of a Hermitian indefinite packed matrix.
312 *
313  ELSE IF( lsamen( 2, c2, 'HP' ) ) THEN
314 *
315 * ZHPTRF
316 *
317  srnamt = 'ZHPTRF'
318  infot = 1
319  CALL zhptrf( '/', 0, a, ip, info )
320  CALL chkxer( 'ZHPTRF', infot, nout, lerr, ok )
321  infot = 2
322  CALL zhptrf( 'U', -1, a, ip, info )
323  CALL chkxer( 'ZHPTRF', infot, nout, lerr, ok )
324 *
325 * ZHPTRI
326 *
327  srnamt = 'ZHPTRI'
328  infot = 1
329  CALL zhptri( '/', 0, a, ip, w, info )
330  CALL chkxer( 'ZHPTRI', infot, nout, lerr, ok )
331  infot = 2
332  CALL zhptri( 'U', -1, a, ip, w, info )
333  CALL chkxer( 'ZHPTRI', infot, nout, lerr, ok )
334 *
335 * ZHPTRS
336 *
337  srnamt = 'ZHPTRS'
338  infot = 1
339  CALL zhptrs( '/', 0, 0, a, ip, b, 1, info )
340  CALL chkxer( 'ZHPTRS', infot, nout, lerr, ok )
341  infot = 2
342  CALL zhptrs( 'U', -1, 0, a, ip, b, 1, info )
343  CALL chkxer( 'ZHPTRS', infot, nout, lerr, ok )
344  infot = 3
345  CALL zhptrs( 'U', 0, -1, a, ip, b, 1, info )
346  CALL chkxer( 'ZHPTRS', infot, nout, lerr, ok )
347  infot = 7
348  CALL zhptrs( 'U', 2, 1, a, ip, b, 1, info )
349  CALL chkxer( 'ZHPTRS', infot, nout, lerr, ok )
350 *
351 * ZHPRFS
352 *
353  srnamt = 'ZHPRFS'
354  infot = 1
355  CALL zhprfs( '/', 0, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
356  $ info )
357  CALL chkxer( 'ZHPRFS', infot, nout, lerr, ok )
358  infot = 2
359  CALL zhprfs( 'U', -1, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
360  $ info )
361  CALL chkxer( 'ZHPRFS', infot, nout, lerr, ok )
362  infot = 3
363  CALL zhprfs( 'U', 0, -1, a, af, ip, b, 1, x, 1, r1, r2, w, r,
364  $ info )
365  CALL chkxer( 'ZHPRFS', infot, nout, lerr, ok )
366  infot = 8
367  CALL zhprfs( 'U', 2, 1, a, af, ip, b, 1, x, 2, r1, r2, w, r,
368  $ info )
369  CALL chkxer( 'ZHPRFS', infot, nout, lerr, ok )
370  infot = 10
371  CALL zhprfs( 'U', 2, 1, a, af, ip, b, 2, x, 1, r1, r2, w, r,
372  $ info )
373  CALL chkxer( 'ZHPRFS', infot, nout, lerr, ok )
374 *
375 * ZHPCON
376 *
377  srnamt = 'ZHPCON'
378  infot = 1
379  CALL zhpcon( '/', 0, a, ip, anrm, rcond, w, info )
380  CALL chkxer( 'ZHPCON', infot, nout, lerr, ok )
381  infot = 2
382  CALL zhpcon( 'U', -1, a, ip, anrm, rcond, w, info )
383  CALL chkxer( 'ZHPCON', infot, nout, lerr, ok )
384  infot = 5
385  CALL zhpcon( 'U', 1, a, ip, -anrm, rcond, w, info )
386  CALL chkxer( 'ZHPCON', infot, nout, lerr, ok )
387  END IF
388 *
389 * Print a summary line.
390 *
391  CALL alaesm( path, ok, nout )
392 *
393  return
394 *
395 * End of ZERRHE
396 *
397  END