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