LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ zchkeq()

subroutine zchkeq ( double precision  thresh,
integer  nout 
)

ZCHKEQ

Purpose:
 ZCHKEQ tests ZGEEQU, ZGBEQU, ZPOEQU, ZPPEQU and ZPBEQU
Parameters
[in]THRESH
          THRESH is DOUBLE PRECISION
          Threshold for testing routines. Should be between 2 and 10.
[in]NOUT
          NOUT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 53 of file zchkeq.f.

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*
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
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69
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
Here is the call graph for this function:
Here is the caller graph for this function: