Télécharger dyn202.eso

Retour à la liste

Numérotation des lignes :

  1. C DYN202 SOURCE BP208322 16/06/06 21:15:03 8944
  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,MONPER,MARAID,TYPRET
  41. CHARACTER*16 CHARRE
  42. CHARACTER*20 MONECR
  43. *
  44. MTLIAB = KTLIAB
  45. *
  46. * --- choc {l{mentaire POINT_POINT avec ou sans amortissement
  47. *
  48. IF (ITYP.EQ.11) THEN
  49. CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_A',L0,IP0,
  50. & 'POINT',I1,X1,' ',L1,INOA)
  51. IF (IERR.NE.0) RETURN
  52. CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_B',L0,IP0,
  53. & 'POINT',I1,X1,' ',L1,INOB)
  54. IF (IERR.NE.0) RETURN
  55. CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0,
  56. & 'POINT',I1,X1,' ',L1,IPOI)
  57. IF (IERR.NE.0) RETURN
  58. MARAID = ' '
  59. CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR',L0,IP0,
  60. & MARAID,I0,XRAID,' ',L1,IP1)
  61. IF (IERR.NE.0) RETURN
  62. IF (MARAID .EQ. 'ENTIER ') THEN
  63. XRAID = 1.D0*I0
  64. MARAID = 'FLOTTANT'
  65. ENDIF
  66. CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0,
  67. & 'FLOTTANT',I0,XJEU,' ',L1,IP1)
  68. IF (IERR.NE.0) RETURN
  69.  
  70. MONPER = ' '
  71. LPERM = .FALSE.
  72. IPERM = 0
  73. CALL ACCTAB(ITLB,'MOT',I1,X0,'LIAISON_PERMANENTE',L0,
  74. & IP0,MONPER,I0,X1,' ',LPERM,IP1)
  75. IF (IERR.NE.0) RETURN
  76. IF (LPERM) THEN
  77. IPERM = 1
  78. ENDIF
  79. *
  80. MONAMO = ' '
  81. CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0,
  82. & MONAMO,I0,XAMON,CHARRE,L1,IP1)
  83. IF (IERR.NE.0) RETURN
  84. IF (MONAMO .EQ. 'ENTIER ') THEN
  85. XAMON = 1.D0*I0
  86. MONAMO = 'FLOTTANT'
  87. ENDIF
  88.  
  89. TYPRET = ' '
  90. CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0,
  91. & TYPRET,I1,X1,' ',L1,IPEVO)
  92. IF (IERR.NE.0) RETURN
  93.  
  94. IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN
  95. CALL ERREUR(891)
  96. RETURN
  97. ENDIF
  98. *
  99. IF (TYPRET.EQ.'EVOLUTIO') THEN
  100. ITYP = 111
  101. XRAID = 0.d0
  102. ENDIF
  103.  
  104. IPALB(I,1) = ITYP
  105. IPALB(I,3) = IDIM
  106. IPALB(I,4) = IPERM
  107. XPALB(I,1) = XRAID
  108. XPALB(I,2) = XJEU
  109. *
  110. * normalisation de la normale
  111. *
  112. IPNV = (IDIM + 1) * (IPOI - 1)
  113. PS = 0.D0
  114. DO 10 ID = 1,IDIM
  115. XC = XCOOR(IPNV + ID)
  116. PS = PS + XC * XC
  117. 10 CONTINUE
  118. * end do
  119. IF (PS.LE.0.D0) THEN
  120. CALL ERREUR(162)
  121. RETURN
  122. ENDIF
  123. IF (MONAMO.EQ.'FLOTTANT') THEN
  124. XPALB(I,3) = XAMON
  125. ELSE
  126. XPALB(I,3) = 0.d0
  127. ENDIF
  128. DO 12 ID = 1,IDIM
  129. ID2 = 3 + ID
  130. XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
  131. 12 CONTINUE
  132. * end do
  133. *
  134. IF (IPALB(I,1) .EQ. 111) THEN
  135. MEVOLL = IPEVO
  136. *
  137. * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe)
  138. * Ici, on recupere les abscisses et les ordonnees de l'evolution dans des
  139. * tableaux xabsci et xordon
  140. *
  141. SEGACT MEVOLL
  142. KEVOLL = IEVOLL(1)
  143. SEGACT KEVOLL
  144. MLREE1 = IPROGX
  145. MLREE2 = IPROGY
  146. SEGACT MLREE1
  147. SEGACT MLREE2
  148. NIP = XABSCI(/2)
  149. *
  150. DO 16 MM=1,NIP
  151. XABSCI (I,MM) = MLREE1.PROG(MM)
  152. XORDON (I,MM) = MLREE2.PROG(MM)
  153. 16 CONTINUE
  154. *
  155. SEGDES MLREE1
  156. SEGDES MLREE2
  157. SEGDES KEVOLL
  158. SEGDES MEVOLL
  159. ENDIF
  160. *
  161. CALL PLACE2(JPLIB,NPLB,IPLAC,INOA)
  162. IPLIB(I,1) = IPLAC
  163. CALL PLACE2(JPLIB,NPLB,IPLAC,INOB)
  164. IPLIB(I,2) = IPLAC
  165. *
  166. * --- choc {l{mentaire POINT_POINT_FROTTEMENT avec ou sans amortissement
  167. *
  168. elseIF (ITYP.EQ.13) THEN
  169. CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_A',L0,IP0,
  170. & 'POINT',I1,X1,' ',L1,INOA)
  171. IF (IERR.NE.0) RETURN
  172. CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_B',L0,IP0,
  173. & 'POINT',I1,X1,' ',L1,INOB)
  174. IF (IERR.NE.0) RETURN
  175. CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0,
  176. & 'POINT',I1,X1,' ',L1,IPOI)
  177. IF (IERR.NE.0) RETURN
  178. MARAID = ' '
  179. CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR',L0,IP0,
  180. & MARAID,I0,XRAID,' ',L1,IP1)
  181. IF (IERR.NE.0) RETURN
  182. IF (MARAID .EQ. 'ENTIER ') THEN
  183. XRAID = 1.D0*I0
  184. MARAID = 'FLOTTANT'
  185. ENDIF
  186.  
  187. CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0,
  188. & 'FLOTTANT',I0,XJEU,' ',L1,IP1)
  189. IF (IERR.NE.0) RETURN
  190. CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_GLISSEMENT',L0,IP0,
  191. & 'FLOTTANT',I0,XGLIS,' ',L1,IP1)
  192. IF (IERR.NE.0) RETURN
  193. CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_ADHERENCE',L0,IP0,
  194. & 'FLOTTANT',I0,XADHE,' ',L1,IP1)
  195. IF (IERR.NE.0) RETURN
  196. CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR_TANGENTIELLE',L0,IP0,
  197. & 'FLOTTANT',I0,XRAIT,' ',L1,IP1)
  198. IF (IERR.NE.0) RETURN
  199. CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT_TANGENTIEL',L0,
  200. & IP0,'FLOTTANT',I0,XAMOT,' ',L1,IP1)
  201. IF (IERR.NE.0) RETURN
  202. TYPRET = ' '
  203. CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0,
  204. & TYPRET,I1,X1,' ',L1,IPEVO)
  205. IF (IERR.NE.0) RETURN
  206. *
  207. MONAMO = ' '
  208. CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0,
  209. & MONAMO,I0,XAMON,CHARRE,L1,IP1)
  210. IF (IERR.NE.0) RETURN
  211. IF (MONAMO .EQ. 'ENTIER ') THEN
  212. XAMON = 1.D0*I0
  213. MONAMO = 'FLOTTANT'
  214. ENDIF
  215. IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN
  216. CALL ERREUR(891)
  217. RETURN
  218. ENDIF
  219. IF (TYPRET.EQ.'EVOLUTIO') THEN
  220. ITYP = 113
  221. XRAID = 0.d0
  222. ENDIF
  223. *
  224. *bp,2016 petit message informatif pour ceux qui, comme moi, n'auraient
  225. * pas lu la notice jusqu'au bout :
  226. IF(XRAIT.LT.0.D0) THEN
  227. IF(XAMOT.LE.0D0.OR.IIMPI.GT.0) THEN
  228. WRITE(IOIMP,*) 'Liaison elementaire ..._FROTTEMENT numero',I
  229. WRITE(IOIMP,*)
  230. & 'utilisation du modele de frottement regularise d ODEN'
  231. ENDIF
  232. IF(XAMOT.LE.0D0) THEN
  233. c ERREUR: %m1:8 = %r1 inferieur a %r2
  234. MOTERR(1:8)='AMOR*_T*'
  235. REAERR(1)=XAMOT
  236. REAERR(2)=0.D0
  237. CALL ERREUR(41)
  238. RETURN
  239. ENDIF
  240. ENDIF
  241.  
  242. IPALB(I,1) = ITYP
  243. IPALB(I,3) = IDIM
  244. XPALB(I,1) = XRAID
  245. XPALB(I,2) = XJEU
  246. XPALB(I,3) = XGLIS
  247. XPALB(I,4) = XADHE
  248. XPALB(I,5) = XRAIT
  249. XPALB(I,6) = XAMOT
  250. IF (MONAMO.EQ.'FLOTTANT') THEN
  251. XPALB(I,7) = XAMON
  252. ELSE
  253. XPALB(I,7) = 0.D0
  254. ENDIF
  255.  
  256. * cas particulier pas tres orthodoxe pour Gibert
  257. * on passe a ityp = -13 et on modifie et ajoute
  258. * devlb2, devlb1-->devfb2--->dgcha4--->dgchfr--->dgchgl, devso4
  259. TYPRET = ' '
  260. CALL ACCTAB(ITLB,'MOT',I1,X0,'MODELE',L0,IP0,
  261. & TYPRET,I1,X1,CHARRE,L1,IGIB)
  262. IF (TYPRET.EQ.'MOT') THEN
  263. IF (CHARRE.EQ.'NEDJAI-GIBERT') THEN
  264. IPALB(I,1) = -13
  265. ELSE
  266. CALL ERREUR(891)
  267. RETURN
  268. ENDIF
  269. ELSEIF (IGIB.NE.0) THEN
  270. CALL ERREUR(891)
  271. RETURN
  272. ENDIF
  273.  
  274.  
  275.  
  276.  
  277. *
  278. * normalisation de la normale
  279. *
  280. IPNV = (IDIM + 1) * (IPOI - 1)
  281. PS = 0.D0
  282. DO 20 ID = 1,IDIM
  283. XC = XCOOR(IPNV + ID)
  284. PS = PS + XC * XC
  285. 20 CONTINUE
  286. * end do
  287. IF (PS.LE.0.D0) THEN
  288. CALL ERREUR(162)
  289. RETURN
  290. ENDIF
  291. DO 22 ID = 1,IDIM
  292. ID2 = 7 + ID
  293. XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
  294. 22 CONTINUE
  295. * end do
  296. *
  297. IF (IPALB(I,1) .EQ. 113) THEN
  298. MEVOLL = IPEVO
  299. *
  300. * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe)
  301. * Ici, on recupere les abscisses et les ordonnees de l'evolution dans des
  302. * tableaux xabsci et xordon
  303. *
  304. SEGACT MEVOLL
  305. KEVOLL = IEVOLL(1)
  306. SEGACT KEVOLL
  307. MLREE1 = IPROGX
  308. MLREE2 = IPROGY
  309. SEGACT MLREE1
  310. SEGACT MLREE2
  311. NIP = XABSCI(/2)
  312. *
  313. DO 24 MM=1,NIP
  314. XABSCI (I,MM) = MLREE1.PROG(MM)
  315. XORDON (I,MM) = MLREE2.PROG(MM)
  316. 24 CONTINUE
  317. *
  318. SEGDES MLREE1
  319. SEGDES MLREE2
  320. SEGDES KEVOLL
  321. SEGDES MEVOLL
  322. ENDIF
  323. *
  324. CALL PLACE2(JPLIB,NPLB,IPLAC,INOA)
  325. IPLIB(I,1) = IPLAC
  326. CALL PLACE2(JPLIB,NPLB,IPLAC,INOB)
  327. IPLIB(I,2) = IPLAC
  328.  
  329. *
  330. * --- choc elementaire POINT_POINT_DEPLACEMENT_PLASTIQUE avec ou sans
  331. * amortissement
  332. *
  333. ELSE IF (ITYP.EQ.16) THEN
  334. CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_A',L0,IP0,
  335. & 'POINT',I1,X1,' ',L1,INOA)
  336. IF (IERR.NE.0) RETURN
  337. CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_B',L0,IP0,
  338. & 'POINT',I1,X1,' ',L1,INOB)
  339. IF (IERR.NE.0) RETURN
  340. CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0,
  341. & 'POINT',I1,X1,' ',L1,IPOI)
  342. IF (IERR.NE.0) RETURN
  343. CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0,
  344. & 'FLOTTANT',I0,XJEU,' ',L1,IP1)
  345. IF (IERR.NE.0) RETURN
  346. CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0,
  347. & 'EVOLUTIO',I1,X1,' ',L1,IPEVO)
  348. IF (IERR.NE.0) RETURN
  349. *
  350. MONPER = ' '
  351. LPERM = .FALSE.
  352. IPERM = 1
  353. CALL ACCTAB(ITLB,'MOT',I1,X0,'LIAISON_PERMANENTE',L0,
  354. & IP0,MONPER,I0,X1,' ',LPERM,IP1)
  355. IF (IERR.NE.0) RETURN
  356.  
  357. IF (LPERM) THEN
  358. CALL ACCTAB(ITLB,'MOT',I1,X0,'ECROUISSAGE',L0,
  359. & IP0,'MOT',I0,X1,MONECR,L1,IP1)
  360. IF (IERR.NE.0) RETURN
  361. IF (.NOT.(XJEU.EQ.0.D0)) THEN
  362. * WRITE (*,*) 'Liaison permanente, mise a zero du jeu.'
  363. XJEU = 0.D0
  364. ENDIF
  365. IF (MONECR.EQ.'ISOTROPE') THEN
  366. IPERM = 2
  367. ELSEIF (MONECR.EQ.'CINEMATIQUE') THEN
  368. IPERM = 3
  369. ELSE
  370. call erreur(21)
  371. RETURN
  372. ENDIF
  373. ENDIF
  374. *
  375. MEVOLL = IPEVO
  376. *
  377. * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe)
  378. * Ici, on recupere les abscisses et les ordonnees de l'evolution dans des
  379. * tableaux xabsci et xordon
  380. *
  381. SEGACT MEVOLL
  382. KEVOLL = IEVOLL(1)
  383. SEGACT KEVOLL
  384. MLREE1 = IPROGX
  385. MLREE2 = IPROGY
  386. SEGACT MLREE1
  387. SEGACT MLREE2
  388. NIP = XABSCI(/2)
  389. *
  390. DO 26 MM=1,NIP
  391. XABSCI (I,MM) = MLREE1.PROG(MM)
  392. XORDON (I,MM) = MLREE2.PROG(MM)
  393. 26 CONTINUE
  394. *
  395. SEGDES MLREE1
  396. SEGDES MLREE2
  397. SEGDES KEVOLL
  398. SEGDES MEVOLL
  399. *
  400. MONAMO = ' '
  401. CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0,
  402. & MONAMO,I0,XAMON,CHARRE,L1,IP1)
  403. IF (IERR.NE.0) RETURN
  404. *
  405. IPALB(I,1) = ITYP
  406. IPALB(I,3) = IDIM
  407. XPALB(I,1) = XJEU
  408. IPALB(I,5) = IPERM
  409. *
  410. * normalisation de la normale
  411. *
  412. IPNV = (IDIM + 1) * (IPOI - 1)
  413. PS = 0.D0
  414. DO 30 ID = 1,IDIM
  415. XC = XCOOR(IPNV + ID)
  416. PS = PS + XC * XC
  417. 30 CONTINUE
  418. * end do
  419. IF (PS.LE.0.D0) THEN
  420. CALL ERREUR(162)
  421. RETURN
  422. ENDIF
  423. IF (MONAMO.EQ.'FLOTTANT') THEN
  424. IPALB(I,1) = 17
  425. XPALB(I,2) = XAMON
  426. DO 32 ID = 1,IDIM
  427. ID2 = 2 + ID
  428. XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
  429. 32 CONTINUE
  430. * end do
  431. ELSE
  432. DO 34 ID = 1,IDIM
  433. ID2 = 1 + ID
  434. XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
  435. 34 CONTINUE
  436. * end do
  437. ENDIF
  438. *
  439. CALL PLACE2(JPLIB,NPLB,IPLAC,INOA)
  440. IPLIB(I,1) = IPLAC
  441. CALL PLACE2(JPLIB,NPLB,IPLAC,INOB)
  442. IPLIB(I,2) = IPLAC
  443. *
  444. * --- choc {l{mentaire POINT_POINT...
  445. *
  446. * ELSE IF (ITYP.EQ. ) THEN
  447. * ...
  448. * ...
  449. ENDIF
  450. *
  451. END
  452.  
  453.  
  454.  
  455.  
  456.  
  457.  
  458.  
  459.  
  460.  
  461.  
  462.  
  463.  
  464.  
  465.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales