LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine dchkeq ( double precision  THRESH,
integer  NOUT 
)

DCHKEQ

Purpose: 
 DCHKEQ tests DGEEQU, DGBEQU, DPOEQU, DPPEQU and DPBEQU
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.
Date
November 2011

Definition at line 56 of file dchkeq.f.

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  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  DOUBLE PRECISION ccond, eps, norm, ratio, rcmax, rcmin, rcond
83 * ..
84 * .. Local Arrays ..
85  DOUBLE PRECISION 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  DOUBLE PRECISION dlamch
91  EXTERNAL dlamch
92 * ..
93 * .. External Subroutines ..
94  EXTERNAL dgbequ, dgeequ, dpbequ, dpoequ, dppequ
95 * ..
96 * .. Intrinsic Functions ..
97  INTRINSIC abs, max, min
98 * ..
99 * .. Executable Statements ..
100 *
101  path( 1: 1 ) = 'Double precision'
102  path( 2: 3 ) = 'EQ'
103 *
104  eps = dlamch( '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 DGEEQU
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 dgeequ( 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 dgeequ( 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 dgeequ( 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 DGBEQU
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 dgbequ( 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 DPOEQU
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 dpoequ( 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 dpoequ( 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 DPPEQU
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 dppequ( '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 dppequ( '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 dppequ( '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 DPBEQU
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 dpbequ( '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 dpbequ( '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 dpbequ( '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 dpbequ( '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( ' DGEEQU failed test with value ', d10.3, ' exceeding',
477  $ ' threshold ', d10.3 )
478  9997 FORMAT( ' DGBEQU failed test with value ', d10.3, ' exceeding',
479  $ ' threshold ', d10.3 )
480  9996 FORMAT( ' DPOEQU failed test with value ', d10.3, ' exceeding',
481  $ ' threshold ', d10.3 )
482  9995 FORMAT( ' DPPEQU failed test with value ', d10.3, ' exceeding',
483  $ ' threshold ', d10.3 )
484  9994 FORMAT( ' DPBEQU failed test with value ', d10.3, ' exceeding',
485  $ ' threshold ', d10.3 )
486  RETURN
487 *
488 * End of DCHKEQ
489 *
dlamch
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65
dgeequ
subroutine dgeequ(M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO)
DGEEQU
Definition: dgeequ.f:141
dpbequ
subroutine dpbequ(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO)
DPBEQU
Definition: dpbequ.f:131
dppequ
subroutine dppequ(UPLO, N, AP, S, SCOND, AMAX, INFO)
DPPEQU
Definition: dppequ.f:118
dgbequ
subroutine dgbequ(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO)
DGBEQU
Definition: dgbequ.f:155
dpoequ
subroutine dpoequ(N, A, LDA, S, SCOND, AMAX, INFO)
DPOEQU
Definition: dpoequ.f:114

Here is the call graph for this function:

Here is the caller graph for this function: