]>
Commit | Line | Data |
---|---|---|
0795afa3 | 1 | * |
2 | * $Id$ | |
3 | * | |
4 | * $Log$ | |
5 | * Revision 1.9 2000/07/25 14:53:05 mclareni | |
6 | * Version 7.51 from author | |
7 | * | |
8 | * | |
9 | *#include "sys/CERNLIB_machine.h" | |
10 | #include "isajet/pilot.h" | |
11 | #if defined(CERNLIB_NOCERN) | |
12 | SUBROUTINE TQL2(NM,N,D,E,Z,IERR) | |
13 | C FROM CERN PROGRAM LIBRARY | |
14 | #if defined(CERNLIB_IMPNONE) | |
15 | IMPLICIT NONE | |
16 | #endif | |
17 | INTEGER I,J,K,L,M,N,II,NM,MML,IERR | |
18 | REAL D(N),E(N),Z(NM,N) | |
19 | REAL B,C,F,G,H,P,R,S,MACHEP | |
20 | MACHEP=2.**(-23) | |
21 | #if defined(CERNLIB_CDC) | |
22 | MACHEP=2.**(-47) | |
23 | #endif | |
24 | IERR = 0 | |
25 | IF (N .EQ. 1) GO TO 1001 | |
26 | DO 100 I = 2, N | |
27 | 100 E(I-1) = E(I) | |
28 | F = 0.0 | |
29 | B = 0.0 | |
30 | E(N) = 0.0 | |
31 | DO 240 L = 1, N | |
32 | J = 0 | |
33 | H = MACHEP * (ABS(D(L)) + ABS(E(L))) | |
34 | IF (B .LT. H) B = H | |
35 | DO 110 M = L, N | |
36 | IF (ABS(E(M)) .LE. B) GO TO 120 | |
37 | 110 CONTINUE | |
38 | 120 IF (M .EQ. L) GO TO 220 | |
39 | 130 IF (J .EQ. 30) GO TO 1000 | |
40 | J = J + 1 | |
41 | P = (D(L+1) - D(L)) / (2.0 * E(L)) | |
42 | R = SQRT(P*P+1.0) | |
43 | H = D(L) - E(L) / (P + SIGN(R,P)) | |
44 | DO 140 I = L, N | |
45 | 140 D(I) = D(I) - H | |
46 | F = F + H | |
47 | P = D(M) | |
48 | C = 1.0 | |
49 | S = 0.0 | |
50 | MML = M - L | |
51 | DO 200 II = 1, MML | |
52 | I = M - II | |
53 | G = C * E(I) | |
54 | H = C * P | |
55 | IF (ABS(P) .LT. ABS(E(I))) GO TO 150 | |
56 | C = E(I) / P | |
57 | R = SQRT(C*C+1.0) | |
58 | E(I+1) = S * P * R | |
59 | S = C / R | |
60 | C = 1.0 / R | |
61 | GO TO 160 | |
62 | 150 C = P / E(I) | |
63 | R = SQRT(C*C+1.0) | |
64 | E(I+1) = S * E(I) * R | |
65 | S = 1.0 / R | |
66 | C = C * S | |
67 | 160 P = C * D(I) - S * G | |
68 | D(I+1) = H + S * (C * G + S * D(I)) | |
69 | DO 180 K = 1, N | |
70 | H = Z(K,I+1) | |
71 | Z(K,I+1) = S * Z(K,I) + C * H | |
72 | Z(K,I) = C * Z(K,I) - S * H | |
73 | 180 CONTINUE | |
74 | 200 CONTINUE | |
75 | E(L) = S * P | |
76 | D(L) = C * P | |
77 | IF (ABS(E(L)) .GT. B) GO TO 130 | |
78 | 220 D(L) = D(L) + F | |
79 | 240 CONTINUE | |
80 | DO 300 II = 2, N | |
81 | I = II - 1 | |
82 | K = I | |
83 | P = D(I) | |
84 | DO 260 J = II, N | |
85 | IF (D(J) .GE. P) GO TO 260 | |
86 | K = J | |
87 | P = D(J) | |
88 | 260 CONTINUE | |
89 | IF (K .EQ. I) GO TO 300 | |
90 | D(K) = D(I) | |
91 | D(I) = P | |
92 | DO 280 J = 1, N | |
93 | P = Z(J,I) | |
94 | Z(J,I) = Z(J,K) | |
95 | Z(J,K) = P | |
96 | 280 CONTINUE | |
97 | 300 CONTINUE | |
98 | GO TO 1001 | |
99 | 1000 IERR = L | |
100 | 1001 RETURN | |
101 | END | |
102 | #endif |