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