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
|
SUBROUTINE COMB2
C
C COMB2 PERFORMS THE TRANSFORMATION AND ADDITION OF STIFFNESS, MASS,
C OR LOAD MATRICES FOR THE PHASE 2 SUBSTRUCTURE COMBINE OPERATION
C
C NOVEMBER 1973
C
C
LOGICAL ADDFLG
INTEGER TFLAG ,SIGNAB ,SIGNC ,PREC ,
1 SCR1 ,SCR2 ,SCR3 ,SCR4 ,SCR5 ,
2 RULE ,TYPIN ,TYPOUT ,ACOMB ,AMCB(7,7) ,
3 HMCB(6,7),SOF1 ,SOF2 ,SOF3 ,DRY ,
4 BUF1 ,RDSOF ,RC ,USE ,HORG ,
5 PVEC ,RFILES ,IZ(1) ,RECT ,RSP ,
6 NAME(2) ,RSOFAR ,KMP(5) ,TYPE ,KMPITM(5) ,
7 BLANK ,SYSBUF ,CPV(7) ,RPV(7) ,SCR6 ,
8 XXXX ,SCR7 ,PORA ,PAPP
DOUBLE PRECISION DBZ(1)
DIMENSION MCBTRL(7)
CHARACTER UFM*23 ,UWM*25 ,UIM*29 ,SFM*25
COMMON /XMSSG / UFM ,UWM ,UIM ,SFM
COMMON /BLANK / DRY ,TYPE(2) ,PORA(2) ,NAMESS(2,7),
1 ACOMB ,USE(14) ,RFILES(3) ,KK ,
2 KN ,JN
COMMON /SYSTEM/ SYSBUF ,NOUT
COMMON /NAMES / RD ,RDREW ,WRT ,WRTREW ,
1 REW ,NOREW ,EOFNRW ,RSP ,
2 RDP ,CSP ,CDP ,SQUARE ,
3 RECT
COMMON /PACKX / TYPIN ,TYPOUT ,IROW ,NROW ,
1 INCR
COMMON /PARMEG/ MCBP(7) ,MCBP11(7) ,MCBP21(7) ,MCBP12(7) ,
1 MCBP22(7) ,MRGZ ,RULE
COMMON /MPY3TL/ MCBA2(7) ,MCBB2(7) ,MCBC2(7) ,MCBD2(7) ,
1 SCR5 ,SCR6 ,SCR7 ,LKORE ,
2 ICODE ,IPREC ,DUMMY(13)
COMMON /MPYADX/ MCBA(7) ,MCBB(7) ,MCBC(7) ,MCBD(7) ,
1 LCORE ,TFLAG ,SIGNAB ,SIGNC ,
2 PREC ,MSCR ,DUMM
COMMON /ZZZZZZ/ Z(1)
EQUIVALENCE (DBZ(1),Z(1),IZ(1)),(PVEC,KMPITM(3))
DATA NAME / 4HCOMB,4H2 /
DATA HORG / 4HHORG /
DATA BLANK / 4H /
DATA XXXX / 4HXXXX /
DATA PAPP / 4HPAPP /
DATA KMP / 4HK , 4HM , 4HP , 4HB , 4HK4 /
DATA KMPITM / 4HKMTX, 4HMMTX, 4HPVEC, 4HBMTX, 4HK4MX /
C
C INITIALIZE
C
DO 5 I = 1,14
IF (NAMESS(I,1).EQ.XXXX .OR. NAMESS(I,1).EQ.0) NAMESS(I,1) = BLANK
5 CONTINUE
ACOMB = 201
SCR1 = 301
SCR2 = 302
SCR3 = 303
SCR4 = 304
SCR5 = 305
SCR6 = 306
SCR7 = 307
SIGNAB= 1
SIGNC = 1
PREC = 0
MSCR = SCR5
ICODE = 0
RULE = 0
RDSOF = 1
NOGO = 0
RFILES(1) = ACOMB
NSIZE = 0
MCBP21(1) = 0
MCBP22(1) = 0
RSOFAR = 0
KN = 1
JN =-1
DO 10 I = 1,5
IF (TYPE(1) .EQ. KMP(I)) GO TO 20
10 CONTINUE
WRITE (NOUT,6302) SFM,TYPE
IF (DRY .LT. 0) RETURN
C
DRY =-2
ITEM = 0
GO TO 30
20 ITEM = KMPITM(I)
IF (ITEM .EQ. PVEC) ITEM = PORA(1)
IF (DRY .LT. 0) RETURN
C
30 LCORE = KORSZ(Z) - 1
LKORE = LCORE
BUF1 = LCORE - SYSBUF + 1
SOF1 = BUF1 - SYSBUF
SOF2 = SOF1 - SYSBUF - 1
SOF3 = SOF2 - SYSBUF
IF (SOF3 .GT. 0) GO TO 40
CALL MESAGE (8,0,NAME)
DRY =-2
RETURN
C
40 CALL SOFOPN (Z(SOF1),Z(SOF2),Z(SOF3))
C
C GRAB THE MATRIX CONTROL BLOCKS
C
NMAT = 0
DO 170 I = 1,7
IF (NAMESS(1,I) .EQ. BLANK) GO TO 170
AMCB(1,I) = 100 + I
CALL RDTRL (AMCB(1,I))
IF (AMCB(1,I) .GT. 0) GO TO 135
C
C NO GINO FILE. CHECK SOF
C
CALL SOFTRL (NAMESS(1,I),ITEM,AMCB(1,I))
RC = AMCB(1,I)
GO TO (130,110,115,120,120), RC
110 NOGO = 1
WRITE (NOUT,6301) SFM,NAMESS(1,I),NAMESS(2,I),ITEM
GO TO 170
115 IF (TYPE(1) .EQ. KMP(3)) GO TO 170
120 NOGO = 1
CALL SMSG (RC-2,ITEM,NAMESS(1,I))
GO TO 170
C
C MATRIX FOUND ON SOF
C
130 CONTINUE
AMCB(1,I) = 0
C
C GRAB THE MCB OF THE TRANSFORMATION MATRIX
C
135 CALL SOFTRL (NAMESS(1,I),HORG,MCBTRL)
RC = MCBTRL(1)
GO TO (160,140,150,155,155), RC
140 NOGO = 1
CALL SMSG (1,HORG,NAMESS(1,I))
GO TO 170
150 NOGO = 1
WRITE (NOUT,6303) SFM,NAMESS(1,I),NAMESS(2,I)
GO TO 170
155 NOGO = 1
CALL SMSG (RC-2,HORG,NAMESS(1,I))
GO TO 170
160 DO 161 IT = 1,6
161 HMCB(IT,I) = MCBTRL(IT+1)
NMAT = NMAT + 1
USE(2*NMAT-1) = I
DEN = FLOAT(AMCB(7,I))/10000.
USE(2*NMAT) = AMCB(2,I)*AMCB(3,I)*DEN
C
C CHECK COMPATIBILITY OF DIMENSIONS
C
IF (NSIZE .EQ. 0) NSIZE = HMCB(1,I)
IF (HMCB(1,I).EQ.NSIZE .AND. HMCB(2,I).EQ.AMCB(2,I) .AND.
1 HMCB(2,I).EQ.AMCB(3,I)) GO TO 170
IF (ITEM.EQ.PVEC .OR. ITEM.EQ.PAPP .AND. HMCB(1,I).EQ.NSIZE .AND.
1 HMCB(2,I).EQ.AMCB(3,I)) GO TO 170
NOGO = 1
WRITE (NOUT,6304) SFM,I,NAMESS(1,I),NAMESS(2,I)
170 CONTINUE
IF (NOGO .EQ. 0) GO TO 175
C
174 DRY =-2
WRITE (NOUT,177) AMCB,HMCB
177 FORMAT ('0*** COMB2 MATRIX TRAILER DUMP',
1 //7(4X,7I10/), /7(11X,6I10/))
GO TO 9999
C
175 IF (NMAT .EQ. 0) GO TO 9999
C
C DETERMINE PRECISION FOR FINAL MATRIX
C
IPRC = 1
ITYP = 0
DO 176 I = 1,NMAT
IF (AMCB(5,I).EQ.2 .OR. AMCB(5,I).EQ.4) IPRC = 2
IF (AMCB(5,I) .GE. 3) ITYP = 2
176 CONTINUE
IPREC = ITYP + IPRC
C
IF (ITEM.EQ.PVEC .OR. ITEM.EQ.PAPP) GO TO 300
C ******
C *
C PROCESS STIFFNESS, MASS OR DAMPING MATRICES *
C *
C ******
C
C IF NMAT IS ODD, PUT FIRST RESULT ON ACOMB. IF EVEN, PUT IT ON
C SCR4. FINAL RESULT WILL THEN BE ON ACOMB.
C
CALL SORT (0,0,2,2,USE,2*NMAT)
IRF = 1
IF ((NMAT/2)*2 .EQ. NMAT) IRF = 2
IFORM = 6
RFILES(2) = SCR4
ADDFLG =.FALSE.
C
DO 230 KK = 1,NMAT
J = 2*KK - 1
JN = JN + 2
INUSE = USE(JN)
C
C MOVE TRANSFORMATION MATRIX TO SCR2
C
CALL MTRXI (SCR2,NAMESS(1,INUSE),HORG,Z(BUF1),RC)
C
C IF INPUT MATRIX IS ON SOF, MOVE IT TO SCR1
C
MCBB2(1) = 100 + INUSE
IF (AMCB(1,INUSE) .GT. 0) GO TO 180
MCBB2(1) = SCR1
CALL MTRXI (SCR1,NAMESS(1,INUSE),ITEM,Z(BUF1),RC)
C
C PERFORM TRIPLE MULTIPLY H(T)*INPUT*H
C
180 CALL SOFCLS
MCBA2(1) = SCR2
MCBC2(1) = 0
IF (ADDFLG) MCBC2(1) = RFILES(3-IRF)
ADDFLG = .TRUE.
DO 190 J = 2,7
MCBA2(J) = HMCB(J-1,INUSE)
MCBB2(J) = AMCB(J,INUSE)
190 CONTINUE
IF (MCBB2(4) .LE. 2) IFORM = MCBB2(4)
CALL MAKMCB (MCBD2,RFILES(IRF),HMCB(1,INUSE),IFORM,IPREC)
C
CALL MPY3DR (Z)
C
CALL WRTTRL (MCBD2)
DO 220 J = 2,7
220 MCBC2(J) = MCBD2(J)
IRF = 3 - IRF
CALL SOFOPN (Z(SOF1),Z(SOF2),Z(SOF3))
230 CONTINUE
GO TO 9999
C ******
C *
C PROCESS LOAD MATRICES *
C *
C**** ******
300 MCBC(1) = 0
MCBA(1) = SCR2
TFLAG = 1
MRGZ = LCORE
PREC = 0
C
C SELECT FIRST RESULT FILE SO THAT FINAL RESULT WILL WIND UP ON
C ACOMB
C
RFILES(2) = SCR3
RFILES(3) = SCR4
IRF = 1
IF (NMAT.EQ.2 .OR. NMAT.EQ.5) IRF = 2
IF (NMAT.EQ.3 .OR. NMAT.EQ.6) IRF = 3
IF (NMAT .EQ. 1) MCBP(1) = ACOMB
C
C CREATE COLUMN PARTITIONING VECTOR FOR ALL MERGES
C (VECTOR IS ALWAYS NULL)
C
CALL MAKMCB (CPV,SCR6,NSIZE,RECT,RSP)
TYPIN = RSP
TYPOUT = RSP
IROW = 1
NROW = 1
INCR = 1
CALL GOPEN (SCR6,Z(BUF1),WRTREW)
CALL PACK (0,SCR6,CPV)
CALL CLOSE (SCR6,REW)
ADDFLG =.TRUE.
C
DO 400 KK = 1,NMAT
INUSE = USE(2*KK-1)
C
C COPY TRANSFORMATION MATRIX TO SCR2
C
CALL MTRXI (SCR2,NAMESS(1,INUSE),HORG,Z(BUF1),RC)
C
C IF LOAD MATRIX IS ON SOF, COPY IT TO SCR1
C
MCBB(1) = 100 + INUSE
IF (AMCB(1,INUSE) .GT. 0) GO TO 330
MCBB(1) = SCR1
CALL MTRXI (SCR1,NAMESS(1,INUSE),ITEM,Z(BUF1),RC)
C
C MULTIPLY (HT * A) AND STORE RESULT ON RFILES(IRF)
C (ACOMB,SCR3, OR SCR4)
C
330 CALL SOFCLS
DO 340 J = 2,7
MCBA(J) = HMCB(J-1,INUSE)
MCBB(J) = AMCB(J,INUSE)
340 CONTINUE
IF (MCBB(6).EQ.0 .OR. MCBA(3).EQ.MCBB(3)) GO TO 350
I = KK
NOGO = 1
WRITE (NOUT,6304) SFM,I,NAMESS(1,I),NAMESS(2,I)
GO TO 174
350 CALL MAKMCB (MCBD,RFILES(IRF),HMCB(1,INUSE),RECT,IPREC)
C
CALL MPYAD (Z,Z,Z)
C
IF (ADDFLG) GO TO 390
C
C COMPUTE ROW PARTITIONING VECTOR TO MERGE RESULT OF THIS MULTIPLY
C WITH ALL PREVIOUS RESULTS
C
K = AMCB(2,INUSE)
CALL MAKMCB (RPV,SCR5,RSOFAR+K,RECT,RSP)
IF (K .GT. LCORE) GO TO 9008
DO 360 J = 1,K
360 Z(J) = 1.0E0
TYPIN = RSP
TYPOUT= RSP
IROW = RSOFAR + 1
NROW = RSOFAR + K
INCR = 1
CALL GOPEN (SCR5,Z(BUF1),WRTREW)
CALL PACK (Z,SCR5,RPV)
CALL CLOSE (SCR5,REW)
C
C MERGE MATRICES STORE RESULT ON NEXT AVAILABLE RFILE
C
J = MOD(IRF,3) + 1
CALL MAKMCB (MCBP,RFILES(J),NSIZE,RECT,IPREC)
MCBP(2) = RPV(3)
J = MOD(J,3) + 1
MCBP11(1) = RFILES(J)
MCBP12(1) = RFILES(IRF)
DO 380 J = 2,7
MCBP11(J) = MCBP(J)
MCBP12(J) = MCBD(J)
380 CONTINUE
C
CALL MERGE (RPV,CPV,Z)
C
IRF = MOD(IRF,3) + 1
GO TO 395
390 DO 391 J = 2,7
391 MCBP(J) = MCBD(J)
395 RSOFAR = RSOFAR + AMCB(2,INUSE)
ADDFLG =.FALSE.
IRF = MOD(IRF,3) + 1
CALL SOFOPN (Z(SOF1),Z(SOF2),Z(SOF3))
400 CONTINUE
CALL WRTTRL (MCBP)
GO TO 9999
C
C DIAGNOSTICS
C
6301 FORMAT (A25,' 6301, DATA MISSING IN GO MODE FOR SUBSTRUCTURE ',
1 2A4,' ITEM ',A4)
6302 FORMAT (A25,' 6302, ',2A4,' IS ILLEGAL MATRIX TYPE FOR MODULE ',
1 'COMB2')
6303 FORMAT (A25,' 6303, H OR G TRANSFORMATION MATRIX FOR SUBSTRUCTURE'
1, 1X,2A4,' CANNOT BE FOUND ON SOF')
6304 FORMAT (A25,' 6304, MODULE COMB2 INPUT MATRIX NUMBER ',I2,
1 ' FOR SUBSTRUCTURE ,2A4,28H HAS INCOMPATIBLE DIMENSIONS')
9008 CALL MESAGE (8,0,NAME)
C
C NORMAL COMPLETION
C
9999 CALL SOFCLS
RETURN
END
|
