]>
Commit | Line | Data |
---|---|---|
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 TRED2(NM,N,A,D,E,Z) | |
11 | INTEGER I,J,K,L,N,II,NM,JP1 | |
12 | REAL A(NM,N),D(N),E(N),Z(NM,N) | |
13 | REAL F,G,H,HH,SCALE | |
14 | DO 100 I = 1, N | |
15 | DO 100 J = 1, I | |
16 | Z(I,J) = A(I,J) | |
17 | 100 CONTINUE | |
18 | IF (N .EQ. 1) GO TO 320 | |
19 | DO 300 II = 2, N | |
20 | I = N + 2 - II | |
21 | L = I - 1 | |
22 | H = 0.0 | |
23 | SCALE = 0.0 | |
24 | IF (L .LT. 2) GO TO 130 | |
25 | DO 120 K = 1, L | |
26 | 120 SCALE = SCALE + ABS(Z(I,K)) | |
27 | IF (SCALE .NE. 0.0) GO TO 140 | |
28 | 130 E(I) = Z(I,L) | |
29 | GO TO 290 | |
30 | 140 DO 150 K = 1, L | |
31 | Z(I,K) = Z(I,K) / SCALE | |
32 | H = H + Z(I,K) * Z(I,K) | |
33 | 150 CONTINUE | |
34 | F = Z(I,L) | |
35 | G = -SIGN(SQRT(H),F) | |
36 | E(I) = SCALE * G | |
37 | H = H - F * G | |
38 | Z(I,L) = F - G | |
39 | F = 0.0 | |
40 | DO 240 J = 1, L | |
41 | Z(J,I) = Z(I,J) / (SCALE * H) | |
42 | G = 0.0 | |
43 | DO 180 K = 1, J | |
44 | 180 G = G + Z(J,K) * Z(I,K) | |
45 | JP1 = J + 1 | |
46 | IF (L .LT. JP1) GO TO 220 | |
47 | DO 200 K = JP1, L | |
48 | 200 G = G + Z(K,J) * Z(I,K) | |
49 | 220 E(J) = G / H | |
50 | F = F + E(J) * Z(I,J) | |
51 | 240 CONTINUE | |
52 | HH = F / (H + H) | |
53 | DO 260 J = 1, L | |
54 | F = Z(I,J) | |
55 | G = E(J) - HH * F | |
56 | E(J) = G | |
57 | DO 260 K = 1, J | |
58 | Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K) | |
59 | 260 CONTINUE | |
60 | DO 280 K = 1, L | |
61 | 280 Z(I,K) = SCALE * Z(I,K) | |
62 | 290 D(I) = H | |
63 | 300 CONTINUE | |
64 | 320 D(1) = 0.0 | |
65 | E(1) = 0.0 | |
66 | DO 500 I = 1, N | |
67 | L = I - 1 | |
68 | IF (D(I) .EQ. 0.0) GO TO 380 | |
69 | DO 360 J = 1, L | |
70 | G = 0.0 | |
71 | DO 340 K = 1, L | |
72 | 340 G = G + Z(I,K) * Z(K,J) | |
73 | DO 360 K = 1, L | |
74 | Z(K,J) = Z(K,J) - G * Z(K,I) | |
75 | 360 CONTINUE | |
76 | 380 D(I) = Z(I,I) | |
77 | Z(I,I) = 1.0 | |
78 | IF (L .LT. 1) GO TO 500 | |
79 | DO 400 J = 1, L | |
80 | Z(I,J) = 0.0 | |
81 | Z(J,I) = 0.0 | |
82 | 400 CONTINUE | |
83 | 500 CONTINUE | |
84 | RETURN | |
85 | END |