Télécharger dyn202.eso

Retour à la liste

Numérotation des lignes :

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

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