]>
Commit | Line | Data |
---|---|---|
fe4da5cc | 1 | * |
2 | * $Id$ | |
3 | * | |
4 | * $Log$ | |
5 | * Revision 1.1.1.1 1996/04/01 15:02:36 mclareni | |
6 | * Mathlib gen | |
7 | * | |
8 | * | |
9 | #include "gen/pilot.h" | |
10 | SUBROUTINE IMTQL1(N,D,E,IERR) | |
11 | INTEGER I,J,L,M,N,II,MML,IERR | |
12 | REAL D(N),E(N) | |
13 | REAL B,C,F,G,P,R,S,MACHEP | |
14 | #if defined(CERNLIB_CDC) | |
15 | MACHEP=2.**(-47) | |
16 | #endif | |
17 | #if !defined(CERNLIB_CDC) | |
18 | MACHEP=2.**(-23) | |
19 | #endif | |
20 | IERR = 0 | |
21 | IF (N .EQ. 1) GO TO 1001 | |
22 | DO 100 I = 2, N | |
23 | 100 E(I-1) = E(I) | |
24 | E(N) = 0.0 | |
25 | DO 290 L = 1, N | |
26 | J = 0 | |
27 | 105 DO 110 M = L, N | |
28 | IF (M .EQ. N) GO TO 120 | |
29 | IF (ABS(E(M)) .LE. MACHEP * (ABS(D(M)) + ABS(D(M+1)))) | |
30 | X GO TO 120 | |
31 | 110 CONTINUE | |
32 | 120 P = D(L) | |
33 | IF (M .EQ. L) GO TO 215 | |
34 | IF (J .EQ. 30) GO TO 1000 | |
35 | J = J + 1 | |
36 | G = (D(L+1) - P) / (2.0 * E(L)) | |
37 | R = SQRT(G*G+1.0) | |
38 | G = D(M) - P + E(L) / (G + SIGN(R,G)) | |
39 | S = 1.0 | |
40 | C = 1.0 | |
41 | P = 0.0 | |
42 | MML = M - L | |
43 | DO 200 II = 1, MML | |
44 | I = M - II | |
45 | F = S * E(I) | |
46 | B = C * E(I) | |
47 | IF (ABS(F) .LT. ABS(G)) GO TO 150 | |
48 | C = G / F | |
49 | R = SQRT(C*C+1.0) | |
50 | E(I+1) = F * R | |
51 | S = 1.0 / R | |
52 | C = C * S | |
53 | GO TO 160 | |
54 | 150 S = F / G | |
55 | R = SQRT(S*S+1.0) | |
56 | E(I+1) = G * R | |
57 | C = 1.0 / R | |
58 | S = S * C | |
59 | 160 G = D(I+1) - P | |
60 | R = (D(I) - G) * S + 2.0 * C * B | |
61 | P = S * R | |
62 | D(I+1) = G + P | |
63 | G = C * R - B | |
64 | 200 CONTINUE | |
65 | D(L) = D(L) - P | |
66 | E(L) = G | |
67 | E(M) = 0.0 | |
68 | GO TO 105 | |
69 | 215 IF (L .EQ. 1) GO TO 250 | |
70 | DO 230 II = 2, L | |
71 | I = L + 2 - II | |
72 | IF (P .GE. D(I-1)) GO TO 270 | |
73 | D(I) = D(I-1) | |
74 | 230 CONTINUE | |
75 | 250 I = 1 | |
76 | 270 D(I) = P | |
77 | 290 CONTINUE | |
78 | GO TO 1001 | |
79 | 1000 IERR = L | |
80 | 1001 RETURN | |
81 | END |