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
|
SUBROUTINE SETEQ (NAME1,NAME2,PREFX,DRY2,ITEST,IMORE,LIM)
C
C SETS THE SUBSTRUCTURE NAME2 EQUIVALENT TO THE SUBSTRUCTURE NAME1.
C THE OUTPUT VARIABLE ITEST TAKES ON ONE OF THE FOLLOWING VALUES
C
C 4 IF NAME1 DOES NOT EXIST
C 8 IF DRY DOES NOT EQUAL ZERO AND NAME2 OR ONE OF THE NEW
C NAMES ALREADY EXISTS
C 9 IF DRY IS EQUAL TO ZERO AND NAME2 OR ONE OF THE NEW NAMES
C DOES NOT EXIST
C 1 OTHERWISE
C
IMPLICIT INTEGER (A-Z)
EXTERNAL LSHIFT,RSHIFT,ANDF,ORF,COMPLF
LOGICAL DITUP,MDIUP,MORE
DIMENSION NAME1(2),NAME2(2),ISAVE(50),NAMNEW(2),
1 IMORE(1),NMSBR(2)
CHARACTER UFM*23,UWM*25,UIM*29
COMMON /XMSSG / UFM,UWM,UIM
COMMON /MACHIN/ MACH,IHALF,JHALF
COMMON /ZZZZZZ/ BUF(1)
COMMON /SOF / DIT,DITPBN,DITLBN,DITSIZ,DITNSB,DITBL,
1 IO ,IODUM(7),MDI,MDIPBN,MDILBN,MDIBL,
2 NXTDUM(15),DITUP,MDIUP
COMMON /SYS / BLKSIZ,DIRSIZ,SYS(3),IFRST
COMMON /OUTPUT/ TITLE(96),SUBTIT(96)
COMMON /SYSTEM/ NBUFF,NOUT,DUM(36),NBPC,NBPW,NCPW
COMMON /ITEMDT/ NITEM,ITEM(7,1)
DATA PS, SS, IB, LL, CS, HL, BB, IRD, IWRT, INDSBR /
1 1 , 1 , 1 , 2, 2, 2, 1, 1, 2, 15 /
DATA IEMPTY, MASK, NMSBR /
2 4H , 4HMASK, 4HSETE,4HQ /
C
CALL CHKOPN (NMSBR(1))
IF (NITEM+IFRST-1 .GT. 50) GO TO 970
DRY = DRY2
ITEST = 1
CALL FDSUB (NAME1(1),IND1)
IF (IND1 .EQ. -1) GO TO 900
MASK = ANDF(MASK,2**(NBPW-4*NBPC)-1)
MASKSS = COMPLF(LSHIFT(1023,10))
MASKLL = COMPLF(LSHIFT(1023,20))
MASKBB = LSHIFT(1023,20)
C
C IF NAME2 EXISTS - VERIFY THAT IT IS MARKED EQUIVALENT TO NAME1.
C NAME2 MAY ALREADY EXIST FOR RUN=GO OR OPTIONS=PA
C
CALL FDSUB (NAME2(1),IND2)
IF (IND2 .EQ. -1) GO TO 10
DRY = 0
C
CALL FMDI (IND2,IMDI)
IPS = ANDF(BUF(IMDI+PS),1023)
IF (IPS .EQ. 0) GO TO 920
IF (IPS .EQ. IND1) GO TO 10
CALL FMDI (IND1,IMDI)
IPP = ANDF(BUF(IMDI+PS),1023)
IF (IPS .NE. IPP) GO TO 920
C
C STEP 1. MAKE A LIST OF ALL THE SUBSTRUCTURES CONTRIBUTING TO THE
C SUBSTRUCTURE NAME1, AND STORE IT IN THE ARRAY IMORE
C
10 ITOP = 1
IMORE(ITOP) = IND1
IPTR = 1
20 CALL FMDI (IND1,IMDI)
I = BUF(IMDI+LL)
INDLL = RSHIFT(ANDF(I,1073741823),20)
INDCS = RSHIFT(ANDF(I,1048575) ,10)
IF (INDLL .EQ. 0) GO TO 40
DO 30 J = 1,ITOP
IF (IMORE(J) .EQ. INDLL) GO TO 40
30 CONTINUE
ITOP = ITOP + 1
IF (ITOP .GT. LIM) GO TO 960
IMORE(ITOP) = INDLL
40 IF (INDCS.EQ.0 .OR. IPTR.EQ.1) GO TO 60
DO 50 J = 1,ITOP
IF (IMORE(J) .EQ. INDCS) GO TO 60
50 CONTINUE
ITOP = ITOP + 1
IF (ITOP .GT. LIM) GO TO 960
IMORE(ITOP) = INDCS
60 IF (IPTR .EQ. ITOP) GO TO 100
IPTR = IPTR + 1
IND1 = IMORE(IPTR)
GO TO 20
C
C STEP 2. CREATE AN IMAGE SUBSTRUCTURE FOR EACH SUBSTRUCTURE IN THE
C ARRAY IMORE, AND STORE ITS INDEX IN THE ARRAY IMAGE. NOTE THAT
C SINCE IMORE(1) CONTAINS THE INDEX OF NAME1, IMAGE(1) WILL CONTAIN
C THE INDEX OF NAME2
C FOR EACH NEW NAME CHECK THAT MAKING ROOM FOR THE PREFIX DOES NOT
C TRUNCATE THE NAME
C
100 IF (IPTR .NE. 1) GO TO 110
CALL FDSUB (NAME2(1),I)
GO TO 120
110 CALL FDIT (IND1,IDIT)
FIRST = KLSHFT(KRSHFT(PREFX,NCPW-1),NCPW-1)
REST = KLSHFT(KRSHFT(BUF(IDIT),NCPW-3),NCPW-4)
NAMNEW(1) = ORF(ORF(FIRST,REST),MASK)
FIRST = KLSHFT(KRSHFT(BUF(IDIT),NCPW-4),NCPW-1)
REST = KLSHFT(KRSHFT(BUF(IDIT+1),NCPW-3),NCPW-4)
NAMNEW(2)= ORF(ORF(FIRST,REST),MASK)
IF (KHRFN1(IEMPTY,4,BUF(IDIT+1),4) .NE. IEMPTY)
1 WRITE (NOUT,850) UWM,NAMNEW,BUF(IDIT),BUF(IDIT+1)
CALL FDSUB (NAMNEW(1),I)
120 IF (DRY .NE. 0) GO TO 130
IF (I .NE.-1) GO TO 170
GO TO 910
130 IF (I .EQ. -1) GO TO 150
IPTR = IPTR + 1
IF (IPTR .GT. ITOP) GO TO 920
DO 140 I = IPTR,ITOP
IMAGE = IMORE(LIM+I)
CALL FDIT (IMAGE,IDIT)
BUF(IDIT ) = IEMPTY
BUF(IDIT+1) = IEMPTY
DITUP = .TRUE.
140 CONTINUE
GO TO 920
150 IF (IPTR .NE. 1) GO TO 160
CALL CRSUB (NAME2(1),I)
GO TO 170
160 CALL CRSUB (NAMNEW(1),I)
170 IMORE(IPTR+LIM) = I
IF (IPTR .EQ. 1) GO TO 200
IPTR = IPTR - 1
IND1 = IMORE(IPTR)
GO TO 100
C
C STEP 3. BUILD THE MDI OF NAME2, AND OF ALL IMAGE SUBSTRUCTURES
C
200 IND2 = I
210 CALL FMDI (IND1,IMDI)
DO 220 J = 1,DIRSIZ
ISAVE(J) = BUF(IMDI+J)
220 CONTINUE
C
C SET THE SS ENTRY FOR THE SUBSTRUCTURE WITH INDEX IND1
C
IF (DRY .EQ. 0) GO TO 230
BUF(IMDI+SS) = ORF(ANDF(BUF(IMDI+SS),MASKSS),LSHIFT(IND2,10))
MDIUP = .TRUE.
230 CALL FMDI (IND2,IMDI)
IF (DRY .EQ. 0) GO TO 420
I = ISAVE(PS)
C
C SET THE PS ENTRY FOR THE SUBSTRUCTURE WITH INDEX IND2
C
IPS = ANDF(I,1023)
IF (IPS .EQ. 0) GO TO 240
BUF(IMDI+PS) = IPS
GO TO 250
240 BUF(IMDI+PS) = IND1
C
C SET THE SS ENTRY FOR THE SUBSTRUCTURE WITH INDEX IND2
C
250 ISS = RSHIFT(ANDF(I,1048575),10)
IF (ISS .EQ. 0) GO TO 260
BUF(IMDI+SS) = ORF(ANDF(BUF(IMDI+SS),MASKSS),LSHIFT(ISS,10))
C
C SET THE BB ENTRY FOR THE SUBSTRUCTURE WITH INDEX IND2
C
260 IBS = ANDF(I,MASKBB)
BUF(IMDI+BB) = ORF(ANDF(BUF(IMDI+BB),MASKLL),IBS)
I = ISAVE(LL)
C
C SET THE HL ENTRY FOR THE SUBSTRUCTURE WITH INDEX IND2
C
IF (IPTR .EQ. 1) GO TO 300
IHL = ANDF(I,1023)
IF (IHL.EQ.0) GO TO 280
ASSIGN 270 TO IRET
IWANT = IHL
GO TO 320
270 BUF(IMDI+HL) = IFND
C
C SET THE CS ENTRY FOR THE SUBSTRUCTURE WITH INDEX IND2
C
280 ICS = RSHIFT(ANDF(I,1048575),10)
IF (ICS .EQ. 0) GO TO 300
ASSIGN 290 TO IRET
IWANT = ICS
GO TO 320
290 BUF(IMDI+CS) = ORF(ANDF(BUF(IMDI+CS),MASKSS),LSHIFT(IFND,10))
C
C SET THE LL ENTRY FOR THE SUBSTRUCTURE WITH INDEX IND2
C
300 ILL = RSHIFT(ANDF(I,1073741823),20)
IF (ILL .EQ. 0) GO TO 400
ASSIGN 310 TO IRET
IWANT = ILL
GO TO 320
310 BUF(IMDI+LL) = ORF(ANDF(BUF(IMDI+LL),MASKLL),LSHIFT(IFND,20))
GO TO 400
C
C FIND THE INDEX OF THE IMAGE SUBSTRUCTURE TO THE SUBSTRUCTURE WITH
C INDEX IWANT. STORE THE FOUND INDEX IN IFND
C
320 DO 330 K = 1,ITOP
IF (IMORE(K) .NE. IWANT) GO TO 330
IFND = IMORE(LIM+K)
GO TO IRET, (270,290,310)
330 CONTINUE
GO TO 930
C
C SET THE POINTERS OF THE ITEMS BELONGING TO THE SUBSTRUCTURE WITH
C INDEX IND2
C
400 DO 410 J = IFRST,DIRSIZ
410 BUF(IMDI+J) = 0
420 IF (IPTR .EQ. 1) GO TO 440
C
C IMAGE SUBSTRUCTURE - SET POINTERS TO SHARED ITEMS AND SET IB BIT
C
DO 430 J = 1,NITEM
IF (ITEM(4,J) .NE. 0) GO TO 430
ITM = J + IFRST - 1
IF (BUF(IMDI+ITM) .EQ. 0) BUF(IMDI+ITM) = ISAVE(ITM)
430 CONTINUE
BUF(IMDI+IB) = ORF(BUF(IMDI+IB),LSHIFT(1,30))
GO TO 500
C
C SECONDARY SUBSTRUCTURE - SET POINTERS TO SHARED ITEMS
C
440 DO 450 J = 1,NITEM
IF (ITEM(5,J) .NE. 0) GO TO 450
ITM = J + IFRST - 1
IF (BUF(IMDI+ITM) .EQ. 0) BUF(IMDI+ITM) = ISAVE(ITM)
450 CONTINUE
C
C COPY APPROPRIATE ITEMS OF NAME1 AND WRITE THEM FOR
C NAME2 AFTER CHANGING NAME1 TO NAME2 AND INSERTING THE NEW PREFIX
C TO THE NAMES OF ALL CONTRIBUTING SUBSTRUCTURES
C
500 DO 700 J = 1,NITEM
IF (ITEM(3,J) .EQ. 0) GO TO 700
KK = J + IFRST - 1
IF (BUF(IMDI+KK) .NE. 0) GO TO 700
IRDBL = ANDF(ISAVE(KK),JHALF)
IF (IRDBL.NE.0 .AND. IRDBL.NE.JHALF) GO TO 510
BUF(IMDI+KK) = ISAVE(KK)
GO TO 700
510 CALL SOFIO (IRD,IRDBL,BUF(IO-2))
CALL FDIT (IND2,IDIT)
BUF(IO+1) = BUF(IDIT )
BUF(IO+2) = BUF(IDIT+1)
CALL GETBLK (0,IWRTBL)
IF (IWRTBL .EQ. -1) GO TO 940
NEWBLK = IWRTBL
NUMB = ITEM(3,J)/1000000
MIN = (ITEM(3,J) - NUMB*1000000)/1000
INC = ITEM(3,J) - NUMB*1000000 - MIN*1000
NUMB = BUF(IO+NUMB)
IF (NUMB.GT.1 .OR. ILL.NE.0 .OR. IPTR.NE.1) GO TO 530
C
C BASIC SUBSTRUCTURE
C
BUF(IO+MIN ) = NAME2(1)
BUF(IO+MIN+1) = NAME2(2)
MORE = .FALSE.
GO TO 580
C
C NOT A BASIC SUBSTRUCTURE
C
530 IF (NUMB .LE. (BLKSIZ-MIN+1)/INC) GO TO 540
NUMB = NUMB - (BLKSIZ-MIN+1)/INC
MAX = BLKSIZ
MORE = .TRUE.
GO TO 550
540 MAX = MIN + INC*NUMB - 1
MORE = .FALSE.
C
C INSERT THE NEW PREFIX TO THE NAMES OF ALL CONTRIBUTING SUBSTRUC-
C TURES
C IF THE COMPONENT IS FOR MODAL DOF ON THE SECONDARY SUBSTRUCTURE,
C USE THE ACTUAL NAME INSTEAD OF ADDING A PREFIX
C
550 DO 570 K = MIN,MAX,INC
IF (BUF(IO+K).EQ.NAME1(1) .AND. BUF(IO+K+1).EQ.NAME1(2))
1 GO TO 560
FIRST = KLSHFT(KRSHFT(PREFX,NCPW-1),NCPW-1)
REST = KLSHFT(KRSHFT(BUF(IO+K ),NCPW-3),NCPW-4)
FIRST2= KLSHFT(KRSHFT(BUF(IO+K ),NCPW-4),NCPW-1)
REST2 = KLSHFT(KRSHFT(BUF(IO+K+1),NCPW-3),NCPW-4)
BUF(IO+K ) = ORF(ORF(FIRST ,REST ),MASK)
BUF(IO+K+1) = ORF(ORF(FIRST2,REST2),MASK)
GO TO 570
C
560 BUF(IO+K ) = NAME2(1)
BUF(IO+K+1) = NAME2(2)
570 CONTINUE
C
C WRITE OUT UPDATED DATA BLOCK
C
580 CALL SOFIO (IWRT,IWRTBL,BUF(IO-2))
CALL FNXT (IRDBL,INXT)
IF (MOD(IRDBL,2) .EQ. 1) GO TO 590
NEXT = ANDF(RSHIFT(BUF(INXT),IHALF),JHALF)
GO TO 600
590 NEXT = ANDF(BUF(INXT),JHALF)
600 IF (NEXT .EQ. 0) GO TO 620
C
C MORE BLOCKS TO COPY
C
IRDBL = NEXT
CALL GETBLK (IWRTBL,NEXT)
IF (NEXT.NE.-1) GO TO 610
CALL RETBLK (NEWBLK)
GO TO 940
610 IWRTBL = NEXT
CALL SOFIO (IRD,IRDBL,BUF(IO-2))
MIN = 1
IF (MORE) GO TO 530
GO TO 580
C
C NO MORE BLOCKS TO COPY. UPDATE MDI OF NAME2
C
620 BUF(IMDI+KK) = ORF(LSHIFT(RSHIFT(ISAVE(KK),IHALF),IHALF),NEWBLK)
700 CONTINUE
C
MDIUP = .TRUE.
IF (IPTR .EQ. ITOP) GO TO 720
IPTR = IPTR + 1
IND1 = IMORE(IPTR )
IND2 = IMORE(IPTR+LIM)
GO TO 210
C
C WRITE USER MESSAGES
C
720 IF(DRY .EQ. 0) GO TO 780
DO 730 I = 1,96
730 SUBTIT(I) = IEMPTY
CALL PAGE
CALL PAGE2 (-4)
WRITE (NOUT,800) NAME2,NAME1
IMAGE = IMORE(LIM+1)
CALL FMDI (IMAGE,IMDI)
IPS = ANDF(BUF(IMDI+1),1023)
CALL FDIT (IPS,I)
CALL PAGE2 (-2)
WRITE (NOUT,810) NAME2,BUF(I),BUF(I+1)
IPTR = 2
IF (IPTR .GT. ITOP) GO TO 990
CALL PAGE2 (-2)
WRITE (NOUT,820)
740 DO 750 I = 1,16
750 IMORE(I) = IEMPTY
J = 1
760 IMAGE = IMORE(IPTR+LIM)
CALL FDIT (IMAGE,I)
IMORE(J ) = BUF(I )
IMORE(J+1) = BUF(I+1)
IPTR = IPTR + 1
IF (IPTR .GT. ITOP) GO TO 770
J = J + 2
IF (J .LT. 16) GO TO 760
770 CALL PAGE2 (-2)
WRITE (NOUT,830) (IMORE(J),J=1,16)
IF (IPTR .LE. ITOP) GO TO 740
GO TO 990
C
C DRY RUN - PRINT MESSAGE INDICATING ONLY ADDITIONS MADE
C
780 CALL PAGE2 (-3)
WRITE (NOUT,840) UIM,NAME2,NAME1,NAME2
GO TO 990
C
800 FORMAT (32X,67HS U B S T R U C T U R E E Q U I V A L E N C E O
1 P E R A T I O N ,///23X,13HSUBSTRUCTURE ,2A4,56H HAS BEEN CREATED
2 AND MARKED EQUIVALENT TO SUBSTRUCTURE ,2A4)
810 FORMAT (1H0,22X,28HTHE PRIMARY SUBSTRUCTURE OF ,2A4,4H IS ,2A4)
820 FORMAT (1H0,22X, 56HTHE FOLLOWING IMAGE SUBSTRUCTURES HAVE BEEN GE
1NERATED --)
830 FORMAT (1H0,22X,10(2A4,2X))
840 FORMAT (A29,' 6228, SUBSTRUCTURE ',2A4,' IS ALREADY AN EQUIVALENT'
1, ' SUBSTRUCTURE TO ',2A4, /36X,'ONLY ITEMS NOT PREVIOUSLY ',
2 'EXISTING FOR ',2A4,' HAVE BEEN MADE EQUIVALENT.')
850 FORMAT (A25,' 6236, DURING THE CREATION OF A NEW IMAGE SUBSTRUC',
1 'TURE NAMED ',2A4,' THE LAST CHARACTER ', /5X,
2 'OF SUBSTRUCTURE NAMED ',2A4,' WAS TRUNCATED TO MAKE ROOM',
3 ' FOR THE PREFIX.')
C
C ERROR CONDITIONS
C
900 ITEST = 4
GO TO 990
910 ITEST = 9
GO TO 990
920 ITEST = 8
GO TO 990
930 CALL ERRMKN (INDSBR,3)
940 WRITE (NOUT,950) UFM
950 FORMAT (A23,' 6223, SUBROUTINE SETEQ - THERE ARE NO MORE FREE ',
1 'BLOCKS AVAILABLE ON THE SOF.')
K = -37
GO TO 980
960 K = -8
GO TO 980
970 CALL ERRMKN (INDSBR,10)
980 CALL SOFCLS
CALL MESAGE (K,0,NMSBR)
C
990 RETURN
END
|
