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
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
|
SUBROUTINE DPD2
C
C DPD2 ASSEMBLES THE DYNAMIC LOADS TABLE (DLT).
C
INTEGER GPL ,SIL ,USET ,USETD ,GPLD ,SILD ,DPOOL ,
1 DLT ,FRL ,TFL ,TRL ,PSDL ,EED ,SCR1 ,
2 SCR2 ,SCR3 ,SCR4 ,BUF ,BUF1 ,BUF2 ,BUF3 ,
3 BUF4 ,FLAG ,FILE ,EPOINT,SEQEP ,Z ,LOADS ,
5 SDT ,DLOAD ,FREQ1 ,FREQ ,TIC ,TSTEP ,TF ,
6 PSD ,EIGR ,EIGB ,EIGC ,NGRID ,EQDYN ,SCR ,
7 BUFX
DIMENSION BUF(24) ,EPOINT(2) ,SEQEP(2) ,MCB(7),
1 NAM(2),LOADS(32) ,DLOAD(2) ,FREQ1(2) ,
2 FREQ(2) ,ZZ(1) ,BUFR(20) ,NOLIN(21) ,
3 TIC(2),TSTEP(2) ,TF(2) ,PSD(2),MSG(3),EIGR(2)
4, EIGB(2) ,EIGC(2) ,SCR(4),BUFX(3)
COMMON /BLANK / LUSET ,LUSETD,NOTFL ,NODLT ,NOPSDL,NOFRL ,NONLFT,
1 NOTRL ,NOEED ,NOSDT ,NOUE
COMMON /SYSTEM/ IDUMMY(55) ,ITHRML
COMMON /NAMES / RD ,RDREW ,WRT ,WRTREW,CLSREW
COMMON /DPDCOM/ DPOOL ,GPL ,SIL ,USET ,GPLD ,SILD ,USETD ,
1 DLT ,FRL ,NLFT ,TFL ,TRL ,PSDL ,EED ,
2 SCR1 ,SCR2 ,SCR3 ,SCR4 ,BUF ,BUF1 ,BUF2 ,
3 BUF3 ,BUF4 ,EPOINT,SEQEP ,L ,KN ,NEQDYN,
4 LOADS ,DLOAD ,FREQ1 ,FREQ ,NOLIN ,NOGO ,MSG ,
5 TIC ,TSTEP ,TF ,PSD ,EIGR ,EIGB ,EIGC ,
6 MCB ,NAM ,EQDYN ,SDT ,INEQ
COMMON /ZZZZZZ/ Z(1)
EQUIVALENCE (Z(1),ZZ(1)), (BUF(1),BUFR(1)), (MSG(2),NGRID),
1 (SCR1,SCR(1)),(BUF2 ,BUFX(1))
C
C OPEN DYNAMICS POOL. SET POINTERS TO LOOP THRU DAREA, DELAY
C AND DPHASE TABLES.
C
FILE = DPOOL
CALL PRELOC (*2001,Z(BUF1),DPOOL)
II = 1
III = 1
ITABL = NEQDYN + 2
L = 2
J = BUF4 - 1
MSG(1) = 66
C
C LOCATE CARD TYPE. IF PRESENT--
C STORE POINTER TO 1ST TABLE NO. IN LOADS TABLE, OPEN SCRATCH FILE
C FOR TABLES, SET ID = 0.
C
1110 CALL LOCATE (*1141,Z(BUF1),LOADS(II),FLAG)
LOADS(II+2) = J
FILE = SCR(III)
CALL OPEN (*2001,FILE,Z(BUF2),WRTREW)
ID = 0
C
C READ A CARD. IF TABLE NO. IS DIFFERENT, STORE TABLE NO. IN TABLE
C LIST. IF NOT FIRST CARD, SORT TABLE ON SIL NO. AND WRITE ON
C SCRATCH FILE.
C
1120 CALL READ (*2002,*1140,DPOOL,BUF,4,0,FLAG)
IF (BUF(1) .EQ. ID) GO TO 1130
IF (ID .EQ. 0) GO TO 1122
N = I - ITABL
CALL SORT (0,0,2,1,Z(ITABL),N)
CALL WRITE (FILE,Z(ITABL),N,1)
1122 ID = BUF(1)
Z(J) = ID
J = J - 1
I = ITABL
MSG(3) = ID
C
C CONVERT POINT AND COMPONENT TO SIL NO.
C STORE SIL NO. AND VALUE IN CORE.
C
1130 CALL DPDAA
Z(I ) = BUF(2)
Z(I+1) = BUF(4)
I = I + 2
IF (I .LT. J) GO TO 1120
CALL MESAGE (-8,0,NAM)
C
C HERE WHEN LAST CARD OF CURRENT TYPE HAS BEEN READ--
C SORT AND WRITE LAST RECORD. CLOSE SCRATCH FILE. STORE
C NUMBER OF TABLES IN TABLE LIST. TEST FOR ALL CARD TYPES PROCESSED.
C
1140 N = I - ITABL
CALL SORT (0,0,2,1,Z(ITABL),N)
CALL WRITE (FILE,Z(ITABL),N,1)
CALL CLOSE (FILE,CLSREW)
LOADS(II+3) = LOADS(II+2) - J
1141 II = II + 4
III = III + 1
IF (III .LE. 3) GO TO 1110
C
C SET POINTERS TO LOOP THRU RLOAD1,2 AND TLOAD1,2 CARDS
C
NCORE = J
J = 1
III = 1
INEQ = 0
C
C LOCATE A CARD TYPE. IF PRESENT--
C READ ALL CARDS OF TYPE INTO CORE.
C
1160 CALL LOCATE (*1165,Z(BUF1),LOADS(II),FLAG)
M = LOADS(II+2)
1161 Z(J) = III
CALL READ (*2002,*1165,DPOOL,Z(J+1),M,0,FLAG)
J = J + 11
IF (J .LT. NCORE) GO TO 1161
CALL MESAGE (-8,0,NAM)
C
C TEST FOR ALL CARD TYPES PROCESSED.
C IF SO, SORT CARDS ON LOAD SET ID.
C
1165 II = II + 4
III = III + 1
IF (III .LE. 4) GO TO 1160
N = J - 1
IF (N .NE. 0) GO TO 1166
CALL CLOSE (DPOOL,CLSREW)
RETURN
C
1166 CALL SORT (0,0,11,2,Z,N)
NLIST = J - 11
C
C LOCATE DLOAD CARDS ON DYNAMICS POOL.
C IF PRESENT READ INTO CORE. SORT EACH DLOAD CARD ON REFERENCED SET
C ID.
C
NODLD = 0
CALL LOCATE (*1174,Z(BUF1),DLOAD,FLAG)
IDLOAD = J
I = IDLOAD
J = I
1171 CALL READ (*2002,*1174,DPOOL,Z(J+1),2,0,FLAG)
J = J + 3
NODLD = NODLD + 1
1172 CALL READ (*2002,*2003,DPOOL,Z(J),2,0,FLAG)
IF (Z(J) .EQ. -1) GO TO 1173
J = J + 2
IF (J .GE. NCORE) CALL MESAGE (-8,0,NAM)
GO TO 1172
1173 N = J - (I+3)
CALL SORT (0,0,2,2,Z(I+3),N)
C
C CHECK FOR DLOAD SET ID UNIQUENESS
C
DO 11731 KK = 2,N,2
JJ = I + 2 + KK
IF (KK .GE. N) GO TO 11731
IF (Z(JJ) .NE. Z(JJ+2)) GO TO 11731
NOGO = 1
MSG(2) = Z(I+1)
MSG(3) = Z(JJ)
CALL MESAGE (30,135,MSG(2))
11731 CONTINUE
Z(I) = N + 2
I = J
GO TO 1171
1174 CALL CLOSE (DPOOL,CLSREW)
C
C OPEN THE DLT. WRITE NAME IN HEADER RECORD.
C THEN WRITE NO. OF DLOAD CARDS FOLLOWED BY DLOAD SET IDS.
C THEN WRITE SET IDS FOR EACH RECORD OF THE DLT (FOLLOWING DLOAD
C RECORD)
C
FILE = DLT
CALL OPEN (*1249,DLT,Z(BUF1),WRTREW)
CALL FNAME (DLT,BUF)
BUF(3) = NODLD
CALL WRITE (DLT,BUF,3,0)
IF (NODLD .EQ. 0) GO TO 1182
I = IDLOAD
J = 1
1181 CALL WRITE (DLT,Z(I+1),1,0)
I = I + Z(I) + 1
J = J + 1
IF (J .LE. NODLD) GO TO 1181
C
C CHECK DLOAD SID VS RLOAD1,2 AND TLOAD1,2 FOR UNIQUENESS
C
I = IDLOAD
DO 11810 JJ = 1,NODLD
ITEMP = Z(I+1)
DO 11811 KK = 1,NLIST,11
IF (ITEMP .NE. Z(KK+1)) GO TO 11811
NOGO = 1
MSG(2) = ITEMP
CALL MESAGE (30,136,MSG(2))
11811 CONTINUE
I = I + Z(I) + 1
11810 CONTINUE
1182 DO 1183 I = 1,NLIST,11
BUF(1) = Z(I+1)
C
C CHECK FOR UNIQUE SET IDS ON TLOAD1,2 AND RLOAD1,2 CARDS THEN WRIT
C
IF (I .GE. NLIST) GO TO 1184
IF (Z(I+1) .NE. Z(I+12)) GO TO 1184
NOGO = 1
MSG(2) = ITEMP
CALL MESAGE (30,136,MSG(2))
1184 CALL WRITE (DLT,BUF,1,0)
1183 CONTINUE
CALL WRITE (DLT,0,0,1)
C
C IF DLOAD CARDS PRESENT, WRITE THE DLOAD RECORD.
C
IF (NODLD .EQ. 0) GO TO 1200
BUF(1) = -1
BUF(2) = -1
I = IDLOAD
J = 1
1191 N = Z(I)
CALL WRITE (DLT,Z(I+1),N,0)
CALL WRITE (DLT,BUF,2,0)
I = I + N + 1
J = J + 1
IF (J .LE. NODLD) GO TO 1191
CALL WRITE (DLT,0,0,1)
C
C INITIALIZE TO LOOP THRU ALL LOAD SETS. THE REMAINDER OF THE DLT
C WILL CONSIST OF ONE LOGICAL RECORD PER LOAD SET.
C
1200 I = 1
C
C WRITE FIXED SECTION OF DLT RECORD.
C
1205 BUF(1) = Z(I )
BUF(2) = Z(I+2)
C
C SAVE INFORCED MOTION FLAG ON TLOAD CARDS
C
IF (Z(I).LT.3 .OR. Z(I).GT.4) GO TO 1206
IEMF = Z(I+4)
Z(I+4) = 0
1206 CONTINUE
CALL WRITE (DLT,BUF,2,0)
CALL WRITE (DLT,Z(I+5),6,0)
C
C POSITION SCRATCH FILES TO SELECTED TABLES.
C
IDAREA = 0
DO 1215 J = 1,3
BUF(2*J-1) = 16777215
C 16777215 =2**24 - 1
K = I + J
BUF(J+16) = Z(K+1)
IF (BUF(J+16) .EQ. 0) GO TO 1215
JJ = LOADS(4*J-1)
NN = LOADS(4*J )
IF (NN .EQ. 0) GO TO 1212
DO 1211 NX = 1,NN
IF (Z(JJ) .EQ. BUF(J+16)) GO TO 1213
JJ = JJ - 1
1211 CONTINUE
1212 IF (ITHRML.NE.1 .OR. J.NE.1) GO TO 1300
IDAREA = -1
BUF(17) = 0
GO TO 1215
1300 BUF(10) = Z(I+1)
BUF(11) = BUF(J+16)
BUF(11) = BUF(11) + 100000000*J
NOGO = 1
CALL MESAGE (30,71,BUF(10))
BUF(J+16) = 0
GO TO 1215
1213 NN = NX - 1
FILE = SCR(J)
IBUF = BUFX(J)
CALL OPEN (*2001,FILE,Z(IBUF),RDREW)
IF (NN .EQ. 0) GO TO 1215
DO 1214 NX = 1,NN
CALL FWDREC (*2002,FILE)
1214 CONTINUE
1215 CONTINUE
C
C INITIALIZE TABLE READ.
C
BUF(14) = BUF(17)
BUF(15) = BUF(18)
BUF(16) = BUF(19)
C
C READ AN ENTRY FROM APPROPRIATE TABLE/S).
C IF ALL ENTRIES HAVE BEEN READ, GO TO CLOSE DLT RECORD.
C
1220 DO 1222 J = 1,3
IF (ITHRML.NE.1 .OR. J.NE.1) GO TO 1320
IF (IDAREA .EQ. 0) GO TO 1320
IF (IDAREA .EQ.-2) GO TO 1221
IDAREA = -2
BUF(1) = 1
BUF(2) = 0
BUF(14) = 0
1320 IF (BUF(J+13) .EQ. 0) GO TO 1222
FILE = SCR(J)
J2 = 2*J
CALL READ (*2002,*1221,FILE,BUF(J2-1),2,0,FLAG)
GO TO 1222
1221 BUF(2*J-1) = 16777215
BUF(J+13) = 0
1222 CONTINUE
IF (BUF(1)+BUF(3)+BUF(5) .EQ. 3*16777215) GO TO 1240
C
C SELECT MINIMUM SIL NO(S) AND FORMAT OUTPUT.
C
DO 1231 J = 1,6
1231 BUF(J+10) = 0
BUF(7) = 1
BUF(8) = 2
BUF(9) = 3
IF (BUF(1) .GT. BUF(3)) GO TO 1232
C
C 1 .LE. 2--COMPARE 2 TO 3. IF 2 .GT. 3, SWITCH 2 AND 3.
C
IF (BUF(3) .LE. BUF(5)) GO TO 1234
K = BUF(8)
BUF(8) = BUF(9)
BUF(9) = K
GO TO 1233
C
C 1 .GT. 2--SWITCH 1 AND 2 THEN COMPARE 2 AND 3. IF 2 .GT. 3, SWITCH
C
1232 K = BUF(7)
BUF(7) = BUF(8)
BUF(8) = K
IF (BUF(1) .LE. BUF(5)) GO TO 1234
K = BUF(8)
BUF(8) = BUF(9)
BUF(9) = K
C
C COMPARE 1 TO 2--IF 1 .GT. 2, SWITCH 1 AND 2.
C
1233 K = BUF(7)
L = BUF(8)
IF (BUF(2*K-1) .LE. BUF(2*L-1)) GO TO 1234
BUF(7) = L
BUF(8) = K
C
C PICK UP 1. SET TO READ 1.
C
1234 K = BUF(7)
BUF( 10) = BUF(2*K-1)
BUF(K+10) = BUF(2*K )
BUF(K+13) = K
C
C IF 1 .EQ. 2, PICK UP 2 AND SET TO READ 2.
C
L = BUF(8)
IF (BUF(2*K-1) .NE. BUF(2*L-1)) GO TO 1235
BUF(L+10) = BUF(2*L)
BUF(L+13) = L
C
C IF 1 .EQ. 2 .EQ. 3, PICK UP 3 AND SET TO READ 3.
C
M = BUF(9)
IF (BUF(2*L-1) .NE. BUF(2*M-1)) GO TO 1235
BUF(M+10) = BUF(2*M)
BUF(M+13) = M
C
C WRITE SIL NO., A, TAU, THETA. THEN GO TO READ ANOTHER TABLE
C ENTRY(S).
C
1235 IF (Z(I).LT.3 .OR. Z(I).GT.4) GO TO 1236
BUF(13) = IEMF
1236 CALL WRITE (DLT,BUF(10),4,0)
GO TO 1220
C
C CLOSE DLT RECORD, CLOSE TABLES AND TEST FOR COMPLETION OF DLT.
C
1240 CALL WRITE (DLT,0,0,1)
DO 1241 J = 1,3
IF (BUF(J+16) .NE. 0) CALL CLOSE (SCR(J),CLSREW)
1241 CONTINUE
I = I + 11
IF (I .LE. NLIST) GO TO 1205
C
C CLOSE DLT, WRITE TRAILER AND RETURN.
C
CALL CLOSE (DLT,CLSREW)
MCB(1) = DLT
MCB(2) = DLT
CALL WRTTRL (MCB)
NODLT = 1
1249 RETURN
C
C FATAL FILE ERRORS
C
2001 N= -1
GO TO 2005
2002 N= -2
GO TO 2005
2003 N= -3
2005 CALL MESAGE (N,FILE,NAM)
RETURN
END
|
