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
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
|
SUBROUTINE DPD4
C
C DPD4 ASSEMBLES THE NON-LINEAR FORCING TABLE (NLFT)
C AND THE TRANSIENT RESPONSE LIST (TRL).
C
EXTERNAL ANDF
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 ANDF ,DLOAD ,FREQ1 ,FREQ ,TIC ,TSTEP ,TF ,
6 PSD ,EIGR ,EIGB ,EIGC ,NGRID ,EQDYN ,SDT ,
7 UD ,UE ,TWO
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) ,
4 MSG(3) ,EIGR(2) ,EIGB(2) ,EIGC(2)
COMMON /BLANK / LUSET ,LUSETD,NOTFL ,NODLT ,NOPSDL,NOFRL ,NONLFT,
1 NOTRL ,NOEED
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 ,
5 MSG ,TIC ,TSTEP ,TF ,PSD ,EIGR ,EIGB ,
6 EIGC ,MCB ,NAM ,EQDYN ,SDT ,INEQ
COMMON /TWO / TWO(32)
COMMON /BITPOS/ UM ,UO ,UR ,USG ,USB ,UL ,UA ,
1 UF ,US ,UN ,UG ,UE ,UP ,UNE ,
2 UFE ,UD
COMMON /ZZZZZZ/ Z(1)
EQUIVALENCE (Z(1) ,ZZ(1)),(BUF(1),BUFR(1)),(MSG(2),NGRID)
DATA NOLINR/ 7 /
C
C INITIALIZE POINTERS. OPEN SCR1. OPEN DYNAMICS POOL.
C
INOLIN = NEQDYN + 2
J = INOLIN
MSKUD = TWO(UD)
MSKUE = TWO(UE)
INCORE = 0
II = 1
I = 1
MSG(1) = 67
CALL PRELOC (*2001,Z(BUF1),DPOOL)
CALL OPEN (*2001,SCR1,Z(BUF2),WRTREW)
INEQ = 0
C
C LOCATE NOLINI CARD. IF PRESENT, TURN NONLFT FLAG OFF,
C
1320 CALL LOCATE (*1358,Z(BUF1),NOLIN(I),FLAG)
NONLFT = 1
NWDIN = NOLIN(I+2)
C
C READ A NOLINI CARD. CONVERT POINTS ON CARD TO SIL NOS.
C STORE DATA IN CORE. IF SPILL, WRITE ON SCRATCH FILE.
C
1340 CALL READ (*2002,*1358,DPOOL,BUF,NWDIN,0,FLAG)
MSG(3) = 100000000*II + BUF(1)
IF (II .GE. 5) IF (II-6) 1350, 1354, 1342
C NOLIN5,NFTUBE,NOLIN6
III = II
IF (BUF(6) .LT. 10) GO TO 1341
III = II + 4
BUF(6) = BUF(6) - 10
1341 IF (II .NE. 2) GO TO 1343
IF (BUF(8) .LT. 10) GO TO 1343
BUF(8) = BUF(8) - 10
IF(III.EQ.2) III = 10
IF(III.EQ.6) III = 9
GO TO 1343
1342 III = 13
IF (BUF(6) .LT. 10) GO TO 1343
III = 14
BUF(6) = BUF(6) - 10
1343 L = 2
CALL DPDAA
BUF(3) = BUF(2)
L = 5
CALL DPDAA
L = 7
IF (II .EQ. 2) CALL DPDAA
BUF(6) = BUF(7)
BUF(2) = III
1344 NN = 6
1345 IF (INCORE .NE. 0) GO TO 1348
IF (J+NN .GE. BUF2) GO TO 1347
DO 1346 K = 1,NN
Z(J) = BUF(K)
1346 J = J + 1
GO TO 1340
1347 CALL WRITE (SCR1,Z(INOLIN),J-INOLIN,0)
INCORE = 1
1348 CALL WRITE (SCR1,BUF,NN,0)
GO TO 1340
C
C SPECIAL HANDLING OF NOLIN5 CARD
C CARD FORMAT AS RECEIVED FROM IFP
C SID AA AB FAB EA/TEA EB/TEB ALPA/TALPA ALPB/TALPB
C GA1 GA2 GA3 GA4 GB1 GB2 GB3 GB4
C
C WE CONVERT THIS CARD INTO THE FOLLOWING 6-WORD ENTRY FORMAT
C
C SID 12 SILA1 AA SILA2 AB
C SID 12 SILA3 FAB SIL4 0
C SID 12 SILB1 EA/TEA SILB2 EB/TEB
C SID 12 SILB3 ALPA/TALPA SILB4 ALPB/TALPB
C
1350 L = 23
KK= 16
DO 1351 K = 1,8
BUF(L+1) = 0
BUF(L ) = BUF(KK)
IF (BUF(L) .NE. 0) CALL DPDAA
KK = KK - 1
1351 L = L -2
BUF(24) = BUF( 8)
BUF(22) = BUF( 7)
BUF(18) = BUF( 6)
BUF(16) = BUF( 5)
BUF(12) = 0
BUF(10) = BUF( 4)
BUF( 6) = BUF( 3)
BUF( 4) = BUF( 2)
BUF( 3) = BUF( 9)
BUF( 5) = BUF(11)
BUF( 9) = BUF(13)
BUF(11) = BUF(15)
BUF(17) = BUF(19)
DO 1352 K = 1,24,6
BUF(K ) = BUF(1)
1352 BUF(K+1) = 12
NN = 24
GO TO 1345
C
1354 L = 7
BUF(7) = BUF(2)
BUF(8) = 1
CALL DPDAA
BUF(3) = BUF(7)
BUF(7) = BUF(3)
BUF(8) = 1
CALL DPDAA
BUF(5) = BUF(7)
BUF(6) = BUF(5)
BUF(2) = 11
MSG(3) = BUF(1)
GO TO 1344
C
C HERE WHEN ALL CARDS OF CURRENT TYPE HAVE BEEN READ.
C TEST FOR ALL CARDS READ.
C
1358 I = I + 3
II = II+ 1
IF (II .LE. NOLINR) GO TO 1320
CALL WRITE (SCR1,0,0,1)
CALL CLOSE (SCR1,CLSREW)
IF (NONLFT .EQ. -1) GO TO 1400
C
C SORT THE DATA ON SET ID.
C
IF (INCORE .NE. 0) GO TO 1362
NNOLIN = J - 6
N = J - INOLIN
GO TO 1364
1362 CALL OPEN (*2001,SCR1,Z(BUF2),RDREW)
CALL READ (*2002,*1363,SCR1,Z,BUF1,1,N)
CALL MESAGE (-8,0,NAM)
1363 CALL CLOSE (SCR1,CLSREW)
INOLIN = 1
NNOLIN = N - 5
1364 CALL SORT (0,0,6,1,Z(INOLIN),N)
C
C READ USETD INTO CORE.
C
FILE = USETD
CALL OPEN (*2001,USETD,Z(BUF2),RDREW)
CALL FWDREC (*2002,USETD)
IUSETD = NNOLIN + 7
CALL READ (*2002,*1365,USETD,Z(IUSETD),BUF2-IUSETD,1,N)
CALL MESAGE (-8,0,NAM)
1365 CALL CLOSE (USETD,CLSREW)
C
C OPEN THE NLFT. WRITE SET IDS IN HEADER RECORD.
C
FILE = NLFT
CALL OPEN (*1392,NLFT,Z(BUF2),WRTREW)
CALL FNAME (NLFT,BUF)
CALL WRITE (NLFT,BUF,2,0)
Z(NNOLIN+6) = 0
DO 1371 I = INOLIN,NNOLIN,6
IF (Z(I+6) .NE. Z(I)) CALL WRITE (NLFT,Z(I),1,0)
1371 CONTINUE
CALL WRITE (NLFT,0,0,1)
C
C WRITE ONE RECORD PER SET. WITHIN EACH SET, SORT DATA ON SIL NO.
C CONVERT SIL NOS. TO SIL NOS. IN UD AND UE SETS
C
I = INOLIN
1381 J = I
1382 IF (Z(I+6) .NE. Z(I)) GO TO 1383
I = I + 6
GO TO 1382
1383 N = I + 6 - J
C
C ... THE FOLLOWING SORT WAS REMOVED DUE TO THE INSTALLATION OF NOLIN5
C CALL SORT (0,0,6,3,Z(J),N)
C
CWKBR SPR94005 6/94 DO 1387 KC = J,I,6
DO 1387 K = J,I,6
BUF(1) = Z(K+1)
BUF(2) = Z(K+2)
BUF(4) = Z(K+3)
BUF(5) = Z(K+4)
BUF(8) = Z(K+5)
BUF(9) = 0
DO 1386 KK = 2,8,3
IF (KK.GE.8 .AND. BUF(1).NE.2 .AND. BUF(1).NE.6 .AND. BUF(1).NE.9
1 .AND. BUF(1).NE.10.AND.KK.EQ.8) GO TO 1386
K1 = 0
K2 = 0
NUSETD = IUSETD + BUF(KK) - 1
IF (NUSETD .LT. IUSETD) GO TO 1385
DO 1384 KKK = IUSETD,NUSETD
BUF(10) = Z(KKK)
IF (ANDF(BUF(10),MSKUD) .NE. 0) K1 = K1 + 1
IF (ANDF(BUF(10),MSKUE) .NE. 0) K2 = K2 + 1
1384 CONTINUE
1385 BUF(KK ) = K1
BUF(KK+1) = K2
IF (NUSETD .LT. IUSETD) GO TO 1386
IF (ANDF(BUF(10),MSKUE) .EQ. 0) BUF(KK+1) = 0
IF (ANDF(BUF(10),MSKUD) .NE. 0) GO TO 1386
NOGO = 1
BUF(1) = Z(K)
BUF(2) = K1
CALL MESAGE (30,93,BUF)
1386 CONTINUE
BUF(7) = BUF(8)
BUF(8) = BUF(9)
CALL WRITE (NLFT,BUF,8,0)
1387 CONTINUE
CALL WRITE (NLFT,0,0,1)
I = I + 6
IF (Z(I) .NE. 0) GO TO 1381
C
C CLOSE FILE AND WRITE TRAILER.
C
CALL CLOSE (NLFT,CLSREW)
MCB(1) = NLFT
MCB(2) = (NNOLIN-INOLIN)/6 + 1
CALL WRTTRL (MCB)
IF (INCORE .NE. 0) INEQ = 0
GO TO 1400
1392 NONLFT =-1
C
C LOCATE TIC CARDS IN DYNAMICS POOL.
C
1400 NOTRL =-1
NOTIC = 0
NOTSTP= 0
CALL LOCATE (*1500,Z(BUF1),TIC,FLAG)
NOTRL = 1
C
C OPEN SCR1. INITIALIZE TO READ TIC CARDS.
C
FILE = SCR1
CALL OPEN (*2001,SCR1,Z(BUF2),WRTREW)
ITIC = NEQDYN + 2
NSET = BUF3 - 1
J = NSET
L = 2
MSG(1) = 69
ID = 0
C
C READ A TIC CARD. IF SET ID IS DIFFERENT, STORE IT IN LIST.
C IF NOT FIRST CARD, SORT DATA ON SIL NO. AND WRITE IT IN SCR1.
C
1420 CALL READ (*2002,*1440,DPOOL,BUF,5,0,FLAG)
IF (BUF(1) .EQ. ID) GO TO 1430
IF (ID .EQ. 0) GO TO 1421
N = I - ITIC
CALL SORT (0,0,3,1,Z(ITIC),N)
CALL WRITE (SCR1,Z(ITIC),N,1)
1421 ID = BUF(1)
Z(J) = ID
J = J - 1
I = ITIC
MSG(3) = ID
C
C CONVERT POINT AND COMPONENT TO SIL NO.
C STORE SIL NO., UO, VO IN CORE.
C
1430 CALL DPDAA
Z(I ) = BUF(2)
Z(I+1) = BUF(4)
Z(I+2) = BUF(5)
I = I + 3
IF (I .LT. J) GO TO 1420
CALL MESAGE (-8,0,NAM)
C
C HERE WHEN LAST CARD READ - SORT AND WRITE LAST RECORD.
C
1440 N = I - ITIC
CALL SORT (0,0,3,1,Z(ITIC),N)
CALL WRITE (SCR1,Z(ITIC),N,1)
CALL CLOSE (SCR1,CLSREW)
ISET = J + 1
C
C OPEN TRL. WRITE SET IDS IN HEADER.
C
FILE = TRL
CALL OPEN (*1493,TRL,Z(BUF2),WRTREW)
CALL FNAME (TRL,BUF)
N = NSET - ISET + 1
BUF(3) = N
NOTIC = N
CALL WRITE (TRL,BUF,3,0)
I = ISET
J = NSET
1451 ID = Z(J)
Z(J) = Z(I)
Z(I) = ID
I = I + 1
J = J - 1
IF (I .LT. J) GO TO 1451
CALL WRITE (TRL,Z(ISET),N,0)
C
C READ USETD INTO CORE.
C COMPUTE NO. OF POINTS UN UD SET. WRITE NO. AS LAST WORD OF HEADER.
C
1460 FILE = USETD
CALL OPEN (*2001,USETD,Z(BUF3),RDREW)
CALL FWDREC (*2002,USETD)
IUSETD = 1
INEQ = 0
CALL READ (*2002,*1462,USETD,Z(IUSETD),BUF3-IUSETD,1,N)
CALL MESAGE (-8,0,NAM)
1462 CALL CLOSE (USETD,CLSREW)
NUSETD = IUSETD + N - 1
K = 0
DO 1463 I = IUSETD,NUSETD
IF (ANDF(Z(I),MSKUD) .NE. 0) K = K + 1
1463 CONTINUE
CALL WRITE (TRL,K,1,1)
IF (NOTIC .EQ. 0) GO TO 1481
C
C READ SCR1. CONVERT SIL NO. TO AN SIL NO. IN THE D-SET.
C WRITE TRL ONE RECORD PER SET.
C
FILE = SCR1
KSET = ISET
CALL OPEN (*2001,SCR1,Z(BUF3),RDREW)
1475 K = 0
IPOINT = IUSETD
1471 CALL READ (*1474,*1473,SCR1,BUF,3,0,FLAG)
NUSETD = IUSETD + BUF(1) - 1
DO 1472 I = IPOINT,NUSETD
IF (ANDF(Z(I),MSKUD) .NE. 0) K = K + 1
1472 CONTINUE
BUF(1) = K
IF (ANDF(Z(NUSETD),MSKUD) .NE. 0) GO TO 1476
NOGO = 1
CALL MESAGE (30,133,Z(KSET))
1476 CALL WRITE (TRL,BUF,3,0)
IPOINT = NUSETD + 1
GO TO 1471
1473 CALL WRITE (TRL,0,0,1)
KSET = KSET + 1
GO TO 1475
1474 CALL CLOSE (SCR1,CLSREW)
C
C IF TSTEP CARDS PRESENT, COPY THEM ONTO TRL.
C
CALL LOCATE (*1490,Z(BUF1),TSTEP,FLAG)
1481 CALL READ (*2002,*1483,DPOOL,BUF,1,0,FLAG)
NOTSTP = NOTSTP + 1
CALL WRITE (TRL,BUF,1,0)
1482 CALL READ (*2002,*2003,DPOOL,BUF,3,0,FLAG)
IF (BUF(1) .EQ. -1) GO TO 1485
CALL WRITE (TRL,BUF,3,0)
GO TO 1482
1485 CALL WRITE (TRL,0,0,1)
GO TO 1481
1483 CONTINUE
C
C CLOSE FILES AND WRITE TRAILER.
C
1490 CALL CLOSE (TRL,CLSREW)
MCB(1) = TRL
MCB(2) = NOTIC
MCB(3) = NOTSTP
CALL WRTTRL (MCB)
1492 CALL CLOSE (DPOOL,CLSREW)
RETURN
C
1493 NOTRL = -1
GO TO 1492
C
C HERE IF NO TIC CARDS - LOCATE TSTEP CARDS IN DYNAMICS POOL.
C IF ABSENT, RETURN. OTHERWISE OPEN TRL AND WRTIE HEADER.
C
1500 CALL LOCATE (*1492,Z(BUF1),TSTEP,FLAG)
NOTRL = 1
FILE = TRL
CALL OPEN (*1493,TRL,Z(BUF2),WRTREW)
CALL FNAME (TRL,BUF)
BUF(3) = 0
CALL WRITE (TRL,BUF,3,0)
GO TO 1460
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
|
