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, IHI, ILO, INFO, J, M, NT
74
75
76 LOGICAL SEL( NMAX )
77 INTEGER IFAILL( NMAX ), IFAILR( NMAX )
78 DOUBLE PRECISION A( NMAX, NMAX ), C( NMAX, NMAX ), S( NMAX ),
79 $ TAU( NMAX ), VL( NMAX, NMAX ),
80 $ VR( NMAX, NMAX ), W( LW ), WI( NMAX ),
81 $ WR( NMAX )
82
83
84 LOGICAL LSAMEN
86
87
90
91
92 INTRINSIC dble
93
94
95 LOGICAL LERR, OK
96 CHARACTER*32 SRNAMT
97 INTEGER INFOT, NOUT
98
99
100 COMMON / infoc / infot, nout, ok, lerr
101 COMMON / srnamc / srnamt
102
103
104
105 nout = nunit
106 WRITE( nout, fmt = * )
107 c2 = path( 2: 3 )
108
109
110
111 DO 20 j = 1, nmax
112 DO 10 i = 1, nmax
113 a( i, j ) = 1.d0 / dble( i+j )
114 10 CONTINUE
115 wi( j ) = dble( j )
116 sel( j ) = .true.
117 20 CONTINUE
118 ok = .true.
119 nt = 0
120
121
122
123 IF(
lsamen( 2, c2,
'HS' ) )
THEN
124
125
126
127 srnamt = 'DGEBAL'
128 infot = 1
129 CALL dgebal(
'/', 0, a, 1, ilo, ihi, s, info )
130 CALL chkxer(
'DGEBAL', infot, nout, lerr, ok )
131 infot = 2
132 CALL dgebal(
'N', -1, a, 1, ilo, ihi, s, info )
133 CALL chkxer(
'DGEBAL', infot, nout, lerr, ok )
134 infot = 4
135 CALL dgebal(
'N', 2, a, 1, ilo, ihi, s, info )
136 CALL chkxer(
'DGEBAL', infot, nout, lerr, ok )
137 nt = nt + 3
138
139
140
141 srnamt = 'DGEBAK'
142 infot = 1
143 CALL dgebak(
'/',
'R', 0, 1, 0, s, 0, a, 1, info )
144 CALL chkxer(
'DGEBAK', infot, nout, lerr, ok )
145 infot = 2
146 CALL dgebak(
'N',
'/', 0, 1, 0, s, 0, a, 1, info )
147 CALL chkxer(
'DGEBAK', infot, nout, lerr, ok )
148 infot = 3
149 CALL dgebak(
'N',
'R', -1, 1, 0, s, 0, a, 1, info )
150 CALL chkxer(
'DGEBAK', infot, nout, lerr, ok )
151 infot = 4
152 CALL dgebak(
'N',
'R', 0, 0, 0, s, 0, a, 1, info )
153 CALL chkxer(
'DGEBAK', infot, nout, lerr, ok )
154 infot = 4
155 CALL dgebak(
'N',
'R', 0, 2, 0, s, 0, a, 1, info )
156 CALL chkxer(
'DGEBAK', infot, nout, lerr, ok )
157 infot = 5
158 CALL dgebak(
'N',
'R', 2, 2, 1, s, 0, a, 2, info )
159 CALL chkxer(
'DGEBAK', infot, nout, lerr, ok )
160 infot = 5
161 CALL dgebak(
'N',
'R', 0, 1, 1, s, 0, a, 1, info )
162 CALL chkxer(
'DGEBAK', infot, nout, lerr, ok )
163 infot = 7
164 CALL dgebak(
'N',
'R', 0, 1, 0, s, -1, a, 1, info )
165 CALL chkxer(
'DGEBAK', infot, nout, lerr, ok )
166 infot = 9
167 CALL dgebak(
'N',
'R', 2, 1, 2, s, 0, a, 1, info )
168 CALL chkxer(
'DGEBAK', infot, nout, lerr, ok )
169 nt = nt + 9
170
171
172
173 srnamt = 'DGEHRD'
174 infot = 1
175 CALL dgehrd( -1, 1, 1, a, 1, tau, w, 1, info )
176 CALL chkxer(
'DGEHRD', infot, nout, lerr, ok )
177 infot = 2
178 CALL dgehrd( 0, 0, 0, a, 1, tau, w, 1, info )
179 CALL chkxer(
'DGEHRD', infot, nout, lerr, ok )
180 infot = 2
181 CALL dgehrd( 0, 2, 0, a, 1, tau, w, 1, info )
182 CALL chkxer(
'DGEHRD', infot, nout, lerr, ok )
183 infot = 3
184 CALL dgehrd( 1, 1, 0, a, 1, tau, w, 1, info )
185 CALL chkxer(
'DGEHRD', infot, nout, lerr, ok )
186 infot = 3
187 CALL dgehrd( 0, 1, 1, a, 1, tau, w, 1, info )
188 CALL chkxer(
'DGEHRD', infot, nout, lerr, ok )
189 infot = 5
190 CALL dgehrd( 2, 1, 1, a, 1, tau, w, 2, info )
191 CALL chkxer(
'DGEHRD', infot, nout, lerr, ok )
192 infot = 8
193 CALL dgehrd( 2, 1, 2, a, 2, tau, w, 1, info )
194 CALL chkxer(
'DGEHRD', infot, nout, lerr, ok )
195 nt = nt + 7
196
197
198
199 srnamt = 'DORGHR'
200 infot = 1
201 CALL dorghr( -1, 1, 1, a, 1, tau, w, 1, info )
202 CALL chkxer(
'DORGHR', infot, nout, lerr, ok )
203 infot = 2
204 CALL dorghr( 0, 0, 0, a, 1, tau, w, 1, info )
205 CALL chkxer(
'DORGHR', infot, nout, lerr, ok )
206 infot = 2
207 CALL dorghr( 0, 2, 0, a, 1, tau, w, 1, info )
208 CALL chkxer(
'DORGHR', infot, nout, lerr, ok )
209 infot = 3
210 CALL dorghr( 1, 1, 0, a, 1, tau, w, 1, info )
211 CALL chkxer(
'DORGHR', infot, nout, lerr, ok )
212 infot = 3
213 CALL dorghr( 0, 1, 1, a, 1, tau, w, 1, info )
214 CALL chkxer(
'DORGHR', infot, nout, lerr, ok )
215 infot = 5
216 CALL dorghr( 2, 1, 1, a, 1, tau, w, 1, info )
217 CALL chkxer(
'DORGHR', infot, nout, lerr, ok )
218 infot = 8
219 CALL dorghr( 3, 1, 3, a, 3, tau, w, 1, info )
220 CALL chkxer(
'DORGHR', infot, nout, lerr, ok )
221 nt = nt + 7
222
223
224
225 srnamt = 'DORMHR'
226 infot = 1
227 CALL dormhr(
'/',
'N', 0, 0, 1, 0, a, 1, tau, c, 1, w, 1,
228 $ info )
229 CALL chkxer(
'DORMHR', infot, nout, lerr, ok )
230 infot = 2
231 CALL dormhr(
'L',
'/', 0, 0, 1, 0, a, 1, tau, c, 1, w, 1,
232 $ info )
233 CALL chkxer(
'DORMHR', infot, nout, lerr, ok )
234 infot = 3
235 CALL dormhr(
'L',
'N', -1, 0, 1, 0, a, 1, tau, c, 1, w, 1,
236 $ info )
237 CALL chkxer(
'DORMHR', infot, nout, lerr, ok )
238 infot = 4
239 CALL dormhr(
'L',
'N', 0, -1, 1, 0, a, 1, tau, c, 1, w, 1,
240 $ info )
241 CALL chkxer(
'DORMHR', infot, nout, lerr, ok )
242 infot = 5
243 CALL dormhr(
'L',
'N', 0, 0, 0, 0, a, 1, tau, c, 1, w, 1,
244 $ info )
245 CALL chkxer(
'DORMHR', infot, nout, lerr, ok )
246 infot = 5
247 CALL dormhr(
'L',
'N', 0, 0, 2, 0, a, 1, tau, c, 1, w, 1,
248 $ info )
249 CALL chkxer(
'DORMHR', infot, nout, lerr, ok )
250 infot = 5
251 CALL dormhr(
'L',
'N', 1, 2, 2, 1, a, 1, tau, c, 1, w, 2,
252 $ info )
253 CALL chkxer(
'DORMHR', infot, nout, lerr, ok )
254 infot = 5
255 CALL dormhr(
'R',
'N', 2, 1, 2, 1, a, 1, tau, c, 2, w, 2,
256 $ info )
257 CALL chkxer(
'DORMHR', infot, nout, lerr, ok )
258 infot = 6
259 CALL dormhr(
'L',
'N', 1, 1, 1, 0, a, 1, tau, c, 1, w, 1,
260 $ info )
261 CALL chkxer(
'DORMHR', infot, nout, lerr, ok )
262 infot = 6
263 CALL dormhr(
'L',
'N', 0, 1, 1, 1, a, 1, tau, c, 1, w, 1,
264 $ info )
265 CALL chkxer(
'DORMHR', infot, nout, lerr, ok )
266 infot = 6
267 CALL dormhr(
'R',
'N', 1, 0, 1, 1, a, 1, tau, c, 1, w, 1,
268 $ info )
269 CALL chkxer(
'DORMHR', infot, nout, lerr, ok )
270 infot = 8
271 CALL dormhr(
'L',
'N', 2, 1, 1, 1, a, 1, tau, c, 2, w, 1,
272 $ info )
273 CALL chkxer(
'DORMHR', infot, nout, lerr, ok )
274 infot = 8
275 CALL dormhr(
'R',
'N', 1, 2, 1, 1, a, 1, tau, c, 1, w, 1,
276 $ info )
277 CALL chkxer(
'DORMHR', infot, nout, lerr, ok )
278 infot = 11
279 CALL dormhr(
'L',
'N', 2, 1, 1, 1, a, 2, tau, c, 1, w, 1,
280 $ info )
281 CALL chkxer(
'DORMHR', infot, nout, lerr, ok )
282 infot = 13
283 CALL dormhr(
'L',
'N', 1, 2, 1, 1, a, 1, tau, c, 1, w, 1,
284 $ info )
285 CALL chkxer(
'DORMHR', infot, nout, lerr, ok )
286 infot = 13
287 CALL dormhr(
'R',
'N', 2, 1, 1, 1, a, 1, tau, c, 2, w, 1,
288 $ info )
289 CALL chkxer(
'DORMHR', infot, nout, lerr, ok )
290 nt = nt + 16
291
292
293
294 srnamt = 'DHSEQR'
295 infot = 1
296 CALL dhseqr(
'/',
'N', 0, 1, 0, a, 1, wr, wi, c, 1, w, 1,
297 $ info )
298 CALL chkxer(
'DHSEQR', infot, nout, lerr, ok )
299 infot = 2
300 CALL dhseqr(
'E',
'/', 0, 1, 0, a, 1, wr, wi, c, 1, w, 1,
301 $ info )
302 CALL chkxer(
'DHSEQR', infot, nout, lerr, ok )
303 infot = 3
304 CALL dhseqr(
'E',
'N', -1, 1, 0, a, 1, wr, wi, c, 1, w, 1,
305 $ info )
306 CALL chkxer(
'DHSEQR', infot, nout, lerr, ok )
307 infot = 4
308 CALL dhseqr(
'E',
'N', 0, 0, 0, a, 1, wr, wi, c, 1, w, 1,
309 $ info )
310 CALL chkxer(
'DHSEQR', infot, nout, lerr, ok )
311 infot = 4
312 CALL dhseqr(
'E',
'N', 0, 2, 0, a, 1, wr, wi, c, 1, w, 1,
313 $ info )
314 CALL chkxer(
'DHSEQR', infot, nout, lerr, ok )
315 infot = 5
316 CALL dhseqr(
'E',
'N', 1, 1, 0, a, 1, wr, wi, c, 1, w, 1,
317 $ info )
318 CALL chkxer(
'DHSEQR', infot, nout, lerr, ok )
319 infot = 5
320 CALL dhseqr(
'E',
'N', 1, 1, 2, a, 1, wr, wi, c, 1, w, 1,
321 $ info )
322 CALL chkxer(
'DHSEQR', infot, nout, lerr, ok )
323 infot = 7
324 CALL dhseqr(
'E',
'N', 2, 1, 2, a, 1, wr, wi, c, 2, w, 1,
325 $ info )
326 CALL chkxer(
'DHSEQR', infot, nout, lerr, ok )
327 infot = 11
328 CALL dhseqr(
'E',
'V', 2, 1, 2, a, 2, wr, wi, c, 1, w, 1,
329 $ info )
330 CALL chkxer(
'DHSEQR', infot, nout, lerr, ok )
331 infot = 13
332 CALL dhseqr(
'E',
'N', 2, 1, 2, a, 2, wr, wi, c, 1, w, 1,
333 $ info )
334 CALL chkxer(
'DHSEQR', infot, nout, lerr, ok )
335 nt = nt + 10
336
337
338
339 srnamt = 'DHSEIN'
340 infot = 1
341 CALL dhsein(
'/',
'N',
'N', sel, 0, a, 1, wr, wi, vl, 1, vr, 1,
342 $ 0, m, w, ifaill, ifailr, info )
343 CALL chkxer(
'DHSEIN', infot, nout, lerr, ok )
344 infot = 2
345 CALL dhsein(
'R',
'/',
'N', sel, 0, a, 1, wr, wi, vl, 1, vr, 1,
346 $ 0, m, w, ifaill, ifailr, info )
347 CALL chkxer(
'DHSEIN', infot, nout, lerr, ok )
348 infot = 3
349 CALL dhsein(
'R',
'N',
'/', sel, 0, a, 1, wr, wi, vl, 1, vr, 1,
350 $ 0, m, w, ifaill, ifailr, info )
351 CALL chkxer(
'DHSEIN', infot, nout, lerr, ok )
352 infot = 5
353 CALL dhsein(
'R',
'N',
'N', sel, -1, a, 1, wr, wi, vl, 1, vr,
354 $ 1, 0, m, w, ifaill, ifailr, info )
355 CALL chkxer(
'DHSEIN', infot, nout, lerr, ok )
356 infot = 7
357 CALL dhsein(
'R',
'N',
'N', sel, 2, a, 1, wr, wi, vl, 1, vr, 2,
358 $ 4, m, w, ifaill, ifailr, info )
359 CALL chkxer(
'DHSEIN', infot, nout, lerr, ok )
360 infot = 11
361 CALL dhsein(
'L',
'N',
'N', sel, 2, a, 2, wr, wi, vl, 1, vr, 1,
362 $ 4, m, w, ifaill, ifailr, info )
363 CALL chkxer(
'DHSEIN', infot, nout, lerr, ok )
364 infot = 13
365 CALL dhsein(
'R',
'N',
'N', sel, 2, a, 2, wr, wi, vl, 1, vr, 1,
366 $ 4, m, w, ifaill, ifailr, info )
367 CALL chkxer(
'DHSEIN', infot, nout, lerr, ok )
368 infot = 14
369 CALL dhsein(
'R',
'N',
'N', sel, 2, a, 2, wr, wi, vl, 1, vr, 2,
370 $ 1, m, w, ifaill, ifailr, info )
371 CALL chkxer(
'DHSEIN', infot, nout, lerr, ok )
372 nt = nt + 8
373
374
375
376 srnamt = 'DTREVC'
377 infot = 1
378 CALL dtrevc(
'/',
'A', sel, 0, a, 1, vl, 1, vr, 1, 0, m, w,
379 $ info )
380 CALL chkxer(
'DTREVC', infot, nout, lerr, ok )
381 infot = 2
382 CALL dtrevc(
'L',
'/', sel, 0, a, 1, vl, 1, vr, 1, 0, m, w,
383 $ info )
384 CALL chkxer(
'DTREVC', infot, nout, lerr, ok )
385 infot = 4
386 CALL dtrevc(
'L',
'A', sel, -1, a, 1, vl, 1, vr, 1, 0, m, w,
387 $ info )
388 CALL chkxer(
'DTREVC', infot, nout, lerr, ok )
389 infot = 6
390 CALL dtrevc(
'L',
'A', sel, 2, a, 1, vl, 2, vr, 1, 4, m, w,
391 $ info )
392 CALL chkxer(
'DTREVC', infot, nout, lerr, ok )
393 infot = 8
394 CALL dtrevc(
'L',
'A', sel, 2, a, 2, vl, 1, vr, 1, 4, m, w,
395 $ info )
396 CALL chkxer(
'DTREVC', infot, nout, lerr, ok )
397 infot = 10
398 CALL dtrevc(
'R',
'A', sel, 2, a, 2, vl, 1, vr, 1, 4, m, w,
399 $ info )
400 CALL chkxer(
'DTREVC', infot, nout, lerr, ok )
401 infot = 11
402 CALL dtrevc(
'L',
'A', sel, 2, a, 2, vl, 2, vr, 1, 1, m, w,
403 $ info )
404 CALL chkxer(
'DTREVC', infot, nout, lerr, ok )
405 nt = nt + 7
406
407
408
409 srnamt = 'DTREVC3'
410 infot = 1
411 CALL dtrevc3(
'/',
'A', sel, 0, a, 1, vl, 1, vr, 1, 0, m, w,
412 $ lw, info )
413 CALL chkxer(
'DTREVC3', infot, nout, lerr, ok )
414 infot = 2
415 CALL dtrevc3(
'L',
'/', sel, 0, a, 1, vl, 1, vr, 1, 0, m, w,
416 $ lw, info )
417 CALL chkxer(
'DTREVC3', infot, nout, lerr, ok )
418 infot = 4
419 CALL dtrevc3(
'L',
'A', sel, -1, a, 1, vl, 1, vr, 1, 0, m, w,
420 $ lw, info )
421 CALL chkxer(
'DTREVC3', infot, nout, lerr, ok )
422 infot = 6
423 CALL dtrevc3(
'L',
'A', sel, 2, a, 1, vl, 2, vr, 1, 4, m, w,
424 $ lw, info )
425 CALL chkxer(
'DTREVC3', infot, nout, lerr, ok )
426 infot = 8
427 CALL dtrevc3(
'L',
'A', sel, 2, a, 2, vl, 1, vr, 1, 4, m, w,
428 $ lw, info )
429 CALL chkxer(
'DTREVC3', infot, nout, lerr, ok )
430 infot = 10
431 CALL dtrevc3(
'R',
'A', sel, 2, a, 2, vl, 1, vr, 1, 4, m, w,
432 $ lw, info )
433 CALL chkxer(
'DTREVC3', infot, nout, lerr, ok )
434 infot = 11
435 CALL dtrevc3(
'L',
'A', sel, 2, a, 2, vl, 2, vr, 1, 1, m, w,
436 $ lw, info )
437 CALL chkxer(
'DTREVC3', infot, nout, lerr, ok )
438 infot = 14
439 CALL dtrevc3(
'L',
'A', sel, 2, a, 2, vl, 2, vr, 1, 2, m, w,
440 $ 2, info )
441 CALL chkxer(
'DTREVC3', infot, nout, lerr, ok )
442 nt = nt + 8
443 END IF
444
445
446
447 IF( ok ) THEN
448 WRITE( nout, fmt = 9999 )path, nt
449 ELSE
450 WRITE( nout, fmt = 9998 )path
451 END IF
452
453 9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits',
454 $ ' (', i3, ' tests done)' )
455 9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ',
456 $ 'exits ***' )
457
458 RETURN
459
460
461
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
logical function lsamen(N, CA, CB)
LSAMEN
subroutine dgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DGEHRD
subroutine dgebal(JOB, N, A, LDA, ILO, IHI, SCALE, INFO)
DGEBAL
subroutine dgebak(JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO)
DGEBAK
subroutine dhsein(SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, IFAILR, INFO)
DHSEIN
subroutine dtrevc(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO)
DTREVC
subroutine dhseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO)
DHSEQR
subroutine dormhr(SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
DORMHR
subroutine dorghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DORGHR
subroutine dtrevc3(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, LWORK, INFO)
DTREVC3