]>
Commit | Line | Data |
---|---|---|
1 | * | |
2 | * $Id$ | |
3 | * | |
4 | #include "kerngen/pilot.h" | |
5 | SUBROUTINE SORTZV (A,INDEX,N1,MODE,NWAY,NSORT) | |
6 | C | |
7 | C CERN PROGLIB# M101 SORTZV .VERSION KERNFOR 3.15 820113 | |
8 | C ORIG. 02/10/75 | |
9 | C | |
10 | DIMENSION A(N1),INDEX(N1) | |
11 | C | |
12 | C | |
13 | N = N1 | |
14 | IF (N.LE.0) RETURN | |
15 | IF (NSORT.NE.0) GO TO 2 | |
16 | DO 1 I=1,N | |
17 | 1 INDEX(I)=I | |
18 | C | |
19 | 2 IF (N.EQ.1) RETURN | |
20 | IF (MODE) 10,20,30 | |
21 | 10 CALL SORTTI (A,INDEX,N) | |
22 | GO TO 40 | |
23 | C | |
24 | 20 CALL SORTTC(A,INDEX,N) | |
25 | GO TO 40 | |
26 | C | |
27 | 30 CALL SORTTF (A,INDEX,N) | |
28 | C | |
29 | 40 IF (NWAY.EQ.0) GO TO 50 | |
30 | N2 = N/2 | |
31 | DO 41 I=1,N2 | |
32 | ISWAP = INDEX(I) | |
33 | K = N+1-I | |
34 | INDEX(I) = INDEX(K) | |
35 | 41 INDEX(K) = ISWAP | |
36 | 50 RETURN | |
37 | END | |
38 | * ======================================== | |
39 | SUBROUTINE SORTTF (A,INDEX,N1) | |
40 | C | |
41 | DIMENSION A(N1),INDEX(N1) | |
42 | C | |
43 | N = N1 | |
44 | DO 3 I1=2,N | |
45 | I3 = I1 | |
46 | I33 = INDEX(I3) | |
47 | AI = A(I33) | |
48 | 1 I2 = I3/2 | |
49 | IF (I2) 3,3,2 | |
50 | 2 I22 = INDEX(I2) | |
51 | IF (AI.LE.A (I22)) GO TO 3 | |
52 | INDEX (I3) = I22 | |
53 | I3 = I2 | |
54 | GO TO 1 | |
55 | 3 INDEX (I3) = I33 | |
56 | 4 I3 = INDEX (N) | |
57 | INDEX (N) = INDEX (1) | |
58 | AI = A(I3) | |
59 | N = N-1 | |
60 | IF (N-1) 12,12,5 | |
61 | 5 I1 = 1 | |
62 | 6 I2 = I1 + I1 | |
63 | IF (I2.LE.N) I22= INDEX(I2) | |
64 | IF (I2-N) 7,9,11 | |
65 | 7 I222 = INDEX (I2+1) | |
66 | IF (A(I22)-A(I222)) 8,9,9 | |
67 | 8 I2 = I2+1 | |
68 | I22 = I222 | |
69 | 9 IF (AI-A(I22)) 10,11,11 | |
70 | 10 INDEX(I1) = I22 | |
71 | I1 = I2 | |
72 | GO TO 6 | |
73 | 11 INDEX (I1) = I3 | |
74 | GO TO 4 | |
75 | 12 INDEX (1) = I3 | |
76 | RETURN | |
77 | END | |
78 | * ======================================== | |
79 | SUBROUTINE SORTTI (A,INDEX,N1) | |
80 | C | |
81 | INTEGER A,AI | |
82 | DIMENSION A(N1),INDEX(N1) | |
83 | C | |
84 | N = N1 | |
85 | DO 3 I1=2,N | |
86 | I3 = I1 | |
87 | I33 = INDEX(I3) | |
88 | AI = A(I33) | |
89 | 1 I2 = I3/2 | |
90 | IF (I2) 3,3,2 | |
91 | 2 I22 = INDEX(I2) | |
92 | IF (AI.LE.A (I22)) GO TO 3 | |
93 | INDEX (I3) = I22 | |
94 | I3 = I2 | |
95 | GO TO 1 | |
96 | 3 INDEX (I3) = I33 | |
97 | 4 I3 = INDEX (N) | |
98 | INDEX (N) = INDEX (1) | |
99 | AI = A(I3) | |
100 | N = N-1 | |
101 | IF (N-1) 12,12,5 | |
102 | 5 I1 = 1 | |
103 | 6 I2 = I1 + I1 | |
104 | IF (I2.LE.N) I22= INDEX(I2) | |
105 | IF (I2-N) 7,9,11 | |
106 | 7 I222 = INDEX (I2+1) | |
107 | IF (A(I22)-A(I222)) 8,9,9 | |
108 | 8 I2 = I2+1 | |
109 | I22 = I222 | |
110 | 9 IF (AI-A(I22)) 10,11,11 | |
111 | 10 INDEX(I1) = I22 | |
112 | I1 = I2 | |
113 | GO TO 6 | |
114 | 11 INDEX (I1) = I3 | |
115 | GO TO 4 | |
116 | 12 INDEX (1) = I3 | |
117 | RETURN | |
118 | END | |
119 | * ======================================== | |
120 | SUBROUTINE SORTTC (A,INDEX,N1) | |
121 | C | |
122 | INTEGER A,AI | |
123 | DIMENSION A(N1),INDEX(N1) | |
124 | C | |
125 | N = N1 | |
126 | DO 3 I1=2,N | |
127 | I3 = I1 | |
128 | I33 = INDEX(I3) | |
129 | AI = A(I33) | |
130 | 1 I2 = I3/2 | |
131 | IF (I2) 3,3,2 | |
132 | 2 I22 = INDEX(I2) | |
133 | IF(ICMPCH(AI,A(I22)))3,3,21 | |
134 | 21 INDEX (I3) = I22 | |
135 | I3 = I2 | |
136 | GO TO 1 | |
137 | 3 INDEX (I3) = I33 | |
138 | 4 I3 = INDEX (N) | |
139 | INDEX (N) = INDEX (1) | |
140 | AI = A(I3) | |
141 | N = N-1 | |
142 | IF (N-1) 12,12,5 | |
143 | 5 I1 = 1 | |
144 | 6 I2 = I1 + I1 | |
145 | IF (I2.LE.N) I22= INDEX(I2) | |
146 | IF (I2-N) 7,9,11 | |
147 | 7 I222 = INDEX (I2+1) | |
148 | IF (ICMPCH(A(I22),A(I222))) 8,9,9 | |
149 | 8 I2 = I2+1 | |
150 | I22 = I222 | |
151 | 9 IF (ICMPCH(AI,A(I22))) 10,11,11 | |
152 | 10 INDEX(I1) = I22 | |
153 | I1 = I2 | |
154 | GO TO 6 | |
155 | 11 INDEX (I1) = I3 | |
156 | GO TO 4 | |
157 | 12 INDEX (1) = I3 | |
158 | RETURN | |
159 | END | |
160 | * ======================================== | |
161 | FUNCTION ICMPCH(IC1,IC2) | |
162 | C FUNCTION TO COMPARE TWO 4 CHARACTER EBCDIC STRINGS - IC1,IC2 | |
163 | C ICMPCH=-1 IF HEX VALUE OF IC1 IS LESS THAN IC2 | |
164 | C ICMPCH=0 IF HEX VALUES OF IC1 AND IC2 ARE THE SAME | |
165 | C ICMPCH=+1 IF HEX VALUES OF IC1 IS GREATER THAN IC2 | |
166 | I1=IC1 | |
167 | I2=IC2 | |
168 | IF(I1.GE.0.AND.I2.GE.0)GOTO 40 | |
169 | IF(I1.GE.0)GOTO 60 | |
170 | IF(I2.GE.0)GOTO 80 | |
171 | I1=-I1 | |
172 | I2=-I2 | |
173 | IF(I1-I2)80,70,60 | |
174 | 40 IF(I1-I2)60,70,80 | |
175 | 60 ICMPCH=-1 | |
176 | RETURN | |
177 | 70 ICMPCH=0 | |
178 | RETURN | |
179 | 80 ICMPCH=1 | |
180 | RETURN | |
181 | END |