| fe4da5cc |
1 | * |
| 2 | * $Id$ |
| 3 | * |
| 4 | * $Log$ |
| 5 | * Revision 1.1.1.1 1996/04/01 15:02:38 mclareni |
| 6 | * Mathlib gen |
| 7 | * |
| 8 | * |
| 9 | #include "gen/pilot.h" |
| 10 | SUBROUTINE TRED1(NM,N,A,D,E,E2) |
| 11 | INTEGER I,J,K,L,N,II,NM,JP1 |
| 12 | REAL A(NM,N),D(N),E(N),E2(N) |
| 13 | REAL F,G,H,SCALE |
| 14 | DO 100 I = 1, N |
| 15 | 100 D(I) = A(I,I) |
| 16 | DO 300 II = 1, N |
| 17 | I = N + 1 - II |
| 18 | L = I - 1 |
| 19 | H = 0.0 |
| 20 | SCALE = 0.0 |
| 21 | IF (L .LT. 1) GO TO 130 |
| 22 | DO 120 K = 1, L |
| 23 | 120 SCALE = SCALE + ABS(A(I,K)) |
| 24 | IF (SCALE .NE. 0.0) GO TO 140 |
| 25 | 130 E(I) = 0.0 |
| 26 | E2(I) = 0.0 |
| 27 | GO TO 290 |
| 28 | 140 DO 150 K = 1, L |
| 29 | A(I,K) = A(I,K) / SCALE |
| 30 | H = H + A(I,K) * A(I,K) |
| 31 | 150 CONTINUE |
| 32 | E2(I) = SCALE * SCALE * H |
| 33 | F = A(I,L) |
| 34 | G = -SIGN(SQRT(H),F) |
| 35 | E(I) = SCALE * G |
| 36 | H = H - F * G |
| 37 | A(I,L) = F - G |
| 38 | IF (L .EQ. 1) GO TO 270 |
| 39 | F = 0.0 |
| 40 | DO 240 J = 1, L |
| 41 | G = 0.0 |
| 42 | DO 180 K = 1, J |
| 43 | 180 G = G + A(J,K) * A(I,K) |
| 44 | JP1 = J + 1 |
| 45 | IF (L .LT. JP1) GO TO 220 |
| 46 | DO 200 K = JP1, L |
| 47 | 200 G = G + A(K,J) * A(I,K) |
| 48 | 220 E(J) = G / H |
| 49 | F = F + E(J) * A(I,J) |
| 50 | 240 CONTINUE |
| 51 | H = F / (H + H) |
| 52 | DO 260 J = 1, L |
| 53 | F = A(I,J) |
| 54 | G = E(J) - H * F |
| 55 | E(J) = G |
| 56 | DO 260 K = 1, J |
| 57 | A(J,K) = A(J,K) - F * E(K) - G * A(I,K) |
| 58 | 260 CONTINUE |
| 59 | 270 DO 280 K = 1, L |
| 60 | 280 A(I,K) = SCALE * A(I,K) |
| 61 | 290 H = D(I) |
| 62 | D(I) = A(I,I) |
| 63 | A(I,I) = H |
| 64 | 300 CONTINUE |
| 65 | RETURN |
| 66 | END |
git://git.uio.no / u / mrichter / AliRoot.git / blame