LAPACK  3.10.1
LAPACK: Linear Algebra PACKage
cchkeq.f
Go to the documentation of this file.
1 *> \brief \b CCHKEQ
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 CCHKEQ( THRESH, NOUT )
12 *
13 * .. Scalar Arguments ..
14 * INTEGER NOUT
15 * REAL THRESH
16 * ..
17 *
18 *
19 *> \par Purpose:
20 * =============
21 *>
22 *> \verbatim
23 *>
24 *> CCHKEQ tests CGEEQU, CGBEQU, CPOEQU, CPPEQU and CPBEQU
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 complex_lin
51 *
52 * =====================================================================
53  SUBROUTINE cchkeq( 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  COMPLEX CZERO
70  parameter( czero = ( 0.0e0, 0.0e0 ) )
71  COMPLEX CONE
72  parameter( cone = ( 1.0e0, 0.0e0 ) )
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  REAL CCOND, EPS, NORM, RATIO, RCMAX, RCMIN, RCOND
84 * ..
85 * .. Local Arrays ..
86  REAL C( NSZ ), POW( NPOW ), R( NSZ ), RESLTS( 5 ),
87  $ RPOW( NPOW )
88  COMPLEX A( NSZ, NSZ ), AB( NSZB, NSZ ), AP( NSZP )
89 * ..
90 * .. External Functions ..
91  REAL SLAMCH
92  EXTERNAL slamch
93 * ..
94 * .. External Subroutines ..
95  EXTERNAL cgbequ, cgeequ, cpbequ, cpoequ, cppequ
96 * ..
97 * .. Intrinsic Functions ..
98  INTRINSIC abs, max, min
99 * ..
100 * .. Executable Statements ..
101 *
102  path( 1:1 ) = 'Complex precision'
103  path( 2:3 ) = 'EQ'
104 *
105  eps = slamch( '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 CGEEQU
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 cgeequ( 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 cgeequ( 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 cgeequ( 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 CGBEQU
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 cgbequ( 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 CPOEQU
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 cpoequ( 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 cpoequ( 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 CPPEQU
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 cppequ( '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 cppequ( '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 cppequ( '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 CPBEQU
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 cpbequ( '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 cpbequ( '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 cpbequ( '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 cpbequ( '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( ' CGEEQU failed test with value ', e10.3, ' exceeding',
478  $ ' threshold ', e10.3 )
479  9997 FORMAT( ' CGBEQU failed test with value ', e10.3, ' exceeding',
480  $ ' threshold ', e10.3 )
481  9996 FORMAT( ' CPOEQU failed test with value ', e10.3, ' exceeding',
482  $ ' threshold ', e10.3 )
483  9995 FORMAT( ' CPPEQU failed test with value ', e10.3, ' exceeding',
484  $ ' threshold ', e10.3 )
485  9994 FORMAT( ' CPBEQU failed test with value ', e10.3, ' exceeding',
486  $ ' threshold ', e10.3 )
487  RETURN
488 *
489 * End of CCHKEQ
490 *
491  END
subroutine cchkeq(THRESH, NOUT)
CCHKEQ
Definition: cchkeq.f:54
subroutine cgbequ(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO)
CGBEQU
Definition: cgbequ.f:154
subroutine cgeequ(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO)
CGEEQU
Definition: cgeequ.f:140
subroutine cppequ(UPLO, N, AP, S, SCOND, AMAX, INFO)
CPPEQU
Definition: cppequ.f:117
subroutine cpbequ(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO)
CPBEQU
Definition: cpbequ.f:130
subroutine cpoequ(N, A, LDA, S, SCOND, AMAX, INFO)
CPOEQU
Definition: cpoequ.f:113