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