121
122
123
124
125
126
127 CHARACTER DIST, TYPE
128 CHARACTER*3 PATH
129 INTEGER IMAT, KL, KU, M, MODE, N
130 DOUBLE PRECISION ANORM, CNDNUM
131
132
133
134
135
136 DOUBLE PRECISION SHRINK, TENTH
137 parameter( shrink = 0.25d0, tenth = 0.1d+0 )
138 DOUBLE PRECISION ONE
139 parameter( one = 1.0d+0 )
140 DOUBLE PRECISION TWO
141 parameter( two = 2.0d+0 )
142
143
144 LOGICAL FIRST
145 CHARACTER*2 C2
146 INTEGER MAT
147 DOUBLE PRECISION BADC1, BADC2, EPS, LARGE, SMALL
148
149
150 LOGICAL LSAMEN
151 DOUBLE PRECISION DLAMCH
153
154
155 INTRINSIC abs, max, sqrt
156
157
158 SAVE eps, small, large, badc1, badc2, first
159
160
161 DATA first / .true. /
162
163
164
165
166
167 IF( first ) THEN
168 first = .false.
169 eps =
dlamch(
'Precision' )
170 badc2 = tenth / eps
171 badc1 = sqrt( badc2 )
172 small =
dlamch(
'Safe minimum' )
173 large = one / small
174 small = shrink*( small / eps )
175 large = one / small
176 END IF
177
178 c2 = path( 2: 3 )
179
180
181
182 dist = 'S'
183 mode = 3
184
185
186
187
188 IF(
lsamen( 2, c2,
'QR' ) .OR.
lsamen( 2, c2,
'LQ' ) .OR.
189 $
lsamen( 2, c2,
'QL' ) .OR.
lsamen( 2, c2,
'RQ' ) )
THEN
190
191
192
193 TYPE = 'N'
194
195
196
197 IF( imat.EQ.1 ) THEN
198 kl = 0
199 ku = 0
200 ELSE IF( imat.EQ.2 ) THEN
201 kl = 0
202 ku = max( n-1, 0 )
203 ELSE IF( imat.EQ.3 ) THEN
204 kl = max( m-1, 0 )
205 ku = 0
206 ELSE
207 kl = max( m-1, 0 )
208 ku = max( n-1, 0 )
209 END IF
210
211
212
213 IF( imat.EQ.5 ) THEN
214 cndnum = badc1
215 ELSE IF( imat.EQ.6 ) THEN
216 cndnum = badc2
217 ELSE
218 cndnum = two
219 END IF
220
221 IF( imat.EQ.7 ) THEN
222 anorm = small
223 ELSE IF( imat.EQ.8 ) THEN
224 anorm = large
225 ELSE
226 anorm = one
227 END IF
228
229 ELSE IF(
lsamen( 2, c2,
'QK' ) )
THEN
230
231
232
233
234
235
236
237 TYPE = 'N'
238
239
240
241
242 dist = 'S'
243
244
245
246 IF( imat.EQ.2 ) THEN
247
248
249
250 kl = 0
251 ku = 0
252 cndnum = two
253 anorm = one
254 mode = 3
255 ELSE IF( imat.EQ.3 ) THEN
256
257
258
259 kl = 0
260 ku = max( n-1, 0 )
261 cndnum = two
262 anorm = one
263 mode = 3
264 ELSE IF( imat.EQ.4 ) THEN
265
266
267
268 kl = max( m-1, 0 )
269 ku = 0
270 cndnum = two
271 anorm = one
272 mode = 3
273 ELSE
274
275
276
277 kl = max( m-1, 0 )
278 ku = max( n-1, 0 )
279
280 IF( imat.GE.5 .AND. imat.LE.14 ) THEN
281
282
283
284 cndnum = two
285 anorm = one
286 mode = 3
287
288 ELSE IF( imat.EQ.15 ) THEN
289
290
291
292 cndnum = badc1
293 anorm = one
294 mode = 3
295
296 ELSE IF( imat.EQ.16 ) THEN
297
298
299
300 cndnum = badc2
301 anorm = one
302 mode = 3
303
304 ELSE IF( imat.EQ.17 ) THEN
305
306
307
308
309 cndnum = badc2
310 anorm = one
311 mode = 2
312
313 ELSE IF( imat.EQ.18 ) THEN
314
315
316
317 cndnum = two
318 anorm = small
319 mode = 3
320
321 ELSE IF( imat.EQ.19 ) THEN
322
323
324
325 cndnum = two
326 anorm = large
327 mode = 3
328
329 END IF
330
331 END IF
332
333 ELSE IF(
lsamen( 2, c2,
'GE' ) )
THEN
334
335
336
337
338
339 TYPE = 'N'
340
341
342
343 IF( imat.EQ.1 ) THEN
344 kl = 0
345 ku = 0
346 ELSE IF( imat.EQ.2 ) THEN
347 kl = 0
348 ku = max( n-1, 0 )
349 ELSE IF( imat.EQ.3 ) THEN
350 kl = max( m-1, 0 )
351 ku = 0
352 ELSE
353 kl = max( m-1, 0 )
354 ku = max( n-1, 0 )
355 END IF
356
357
358
359 IF( imat.EQ.8 ) THEN
360 cndnum = badc1
361 ELSE IF( imat.EQ.9 ) THEN
362 cndnum = badc2
363 ELSE
364 cndnum = two
365 END IF
366
367 IF( imat.EQ.10 ) THEN
368 anorm = small
369 ELSE IF( imat.EQ.11 ) THEN
370 anorm = large
371 ELSE
372 anorm = one
373 END IF
374
375 ELSE IF(
lsamen( 2, c2,
'GB' ) )
THEN
376
377
378
379
380
381 TYPE = 'N'
382
383
384
385 IF( imat.EQ.5 ) THEN
386 cndnum = badc1
387 ELSE IF( imat.EQ.6 ) THEN
388 cndnum = tenth*badc2
389 ELSE
390 cndnum = two
391 END IF
392
393 IF( imat.EQ.7 ) THEN
394 anorm = small
395 ELSE IF( imat.EQ.8 ) THEN
396 anorm = large
397 ELSE
398 anorm = one
399 END IF
400
401 ELSE IF(
lsamen( 2, c2,
'GT' ) )
THEN
402
403
404
405
406
407 TYPE = 'N'
408
409
410
411 IF( imat.EQ.1 ) THEN
412 kl = 0
413 ELSE
414 kl = 1
415 END IF
416 ku = kl
417
418
419
420 IF( imat.EQ.3 ) THEN
421 cndnum = badc1
422 ELSE IF( imat.EQ.4 ) THEN
423 cndnum = badc2
424 ELSE
425 cndnum = two
426 END IF
427
428 IF( imat.EQ.5 .OR. imat.EQ.11 ) THEN
429 anorm = small
430 ELSE IF( imat.EQ.6 .OR. imat.EQ.12 ) THEN
431 anorm = large
432 ELSE
433 anorm = one
434 END IF
435
436 ELSE IF(
lsamen( 2, c2,
'PO' ) .OR.
lsamen( 2, c2,
'PP' ) )
THEN
437
438
439
440
441
442
443 TYPE = c2( 1: 1 )
444
445
446
447 IF( imat.EQ.1 ) THEN
448 kl = 0
449 ELSE
450 kl = max( n-1, 0 )
451 END IF
452 ku = kl
453
454
455
456 IF( imat.EQ.6 ) THEN
457 cndnum = badc1
458 ELSE IF( imat.EQ.7 ) THEN
459 cndnum = badc2
460 ELSE
461 cndnum = two
462 END IF
463
464 IF( imat.EQ.8 ) THEN
465 anorm = small
466 ELSE IF( imat.EQ.9 ) THEN
467 anorm = large
468 ELSE
469 anorm = one
470 END IF
471
472 ELSE IF(
lsamen( 2, c2,
'HE' ) .OR.
lsamen( 2, c2,
'HP' ) .OR.
473 $
lsamen( 2, c2,
'SY' ) .OR.
lsamen( 2, c2,
'SP' ) )
THEN
474
475
476
477
478
479
480 TYPE = c2( 1: 1 )
481
482
483
484 IF( imat.EQ.1 ) THEN
485 kl = 0
486 ELSE
487 kl = max( n-1, 0 )
488 END IF
489 ku = kl
490
491
492
493 IF( imat.EQ.7 ) THEN
494 cndnum = badc1
495 ELSE IF( imat.EQ.8 ) THEN
496 cndnum = badc2
497 ELSE
498 cndnum = two
499 END IF
500
501 IF( imat.EQ.9 ) THEN
502 anorm = small
503 ELSE IF( imat.EQ.10 ) THEN
504 anorm = large
505 ELSE
506 anorm = one
507 END IF
508
509 ELSE IF(
lsamen( 2, c2,
'PB' ) )
THEN
510
511
512
513
514
515 TYPE = 'P'
516
517
518
519 IF( imat.EQ.5 ) THEN
520 cndnum = badc1
521 ELSE IF( imat.EQ.6 ) THEN
522 cndnum = badc2
523 ELSE
524 cndnum = two
525 END IF
526
527 IF( imat.EQ.7 ) THEN
528 anorm = small
529 ELSE IF( imat.EQ.8 ) THEN
530 anorm = large
531 ELSE
532 anorm = one
533 END IF
534
535 ELSE IF(
lsamen( 2, c2,
'PT' ) )
THEN
536
537
538
539
540 TYPE = 'P'
541 IF( imat.EQ.1 ) THEN
542 kl = 0
543 ELSE
544 kl = 1
545 END IF
546 ku = kl
547
548
549
550 IF( imat.EQ.3 ) THEN
551 cndnum = badc1
552 ELSE IF( imat.EQ.4 ) THEN
553 cndnum = badc2
554 ELSE
555 cndnum = two
556 END IF
557
558 IF( imat.EQ.5 .OR. imat.EQ.11 ) THEN
559 anorm = small
560 ELSE IF( imat.EQ.6 .OR. imat.EQ.12 ) THEN
561 anorm = large
562 ELSE
563 anorm = one
564 END IF
565
566 ELSE IF(
lsamen( 2, c2,
'TR' ) .OR.
lsamen( 2, c2,
'TP' ) )
THEN
567
568
569
570
571
572 TYPE = 'N'
573
574
575
576 mat = abs( imat )
577 IF( mat.EQ.1 .OR. mat.EQ.7 ) THEN
578 kl = 0
579 ku = 0
580 ELSE IF( imat.LT.0 ) THEN
581 kl = max( n-1, 0 )
582 ku = 0
583 ELSE
584 kl = 0
585 ku = max( n-1, 0 )
586 END IF
587
588
589
590 IF( mat.EQ.3 .OR. mat.EQ.9 ) THEN
591 cndnum = badc1
592 ELSE IF( mat.EQ.4 .OR. mat.EQ.10 ) THEN
593 cndnum = badc2
594 ELSE
595 cndnum = two
596 END IF
597
598 IF( mat.EQ.5 ) THEN
599 anorm = small
600 ELSE IF( mat.EQ.6 ) THEN
601 anorm = large
602 ELSE
603 anorm = one
604 END IF
605
606 ELSE IF(
lsamen( 2, c2,
'TB' ) )
THEN
607
608
609
610
611
612 TYPE = 'N'
613
614
615
616 mat = abs( imat )
617 IF( mat.EQ.2 .OR. mat.EQ.8 ) THEN
618 cndnum = badc1
619 ELSE IF( mat.EQ.3 .OR. mat.EQ.9 ) THEN
620 cndnum = badc2
621 ELSE
622 cndnum = two
623 END IF
624
625 IF( mat.EQ.4 ) THEN
626 anorm = small
627 ELSE IF( mat.EQ.5 ) THEN
628 anorm = large
629 ELSE
630 anorm = one
631 END IF
632 END IF
633 IF( n.LE.1 )
634 $ cndnum = one
635
636 RETURN
637
638
639
double precision function dlamch(cmach)
DLAMCH
logical function lsamen(n, ca, cb)
LSAMEN