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