1 : C DYN202 SOURCE CHAT 05/01/12 23:10:07 5004
2 : SUBROUTINE DYN202(I,ITLB,ITYP,KTLIAB,NPLB)
3 : IMPLICIT INTEGER(I-N)
4 : IMPLICIT REAL*8(A-H,O-Z)
5 : *--------------------------------------------------------------------*
6 : * *
7 : * Op{rateur DYNE : algorithme de Fu - de Vogelaere *
8 : * ________________________________________________ *
9 : * *
10 : * Remplissage des tableaux de description des liaisons sur *
11 : * la base @ partir des informations contenues dans la *
12 : * TABLE ILIB (LIAISON DE TYPE POINT_POINT). *
13 : * *
14 : * Param}tres: *
15 : * *
16 : * e I Num{ro de la liaison. *
17 : * e ITLB Table rassemblant la description d'une liaison. *
18 : * e ITYP Type de la liaison. *
19 : * s KTLIAB Segment descriptif des liaisons sur base B. *
20 : * e NPLB Nombre total de points. *
21 : * *
22 : * *
23 : * Auteur, date de cr{ation: *
24 : * *
25 : * Lionel VIVAN, le 5 D{cembre 1990. *
26 : * *
27 : *--------------------------------------------------------------------*
28 : -INC CCOPTIO
29 : -INC SMCOORD
30 : -INC SMEVOLL
31 : -INC SMLREEL
32 : *
33 : SEGMENT MTLIAB
34 : INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB)
35 : REAL*8 XPALB(NLIAB,NXPALB)
36 : REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP)
37 : ENDSEGMENT
38 : *
39 : LOGICAL L1,L0,LPERM
40 : CHARACTER*8 MONAMO,CHARRE,MONPER,MARAID,TYPRET
41 : CHARACTER*20 MONECR
42 : *
43 : MTLIAB = KTLIAB
44 : *
45 : * --- choc {l{mentaire POINT_POINT avec ou sans amortissement
46 : *
47 : IF (ITYP.EQ.11) THEN
47 : CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_A',L0,IP0,
48 : & 'POINT',I1,X1,' ',L1,INOA)
49 : IF (IERR.NE.0) RETURN
49 : CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_B',L0,IP0,
50 : & 'POINT',I1,X1,' ',L1,INOB)
51 : IF (IERR.NE.0) RETURN
51 : CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0,
52 : & 'POINT',I1,X1,' ',L1,IPOI)
53 : IF (IERR.NE.0) RETURN
54 : MARAID = ' '
54 : CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR',L0,IP0,
55 : & MARAID,I0,XRAID,' ',L1,IP1)
56 : IF (IERR.NE.0) RETURN
57 : IF (MARAID .EQ. 'ENTIER ') THEN
58 : XRAID = 1.D0*I0
59 : MARAID = 'FLOTTANT'
60 : ENDIF
60 : CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0,
61 : & 'FLOTTANT',I0,XJEU,' ',L1,IP1)
62 : IF (IERR.NE.0) RETURN
63 :
64 : MONPER = ' '
65 : LPERM = .FALSE.
66 : IPERM = 0
66 : CALL ACCTAB(ITLB,'MOT',I1,X0,'LIAISON_PERMANENTE',L0,
67 : & IP0,MONPER,I0,X1,' ',LPERM,IP1)
68 : IF (IERR.NE.0) RETURN
69 : IF (LPERM) THEN
70 : IPERM = 1
71 : ENDIF
72 : *
73 : MONAMO = ' '
73 : CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0,
74 : & MONAMO,I0,XAMON,CHARRE,L1,IP1)
75 : IF (IERR.NE.0) RETURN
76 : IF (MONAMO .EQ. 'ENTIER ') THEN
77 : XAMON = 1.D0*I0
78 : MONAMO = 'FLOTTANT'
79 : ENDIF
80 :
81 : TYPRET = ' '
81 : CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0,
82 : & TYPRET,I1,X1,' ',L1,IPEVO)
83 : IF (IERR.NE.0) RETURN
84 :
85 : IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN
85 : CALL ERREUR(891)
86 : RETURN
87 : ENDIF
88 : *
89 : IF (TYPRET.EQ.'EVOLUTIO') THEN
90 : ITYP = 111
91 : XRAID = 0.d0
92 : ENDIF
93 :
94 : IPALB(I,1) = ITYP
95 : IPALB(I,3) = IDIM
96 : IPALB(I,4) = IPERM
97 : XPALB(I,1) = XRAID
98 : XPALB(I,2) = XJEU
99 : *
100 : * normalisation de la normale
101 : *
102 : IPNV = (IDIM + 1) * (IPOI - 1)
103 : PS = 0.D0
104 : DO 10 ID = 1,IDIM
105 : XC = XCOOR(IPNV + ID)
106 : PS = PS + XC * XC
107 : 10 CONTINUE
108 : * end do
109 : IF (PS.LE.0.D0) THEN
109 : CALL ERREUR(162)
110 : RETURN
111 : ENDIF
112 : IF (MONAMO.EQ.'FLOTTANT') THEN
113 : XPALB(I,3) = XAMON
114 : ELSE
115 : XPALB(I,3) = 0.d0
116 : ENDIF
117 : DO 12 ID = 1,IDIM
118 : ID2 = 3 + ID
119 : XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
120 : 12 CONTINUE
121 : * end do
122 : *
123 : IF (IPALB(I,1) .EQ. 111) THEN
124 : MEVOLL = IPEVO
125 : *
126 : * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe)
127 : * Ici, on recupere les abscisses et les ordonnees de l'evolution dans des
128 : * tableaux xabsci et xordon
129 : *
130 : SEGACT MEVOLL
131 : KEVOLL = IEVOLL(1)
132 : SEGACT KEVOLL
133 : MLREE1 = IPROGX
134 : MLREE2 = IPROGY
135 : SEGACT MLREE1
136 : SEGACT MLREE2
137 : NIP = XABSCI(/2)
138 : *
139 : DO 16 MM=1,NIP
140 : XABSCI (I,MM) = MLREE1.PROG(MM)
141 : XORDON (I,MM) = MLREE2.PROG(MM)
142 : 16 CONTINUE
143 : *
144 : SEGDES MLREE1
145 : SEGDES MLREE2
146 : SEGDES KEVOLL
147 : SEGDES MEVOLL
148 : ENDIF
149 : *
149 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOA)
150 : IPLIB(I,1) = IPLAC
150 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOB)
151 : IPLIB(I,2) = IPLAC
152 : *
153 : * --- choc {l{mentaire POINT_POINT_FROTTEMENT avec ou sans amortissement
154 : *
155 : elseIF (ITYP.EQ.13) THEN
155 : CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_A',L0,IP0,
156 : & 'POINT',I1,X1,' ',L1,INOA)
157 : IF (IERR.NE.0) RETURN
157 : CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_B',L0,IP0,
158 : & 'POINT',I1,X1,' ',L1,INOB)
159 : IF (IERR.NE.0) RETURN
159 : CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0,
160 : & 'POINT',I1,X1,' ',L1,IPOI)
161 : IF (IERR.NE.0) RETURN
162 : MARAID = ' '
162 : CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR',L0,IP0,
163 : & MARAID,I0,XRAID,' ',L1,IP1)
164 : IF (IERR.NE.0) RETURN
165 : IF (MARAID .EQ. 'ENTIER ') THEN
166 : XRAID = 1.D0*I0
167 : MARAID = 'FLOTTANT'
168 : ENDIF
169 :
169 : CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0,
170 : & 'FLOTTANT',I0,XJEU,' ',L1,IP1)
171 : IF (IERR.NE.0) RETURN
171 : CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_GLISSEMENT',L0,IP0,
172 : & 'FLOTTANT',I0,XGLIS,' ',L1,IP1)
173 : IF (IERR.NE.0) RETURN
173 : CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_ADHERENCE',L0,IP0,
174 : & 'FLOTTANT',I0,XADHE,' ',L1,IP1)
175 : IF (IERR.NE.0) RETURN
175 : CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR_TANGENTIELLE',L0,IP0,
176 : & 'FLOTTANT',I0,XRAIT,' ',L1,IP1)
177 : IF (IERR.NE.0) RETURN
177 : CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT_TANGENTIEL',L0,
178 : & IP0,'FLOTTANT',I0,XAMOT,' ',L1,IP1)
179 : IF (IERR.NE.0) RETURN
180 : TYPRET = ' '
180 : CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0,
181 : & TYPRET,I1,X1,' ',L1,IPEVO)
182 : IF (IERR.NE.0) RETURN
183 : *
184 : MONAMO = ' '
184 : CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0,
185 : & MONAMO,I0,XAMON,CHARRE,L1,IP1)
186 : IF (IERR.NE.0) RETURN
187 : IF (MONAMO .EQ. 'ENTIER ') THEN
188 : XAMON = 1.D0*I0
189 : MONAMO = 'FLOTTANT'
190 : ENDIF
191 : IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN
191 : CALL ERREUR(891)
192 : RETURN
193 : ENDIF
194 : IF (TYPRET.EQ.'EVOLUTIO') THEN
195 : ITYP = 113
196 : XRAID = 0.d0
197 : ENDIF
198 : *
199 : IPALB(I,1) = ITYP
200 : IPALB(I,3) = IDIM
201 : XPALB(I,1) = XRAID
202 : XPALB(I,2) = XJEU
203 : XPALB(I,3) = XGLIS
204 : XPALB(I,4) = XADHE
205 : XPALB(I,5) = XRAIT
206 : XPALB(I,6) = XAMOT
207 : IF (MONAMO.EQ.'FLOTTANT') THEN
208 : XPALB(I,7) = XAMON
209 : ELSE
210 : XPALB(I,7) = 0.D0
211 : ENDIF
212 :
213 : * cas particulier pas tres orthodoxe pour Gibert
214 : * on passe a ityp = -13 et on modifie et ajoute
215 : * devlb2, devlb1-->devfb2--->dgcha4--->dgchfr--->dgchgl, devso4
216 : TYPRET = ' '
216 : CALL ACCTAB(ITLB,'MOT',I1,X0,'MODELE',L0,IP0,
217 : & TYPRET,I1,X1,CHARRE,L1,IGIB)
218 : IF (TYPRET.EQ.'MOT') THEN
219 : IF (CHARRE.EQ.'GIBERT') THEN
220 : IPALB(I,1) = -13
221 : ELSE
221 : CALL ERREUR(891)
222 : RETURN
223 : ENDIF
224 : ELSEIF (IGIB.NE.0) THEN
224 : CALL ERREUR(891)
225 : RETURN
226 : ENDIF
227 :
228 :
229 :
230 :
231 : *
232 : * normalisation de la normale
233 : *
234 : IPNV = (IDIM + 1) * (IPOI - 1)
235 : PS = 0.D0
236 : DO 20 ID = 1,IDIM
237 : XC = XCOOR(IPNV + ID)
238 : PS = PS + XC * XC
239 : 20 CONTINUE
240 : * end do
241 : IF (PS.LE.0.D0) THEN
241 : CALL ERREUR(162)
242 : RETURN
243 : ENDIF
244 : DO 22 ID = 1,IDIM
245 : ID2 = 7 + ID
246 : XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
247 : 22 CONTINUE
248 : * end do
249 : *
250 : IF (IPALB(I,1) .EQ. 113) THEN
251 : MEVOLL = IPEVO
252 : *
253 : * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe)
254 : * Ici, on recupere les abscisses et les ordonnees de l'evolution dans des
255 : * tableaux xabsci et xordon
256 : *
257 : SEGACT MEVOLL
258 : KEVOLL = IEVOLL(1)
259 : SEGACT KEVOLL
260 : MLREE1 = IPROGX
261 : MLREE2 = IPROGY
262 : SEGACT MLREE1
263 : SEGACT MLREE2
264 : NIP = XABSCI(/2)
265 : *
266 : DO 24 MM=1,NIP
267 : XABSCI (I,MM) = MLREE1.PROG(MM)
268 : XORDON (I,MM) = MLREE2.PROG(MM)
269 : 24 CONTINUE
270 : *
271 : SEGDES MLREE1
272 : SEGDES MLREE2
273 : SEGDES KEVOLL
274 : SEGDES MEVOLL
275 : ENDIF
276 : *
276 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOA)
277 : IPLIB(I,1) = IPLAC
277 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOB)
278 : IPLIB(I,2) = IPLAC
279 :
280 : *
281 : * --- choc elementaire POINT_POINT_DEPLACEMENT_PLASTIQUE avec ou sans
282 : * amortissement
283 : *
284 : ELSE IF (ITYP.EQ.16) THEN
284 : CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_A',L0,IP0,
285 : & 'POINT',I1,X1,' ',L1,INOA)
286 : IF (IERR.NE.0) RETURN
286 : CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_B',L0,IP0,
287 : & 'POINT',I1,X1,' ',L1,INOB)
288 : IF (IERR.NE.0) RETURN
288 : CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0,
289 : & 'POINT',I1,X1,' ',L1,IPOI)
290 : IF (IERR.NE.0) RETURN
290 : CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0,
291 : & 'FLOTTANT',I0,XJEU,' ',L1,IP1)
292 : IF (IERR.NE.0) RETURN
292 : CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0,
293 : & 'EVOLUTIO',I1,X1,' ',L1,IPEVO)
294 : IF (IERR.NE.0) RETURN
295 : *
296 : MONPER = ' '
297 : LPERM = .FALSE.
298 : IPERM = 1
298 : CALL ACCTAB(ITLB,'MOT',I1,X0,'LIAISON_PERMANENTE',L0,
299 : & IP0,MONPER,I0,X1,' ',LPERM,IP1)
300 : IF (IERR.NE.0) RETURN
301 :
302 : IF (LPERM) THEN
302 : CALL ACCTAB(ITLB,'MOT',I1,X0,'ECROUISSAGE',L0,
303 : & IP0,'MOT',I0,X1,MONECR,L1,IP1)
304 : IF (IERR.NE.0) RETURN
305 : IF (.NOT.(XJEU.EQ.0.D0)) THEN
306 : * WRITE (*,*) 'Liaison permanente, mise a zero du jeu.'
307 : XJEU = 0.D0
308 : ENDIF
309 : IF (MONECR.EQ.'ISOTROPE') THEN
310 : IPERM = 2
311 : ELSEIF (MONECR.EQ.'CINEMATIQUE') THEN
312 : IPERM = 3
313 : ELSE
313 : call erreur(21)
314 : RETURN
315 : ENDIF
316 : ENDIF
317 : *
318 : MEVOLL = IPEVO
319 : *
320 : * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe)
321 : * Ici, on recupere les abscisses et les ordonnees de l'evolution dans des
322 : * tableaux xabsci et xordon
323 : *
324 : SEGACT MEVOLL
325 : KEVOLL = IEVOLL(1)
326 : SEGACT KEVOLL
327 : MLREE1 = IPROGX
328 : MLREE2 = IPROGY
329 : SEGACT MLREE1
330 : SEGACT MLREE2
331 : NIP = XABSCI(/2)
332 : *
333 : DO 26 MM=1,NIP
334 : XABSCI (I,MM) = MLREE1.PROG(MM)
335 : XORDON (I,MM) = MLREE2.PROG(MM)
336 : 26 CONTINUE
337 : *
338 : SEGDES MLREE1
339 : SEGDES MLREE2
340 : SEGDES KEVOLL
341 : SEGDES MEVOLL
342 : *
343 : MONAMO = ' '
343 : CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0,
344 : & MONAMO,I0,XAMON,CHARRE,L1,IP1)
345 : IF (IERR.NE.0) RETURN
346 : *
347 : IPALB(I,1) = ITYP
348 : IPALB(I,3) = IDIM
349 : XPALB(I,1) = XJEU
350 : IPALB(I,5) = IPERM
351 : *
352 : * normalisation de la normale
353 : *
354 : IPNV = (IDIM + 1) * (IPOI - 1)
355 : PS = 0.D0
356 : DO 30 ID = 1,IDIM
357 : XC = XCOOR(IPNV + ID)
358 : PS = PS + XC * XC
359 : 30 CONTINUE
360 : * end do
361 : IF (PS.LE.0.D0) THEN
361 : CALL ERREUR(162)
362 : RETURN
363 : ENDIF
364 : IF (MONAMO.EQ.'FLOTTANT') THEN
365 : IPALB(I,1) = 17
366 : XPALB(I,2) = XAMON
367 : DO 32 ID = 1,IDIM
368 : ID2 = 2 + ID
369 : XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
370 : 32 CONTINUE
371 : * end do
372 : ELSE
373 : DO 34 ID = 1,IDIM
374 : ID2 = 1 + ID
375 : XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
376 : 34 CONTINUE
377 : * end do
378 : ENDIF
379 : *
379 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOA)
380 : IPLIB(I,1) = IPLAC
380 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOB)
381 : IPLIB(I,2) = IPLAC
382 : *
383 : * --- choc {l{mentaire POINT_POINT...
384 : *
385 : * ELSE IF (ITYP.EQ. ) THEN
386 : * ...
387 : * ...
388 : ENDIF
389 : *
390 : END
391 :
392 :
393 :
394 :
395 :
396 :
397 :
398 :
399 :
400 :
401 :
© Cast3M 2003 - All rights reserved.
Disclaimer