1 : C COPBA3 SOURCE PV 09/03/12 21:18:14 6325
2 : SUBROUTINE COPBA3(ITBAS,MOTCLE,IMODE,IMAIL,INOMA,LCHAIN,KTRCHP,
3 : & KTRCHA,KTRAV,ICONT)
4 : IMPLICIT INTEGER(I-N)
5 : IMPLICIT REAL*8(A-H,O-Z)
6 :
7 : *--------------------------------------------------------------------*
8 : * *
9 : * Effectue une op{ration g{om{trique de translation (MOTCLE = *
10 : * 'PLUS') ou de rotation (MOTCLE = 'ROTA') sur ITBAS contenant *
11 : * les modes, les pseudo-modes de la structure. *
12 : * *
13 : * Param}tres: *
14 : * *
15 : * e ITBAS table contenant les modes, ou les pseudo-modes *
16 : * e MOTCLE mot : PLUS ou ROTA *
17 : * *
18 : * Auteur, date de cr{ation: *
19 : * *
20 : * Lionel VIVAN, le 31 mai 1990. *
21 : * *
22 : *--------------------------------------------------------------------*
23 : * *
24 : -INC CCOPTIO
25 : -INC SMCHPOI
26 : -INC SMCHAML
27 : -INC SMELEME
28 : -INC SMTABLE
29 : *
30 : SEGMENT ITRCHP
31 : INTEGER ICHCA(NSOU),ICHCN(NSOU)
32 : ENDSEGMENT
33 : SEGMENT ITRCHA
34 : INTEGER ICHAM(NSOUS)
35 : ENDSEGMENT
36 : SEGMENT MTRAV
37 : REAL*8 XPT(IDIMB),XPTP(IDIMB),XP1PT(IDIMB),XMPT(IDIMB,IDIMB)
38 : ENDSEGMENT
39 : SEGMENT MTRA2
40 : INTEGER IDEP(3),IROT(3)
41 : REAL*8 XDEP(3),XROT(3)
42 : ENDSEGMENT
43 : SEGMENT MTRA3
44 : REAL*8 XDGEN(3),XDGE2(3)
45 : ENDSEGMENT
46 : SEGMENT MTRA4
47 : INTEGER IFOR(3),IMOM(3)
48 : REAL*8 XFOR(3),XMOM(3)
49 : ENDSEGMENT
50 : *
51 : INTEGER LCHAIN(*)
52 : CHARACTER*4 COMP,MOTCLE
53 : *
54 : ITRCHP = KTRCHP
55 : NSOU = ICHCA(/1)
56 : IF (ICONT.EQ.1) THEN
57 : ITRCHA = KTRCHA
58 : NSOUS = ICHAM(/1)
59 : ENDIF
60 : IF (MOTCLE.EQ.'ROTA') MTRAV = KTRAV
61 : *
62 : MTABLE = ITBAS
63 : SEGACT MTABLE*MOD
64 : LONG = MLOTAB
65 : IM = IMODE
66 : DO 10 I = 1,LONG
67 : IF (MTABTI(I).EQ.'ENTIER ' .AND. MTABII(I).EQ.IM .AND.
68 : & MTABTV(I).EQ.'TABLE ') THEN
69 : ITMOD = MTABIV(I)
70 : IM = IM + 1
71 : MTAB1 = ITMOD
72 : SEGACT MTAB1*MOD
73 : LON1 = MTAB1.MLOTAB
74 : DO 20 I1 = 1,LON1
75 : IF (MTAB1.MTABTI(I1).EQ.'MOT ') THEN
76 : IF (MTAB1.MTABII(I1).EQ.LCHAIN(3) .OR.
77 : & MTAB1.MTABII(I1).EQ.LCHAIN(6)) THEN
78 : IF (MTAB1.MTABTV(I1).EQ.'CHPOINT ') THEN
79 : ICHDEP = MTAB1.MTABIV(I1)
80 : MCHPOI = ICHDEP
81 : SEGACT MCHPOI
82 : DO 22 INS = 1,NSOU
83 : MSOUPO = IPCHP(INS)
84 : SEGACT MSOUPO*MOD
85 : IF (MOTCLE.EQ.'ROTA') THEN
86 : NCOM = NOCOMP(/2)
87 : SEGINI MTRA2
88 : MPOVAL = IPOVAL
89 : SEGACT MPOVAL
90 : NPOIN = VPOCHA(/1)
91 : DO 24 IP = 1,NPOIN
92 : ICD = 0
93 : ICR = 0
94 : DO 26 IC = 1,NCOM
95 : COMP = NOCOMP(IC)
96 : IF (COMP(1:1).EQ.'U') THEN
97 : ICD = ICD + 1
98 : IDEP(ICD) = IC
99 : XDEP(ICD) = VPOCHA(IP,IC)
100 : ELSE IF (COMP(1:1).EQ.'R') THEN
101 : ICR = ICR + 1
102 : IROT(ICR) = IC
103 : XROT(ICR) = VPOCHA(IP,IC)
104 : ENDIF
105 : 26 CONTINUE
106 : * end do
107 : DO 28 IDE = 1,ICD
108 : XVAL = 0.D0
109 : DO 30 ID2 = 1,ICD
110 : XVAL = XVAL + XMPT(IDE,ID2) * XDEP(ID2)
111 : 30 CONTINUE
112 : * end do
113 : IC = IDEP(IDE)
114 : VPOCHA(IP,IC) = XVAL
115 : 28 CONTINUE
116 : * end do
117 : IF (IDIM.EQ.3) THEN
118 : DO 32 IRO = 1,ICR
119 : XVAL = 0.D0
120 : DO 34 IR2 = 1,ICR
121 : XVAL = XVAL + XMPT(IRO,IR2) * XROT(IR2)
122 : 34 CONTINUE
123 : * end do
124 : IC = IROT(IRO)
125 : VPOCHA(IP,IC) = XVAL
126 : 32 CONTINUE
127 : * end do
128 : ENDIF
129 : 24 CONTINUE
130 : * end do
131 : SEGDES MPOVAL
132 : SEGSUP MTRA2
133 : ENDIF
134 : IGEOC = ICHCN(INS)
135 : SEGDES MSOUPO
136 : 22 CONTINUE
137 : * end do
138 : SEGDES MCHPOI
139 : MTAB1.MTABIV(I1) = ICHDEP
140 : ENDIF
141 : ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(5) .OR.
142 : & MTAB1.MTABII(I1).EQ.LCHAIN(8)) THEN
143 : IF (MTAB1.MTABTV(I1).EQ.'CHPOINT ') THEN
144 : ICHDEP = MTAB1.MTABIV(I1)
145 : MCHPOI = ICHDEP
146 : SEGACT MCHPOI
147 : NSOU2 = IPCHP(/1)
148 : DO 40 INS = 1,NSOU2
149 : MSOUPO = IPCHP(INS)
150 : SEGACT MSOUPO*MOD
151 : IF (MOTCLE.EQ.'ROTA') THEN
152 : NCOM2 = NOCOMP(/2)
153 : SEGINI MTRA4
154 : MPOVAL = IPOVAL
155 : SEGACT MPOVAL
156 : NPOI2 = VPOCHA(/1)
157 : NCOM2 = VPOCHA(/2)
158 : DO 42 IP = 1,NPOI2
159 : ICF = 0
160 : ICM = 0
161 : DO 44 IC = 1,NCOM2
162 : COMP = NOCOMP(IC)
163 : IF (COMP(1:1).EQ.'F') THEN
164 : ICF = ICF + 1
165 : IFOR(ICF) = IC
166 : XFOR(ICF) = VPOCHA(IP,IC)
167 : ELSE IF (COMP(1:1).EQ.'M') THEN
168 : ICM = ICM + 1
169 : IMOM(ICM) = IC
170 : XMOM(ICM) = VPOCHA(IP,IC)
171 : ENDIF
172 : 44 CONTINUE
173 : * end do
174 : DO 46 IDE = 1,ICF
175 : XVAL = 0.D0
176 : DO 48 ID2 = 1,ICF
177 : XVAL = XVAL + XMPT(IDE,ID2) * XFOR(ID2)
178 : 48 CONTINUE
179 : * end do
180 : IC = IFOR(IDE)
181 : VPOCHA(IP,IC) = XVAL
182 : 46 CONTINUE
183 : * end do
184 : IF (IDIM.EQ.3) THEN
185 : DO 50 IRO = 1,ICM
186 : XVAL = 0.D0
187 : DO 52 IR2 = 1,ICM
188 : XVAL = XVAL + XMPT(IRO,IR2) * XMOM(IR2)
189 : 52 CONTINUE
190 : * end do
191 : IC = IMOM(IRO)
192 : VPOCHA(IP,IC) = XVAL
193 : 50 CONTINUE
194 : * end do
195 : ENDIF
196 : 42 CONTINUE
197 : * end do
198 : SEGDES MPOVAL
199 : SEGSUP MTRA4
200 : ENDIF
201 : IPT1 = IGEOC
202 : SEGINI,MELEME=IPT1
203 : NBE = NUM(/2)
204 : NBP = NUM(/1)
205 : DO 54 IE = 1,NBE
206 : DO 56 IP = 1,NBP
207 : IPTS = NUM(IP,IE)
207 : CALL BAPOIN(IMAIL,IPTS,INOMA,INOPT)
208 : IF (IERR.NE.0) RETURN
209 : NUM(IP,IE) = INOPT
210 : 56 CONTINUE
211 : * end do
212 : 54 CONTINUE
213 : * end do
214 : SEGDES MELEME
215 : IGEOC = MELEME
216 : SEGDES MSOUPO
217 : 40 CONTINUE
218 : * end do
219 : SEGDES MCHPOI
220 : MTAB1.MTABIV(I1) = ICHDEP
221 : ENDIF
222 : ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(4) .OR.
223 : & MTAB1.MTABII(I1).EQ.LCHAIN(7)) THEN
224 : IF (MTAB1.MTABTV(I1).EQ.'MCHAML ') THEN
225 : ICHCON = MTAB1.MTABIV(I1)
226 : MCHELM = ICHCON
227 : SEGACT MCHELM*MOD
228 : DO 60 INS = 1,NSOUS
229 : IMACHE(INS) = ICHAM(INS)
230 : 60 CONTINUE
231 : * end do
232 : SEGDES MCHELM
233 : MTAB1.MTABIV(I1) = ICHCON
234 : ENDIF
235 : ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(9) .AND.
236 : & MTAB1.MTABTV(I1).EQ.'CHPOINT ') THEN
237 : ICHDEP = MTAB1.MTABIV(I1)
238 : MCHPOI = ICHDEP
239 : SEGACT MCHPOI
240 : NSOU3 = IPCHP(/1)
241 : DO 80 INS = 1,NSOU3
242 : MSOUPO = IPCHP(INS)
243 : SEGACT MSOUPO
244 : IPT1 = IGEOC
245 : SEGINI,MELEME=IPT1
246 : NBE = NUM(/2)
247 : NBP = NUM(/1)
248 : DO 82 IE = 1,NBE
249 : DO 84 IP = 1,NBP
250 : IPTS = NUM(IP,IE)
250 : CALL BAPOIN(IMAIL,IPTS,INOMA,INOPT)
251 : IF (IERR.NE.0) RETURN
252 : NUM(IP,IE) = INOPT
253 : 84 CONTINUE
254 : * end do
255 : 82 CONTINUE
256 : * end do
257 : SEGDES MELEME
258 : IGEOC = MELEME
259 : SEGDES MSOUPO
260 : 80 CONTINUE
261 : * end do
262 : SEGDES MCHPOI
263 : MTAB1.MTABIV(I1) = ICHDEP
264 : ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(10) .AND.
265 : & MTAB1.MTABTV(I1).EQ.'POINT ') THEN
266 : IPTS = MTAB1.MTABIV(I1)
266 : CALL BAPOIN(IMAIL,IPTS,INOMA,INOPT)
267 : IF (IERR.NE.0) RETURN
268 : MTAB1.MTABIV(I1) = INOPT
269 : ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(2) .AND.
270 : & MTAB1.MTABTV(I1).EQ.'TABLE ') THEN
271 : IF (MOTCLE.EQ.'ROTA') THEN
272 : ITDEPG = MTAB1.MTABIV(I1)
273 : SEGINI MTRA3
274 : MTAB2 = ITDEPG
275 : SEGACT MTAB2
276 : LON2 = MTAB2.MLOTAB
277 : IDG = 1
278 : DO 70 I2 = 1,LON2
279 : IF (MTAB2.MTABTI(I2).EQ.'ENTIER ' .AND.
280 : & MTAB2.MTABII(I2).EQ.IDG .AND.
281 : & MTAB2.MTABTV(I2).EQ.'FLOTTANT') THEN
282 : XDGEN(IDG) = MTAB2.RMTABV(I2)
283 : IDG = IDG + 1
284 : ENDIF
285 : 70 CONTINUE
286 : * end do
287 : DO 72 ID1 = 1,IDIM
288 : XVAL = 0.D0
289 : DO 74 ID2 = 1,IDIM
290 : XVAL = XVAL + (XMPT(ID1,ID2) * XDGEN(ID2))
291 : 74 CONTINUE
292 : * end do
293 : XDGE2(ID1) = XVAL
294 : 72 CONTINUE
295 : * end do
296 : IDG = 1
297 : DO 76 I2 = 1,LON2
298 : IF (MTAB2.MTABTI(I2).EQ.'ENTIER ' .AND.
299 : & MTAB2.MTABII(I2).EQ.IDG .AND.
300 : & MTAB2.MTABTV(I2).EQ.'FLOTTANT') THEN
301 : MTAB2.RMTABV(I2) = XDGE2(IDG)
302 : IDG = IDG + 1
303 : ENDIF
304 : 76 CONTINUE
305 : * end do
306 : SEGDES MTAB2
307 : MTAB1.MTABIV(I1) = ITDEPG
308 : SEGSUP MTRA3
309 : ENDIF
310 : ENDIF
311 : ENDIF
312 : 20 CONTINUE
313 : * end do
314 : SEGDES MTAB1
315 : MTABIV(I) = ITMOD
316 : ENDIF
317 : 10 CONTINUE
318 : * end do
319 : SEGDES MTABLE
320 : *
321 : END
322 :
323 :
324 :
325 :
© Cast3M 2003 - All rights reserved.
Disclaimer