55
56
57
58
59
60
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63
64
65
66
67
68 INTEGER NMAX
69 parameter( nmax = 4 )
70
71
72 CHARACTER*2 C2
73 INTEGER I, INFO, J
74 REAL ANRM, CCOND, RCOND
75
76
77 INTEGER IP( NMAX )
78 REAL R( NMAX ), R1( NMAX ), R2( NMAX )
79 COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
80 $ W( 2*NMAX ), X( NMAX )
81
82
83 LOGICAL LSAMEN
85
86
90
91
92 LOGICAL LERR, OK
93 CHARACTER*32 SRNAMT
94 INTEGER INFOT, NOUT
95
96
97 COMMON / infoc / infot, nout, ok, lerr
98 COMMON / srnamc / srnamt
99
100
101 INTRINSIC cmplx, real
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 ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
114 af( i, j ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
115 10 CONTINUE
116 b( j ) = 0.
117 r1( j ) = 0.
118 r2( j ) = 0.
119 w( j ) = 0.
120 x( j ) = 0.
121 ip( j ) = j
122 20 CONTINUE
123 ok = .true.
124
125
126
127
128 IF(
lsamen( 2, c2,
'GE' ) )
THEN
129
130
131
132 srnamt = 'CGETRF'
133 infot = 1
134 CALL cgetrf( -1, 0, a, 1, ip, info )
135 CALL chkxer(
'CGETRF', infot, nout, lerr, ok )
136 infot = 2
137 CALL cgetrf( 0, -1, a, 1, ip, info )
138 CALL chkxer(
'CGETRF', infot, nout, lerr, ok )
139 infot = 4
140 CALL cgetrf( 2, 1, a, 1, ip, info )
141 CALL chkxer(
'CGETRF', infot, nout, lerr, ok )
142
143
144
145 srnamt = 'CGETF2'
146 infot = 1
147 CALL cgetf2( -1, 0, a, 1, ip, info )
148 CALL chkxer(
'CGETF2', infot, nout, lerr, ok )
149 infot = 2
150 CALL cgetf2( 0, -1, a, 1, ip, info )
151 CALL chkxer(
'CGETF2', infot, nout, lerr, ok )
152 infot = 4
153 CALL cgetf2( 2, 1, a, 1, ip, info )
154 CALL chkxer(
'CGETF2', infot, nout, lerr, ok )
155
156
157
158 srnamt = 'CGETRI'
159 infot = 1
160 CALL cgetri( -1, a, 1, ip, w, 1, info )
161 CALL chkxer(
'CGETRI', infot, nout, lerr, ok )
162 infot = 3
163 CALL cgetri( 2, a, 1, ip, w, 2, info )
164 CALL chkxer(
'CGETRI', infot, nout, lerr, ok )
165 infot = 6
166 CALL cgetri( 2, a, 2, ip, w, 1, info )
167 CALL chkxer(
'CGETRI', infot, nout, lerr, ok )
168
169
170
171 srnamt = 'CGETRS'
172 infot = 1
173 CALL cgetrs(
'/', 0, 0, a, 1, ip, b, 1, info )
174 CALL chkxer(
'CGETRS', infot, nout, lerr, ok )
175 infot = 2
176 CALL cgetrs(
'N', -1, 0, a, 1, ip, b, 1, info )
177 CALL chkxer(
'CGETRS', infot, nout, lerr, ok )
178 infot = 3
179 CALL cgetrs(
'N', 0, -1, a, 1, ip, b, 1, info )
180 CALL chkxer(
'CGETRS', infot, nout, lerr, ok )
181 infot = 5
182 CALL cgetrs(
'N', 2, 1, a, 1, ip, b, 2, info )
183 CALL chkxer(
'CGETRS', infot, nout, lerr, ok )
184 infot = 8
185 CALL cgetrs(
'N', 2, 1, a, 2, ip, b, 1, info )
186 CALL chkxer(
'CGETRS', infot, nout, lerr, ok )
187
188
189
190 srnamt = 'CGERFS'
191 infot = 1
192 CALL cgerfs(
'/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
193 $ r, info )
194 CALL chkxer(
'CGERFS', infot, nout, lerr, ok )
195 infot = 2
196 CALL cgerfs(
'N', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
197 $ w, r, info )
198 CALL chkxer(
'CGERFS', infot, nout, lerr, ok )
199 infot = 3
200 CALL cgerfs(
'N', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
201 $ w, r, info )
202 CALL chkxer(
'CGERFS', infot, nout, lerr, ok )
203 infot = 5
204 CALL cgerfs(
'N', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
205 $ r, info )
206 CALL chkxer(
'CGERFS', infot, nout, lerr, ok )
207 infot = 7
208 CALL cgerfs(
'N', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
209 $ r, info )
210 CALL chkxer(
'CGERFS', infot, nout, lerr, ok )
211 infot = 10
212 CALL cgerfs(
'N', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
213 $ r, info )
214 CALL chkxer(
'CGERFS', infot, nout, lerr, ok )
215 infot = 12
216 CALL cgerfs(
'N', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
217 $ r, info )
218 CALL chkxer(
'CGERFS', infot, nout, lerr, ok )
219
220
221
222 srnamt = 'CGECON'
223 infot = 1
224 CALL cgecon(
'/', 0, a, 1, anrm, rcond, w, r, info )
225 CALL chkxer(
'CGECON', infot, nout, lerr, ok )
226 infot = 2
227 CALL cgecon(
'1', -1, a, 1, anrm, rcond, w, r, info )
228 CALL chkxer(
'CGECON', infot, nout, lerr, ok )
229 infot = 4
230 CALL cgecon(
'1', 2, a, 1, anrm, rcond, w, r, info )
231 CALL chkxer(
'CGECON', infot, nout, lerr, ok )
232
233
234
235 srnamt = 'CGEEQU'
236 infot = 1
237 CALL cgeequ( -1, 0, a, 1, r1, r2, rcond, ccond, anrm, info )
238 CALL chkxer(
'CGEEQU', infot, nout, lerr, ok )
239 infot = 2
240 CALL cgeequ( 0, -1, a, 1, r1, r2, rcond, ccond, anrm, info )
241 CALL chkxer(
'CGEEQU', infot, nout, lerr, ok )
242 infot = 4
243 CALL cgeequ( 2, 2, a, 1, r1, r2, rcond, ccond, anrm, info )
244 CALL chkxer(
'CGEEQU', infot, nout, lerr, ok )
245
246
247
248
249 ELSE IF(
lsamen( 2, c2,
'GB' ) )
THEN
250
251
252
253 srnamt = 'CGBTRF'
254 infot = 1
255 CALL cgbtrf( -1, 0, 0, 0, a, 1, ip, info )
256 CALL chkxer(
'CGBTRF', infot, nout, lerr, ok )
257 infot = 2
258 CALL cgbtrf( 0, -1, 0, 0, a, 1, ip, info )
259 CALL chkxer(
'CGBTRF', infot, nout, lerr, ok )
260 infot = 3
261 CALL cgbtrf( 1, 1, -1, 0, a, 1, ip, info )
262 CALL chkxer(
'CGBTRF', infot, nout, lerr, ok )
263 infot = 4
264 CALL cgbtrf( 1, 1, 0, -1, a, 1, ip, info )
265 CALL chkxer(
'CGBTRF', infot, nout, lerr, ok )
266 infot = 6
267 CALL cgbtrf( 2, 2, 1, 1, a, 3, ip, info )
268 CALL chkxer(
'CGBTRF', infot, nout, lerr, ok )
269
270
271
272 srnamt = 'CGBTF2'
273 infot = 1
274 CALL cgbtf2( -1, 0, 0, 0, a, 1, ip, info )
275 CALL chkxer(
'CGBTF2', infot, nout, lerr, ok )
276 infot = 2
277 CALL cgbtf2( 0, -1, 0, 0, a, 1, ip, info )
278 CALL chkxer(
'CGBTF2', infot, nout, lerr, ok )
279 infot = 3
280 CALL cgbtf2( 1, 1, -1, 0, a, 1, ip, info )
281 CALL chkxer(
'CGBTF2', infot, nout, lerr, ok )
282 infot = 4
283 CALL cgbtf2( 1, 1, 0, -1, a, 1, ip, info )
284 CALL chkxer(
'CGBTF2', infot, nout, lerr, ok )
285 infot = 6
286 CALL cgbtf2( 2, 2, 1, 1, a, 3, ip, info )
287 CALL chkxer(
'CGBTF2', infot, nout, lerr, ok )
288
289
290
291 srnamt = 'CGBTRS'
292 infot = 1
293 CALL cgbtrs(
'/', 0, 0, 0, 1, a, 1, ip, b, 1, info )
294 CALL chkxer(
'CGBTRS', infot, nout, lerr, ok )
295 infot = 2
296 CALL cgbtrs(
'N', -1, 0, 0, 1, a, 1, ip, b, 1, info )
297 CALL chkxer(
'CGBTRS', infot, nout, lerr, ok )
298 infot = 3
299 CALL cgbtrs(
'N', 1, -1, 0, 1, a, 1, ip, b, 1, info )
300 CALL chkxer(
'CGBTRS', infot, nout, lerr, ok )
301 infot = 4
302 CALL cgbtrs(
'N', 1, 0, -1, 1, a, 1, ip, b, 1, info )
303 CALL chkxer(
'CGBTRS', infot, nout, lerr, ok )
304 infot = 5
305 CALL cgbtrs(
'N', 1, 0, 0, -1, a, 1, ip, b, 1, info )
306 CALL chkxer(
'CGBTRS', infot, nout, lerr, ok )
307 infot = 7
308 CALL cgbtrs(
'N', 2, 1, 1, 1, a, 3, ip, b, 2, info )
309 CALL chkxer(
'CGBTRS', infot, nout, lerr, ok )
310 infot = 10
311 CALL cgbtrs(
'N', 2, 0, 0, 1, a, 1, ip, b, 1, info )
312 CALL chkxer(
'CGBTRS', infot, nout, lerr, ok )
313
314
315
316 srnamt = 'CGBRFS'
317 infot = 1
318 CALL cgbrfs(
'/', 0, 0, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
319 $ r2, w, r, info )
320 CALL chkxer(
'CGBRFS', infot, nout, lerr, ok )
321 infot = 2
322 CALL cgbrfs(
'N', -1, 0, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
323 $ r2, w, r, info )
324 CALL chkxer(
'CGBRFS', infot, nout, lerr, ok )
325 infot = 3
326 CALL cgbrfs(
'N', 1, -1, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
327 $ r2, w, r, info )
328 CALL chkxer(
'CGBRFS', infot, nout, lerr, ok )
329 infot = 4
330 CALL cgbrfs(
'N', 1, 0, -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
331 $ r2, w, r, info )
332 CALL chkxer(
'CGBRFS', infot, nout, lerr, ok )
333 infot = 5
334 CALL cgbrfs(
'N', 1, 0, 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1,
335 $ r2, w, r, info )
336 CALL chkxer(
'CGBRFS', infot, nout, lerr, ok )
337 infot = 7
338 CALL cgbrfs(
'N', 2, 1, 1, 1, a, 2, af, 4, ip, b, 2, x, 2, r1,
339 $ r2, w, r, info )
340 CALL chkxer(
'CGBRFS', infot, nout, lerr, ok )
341 infot = 9
342 CALL cgbrfs(
'N', 2, 1, 1, 1, a, 3, af, 3, ip, b, 2, x, 2, r1,
343 $ r2, w, r, info )
344 CALL chkxer(
'CGBRFS', infot, nout, lerr, ok )
345 infot = 12
346 CALL cgbrfs(
'N', 2, 0, 0, 1, a, 1, af, 1, ip, b, 1, x, 2, r1,
347 $ r2, w, r, info )
348 CALL chkxer(
'CGBRFS', infot, nout, lerr, ok )
349 infot = 14
350 CALL cgbrfs(
'N', 2, 0, 0, 1, a, 1, af, 1, ip, b, 2, x, 1, r1,
351 $ r2, w, r, info )
352 CALL chkxer(
'CGBRFS', infot, nout, lerr, ok )
353
354
355
356 srnamt = 'CGBCON'
357 infot = 1
358 CALL cgbcon(
'/', 0, 0, 0, a, 1, ip, anrm, rcond, w, r, info )
359 CALL chkxer(
'CGBCON', infot, nout, lerr, ok )
360 infot = 2
361 CALL cgbcon(
'1', -1, 0, 0, a, 1, ip, anrm, rcond, w, r, info )
362 CALL chkxer(
'CGBCON', infot, nout, lerr, ok )
363 infot = 3
364 CALL cgbcon(
'1', 1, -1, 0, a, 1, ip, anrm, rcond, w, r, info )
365 CALL chkxer(
'CGBCON', infot, nout, lerr, ok )
366 infot = 4
367 CALL cgbcon(
'1', 1, 0, -1, a, 1, ip, anrm, rcond, w, r, info )
368 CALL chkxer(
'CGBCON', infot, nout, lerr, ok )
369 infot = 6
370 CALL cgbcon(
'1', 2, 1, 1, a, 3, ip, anrm, rcond, w, r, info )
371 CALL chkxer(
'CGBCON', infot, nout, lerr, ok )
372
373
374
375 srnamt = 'CGBEQU'
376 infot = 1
377 CALL cgbequ( -1, 0, 0, 0, a, 1, r1, r2, rcond, ccond, anrm,
378 $ info )
379 CALL chkxer(
'CGBEQU', infot, nout, lerr, ok )
380 infot = 2
381 CALL cgbequ( 0, -1, 0, 0, a, 1, r1, r2, rcond, ccond, anrm,
382 $ info )
383 CALL chkxer(
'CGBEQU', infot, nout, lerr, ok )
384 infot = 3
385 CALL cgbequ( 1, 1, -1, 0, a, 1, r1, r2, rcond, ccond, anrm,
386 $ info )
387 CALL chkxer(
'CGBEQU', infot, nout, lerr, ok )
388 infot = 4
389 CALL cgbequ( 1, 1, 0, -1, a, 1, r1, r2, rcond, ccond, anrm,
390 $ info )
391 CALL chkxer(
'CGBEQU', infot, nout, lerr, ok )
392 infot = 6
393 CALL cgbequ( 2, 2, 1, 1, a, 2, r1, r2, rcond, ccond, anrm,
394 $ info )
395 CALL chkxer(
'CGBEQU', infot, nout, lerr, ok )
396 END IF
397
398
399
400 CALL alaesm( path, ok, nout )
401
402 RETURN
403
404
405
subroutine alaesm(path, ok, nout)
ALAESM
subroutine chkxer(srnamt, infot, nout, lerr, ok)
subroutine cgbcon(norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond, work, rwork, info)
CGBCON
subroutine cgbequ(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, info)
CGBEQU
subroutine cgbrfs(trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CGBRFS
subroutine cgbtf2(m, n, kl, ku, ab, ldab, ipiv, info)
CGBTF2 computes the LU factorization of a general band matrix using the unblocked version of the algo...
subroutine cgbtrf(m, n, kl, ku, ab, ldab, ipiv, info)
CGBTRF
subroutine cgbtrs(trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
CGBTRS
subroutine cgecon(norm, n, a, lda, anorm, rcond, work, rwork, info)
CGECON
subroutine cgeequ(m, n, a, lda, r, c, rowcnd, colcnd, amax, info)
CGEEQU
subroutine cgerfs(trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CGERFS
subroutine cgetf2(m, n, a, lda, ipiv, info)
CGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row inter...
subroutine cgetrf(m, n, a, lda, ipiv, info)
CGETRF
subroutine cgetri(n, a, lda, ipiv, work, lwork, info)
CGETRI
subroutine cgetrs(trans, n, nrhs, a, lda, ipiv, b, ldb, info)
CGETRS
logical function lsamen(n, ca, cb)
LSAMEN