]>
Commit | Line | Data |
---|---|---|
fe4da5cc | 1 | * |
2 | * $Id$ | |
3 | * | |
4 | * $Log$ | |
5 | * Revision 1.1.1.1 1996/04/01 15:02:37 mclareni | |
6 | * Mathlib gen | |
7 | * | |
8 | * | |
9 | #include "gen/pilot.h" | |
10 | SUBROUTINE ORTHES(NM,N,LOW,IGH,A,ORT) | |
11 | INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW | |
12 | REAL A(NM,N),ORT(IGH) | |
13 | REAL F,G,H,SCALE | |
14 | LA = IGH - 1 | |
15 | KP1 = LOW + 1 | |
16 | IF (LA .LT. KP1) GO TO 200 | |
17 | DO 180 M = KP1, LA | |
18 | H = 0.0 | |
19 | ORT(M) = 0.0 | |
20 | SCALE = 0.0 | |
21 | DO 90 I = M, IGH | |
22 | 90 SCALE = SCALE + ABS(A(I,M-1)) | |
23 | IF (SCALE .EQ. 0.0) GO TO 180 | |
24 | MP = M + IGH | |
25 | DO 100 II = M, IGH | |
26 | I = MP - II | |
27 | ORT(I) = A(I,M-1) / SCALE | |
28 | H = H + ORT(I) * ORT(I) | |
29 | 100 CONTINUE | |
30 | G = -SIGN(SQRT(H),ORT(M)) | |
31 | H = H - ORT(M) * G | |
32 | ORT(M) = ORT(M) - G | |
33 | DO 130 J = M, N | |
34 | F = 0.0 | |
35 | DO 110 II = M, IGH | |
36 | I = MP - II | |
37 | F = F + ORT(I) * A(I,J) | |
38 | 110 CONTINUE | |
39 | F = F / H | |
40 | DO 120 I = M, IGH | |
41 | 120 A(I,J) = A(I,J) - F * ORT(I) | |
42 | 130 CONTINUE | |
43 | DO 160 I = 1, IGH | |
44 | F = 0.0 | |
45 | DO 140 JJ = M, IGH | |
46 | J = MP - JJ | |
47 | F = F + ORT(J) * A(I,J) | |
48 | 140 CONTINUE | |
49 | F = F / H | |
50 | DO 150 J = M, IGH | |
51 | 150 A(I,J) = A(I,J) - F * ORT(J) | |
52 | 160 CONTINUE | |
53 | ORT(M) = SCALE * ORT(M) | |
54 | A(M,M-1) = SCALE * G | |
55 | 180 CONTINUE | |
56 | 200 RETURN | |
57 | END |