55
56
57
58
59
60
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63
64
65
66
67
68 INTEGER NMAX, LW
69 parameter( nmax = 3, lw = ( nmax+2 )*( nmax+2 )+nmax )
70
71
72 CHARACTER*2 C2
73 INTEGER I, ILO, IHI, INFO, J, M, NT
74
75
76 LOGICAL SEL( NMAX )
77 INTEGER IFAILL( NMAX ), IFAILR( NMAX )
78 REAL A( NMAX, NMAX ), C( NMAX, NMAX ), TAU( NMAX ),
79 $ VL( NMAX, NMAX ), VR( NMAX, NMAX ), W( LW ),
80 $ WI( NMAX ), WR( NMAX ), S( NMAX )
81
82
83 LOGICAL LSAMEN
85
86
89
90
91 INTRINSIC real
92
93
94 LOGICAL LERR, OK
95 CHARACTER*32 SRNAMT
96 INTEGER INFOT, NOUT
97
98
99 COMMON / infoc / infot, nout, ok, lerr
100 COMMON / srnamc / srnamt
101
102
103
104 nout = nunit
105 WRITE( nout, fmt = * )
106 c2 = path( 2: 3 )
107
108
109
110 DO 20 j = 1, nmax
111 DO 10 i = 1, nmax
112 a( i, j ) = 1. / real( i+j )
113 10 CONTINUE
114 wi( j ) = real( j )
115 sel( j ) = .true.
116 20 CONTINUE
117 ok = .true.
118 nt = 0
119
120
121
122 IF(
lsamen( 2, c2,
'HS' ) )
THEN
123
124
125
126 srnamt = 'SGEBAL'
127 infot = 1
128 CALL sgebal(
'/', 0, a, 1, ilo, ihi, s, info )
129 CALL chkxer(
'SGEBAL', infot, nout, lerr, ok )
130 infot = 2
131 CALL sgebal(
'N', -1, a, 1, ilo, ihi, s, info )
132 CALL chkxer(
'SGEBAL', infot, nout, lerr, ok )
133 infot = 4
134 CALL sgebal(
'N', 2, a, 1, ilo, ihi, s, info )
135 CALL chkxer(
'SGEBAL', infot, nout, lerr, ok )
136 nt = nt + 3
137
138
139
140 srnamt = 'SGEBAK'
141 infot = 1
142 CALL sgebak(
'/',
'R', 0, 1, 0, s, 0, a, 1, info )
143 CALL chkxer(
'SGEBAK', infot, nout, lerr, ok )
144 infot = 2
145 CALL sgebak(
'N',
'/', 0, 1, 0, s, 0, a, 1, info )
146 CALL chkxer(
'SGEBAK', infot, nout, lerr, ok )
147 infot = 3
148 CALL sgebak(
'N',
'R', -1, 1, 0, s, 0, a, 1, info )
149 CALL chkxer(
'SGEBAK', infot, nout, lerr, ok )
150 infot = 4
151 CALL sgebak(
'N',
'R', 0, 0, 0, s, 0, a, 1, info )
152 CALL chkxer(
'SGEBAK', infot, nout, lerr, ok )
153 infot = 4
154 CALL sgebak(
'N',
'R', 0, 2, 0, s, 0, a, 1, info )
155 CALL chkxer(
'SGEBAK', infot, nout, lerr, ok )
156 infot = 5
157 CALL sgebak(
'N',
'R', 2, 2, 1, s, 0, a, 2, info )
158 CALL chkxer(
'SGEBAK', infot, nout, lerr, ok )
159 infot = 5
160 CALL sgebak(
'N',
'R', 0, 1, 1, s, 0, a, 1, info )
161 CALL chkxer(
'SGEBAK', infot, nout, lerr, ok )
162 infot = 7
163 CALL sgebak(
'N',
'R', 0, 1, 0, s, -1, a, 1, info )
164 CALL chkxer(
'SGEBAK', infot, nout, lerr, ok )
165 infot = 9
166 CALL sgebak(
'N',
'R', 2, 1, 2, s, 0, a, 1, info )
167 CALL chkxer(
'SGEBAK', infot, nout, lerr, ok )
168 nt = nt + 9
169
170
171
172 srnamt = 'SGEHRD'
173 infot = 1
174 CALL sgehrd( -1, 1, 1, a, 1, tau, w, 1, info )
175 CALL chkxer(
'SGEHRD', infot, nout, lerr, ok )
176 infot = 2
177 CALL sgehrd( 0, 0, 0, a, 1, tau, w, 1, info )
178 CALL chkxer(
'SGEHRD', infot, nout, lerr, ok )
179 infot = 2
180 CALL sgehrd( 0, 2, 0, a, 1, tau, w, 1, info )
181 CALL chkxer(
'SGEHRD', infot, nout, lerr, ok )
182 infot = 3
183 CALL sgehrd( 1, 1, 0, a, 1, tau, w, 1, info )
184 CALL chkxer(
'SGEHRD', infot, nout, lerr, ok )
185 infot = 3
186 CALL sgehrd( 0, 1, 1, a, 1, tau, w, 1, info )
187 CALL chkxer(
'SGEHRD', infot, nout, lerr, ok )
188 infot = 5
189 CALL sgehrd( 2, 1, 1, a, 1, tau, w, 2, info )
190 CALL chkxer(
'SGEHRD', infot, nout, lerr, ok )
191 infot = 8
192 CALL sgehrd( 2, 1, 2, a, 2, tau, w, 1, info )
193 CALL chkxer(
'SGEHRD', infot, nout, lerr, ok )
194 nt = nt + 7
195
196
197
198 srnamt = 'SGEHD2'
199 infot = 1
200 CALL sgehd2( -1, 1, 1, a, 1, tau, w, info )
201 CALL chkxer(
'SGEHD2', infot, nout, lerr, ok )
202 infot = 2
203 CALL sgehd2( 0, 0, 0, a, 1, tau, w, info )
204 CALL chkxer(
'SGEHD2', infot, nout, lerr, ok )
205 infot = 2
206 CALL sgehd2( 0, 2, 0, a, 1, tau, w, info )
207 CALL chkxer(
'SGEHD2', infot, nout, lerr, ok )
208 infot = 3
209 CALL sgehd2( 1, 1, 0, a, 1, tau, w, info )
210 CALL chkxer(
'SGEHD2', infot, nout, lerr, ok )
211 infot = 3
212 CALL sgehd2( 0, 1, 1, a, 1, tau, w, info )
213 CALL chkxer(
'SGEHD2', infot, nout, lerr, ok )
214 infot = 5
215 CALL sgehd2( 2, 1, 1, a, 1, tau, w, info )
216 CALL chkxer(
'SGEHD2', infot, nout, lerr, ok )
217 nt = nt + 6
218
219
220
221 srnamt = 'SORGHR'
222 infot = 1
223 CALL sorghr( -1, 1, 1, a, 1, tau, w, 1, info )
224 CALL chkxer(
'SORGHR', infot, nout, lerr, ok )
225 infot = 2
226 CALL sorghr( 0, 0, 0, a, 1, tau, w, 1, info )
227 CALL chkxer(
'SORGHR', infot, nout, lerr, ok )
228 infot = 2
229 CALL sorghr( 0, 2, 0, a, 1, tau, w, 1, info )
230 CALL chkxer(
'SORGHR', infot, nout, lerr, ok )
231 infot = 3
232 CALL sorghr( 1, 1, 0, a, 1, tau, w, 1, info )
233 CALL chkxer(
'SORGHR', infot, nout, lerr, ok )
234 infot = 3
235 CALL sorghr( 0, 1, 1, a, 1, tau, w, 1, info )
236 CALL chkxer(
'SORGHR', infot, nout, lerr, ok )
237 infot = 5
238 CALL sorghr( 2, 1, 1, a, 1, tau, w, 1, info )
239 CALL chkxer(
'SORGHR', infot, nout, lerr, ok )
240 infot = 8
241 CALL sorghr( 3, 1, 3, a, 3, tau, w, 1, info )
242 CALL chkxer(
'SORGHR', infot, nout, lerr, ok )
243 nt = nt + 7
244
245
246
247 srnamt = 'SORMHR'
248 infot = 1
249 CALL sormhr(
'/',
'N', 0, 0, 1, 0, a, 1, tau, c, 1, w, 1,
250 $ info )
251 CALL chkxer(
'SORMHR', infot, nout, lerr, ok )
252 infot = 2
253 CALL sormhr(
'L',
'/', 0, 0, 1, 0, a, 1, tau, c, 1, w, 1,
254 $ info )
255 CALL chkxer(
'SORMHR', infot, nout, lerr, ok )
256 infot = 3
257 CALL sormhr(
'L',
'N', -1, 0, 1, 0, a, 1, tau, c, 1, w, 1,
258 $ info )
259 CALL chkxer(
'SORMHR', infot, nout, lerr, ok )
260 infot = 4
261 CALL sormhr(
'L',
'N', 0, -1, 1, 0, a, 1, tau, c, 1, w, 1,
262 $ info )
263 CALL chkxer(
'SORMHR', infot, nout, lerr, ok )
264 infot = 5
265 CALL sormhr(
'L',
'N', 0, 0, 0, 0, a, 1, tau, c, 1, w, 1,
266 $ info )
267 CALL chkxer(
'SORMHR', infot, nout, lerr, ok )
268 infot = 5
269 CALL sormhr(
'L',
'N', 0, 0, 2, 0, a, 1, tau, c, 1, w, 1,
270 $ info )
271 CALL chkxer(
'SORMHR', infot, nout, lerr, ok )
272 infot = 5
273 CALL sormhr(
'L',
'N', 1, 2, 2, 1, a, 1, tau, c, 1, w, 2,
274 $ info )
275 CALL chkxer(
'SORMHR', infot, nout, lerr, ok )
276 infot = 5
277 CALL sormhr(
'R',
'N', 2, 1, 2, 1, a, 1, tau, c, 2, w, 2,
278 $ info )
279 CALL chkxer(
'SORMHR', infot, nout, lerr, ok )
280 infot = 6
281 CALL sormhr(
'L',
'N', 1, 1, 1, 0, a, 1, tau, c, 1, w, 1,
282 $ info )
283 CALL chkxer(
'SORMHR', infot, nout, lerr, ok )
284 infot = 6
285 CALL sormhr(
'L',
'N', 0, 1, 1, 1, a, 1, tau, c, 1, w, 1,
286 $ info )
287 CALL chkxer(
'SORMHR', infot, nout, lerr, ok )
288 infot = 6
289 CALL sormhr(
'R',
'N', 1, 0, 1, 1, a, 1, tau, c, 1, w, 1,
290 $ info )
291 CALL chkxer(
'SORMHR', infot, nout, lerr, ok )
292 infot = 8
293 CALL sormhr(
'L',
'N', 2, 1, 1, 1, a, 1, tau, c, 2, w, 1,
294 $ info )
295 CALL chkxer(
'SORMHR', infot, nout, lerr, ok )
296 infot = 8
297 CALL sormhr(
'R',
'N', 1, 2, 1, 1, a, 1, tau, c, 1, w, 1,
298 $ info )
299 CALL chkxer(
'SORMHR', infot, nout, lerr, ok )
300 infot = 11
301 CALL sormhr(
'L',
'N', 2, 1, 1, 1, a, 2, tau, c, 1, w, 1,
302 $ info )
303 CALL chkxer(
'SORMHR', infot, nout, lerr, ok )
304 infot = 13
305 CALL sormhr(
'L',
'N', 1, 2, 1, 1, a, 1, tau, c, 1, w, 1,
306 $ info )
307 CALL chkxer(
'SORMHR', infot, nout, lerr, ok )
308 infot = 13
309 CALL sormhr(
'R',
'N', 2, 1, 1, 1, a, 1, tau, c, 2, w, 1,
310 $ info )
311 CALL chkxer(
'SORMHR', infot, nout, lerr, ok )
312 nt = nt + 16
313
314
315
316 srnamt = 'SHSEQR'
317 infot = 1
318 CALL shseqr(
'/',
'N', 0, 1, 0, a, 1, wr, wi, c, 1, w, 1,
319 $ info )
320 CALL chkxer(
'SHSEQR', infot, nout, lerr, ok )
321 infot = 2
322 CALL shseqr(
'E',
'/', 0, 1, 0, a, 1, wr, wi, c, 1, w, 1,
323 $ info )
324 CALL chkxer(
'SHSEQR', infot, nout, lerr, ok )
325 infot = 3
326 CALL shseqr(
'E',
'N', -1, 1, 0, a, 1, wr, wi, c, 1, w, 1,
327 $ info )
328 CALL chkxer(
'SHSEQR', infot, nout, lerr, ok )
329 infot = 4
330 CALL shseqr(
'E',
'N', 0, 0, 0, a, 1, wr, wi, c, 1, w, 1,
331 $ info )
332 CALL chkxer(
'SHSEQR', infot, nout, lerr, ok )
333 infot = 4
334 CALL shseqr(
'E',
'N', 0, 2, 0, a, 1, wr, wi, c, 1, w, 1,
335 $ info )
336 CALL chkxer(
'SHSEQR', infot, nout, lerr, ok )
337 infot = 5
338 CALL shseqr(
'E',
'N', 1, 1, 0, a, 1, wr, wi, c, 1, w, 1,
339 $ info )
340 CALL chkxer(
'SHSEQR', infot, nout, lerr, ok )
341 infot = 5
342 CALL shseqr(
'E',
'N', 1, 1, 2, a, 1, wr, wi, c, 1, w, 1,
343 $ info )
344 CALL chkxer(
'SHSEQR', infot, nout, lerr, ok )
345 infot = 7
346 CALL shseqr(
'E',
'N', 2, 1, 2, a, 1, wr, wi, c, 2, w, 1,
347 $ info )
348 CALL chkxer(
'SHSEQR', infot, nout, lerr, ok )
349 infot = 11
350 CALL shseqr(
'E',
'V', 2, 1, 2, a, 2, wr, wi, c, 1, w, 1,
351 $ info )
352 CALL chkxer(
'SHSEQR', infot, nout, lerr, ok )
353 infot = 13
354 CALL shseqr(
'E',
'N', 2, 1, 2, a, 2, wr, wi, c, 1, w, 1,
355 $ info )
356 CALL chkxer(
'SHSEQR', infot, nout, lerr, ok )
357 nt = nt + 10
358
359
360
361 srnamt = 'SHSEIN'
362 infot = 1
363 CALL shsein(
'/',
'N',
'N', sel, 0, a, 1, wr, wi, vl, 1, vr, 1,
364 $ 0, m, w, ifaill, ifailr, info )
365 CALL chkxer(
'SHSEIN', infot, nout, lerr, ok )
366 infot = 2
367 CALL shsein(
'R',
'/',
'N', sel, 0, a, 1, wr, wi, vl, 1, vr, 1,
368 $ 0, m, w, ifaill, ifailr, info )
369 CALL chkxer(
'SHSEIN', infot, nout, lerr, ok )
370 infot = 3
371 CALL shsein(
'R',
'N',
'/', sel, 0, a, 1, wr, wi, vl, 1, vr, 1,
372 $ 0, m, w, ifaill, ifailr, info )
373 CALL chkxer(
'SHSEIN', infot, nout, lerr, ok )
374 infot = 5
375 CALL shsein(
'R',
'N',
'N', sel, -1, a, 1, wr, wi, vl, 1, vr,
376 $ 1, 0, m, w, ifaill, ifailr, info )
377 CALL chkxer(
'SHSEIN', infot, nout, lerr, ok )
378 infot = 7
379 CALL shsein(
'R',
'N',
'N', sel, 2, a, 1, wr, wi, vl, 1, vr, 2,
380 $ 4, m, w, ifaill, ifailr, info )
381 CALL chkxer(
'SHSEIN', infot, nout, lerr, ok )
382 infot = 11
383 CALL shsein(
'L',
'N',
'N', sel, 2, a, 2, wr, wi, vl, 1, vr, 1,
384 $ 4, m, w, ifaill, ifailr, info )
385 CALL chkxer(
'SHSEIN', infot, nout, lerr, ok )
386 infot = 13
387 CALL shsein(
'R',
'N',
'N', sel, 2, a, 2, wr, wi, vl, 1, vr, 1,
388 $ 4, m, w, ifaill, ifailr, info )
389 CALL chkxer(
'SHSEIN', infot, nout, lerr, ok )
390 infot = 14
391 CALL shsein(
'R',
'N',
'N', sel, 2, a, 2, wr, wi, vl, 1, vr, 2,
392 $ 1, m, w, ifaill, ifailr, info )
393 CALL chkxer(
'SHSEIN', infot, nout, lerr, ok )
394 nt = nt + 8
395
396
397
398 srnamt = 'STREVC'
399 infot = 1
400 CALL strevc(
'/',
'A', sel, 0, a, 1, vl, 1, vr, 1, 0, m, w,
401 $ info )
402 CALL chkxer(
'STREVC', infot, nout, lerr, ok )
403 infot = 2
404 CALL strevc(
'L',
'/', sel, 0, a, 1, vl, 1, vr, 1, 0, m, w,
405 $ info )
406 CALL chkxer(
'STREVC', infot, nout, lerr, ok )
407 infot = 4
408 CALL strevc(
'L',
'A', sel, -1, a, 1, vl, 1, vr, 1, 0, m, w,
409 $ info )
410 CALL chkxer(
'STREVC', infot, nout, lerr, ok )
411 infot = 6
412 CALL strevc(
'L',
'A', sel, 2, a, 1, vl, 2, vr, 1, 4, m, w,
413 $ info )
414 CALL chkxer(
'STREVC', infot, nout, lerr, ok )
415 infot = 8
416 CALL strevc(
'L',
'A', sel, 2, a, 2, vl, 1, vr, 1, 4, m, w,
417 $ info )
418 CALL chkxer(
'STREVC', infot, nout, lerr, ok )
419 infot = 10
420 CALL strevc(
'R',
'A', sel, 2, a, 2, vl, 1, vr, 1, 4, m, w,
421 $ info )
422 CALL chkxer(
'STREVC', infot, nout, lerr, ok )
423 infot = 11
424 CALL strevc(
'L',
'A', sel, 2, a, 2, vl, 2, vr, 1, 1, m, w,
425 $ info )
426 CALL chkxer(
'STREVC', infot, nout, lerr, ok )
427 nt = nt + 7
428
429
430
431 srnamt = 'STREVC3'
432 infot = 1
433 CALL strevc3(
'/',
'A', sel, 0, a, 1, vl, 1, vr, 1, 0, m, w,
434 $ lw, info )
435 CALL chkxer(
'STREVC3', infot, nout, lerr, ok )
436 infot = 2
437 CALL strevc3(
'L',
'/', sel, 0, a, 1, vl, 1, vr, 1, 0, m, w,
438 $ lw, info )
439 CALL chkxer(
'STREVC3', infot, nout, lerr, ok )
440 infot = 4
441 CALL strevc3(
'L',
'A', sel, -1, a, 1, vl, 1, vr, 1, 0, m, w,
442 $ lw, info )
443 CALL chkxer(
'STREVC3', infot, nout, lerr, ok )
444 infot = 6
445 CALL strevc3(
'L',
'A', sel, 2, a, 1, vl, 2, vr, 1, 4, m, w,
446 $ lw, info )
447 CALL chkxer(
'STREVC3', infot, nout, lerr, ok )
448 infot = 8
449 CALL strevc3(
'L',
'A', sel, 2, a, 2, vl, 1, vr, 1, 4, m, w,
450 $ lw, info )
451 CALL chkxer(
'STREVC3', infot, nout, lerr, ok )
452 infot = 10
453 CALL strevc3(
'R',
'A', sel, 2, a, 2, vl, 1, vr, 1, 4, m, w,
454 $ lw, info )
455 CALL chkxer(
'STREVC3', infot, nout, lerr, ok )
456 infot = 11
457 CALL strevc3(
'L',
'A', sel, 2, a, 2, vl, 2, vr, 1, 1, m, w,
458 $ lw, info )
459 CALL chkxer(
'STREVC3', infot, nout, lerr, ok )
460 infot = 14
461 CALL strevc3(
'L',
'A', sel, 2, a, 2, vl, 2, vr, 1, 2, m, w,
462 $ 2, info )
463 CALL chkxer(
'STREVC3', infot, nout, lerr, ok )
464 nt = nt + 8
465 END IF
466
467
468
469 IF( ok ) THEN
470 WRITE( nout, fmt = 9999 )path, nt
471 ELSE
472 WRITE( nout, fmt = 9998 )path
473 END IF
474
475 9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits',
476 $ ' (', i3, ' tests done)' )
477 9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ',
478 $ 'exits ***' )
479
480 RETURN
481
482
483
subroutine chkxer(srnamt, infot, nout, lerr, ok)
subroutine sgebak(job, side, n, ilo, ihi, scale, m, v, ldv, info)
SGEBAK
subroutine sgebal(job, n, a, lda, ilo, ihi, scale, info)
SGEBAL
subroutine sgehd2(n, ilo, ihi, a, lda, tau, work, info)
SGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm.
subroutine sgehrd(n, ilo, ihi, a, lda, tau, work, lwork, info)
SGEHRD
subroutine shsein(side, eigsrc, initv, select, n, h, ldh, wr, wi, vl, ldvl, vr, ldvr, mm, m, work, ifaill, ifailr, info)
SHSEIN
subroutine shseqr(job, compz, n, ilo, ihi, h, ldh, wr, wi, z, ldz, work, lwork, info)
SHSEQR
logical function lsamen(n, ca, cb)
LSAMEN
subroutine strevc3(side, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, mm, m, work, lwork, info)
STREVC3
subroutine strevc(side, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, mm, m, work, info)
STREVC
subroutine sorghr(n, ilo, ihi, a, lda, tau, work, lwork, info)
SORGHR
subroutine sormhr(side, trans, m, n, ilo, ihi, a, lda, tau, c, ldc, work, lwork, info)
SORMHR