| fe4da5cc |
1 | * |
| 2 | * $Id$ |
| 3 | * |
| 4 | * $Log$ |
| 5 | * Revision 1.1.1.1 1996/04/01 15:02:33 mclareni |
| 6 | * Mathlib gen |
| 7 | * |
| 8 | * |
| 9 | #include "gen/pilot.h" |
| 10 | SUBROUTINE CBAL(NM,N,AR,AI,LOW,IGH,SCALE) |
| 11 | INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC |
| 12 | REAL AR(NM,N),AI(NM,N),SCALE(N) |
| 13 | REAL C,F,G,R,S,B2,RADIX |
| 14 | LOGICAL NOCONV |
| 15 | RADIX = 2. |
| 16 | B2 = RADIX * RADIX |
| 17 | K = 1 |
| 18 | L = N |
| 19 | GO TO 100 |
| 20 | 20 SCALE(M) = J |
| 21 | IF (J .EQ. M) GO TO 50 |
| 22 | DO 30 I = 1, L |
| 23 | F = AR(I,J) |
| 24 | AR(I,J) = AR(I,M) |
| 25 | AR(I,M) = F |
| 26 | F = AI(I,J) |
| 27 | AI(I,J) = AI(I,M) |
| 28 | AI(I,M) = F |
| 29 | 30 CONTINUE |
| 30 | DO 40 I = K, N |
| 31 | F = AR(J,I) |
| 32 | AR(J,I) = AR(M,I) |
| 33 | AR(M,I) = F |
| 34 | F = AI(J,I) |
| 35 | AI(J,I) = AI(M,I) |
| 36 | AI(M,I) = F |
| 37 | 40 CONTINUE |
| 38 | 50 GO TO (80,130), IEXC |
| 39 | 80 IF (L .EQ. 1) GO TO 280 |
| 40 | L = L - 1 |
| 41 | 100 DO 120 JJ = 1, L |
| 42 | J = L + 1 - JJ |
| 43 | DO 110 I = 1, L |
| 44 | IF (I .EQ. J) GO TO 110 |
| 45 | IF (AR(J,I) .NE. 0.0 .OR. AI(J,I) .NE. 0.0) GO TO 120 |
| 46 | 110 CONTINUE |
| 47 | M = L |
| 48 | IEXC = 1 |
| 49 | GO TO 20 |
| 50 | 120 CONTINUE |
| 51 | GO TO 140 |
| 52 | 130 K = K + 1 |
| 53 | 140 DO 170 J = K, L |
| 54 | DO 150 I = K, L |
| 55 | IF (I .EQ. J) GO TO 150 |
| 56 | IF (AR(I,J) .NE. 0.0 .OR. AI(I,J) .NE. 0.0) GO TO 170 |
| 57 | 150 CONTINUE |
| 58 | M = K |
| 59 | IEXC = 2 |
| 60 | GO TO 20 |
| 61 | 170 CONTINUE |
| 62 | DO 180 I = K, L |
| 63 | 180 SCALE(I) = 1.0 |
| 64 | 190 NOCONV = .FALSE. |
| 65 | DO 270 I = K, L |
| 66 | C = 0.0 |
| 67 | R = 0.0 |
| 68 | DO 200 J = K, L |
| 69 | IF (J .EQ. I) GO TO 200 |
| 70 | C = C + ABS(AR(J,I)) + ABS(AI(J,I)) |
| 71 | R = R + ABS(AR(I,J)) + ABS(AI(I,J)) |
| 72 | 200 CONTINUE |
| 73 | G = R / RADIX |
| 74 | F = 1.0 |
| 75 | S = C + R |
| 76 | 210 IF (C .GE. G) GO TO 220 |
| 77 | F = F * RADIX |
| 78 | C = C * B2 |
| 79 | GO TO 210 |
| 80 | 220 G = R * RADIX |
| 81 | 230 IF (C .LT. G) GO TO 240 |
| 82 | F = F / RADIX |
| 83 | C = C / B2 |
| 84 | GO TO 230 |
| 85 | 240 IF ((C + R) / F .GE. 0.95 * S) GO TO 270 |
| 86 | G = 1.0 / F |
| 87 | SCALE(I) = SCALE(I) * F |
| 88 | NOCONV = .TRUE. |
| 89 | DO 250 J = K, N |
| 90 | AR(I,J) = AR(I,J) * G |
| 91 | AI(I,J) = AI(I,J) * G |
| 92 | 250 CONTINUE |
| 93 | DO 260 J = 1, L |
| 94 | AR(J,I) = AR(J,I) * F |
| 95 | AI(J,I) = AI(J,I) * F |
| 96 | 260 CONTINUE |
| 97 | 270 CONTINUE |
| 98 | IF (NOCONV) GO TO 190 |
| 99 | 280 LOW = K |
| 100 | IGH = L |
| 101 | RETURN |
| 102 | END |
git://git.uio.no / u / mrichter / AliRoot.git / blame