1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
|
SUBROUTINE SORT (IDUM,JDUM,NR,KEYWD,Z,NWDS)
C
C THE ORIGINAL NASTRAN SORT ROUTINE FOR IN-CORE SORTING AND FILE
C SORT IS NOW RENAMED SORTI
C (ONLY 5 PERCENT OF NASTRAN ROUTINES ACTUALLY CALL SORTI, WITH NON-
C ZERO IDUM AND JDUM)
C
C THIS NEW SORT ROUTINE WITH IDUM=JDUM=0, PERFORMS ONLY IN-CORE SORT
C FOR INTEGERS, FLOATING POINT NUMBERS, AND BCD WORDS, BY THE
C MODIFIED SHELL METHOD
C IT USES MUCH LESS CORE SPACE
C
C ARRAY Z IS NR-ROWS BY (NWDS/NR)-COLUMNS IN SIZE
C DATA STORED ROW-WISE IN Z, AND TO BE SORTED BY KEYWD-TH ROW
C
C USE A NEGATIVE KEYWD IF THE ORIGINAL ORDER OF THE TABLE ENTRIES
C ARE TO BE PRESERVED AND THE COLUMN OF KEYWORDS CONTAINS DUPLICATES
C (INTEGER SORT ONLY) E.G.
C
C ORIGINAL TABLE SORTED(KEYWD=+1) SORTED(KEYWD=-1)
C --------------- ---------------- ----------------
C 1 4 1 4 1 4
C 2 2 1 10 1 3
C 1 3 1 3 1 10
C 1 10 2 2 2 2
C
C
C THIS ROUTINE WOULD SWITCH BACK TO THE OLD SHUTTLE EXCHANGE METHOD
C NUMBERS OVERFLOW DUE TO THE REQUIREMENT THAT ORIGINAL ORDER MUST B
C MAINTAINED
C
C ENTRY POINTS
C
C SORT - TABLE SORT BY INTEGER
C SORTF - TABLE SORT BY F.P. NUMBER
C SORTA - TABLE SORT BY ALPHABETS, 4-BCD CHARACTERS
C SORTA8 - TABLE SORT BY ALPHABETS, 8-BCD CHAR. (KEYWD AND KEYWD+1)
C SORTA7 - SAME AS SORTA8, EXCEPT LEADING CHAR. IS IGNORED
C SORT2K - 2-KEYWORD SORT, SORT BY KEYWD AND KEYWD+1, INTEGER OR
C REAL NUMBER KEYS. NEGATIVE KEYWD IS IGNORED
C
C THE TWO SORT CALLS OF THE FOLLOWING FORM CAN BE REPLACED BY ONE CA
C TO SORT2K, WHICH IS FASTER, NO DANGER OF NUMBER OVERFLOW, AND THE
C ORIGINAL SEQUENCE WILL NOT CHANGE WHEN THERE ARE DUPLICATES.
C
C CALL SORT (0,0,N1,-(N2+1),TABLE,N3)
C CALL SORT (0,0,N1,-N2, TABLE,N3)
C CAN BE REPLACED BY
C CALL SORT2K (0,0,N1,N2,TABLE,N3)
C
C
C WRITTEN BY G.CHAN/SPERRY, 3/1987
C
LOGICAL RVSBCD
INTEGER ZI, ZN, TEMP, Z(NR,1), TWO31, TWO,
1 SUBR(6)
REAL RI, RN
COMMON /SYSTEM/ IBUF, NOUT, DM37(37),NBPW
COMMON /MACHIN/ MACH, IJHLF(2),LQRO
COMMON /TWO / TWO(16)
EQUIVALENCE (ZI,RI), (ZN,RN)
DATA SUBR / 2H , 2HF , 2HA , 2HA8, 2HA7, 2H2K/
C
C CHECK ERROR, CHECK DATA TYPE, AND PREPARE FOR SORT
C
ISORT = 1
GO TO 10
C
ENTRY SORTF (IDUM,JDUM,NR,KEYWD,Z,NWDS)
C =======================================
ISORT = 2
GO TO 10
C
ENTRY SORTA (IDUM,JDUM,NR,KEYWD,Z,NWDS)
C =======================================
ISORT = 3
GO TO 10
C
ENTRY SORTA8 (IDUM,JDUM,NR,KEYWD,Z,NWDS)
C ========================================
ISORT = 4
GO TO 10
C
ENTRY SORTA7 (IDUM,JDUM,NR,KEYWD,Z,NWDS)
C ========================================
ISORT = 5
GO TO 10
C
ENTRY SORT2K (IDUM,JDUM,NR,KEYWD,Z,NWDS)
C ========================================
ISORT = 6
C
10 IF (NWDS .EQ. 0) GO TO 330
IF (IDUM.NE.0 .OR. JDUM.NE.0) GO TO 300
RVSBCD = MOD(LQRO,10) .EQ. 1
KEY = IABS(KEYWD)
IF (KEY .GT. NR) GO TO 280
NC = NWDS/NR
IF (NC*NR .NE. NWDS) GO TO 280
M = NC
IF (ISORT.NE.1 .OR. KEYWD.GE.0) GO TO 30
C
C - INTEGER SORT ONLY -
C IF ORIGINAL ORDER IS TO BE MAINTAINED WHERE DUPLICATE KEYWORDS MAY
C OCCUR, ADD INDICES TO THE KEYWORDS (GOOD FOR BOTH POSITIVE AND
C NEGATIVE RANGES, AND BE SURE THAT KEYWORDS ARE NOT OVERFLOWED),
C SORT THE DATA, AND REMOVE THE INDICES LATER
C
C IF KEYWORD OVERFLOWS, SWITCH TO SHUTTLE EXCHANGE METHOD
C
IF (NC.GE.TWO(16) .AND. NBPW.LE.32) GO TO 200
J = 30
IF (NBPW .GE. 60) J = 62
TWO31 = 2**J
LIMIT = (TWO31-NC)/NC
DO 20 I = 1,NC
J = Z(KEY,I)
IF (IABS(J) .GT. LIMIT) GO TO 200
J = J*NC + I
K =-1
IF (J .LT. 0) K =-NC
20 Z(KEY,I) = J + K
C
C SORT BY
C MODIFIED SHELL METHOD, A SUPER FAST SORTER
C
30 M = M/2
IF (M .EQ. 0) GO TO 180
J = 1
K = NC - M
40 I = J
50 N = I + M
ZI= Z(KEY,I)
ZN= Z(KEY,N)
GO TO (60,80,90,90,90,60), ISORT
C INT FP A4 A8 A7 2K
C
60 IF (ZI-ZN) 170,70,150
70 IF (ISORT .EQ. 1) GO TO 170
IF (Z(KEY+1,I)-Z(KEY+1,N)) 170,170,150
80 IF (RI-RN) 170,170,150
90 KK = 1
IF (ISORT .EQ. 5) GO TO 110
C
C COMPARE 1ST BYTE, THEN COMPARE 2ND, 3RD, AND 4TH BYTES TOGETHER
C IF MACHINE DOES NOT USE REVERSED BCD ORDER. THOSE MACHINES WITH
C REVERSED BCD ORDER (VAX, ULTRIX, S/G) MUST COMPARE EACH BYTE
C SEPERATELY BECAUSE OF THE SIGN BIT
C
100 IF (KHRFN1(ZERO,4,ZI,1) - KHRFN1(ZERO,4,ZN,1)) 170,110,150
110 IF (.NOT.RVSBCD) IF (KHRFN1(ZI,1,ZERO,4)-KHRFN1(ZN,1,ZERO,4))
1 170,140,150
IF (KHRFN1(ZERO,4,ZI,2) - KHRFN1(ZERO,4,ZN,2)) 170,120,150
120 IF (KHRFN1(ZERO,4,ZI,3) - KHRFN1(ZERO,4,ZN,3)) 170,130,150
130 IF (KHRFN1(ZERO,4,ZI,4) - KHRFN1(ZERO,4,ZN,4)) 170,140,150
140 IF (ISORT.LE.3 .OR. KK.EQ.2) GO TO 170
ZI = Z(KEY+1,I)
ZN = Z(KEY+1,N)
KK = 2
GO TO 100
150 DO 160 L = 1,NR
TEMP = Z(L,I)
Z(L,I) = Z(L,N)
160 Z(L,N) = TEMP
I = I - M
IF (I .GE. 1) GO TO 50
170 J = J + 1
IF (J-K) 40,40,30
180 IF (ISORT.NE.1 .OR. KEYWD.GE.0) GO TO 330
DO 190 I = 1,NC
190 Z(KEY,I) = Z(KEY,I)/NC
GO TO 330
C
C SORT BY
C SHUTTLE EXCHANGE THETHOD, A SLOW SORTER
C (THIS WAS NASTRAN ORIGINAL SORTER, MODIFIED FOR 2-D ARRAY OPERATIO
C WITH 20-COLUMN LIMITATION REMOVED)
C
200 IF (I .LE. 1) GO TO 220
J = I - 1
DO 210 I = 1,J
210 Z(KEY,I) = Z(KEY,I)/NC
C
220 DO 270 II = 2,NC
ZI = Z(KEY,II)
JJ = II - 1
IF (ZI .GE. Z(KEY,JJ)) GO TO 270
230 JJ = JJ - 1
IF (JJ .GT. 0) IF (ZI-Z(KEY,JJ)) 230,240,240
240 JJ = JJ + 2
DO 260 I = 1,NR
TEMP = Z(I,II)
M = II
DO 250 J = JJ,II
Z(I,M) = Z(I,M-1)
250 M = M - 1
260 Z(I,JJ-1) = TEMP
270 CONTINUE
GO TO 330
C
C ERROR. FORCING A WALK BACK
C
280 WRITE (NOUT,290) SUBR(ISORT),NR,KEY,NWDS,NC
290 FORMAT ('0*** ERROR IN SORT',A2,4I8)
GO TO 320
300 WRITE (NOUT,310)
310 FORMAT ('0*** CALLING ROUTINE SHOULD CALL SORTI')
CWKBR 320 CALL ERRTRC ('SORT ',320)
320 CONTINUE
330 RETURN
END
|
