54
55
56
57
58
59
60 INTEGER NOUT
61 REAL THRESH
62
63
64
65
66
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
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
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
91 REAL SLAMCH
93
94
96
97
98 INTRINSIC abs, max, min
99
100
101
102 path( 1:1 ) = 'Complex precision'
103 path( 2:3 ) = 'EQ'
104
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
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
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
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
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
308
309 DO 360 n = 0, nsz
310
311
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
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
378
379 DO 460 n = 0, nsz
380 DO 450 kl = 0, max( n-1, 0 )
381
382
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
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
490
subroutine cgbequ(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, info)
CGBEQU
subroutine cgeequ(m, n, a, lda, r, c, rowcnd, colcnd, amax, info)
CGEEQU
real function slamch(cmach)
SLAMCH
subroutine cpbequ(uplo, n, kd, ab, ldab, s, scond, amax, info)
CPBEQU
subroutine cpoequ(n, a, lda, s, scond, amax, info)
CPOEQU
subroutine cppequ(uplo, n, ap, s, scond, amax, info)
CPPEQU