LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
zchkeq.f
Go to the documentation of this file.
1*> \brief \b ZCHKEQ
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 ZCHKEQ( THRESH, NOUT )
12*
13* .. Scalar Arguments ..
14* INTEGER NOUT
15* DOUBLE PRECISION THRESH
16* ..
17*
18*
19*> \par Purpose:
20* =============
21*>
22*> \verbatim
23*>
24*> ZCHKEQ tests ZGEEQU, ZGBEQU, ZPOEQU, ZPPEQU and ZPBEQU
25*> \endverbatim
26*
27* Arguments:
28* ==========
29*
30*> \param[in] THRESH
31*> \verbatim
32*> THRESH is DOUBLE PRECISION
33*> Threshold for testing routines. Should be between 2 and 10.
34*> \endverbatim
35*>
36*> \param[in] NOUT
37*> \verbatim
38*> NOUT is INTEGER
39*> The unit number for output.
40*> \endverbatim
41*
42* Authors:
43* ========
44*
45*> \author Univ. of Tennessee
46*> \author Univ. of California Berkeley
47*> \author Univ. of Colorado Denver
48*> \author NAG Ltd.
49*
50*> \ingroup complex16_lin
51*
52* =====================================================================
53 SUBROUTINE zchkeq( THRESH, NOUT )
54*
55* -- LAPACK test routine --
56* -- LAPACK is a software package provided by Univ. of Tennessee, --
57* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
58*
59* .. Scalar Arguments ..
60 INTEGER NOUT
61 DOUBLE PRECISION THRESH
62* ..
63*
64* =====================================================================
65*
66* .. Parameters ..
67 DOUBLE PRECISION ZERO, ONE, TEN
68 parameter( zero = 0.0d0, one = 1.0d+0, ten = 1.0d1 )
69 COMPLEX*16 CZERO
70 parameter( czero = ( 0.0d0, 0.0d0 ) )
71 COMPLEX*16 CONE
72 parameter( cone = ( 1.0d0, 0.0d0 ) )
73 INTEGER NSZ, NSZB
74 parameter( nsz = 5, nszb = 3*nsz-2 )
75 INTEGER NSZP, NPOW
76 parameter( nszp = ( nsz*( nsz+1 ) ) / 2,
77 $ npow = 2*nsz+1 )
78* ..
79* .. Local Scalars ..
80 LOGICAL OK
81 CHARACTER*3 PATH
82 INTEGER I, INFO, J, KL, KU, M, N
83 DOUBLE PRECISION CCOND, EPS, NORM, RATIO, RCMAX, RCMIN, RCOND
84* ..
85* .. Local Arrays ..
86 DOUBLE PRECISION C( NSZ ), POW( NPOW ), R( NSZ ), RESLTS( 5 ),
87 $ RPOW( NPOW )
88 COMPLEX*16 A( NSZ, NSZ ), AB( NSZB, NSZ ), AP( NSZP )
89* ..
90* .. External Functions ..
91 DOUBLE PRECISION DLAMCH
92 EXTERNAL dlamch
93* ..
94* .. External Subroutines ..
95 EXTERNAL zgbequ, zgeequ, zpbequ, zpoequ, zppequ
96* ..
97* .. Intrinsic Functions ..
98 INTRINSIC abs, max, min
99* ..
100* .. Executable Statements ..
101*
102 path( 1: 1 ) = 'Zomplex precision'
103 path( 2: 3 ) = 'EQ'
104*
105 eps = dlamch( 'P' )
106 DO 10 i = 1, 5
107 reslts( i ) = zero
108 10 CONTINUE
109 DO 20 i = 1, npow
110 pow( i ) = ten**( i-1 )
111 rpow( i ) = one / pow( i )
112 20 CONTINUE
113*
114* Test ZGEEQU
115*
116 DO 80 n = 0, nsz
117 DO 70 m = 0, nsz
118*
119 DO 40 j = 1, nsz
120 DO 30 i = 1, nsz
121 IF( i.LE.m .AND. j.LE.n ) THEN
122 a( i, j ) = pow( i+j+1 )*( -1 )**( i+j )
123 ELSE
124 a( i, j ) = czero
125 END IF
126 30 CONTINUE
127 40 CONTINUE
128*
129 CALL zgeequ( m, n, a, nsz, r, c, rcond, ccond, norm, info )
130*
131 IF( info.NE.0 ) THEN
132 reslts( 1 ) = one
133 ELSE
134 IF( n.NE.0 .AND. m.NE.0 ) THEN
135 reslts( 1 ) = max( reslts( 1 ),
136 $ abs( ( rcond-rpow( m ) ) / rpow( m ) ) )
137 reslts( 1 ) = max( reslts( 1 ),
138 $ abs( ( ccond-rpow( n ) ) / rpow( n ) ) )
139 reslts( 1 ) = max( reslts( 1 ),
140 $ abs( ( norm-pow( n+m+1 ) ) / pow( n+m+
141 $ 1 ) ) )
142 DO 50 i = 1, m
143 reslts( 1 ) = max( reslts( 1 ),
144 $ abs( ( r( i )-rpow( i+n+1 ) ) /
145 $ rpow( i+n+1 ) ) )
146 50 CONTINUE
147 DO 60 j = 1, n
148 reslts( 1 ) = max( reslts( 1 ),
149 $ abs( ( c( j )-pow( n-j+1 ) ) /
150 $ pow( n-j+1 ) ) )
151 60 CONTINUE
152 END IF
153 END IF
154*
155 70 CONTINUE
156 80 CONTINUE
157*
158* Test with zero rows and columns
159*
160 DO 90 j = 1, nsz
161 a( max( nsz-1, 1 ), j ) = czero
162 90 CONTINUE
163 CALL zgeequ( nsz, nsz, a, nsz, r, c, rcond, ccond, norm, info )
164 IF( info.NE.max( nsz-1, 1 ) )
165 $ reslts( 1 ) = one
166*
167 DO 100 j = 1, nsz
168 a( max( nsz-1, 1 ), j ) = cone
169 100 CONTINUE
170 DO 110 i = 1, nsz
171 a( i, max( nsz-1, 1 ) ) = czero
172 110 CONTINUE
173 CALL zgeequ( nsz, nsz, a, nsz, r, c, rcond, ccond, norm, info )
174 IF( info.NE.nsz+max( nsz-1, 1 ) )
175 $ reslts( 1 ) = one
176 reslts( 1 ) = reslts( 1 ) / eps
177*
178* Test ZGBEQU
179*
180 DO 250 n = 0, nsz
181 DO 240 m = 0, nsz
182 DO 230 kl = 0, max( m-1, 0 )
183 DO 220 ku = 0, max( n-1, 0 )
184*
185 DO 130 j = 1, nsz
186 DO 120 i = 1, nszb
187 ab( i, j ) = czero
188 120 CONTINUE
189 130 CONTINUE
190 DO 150 j = 1, n
191 DO 140 i = 1, m
192 IF( i.LE.min( m, j+kl ) .AND. i.GE.
193 $ max( 1, j-ku ) .AND. j.LE.n ) THEN
194 ab( ku+1+i-j, j ) = pow( i+j+1 )*
195 $ ( -1 )**( i+j )
196 END IF
197 140 CONTINUE
198 150 CONTINUE
199*
200 CALL zgbequ( m, n, kl, ku, ab, nszb, r, c, rcond,
201 $ ccond, norm, info )
202*
203 IF( info.NE.0 ) THEN
204 IF( .NOT.( ( n+kl.LT.m .AND. info.EQ.n+kl+1 ) .OR.
205 $ ( m+ku.LT.n .AND. info.EQ.2*m+ku+1 ) ) ) THEN
206 reslts( 2 ) = one
207 END IF
208 ELSE
209 IF( n.NE.0 .AND. m.NE.0 ) THEN
210*
211 rcmin = r( 1 )
212 rcmax = r( 1 )
213 DO 160 i = 1, m
214 rcmin = min( rcmin, r( i ) )
215 rcmax = max( rcmax, r( i ) )
216 160 CONTINUE
217 ratio = rcmin / rcmax
218 reslts( 2 ) = max( reslts( 2 ),
219 $ abs( ( rcond-ratio ) / ratio ) )
220*
221 rcmin = c( 1 )
222 rcmax = c( 1 )
223 DO 170 j = 1, n
224 rcmin = min( rcmin, c( j ) )
225 rcmax = max( rcmax, c( j ) )
226 170 CONTINUE
227 ratio = rcmin / rcmax
228 reslts( 2 ) = max( reslts( 2 ),
229 $ abs( ( ccond-ratio ) / ratio ) )
230*
231 reslts( 2 ) = max( reslts( 2 ),
232 $ abs( ( norm-pow( n+m+1 ) ) /
233 $ pow( n+m+1 ) ) )
234 DO 190 i = 1, m
235 rcmax = zero
236 DO 180 j = 1, n
237 IF( i.LE.j+kl .AND. i.GE.j-ku ) THEN
238 ratio = abs( r( i )*pow( i+j+1 )*
239 $ c( j ) )
240 rcmax = max( rcmax, ratio )
241 END IF
242 180 CONTINUE
243 reslts( 2 ) = max( reslts( 2 ),
244 $ abs( one-rcmax ) )
245 190 CONTINUE
246*
247 DO 210 j = 1, n
248 rcmax = zero
249 DO 200 i = 1, m
250 IF( i.LE.j+kl .AND. i.GE.j-ku ) THEN
251 ratio = abs( r( i )*pow( i+j+1 )*
252 $ c( j ) )
253 rcmax = max( rcmax, ratio )
254 END IF
255 200 CONTINUE
256 reslts( 2 ) = max( reslts( 2 ),
257 $ abs( one-rcmax ) )
258 210 CONTINUE
259 END IF
260 END IF
261*
262 220 CONTINUE
263 230 CONTINUE
264 240 CONTINUE
265 250 CONTINUE
266 reslts( 2 ) = reslts( 2 ) / eps
267*
268* Test ZPOEQU
269*
270 DO 290 n = 0, nsz
271*
272 DO 270 i = 1, nsz
273 DO 260 j = 1, nsz
274 IF( i.LE.n .AND. j.EQ.i ) THEN
275 a( i, j ) = pow( i+j+1 )*( -1 )**( i+j )
276 ELSE
277 a( i, j ) = czero
278 END IF
279 260 CONTINUE
280 270 CONTINUE
281*
282 CALL zpoequ( n, a, nsz, r, rcond, norm, info )
283*
284 IF( info.NE.0 ) THEN
285 reslts( 3 ) = one
286 ELSE
287 IF( n.NE.0 ) THEN
288 reslts( 3 ) = max( reslts( 3 ),
289 $ abs( ( rcond-rpow( n ) ) / rpow( n ) ) )
290 reslts( 3 ) = max( reslts( 3 ),
291 $ abs( ( norm-pow( 2*n+1 ) ) / pow( 2*n+
292 $ 1 ) ) )
293 DO 280 i = 1, n
294 reslts( 3 ) = max( reslts( 3 ),
295 $ abs( ( r( i )-rpow( i+1 ) ) / rpow( i+
296 $ 1 ) ) )
297 280 CONTINUE
298 END IF
299 END IF
300 290 CONTINUE
301 a( max( nsz-1, 1 ), max( nsz-1, 1 ) ) = -cone
302 CALL zpoequ( nsz, a, nsz, r, rcond, norm, info )
303 IF( info.NE.max( nsz-1, 1 ) )
304 $ reslts( 3 ) = one
305 reslts( 3 ) = reslts( 3 ) / eps
306*
307* Test ZPPEQU
308*
309 DO 360 n = 0, nsz
310*
311* Upper triangular packed storage
312*
313 DO 300 i = 1, ( n*( n+1 ) ) / 2
314 ap( i ) = czero
315 300 CONTINUE
316 DO 310 i = 1, n
317 ap( ( i*( i+1 ) ) / 2 ) = pow( 2*i+1 )
318 310 CONTINUE
319*
320 CALL zppequ( 'U', n, ap, r, rcond, norm, info )
321*
322 IF( info.NE.0 ) THEN
323 reslts( 4 ) = one
324 ELSE
325 IF( n.NE.0 ) THEN
326 reslts( 4 ) = max( reslts( 4 ),
327 $ abs( ( rcond-rpow( n ) ) / rpow( n ) ) )
328 reslts( 4 ) = max( reslts( 4 ),
329 $ abs( ( norm-pow( 2*n+1 ) ) / pow( 2*n+
330 $ 1 ) ) )
331 DO 320 i = 1, n
332 reslts( 4 ) = max( reslts( 4 ),
333 $ abs( ( r( i )-rpow( i+1 ) ) / rpow( i+
334 $ 1 ) ) )
335 320 CONTINUE
336 END IF
337 END IF
338*
339* Lower triangular packed storage
340*
341 DO 330 i = 1, ( n*( n+1 ) ) / 2
342 ap( i ) = czero
343 330 CONTINUE
344 j = 1
345 DO 340 i = 1, n
346 ap( j ) = pow( 2*i+1 )
347 j = j + ( n-i+1 )
348 340 CONTINUE
349*
350 CALL zppequ( 'L', n, ap, r, rcond, norm, info )
351*
352 IF( info.NE.0 ) THEN
353 reslts( 4 ) = one
354 ELSE
355 IF( n.NE.0 ) THEN
356 reslts( 4 ) = max( reslts( 4 ),
357 $ abs( ( rcond-rpow( n ) ) / rpow( n ) ) )
358 reslts( 4 ) = max( reslts( 4 ),
359 $ abs( ( norm-pow( 2*n+1 ) ) / pow( 2*n+
360 $ 1 ) ) )
361 DO 350 i = 1, n
362 reslts( 4 ) = max( reslts( 4 ),
363 $ abs( ( r( i )-rpow( i+1 ) ) / rpow( i+
364 $ 1 ) ) )
365 350 CONTINUE
366 END IF
367 END IF
368*
369 360 CONTINUE
370 i = ( nsz*( nsz+1 ) ) / 2 - 2
371 ap( i ) = -cone
372 CALL zppequ( 'L', nsz, ap, r, rcond, norm, info )
373 IF( info.NE.max( nsz-1, 1 ) )
374 $ reslts( 4 ) = one
375 reslts( 4 ) = reslts( 4 ) / eps
376*
377* Test ZPBEQU
378*
379 DO 460 n = 0, nsz
380 DO 450 kl = 0, max( n-1, 0 )
381*
382* Test upper triangular storage
383*
384 DO 380 j = 1, nsz
385 DO 370 i = 1, nszb
386 ab( i, j ) = czero
387 370 CONTINUE
388 380 CONTINUE
389 DO 390 j = 1, n
390 ab( kl+1, j ) = pow( 2*j+1 )
391 390 CONTINUE
392*
393 CALL zpbequ( 'U', n, kl, ab, nszb, r, rcond, norm, info )
394*
395 IF( info.NE.0 ) THEN
396 reslts( 5 ) = one
397 ELSE
398 IF( n.NE.0 ) THEN
399 reslts( 5 ) = max( reslts( 5 ),
400 $ abs( ( rcond-rpow( n ) ) / rpow( n ) ) )
401 reslts( 5 ) = max( reslts( 5 ),
402 $ abs( ( norm-pow( 2*n+1 ) ) / pow( 2*n+
403 $ 1 ) ) )
404 DO 400 i = 1, n
405 reslts( 5 ) = max( reslts( 5 ),
406 $ abs( ( r( i )-rpow( i+1 ) ) /
407 $ rpow( i+1 ) ) )
408 400 CONTINUE
409 END IF
410 END IF
411 IF( n.NE.0 ) THEN
412 ab( kl+1, max( n-1, 1 ) ) = -cone
413 CALL zpbequ( 'U', n, kl, ab, nszb, r, rcond, norm, info )
414 IF( info.NE.max( n-1, 1 ) )
415 $ reslts( 5 ) = one
416 END IF
417*
418* Test lower triangular storage
419*
420 DO 420 j = 1, nsz
421 DO 410 i = 1, nszb
422 ab( i, j ) = czero
423 410 CONTINUE
424 420 CONTINUE
425 DO 430 j = 1, n
426 ab( 1, j ) = pow( 2*j+1 )
427 430 CONTINUE
428*
429 CALL zpbequ( 'L', n, kl, ab, nszb, r, rcond, norm, info )
430*
431 IF( info.NE.0 ) THEN
432 reslts( 5 ) = one
433 ELSE
434 IF( n.NE.0 ) THEN
435 reslts( 5 ) = max( reslts( 5 ),
436 $ abs( ( rcond-rpow( n ) ) / rpow( n ) ) )
437 reslts( 5 ) = max( reslts( 5 ),
438 $ abs( ( norm-pow( 2*n+1 ) ) / pow( 2*n+
439 $ 1 ) ) )
440 DO 440 i = 1, n
441 reslts( 5 ) = max( reslts( 5 ),
442 $ abs( ( r( i )-rpow( i+1 ) ) /
443 $ rpow( i+1 ) ) )
444 440 CONTINUE
445 END IF
446 END IF
447 IF( n.NE.0 ) THEN
448 ab( 1, max( n-1, 1 ) ) = -cone
449 CALL zpbequ( 'L', n, kl, ab, nszb, r, rcond, norm, info )
450 IF( info.NE.max( n-1, 1 ) )
451 $ reslts( 5 ) = one
452 END IF
453 450 CONTINUE
454 460 CONTINUE
455 reslts( 5 ) = reslts( 5 ) / eps
456 ok = ( reslts( 1 ).LE.thresh ) .AND.
457 $ ( reslts( 2 ).LE.thresh ) .AND.
458 $ ( reslts( 3 ).LE.thresh ) .AND.
459 $ ( reslts( 4 ).LE.thresh ) .AND. ( reslts( 5 ).LE.thresh )
460 WRITE( nout, fmt = * )
461 IF( ok ) THEN
462 WRITE( nout, fmt = 9999 )path
463 ELSE
464 IF( reslts( 1 ).GT.thresh )
465 $ WRITE( nout, fmt = 9998 )reslts( 1 ), thresh
466 IF( reslts( 2 ).GT.thresh )
467 $ WRITE( nout, fmt = 9997 )reslts( 2 ), thresh
468 IF( reslts( 3 ).GT.thresh )
469 $ WRITE( nout, fmt = 9996 )reslts( 3 ), thresh
470 IF( reslts( 4 ).GT.thresh )
471 $ WRITE( nout, fmt = 9995 )reslts( 4 ), thresh
472 IF( reslts( 5 ).GT.thresh )
473 $ WRITE( nout, fmt = 9994 )reslts( 5 ), thresh
474 END IF
475 9999 FORMAT( 1x, 'All tests for ', a3,
476 $ ' routines passed the threshold' )
477 9998 FORMAT( ' ZGEEQU failed test with value ', d10.3, ' exceeding',
478 $ ' threshold ', d10.3 )
479 9997 FORMAT( ' ZGBEQU failed test with value ', d10.3, ' exceeding',
480 $ ' threshold ', d10.3 )
481 9996 FORMAT( ' ZPOEQU failed test with value ', d10.3, ' exceeding',
482 $ ' threshold ', d10.3 )
483 9995 FORMAT( ' ZPPEQU failed test with value ', d10.3, ' exceeding',
484 $ ' threshold ', d10.3 )
485 9994 FORMAT( ' ZPBEQU failed test with value ', d10.3, ' exceeding',
486 $ ' threshold ', d10.3 )
487 RETURN
488*
489* End of ZCHKEQ
490*
491 END
zgbequ
subroutine zgbequ(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, info)
ZGBEQU
Definition zgbequ.f:154
zgeequ
subroutine zgeequ(m, n, a, lda, r, c, rowcnd, colcnd, amax, info)
ZGEEQU
Definition zgeequ.f:140
zpbequ
subroutine zpbequ(uplo, n, kd, ab, ldab, s, scond, amax, info)
ZPBEQU
Definition zpbequ.f:130
zpoequ
subroutine zpoequ(n, a, lda, s, scond, amax, info)
ZPOEQU
Definition zpoequ.f:113
zppequ
subroutine zppequ(uplo, n, ap, s, scond, amax, info)
ZPPEQU
Definition zppequ.f:117
zchkeq
subroutine zchkeq(thresh, nout)
ZCHKEQ
Definition zchkeq.f:54