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
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
|
SUBROUTINE SUBPH1
C
C THIS MODULE PERFORMS THE PHASE 1 CONVERSION OF NASTRAN DATA BLOCK
C TABLES TO THEIR EQUIVALENT SOF ITEMS
C
IMPLICIT INTEGER (A-Z)
EXTERNAL LSHIFT,ANDF,ORF
LOGICAL LAST
INTEGER BUF(10),TEMP(10),TYPE,SUB1(2),ICODE(32),MCB(7),
1 LTYPE1(5),LTYPE2(5),LTYPE3(5)
REAL RZ(12)
CHARACTER UFM*23,UWM*25,UIM*29,SFM*25
COMMON /XMSSG / UFM,UWM,UIM,SFM
COMMON /SYSTEM/ BSIZE,OUT
COMMON /BLANK / DRY,NAME(2),PSET,PITM
COMMON /TWO / TWO(32)
COMMON /ZZZZZZ/ Z(1)
EQUIVALENCE (RZ(1),Z(1))
DATA CASE , EQEX,USET,BGPD,CSTM,GPSE,ELSE,SCRT/
1 101 , 102 ,103 ,104 ,105 ,106 ,107 ,301 /
DATA EQSS / 4HEQSS/,ICSTM/4HCSTM/,LODS /4HLODS/,PLTS/4HPLTS/,
1 BGSS / 4HBGSS/
DATA IUA / 25 /, SUB1/4HSUBP,4HH1 /
DATA LTYPE1/ 4HEXTE,4HRNAL,4H STA,4HTIC ,4HLOAD/
DATA LTYPE2/ 4H ,4H ,4HTHER,4HMAL ,4HLOAD/
DATA LTYPE3/ 4H ELE,4HMENT,4H DEF,4HORMA,4HTION/
DATA LOAP , PAPP /4HLOAP,4HPAPP/, I0 / 0 /
C
MUA = TWO(IUA)
C
C INITIALLIZE CORE, ETC
C
IF (DRY .EQ. 0) RETURN
NC = KORSZ(Z(1))
B1 = NC - BSIZE + 1
C
C OPEN SCRATCH FILE TO WRITE CONVERTED DATA
C
B2 = B1 - BSIZE
B3 = B2 - BSIZE
BUF1 = B3 - BSIZE
BUF2 = BUF1- BSIZE
NZ = BUF2- 1
C
C TEST FOR CORE
C
IF (NZ .LE. 0) GO TO 4010
C
CALL SOFOPN (Z(B1),Z(B2),Z(B3))
C
C EQSS GENERATION
C
FILE = USET
CALL OPEN (*5001,USET,Z(BUF1),0)
CALL FWDREC (*5001,USET)
C
C READ USET INTO CORE
C
CALL READ (*5001,*20,USET,Z(1),NZ,0,NU)
C
C RAN OUT OF CORE
C
CALL CLOSE (USET,1)
GO TO 4010
C
20 CALL CLOSE (USET,1)
C
C FLAG ELEMENTS IN UA SET (SET OTHERS TO ZERO)
C
DO 40 I = 1,NU
IF (ANDF(MUA,Z(I)) .EQ. 0) GO TO 30
Z(I) = 1
GO TO 40
30 Z(I) = 0
40 CONTINUE
C
C READ SECOND RECORD OF EQEXIN - CONTAINS G AND SIL PAIRS
C
FILE = EQEX
CALL OPEN (*5001,EQEX,Z(BUF1),0)
CALL FWDREC (*5001,EQEX)
CALL FWDREC (*5001,EQEX)
C
C OPEN SCRATCH FILE TO WRITE CONVERTED DATA
C
CALL OPEN (*5001,SCRT,Z(BUF2),1)
C
C LOOP ON GRID POINTS
C
K = 0
I = 0
C
50 CALL READ (*5001,*110,EQEX,BUF,2,0,NWDS)
C = 0
I = I + 1
ISIL = BUF(2)/10
TYPE = BUF(2) - 10*ISIL
IF (TYPE-2) 60,80,4020
C
C GRID POINT, DETERMINE UA COMPONENTS, PUT IN BINARY FORM
C
60 DO 70 J = 1,6
IU = ISIL + J - 1
IF (Z(IU) .EQ. 0) GO TO 70
C = ORF(C,LSHIFT(1,J-1))
70 CONTINUE
GO TO 90
C
C SCALAR POINT
C
80 IF (Z(ISIL) .NE. 0) C = 1
C
C WRITE OUT G AND C
C
90 IF (C .EQ. 0) GO TO 100
BUF(2) = C
CALL WRITE (SCRT,BUF,2,0)
K = K + 1
100 CONTINUE
GO TO 50
C
110 MCB(1) = EQEX
CALL RDTRL (MCB)
NPTS = MCB(2)
CALL REWIND (EQEX)
CALL CLOSE (SCRT,1)
IF (NPTS*2 .GT. NZ) GO TO 4010
C
C READ FIRST RECORD OF EQEXIN - GET G AND IOLD
C READ SCRATCH - GET G AND C
C BUILD TABLE IN CORE
C
FILE = EQEX
CALL FWDREC (*5001,EQEX)
FILE = SCRT
CALL OPEN (*5001,SCRT,Z(BUF2),0)
C
C SET CORE TO ZERO
C
DO 150 I = 1,NPTS
IZP = 2*I
Z(IZP ) = 0
Z(IZP-1) = 0
150 CONTINUE
NNEW = K
C
C LOOP ON POINTS IN SCRATCH FILE, STORE C IN ITH WORD OF ENTRY
C POSITION OF ENTRY IS THE INTERNAL SEQUENCE
C
IF (K .LE. 0) GO TO 210
DO 200 I = 1,K
FILE = SCRT
CALL READ (*5001,*210,SCRT,BUF,2,0,NWDS)
FILE = EQEX
180 CALL READ (*5001,*210,EQEX,TEMP,2,0,NWDS)
IF (BUF(1)-TEMP(1)) 5001,190,180
190 IZP = 2*TEMP(2)
Z(IZP) = BUF(2)
200 CONTINUE
C
C CORE TABLE IS COMPLETE, FILL IN FIRST ENTRIES
C
210 CALL CLOSE (SCRT,1)
CALL REWIND (EQEX)
K = 0
DO 300 I = 1,NPTS
IF (Z(2*I) .EQ. 0) GO TO 300
K = K + 1
Z(2*I-1) = K
300 CONTINUE
C
C CORE NOW CONTAINS NEW IP VALUES AND C IN OLD IP POSITIONS
C
FILE = EQSS
C
C CHECK IF SUBSTRUCTURE EXISTS ALREADY
C
CALL FWDREC (*5001,EQEX)
CALL SETLVL (NAME,0,TEMP,ITEST,0)
IF (ITEST .NE. 1) WRITE (OUT,6325) UWM,NAME
ITEST = 3
CALL SFETCH (NAME,EQSS,2,ITEST)
IF (ITEST .EQ. 3) GO TO 340
WRITE (OUT,6326) UWM,NAME,EQSS
GO TO 1000
340 BUF(1) = NAME(1)
BUF(2) = NAME(2)
BUF(3) = 1
BUF(4) = NNEW
BUF(5) = NAME(1)
BUF(6) = NAME(2)
C
CALL SUWRT (BUF,6,2)
C
C PROCESS EQSS OUTPUT- G, IP, C - SORTED ON G
C
DO 400 I = 1,NPTS
C
CALL READ (*5001,*400,EQEX,TEMP,2,0,NWDS)
C
IPT = TEMP(2)*2 - 1
IF (Z(IPT) .EQ. 0) GO TO 400
TEMP(2) = Z(IPT )
TEMP(3) = Z(IPT+1)
CALL SUWRT (TEMP,3,1)
400 CONTINUE
CALL SUWRT (TEMP,0,2)
C
C BUILD SIL TABLE BY COUNTING C VALUES
C
NC = 0
IS = 1
DO 500 I = 1,NPTS
IPT = 2*I - 1
C
IF (Z(IPT) .EQ. 0) GO TO 500
IS = IS + NC
Z(IPT) = IS
C
CALL SUWRT (Z(IPT),2,1)
C
C CALCULATE NUMBER OF COMPONENTS FOR NEXT STEP
C
KCODE = Z(IPT+1)
CALL DECODE (KCODE,ICODE,NC)
500 CONTINUE
CALL SUWRT (0,0,2)
CALL SUWRT (TEMP,0,3)
1000 CALL CLOSE (EQEX,1)
C
C BGSS GENERATION
C
FILE = BGPD
CALL OPEN (*5001,BGPD,Z(BUF1),0)
CALL FWDREC (*5001,BGPD)
ITEST = 3
CALL SFETCH (NAME,BGSS,2,ITEST)
IF (ITEST .EQ. 3) GO TO 1100
WRITE (OUT,6326) UWM,NAME,BGSS
GO TO 2000
1100 CONTINUE
C
BUF(1) = NAME(1)
BUF(2) = NAME(2)
BUF(3) = NNEW
CALL SUWRT (BUF,3,2)
DO 1200 I = 1,NPTS
CALL READ (*5001,*1200,BGPD,BUF,4,0,NWDS)
C
IF (Z(2*I-1) .EQ. 0) GO TO 1200
C
CALL SUWRT (BUF,4,1)
1200 CONTINUE
CALL SUWRT (0,0,2)
CALL SUWRT (BUF,0,3)
2000 CALL CLOSE (BGPD,1)
C
C
C CSTM GENERATION
C
C
CALL OPEN (*2500,CSTM,Z(BUF1),0)
C
C CSTM EXISTS
C
CALL FWDREC (*5001,CSTM)
ITEST = 3
CALL SFETCH (NAME,ICSTM,2,ITEST)
IF (ITEST .EQ. 3) GO TO 2100
WRITE (OUT,6326) UWM,NAME,ICSTM
GO TO 2400
C
2100 BUF(1) = NAME(1)
BUF(2) = NAME(2)
CALL SUWRT (BUF,2,2)
C
C BLAST COPY
C
CALL READ (*5001,*2200,CSTM,Z(1),NZ,1,NWDS)
GO TO 4010
2200 CALL SUWRT (Z(1),NWDS,2)
CALL SUWRT (0,0,3)
2400 CALL CLOSE (CSTM,1)
C
C LODS GENERATION
C
2500 NLOD = 0
C
CALL GOPEN (CASE,Z(BUF1),0)
C
ICASE = 0
C
2600 CALL READ (*2800,*2800,CASE,Z(1),9,1,NWDS)
ICASE = ICASE + 1
IF (Z(I0+4) .EQ. 0) GO TO 2610
WRITE (OUT,6327) UIM,NAME,ICASE,LTYPE1,Z(I0+4)
Z(NLOD+10) = Z(I0+4)
GO TO 2700
2610 IF (Z(I0+7) .EQ. 0) GO TO 2620
WRITE (OUT,6327) UIM,NAME,ICASE,LTYPE2,Z(I0+7)
Z(NLOD+10) = Z(I0+7)
GO TO 2700
2620 IF (Z(I0+6) .EQ. 0) GO TO 2630
WRITE (OUT,6327) UIM,NAME,ICASE,LTYPE3,Z(I0+6)
Z(NLOD+10) = Z(I0+6)
GO TO 2700
2630 Z(NLOD+10) = 0
2700 NLOD = NLOD + 1
GO TO 2600
2800 ITEST = 3
LITM = LODS
IF (PITM .EQ. PAPP) LITM = LOAP
CALL SFETCH (NAME,LITM,2,ITEST)
IF (ITEST .EQ. 3) GO TO 2810
WRITE (OUT,6326) UWM,NAME,LITM
GO TO 2900
2810 Z( 1) = NAME(1)
Z(I0+2) = NAME(2)
Z(I0+3) = NLOD
Z(I0+4) = 1
Z(I0+5) = NAME(1)
Z(I0+6) = NAME(2)
CALL SUWRT (Z(1),6,2)
CALL SUWRT (NLOD,1,1)
CALL SUWRT (Z(I0+10),NLOD,2)
CALL SUWRT (Z(1),0,3)
2900 CALL CLOSE (CASE,1)
C
C PLOT SET DATA (PLTS) GENERATION
C
IF (PSET .LE. 0) GO TO 4000
FILE = BGPD
CALL GOPEN (BGPD,Z(BUF1),0)
C
ITEST = 3
CALL SFETCH (NAME,PLTS,2,ITEST)
IF (ITEST .EQ. 3) GO TO 3010
WRITE (OUT,6326) UWM,NAME,PLTS
CALL CLOSE (BGPD,1)
GO TO 4000
C
3010 BUF(1) = NAME(1)
BUF(2) = NAME(2)
BUF(3) = 1
BUF(4) = NAME(1)
BUF(5) = NAME(2)
CALL SUWRT (BUF,5,1)
DO 3012 I = 1,11
3012 Z(I) = 0
RZ( 4) = 1.0
RZ( 8) = 1.0
RZ(12) = 1.0
CALL SUWRT (Z,12,2)
C
CALL READ (*5001,*3020,BGPD,Z(1),NZ,0,NWDS)
GO TO 4010
3020 CALL SUWRT (Z,NWDS,2)
CALL CLOSE (BGPD,1)
FILE = EQEX
CALL GOPEN (EQEX,Z(BUF1),0)
CALL READ (*5001,*3030,EQEX,Z,NZ,1,NWDS)
GO TO 4010
3030 CALL SUWRT (Z,NWDS,2)
CALL CLOSE (EQEX,1)
FILE = GPSE
LAST = .FALSE.
CALL OPEN (*3500,GPSE,Z(BUF1),0)
C
CALL FWDREC (*3500,GPSE)
C
CALL READ (*5001,*3050,GPSE,Z(1),NZ,0,NSETS)
GO TO 4010
C
C FIND PLOT SET ID
C
3050 IF (NSETS .EQ. 0) GO TO 3500
C
DO 3060 I = 1,NSETS
IF (Z(I) .EQ. PSET) GO TO 3070
3060 CONTINUE
GO TO 3500
3070 IREC = I - 1
C
3075 IF (IREC .EQ. 0) GO TO 3090
C
C POSITION FILE TO SELECTED SET
C
DO 3080 I = 1,IREC
CALL FWDREC (*3500,FILE)
3080 CONTINUE
3090 CALL READ (*3500,*3100,FILE,Z(1),NZ,0,NWDS)
GO TO 4010
3100 CALL SUWRT (Z(1),NWDS,2)
CALL CLOSE (FILE,1)
IF (LAST) GO TO 3300
LAST = .TRUE.
FILE = ELSE
CALL OPEN (*3500,ELSE,Z(BUF1),0)
CALL FWDREC (*3500,ELSE)
GO TO 3075
C
C FINISHED
C
3300 CALL SUWRT (Z(1),0,3)
GO TO 4000
3500 CALL CLOSE (FILE,1)
WRITE (OUT,3510) UWM,PSET
3510 FORMAT (A25,' 6050, REQUESTED PLOT SET NO.',I8,
1 ' HAS NOT BEEN DEFINED')
C
4000 CALL SOFCLS
WRITE (OUT,6361) UIM,NAME
6361 FORMAT (A29,' 6361, PHASE 1 SUCCESSFULLY EXECUTED FOR ',
1 'SUBSTRUCTURE ',2A4)
RETURN
C
C INSUFFICIENT CORE
C
4010 WRITE (OUT,4015) UFM,NZ
4015 FORMAT (A23,' 6011, INSUFFICIENT CORE TO LOAD TABLES', /5X,
1 'IN MODULE SUBPH1, CORE =',1I8)
DRY = -2
GO TO 6000
C
C BAD GRID POINT TYPE (IE AXISYMMETRIC OR)
C
4020 WRITE (OUT,4035) UFM,BUF(1)
4035 FORMAT (A23,' 6013 , ILLEGAL TYPE OF POINT DEFINED FOR ',
1 'SUBSTRUCTURE ANALYSIS.', /5X,'POINT NUMBER =',I9)
GO TO 6000
C
C BAD FILE
C
5001 WRITE (OUT,5005) SFM,FILE
5005 FORMAT (A25,' 6012, FILE =',I4,' IS PURGED OR NULL AND IS ',
1 'REQUIRED IN PHASE 1 SUBSTRUCTURE ANALYSIS.')
C
6000 CALL SOFCLS
CALL MESAGE (-61,0,SUB1)
RETURN
C
C
6325 FORMAT (A25,' 6325, SUBSTRUCTURE PHASE 1, BASIC SUBSTRUCTURE ',
1 2A4,' ALREADY EXISTS ON SOF.', /32X,
2 'ITEMS WHICH ALREADY EXIST WILL NOT BE REGENERATED.')
6326 FORMAT (A25,' 6326, SUBSTRUCTURE ',2A4,', ITEM ',A4,
1 ' ALREADY EXISTS ON SOF.')
6327 FORMAT (A29,' 6327, SUBSTRUCTURE ',2A4,' SUBCASE',I9,
1 ' IS IDENTIFIED BY', /36X,5A4,' SET',I9,' IN LODS ITEM.',
2 /36X,'REFER TO THIS NUMBER ON LOADC CARDS.')
END
|
