Télécharger impf.eso

Retour à la liste

Numérotation des lignes :

  1. C IMPF SOURCE BP208322 16/11/18 21:17:38 9177
  2. *
  3. * Fabrique un maillage :
  4. * - d'elements de frottement a partir d'elements de contact
  5. * - de cables frottants a partir du maillage des cables
  6. *
  7. SUBROUTINE IMPF
  8. *
  9. IMPLICIT INTEGER(I-N)
  10. IMPLICIT REAL*8 (A-H,O-Z)
  11. *
  12. -INC CCOPTIO
  13. *
  14. -INC SMCOORD
  15. -INC SMELEME
  16. -INC CCGEOME
  17. *
  18. segment icpr(nbpts)
  19. *
  20. idimp1 = IDIM + 1
  21. segact mcoord
  22. nbptin = xcoor(/1) / idimp1
  23. nbpts=nbptin
  24. *
  25. *
  26. * Lecture du maillage de contact / des cables frottants
  27. *
  28. call lirobj('MAILLAGE',ipt1,1,iretou)
  29. if (ierr.ne.0) return
  30. *
  31. segact ipt1
  32. *
  33. if (ipt1.lisous(/1) .eq.0) then
  34. ** elem type 2 ==> cable frottant
  35. if (ipt1.itypel.eq.2) goto 100
  36. endif
  37. *
  38. nbnnin = ipt1.num(/1)
  39. nbelin = ipt1.num(/2)
  40. *
  41. *=========================================================
  42. * Elements de frottement <- Elements de contact (type 22)
  43. *=========================================================
  44. *
  45. * Nombre de noeud(s) support(s) supplementaire(s) pour le frottement
  46. * a ajouter a chaque element de contact pour faire l'element de
  47. * frottement correspondant
  48. * Le(s) noeud(s) supplementaire(s) a(ont) les memes coordonnees que
  49. * le noeud support du contact (1er noeud de l'element de contact).
  50. * attention:
  51. * creation des noeuds supports différés à la première utilisation en 3d
  52. * on se sert de icpr pour stocker le mult de frottement associé a un mult de contact
  53. * de facon a ne le creer qu'une fois
  54. segini icpr
  55. nbs = 1
  56. if (idim.eq.3) nbs = 2
  57. ipt2=ipt1
  58. segact ipt2
  59. nbsous=max(1,ipt1.lisous(/1))
  60. nbref=0
  61. nbnn=0
  62. nbelem=0
  63. segini ipt4
  64. do is=1,nbsous
  65. if (ipt1.lisous(/1).ne.0) ipt2=ipt1.lisous(is)
  66. segact ipt2
  67. nbnn=ipt2.num(/1)+nbs
  68. nbelem=ipt2.num(/2)
  69. nbsous=0
  70. segini ipt3
  71. ipt4.lisous(is)=ipt3
  72. ipt3.itypel=22
  73. do iel=1,ipt2.num(/2)
  74. do in=1,ipt2.num(/1)
  75. ipt3.num(in,iel)=ipt2.num(in,iel)
  76. enddo
  77. ipt3.icolor(iel)=ipt2.icolor(iel)
  78. il=ipt2.num(1,iel)
  79. if (icpr(il).eq.0) then
  80. nbpts=nbpts+1
  81. icpr(il)=nbpts
  82. if (idim.eq.3) nbpts=nbpts+1
  83. endif
  84. ipt3.num(ipt2.num(/1)+1,iel)=icpr(il)
  85. if (idim.eq.3) ipt3.num(ipt2.num(/1)+2,iel)=icpr(il)+1
  86. enddo
  87. ipt4.lisous(is)=ipt3
  88. enddo
  89. * remplissage mcoord
  90. segadj mcoord
  91. do i=1,icpr(/1)
  92. ip=icpr(i)
  93. if (ip.ne.0) then
  94. ip=(ip-1)*(idim+1)
  95. xcoor(ip+1)=xcoor((i-1)*(idim+1)+1)
  96. xcoor(ip+2)=xcoor((i-1)*(idim+1)+2)
  97. if (idim.eq.3) xcoor(ip+3)=xcoor((i-1)*(idim+1)+3)
  98. if (idim.eq.3) then
  99. ip=icpr(i)+1
  100. ip=(ip-1)*(idim+1)
  101. xcoor(ip+1)=xcoor((i-1)*(idim+1)+1)
  102. xcoor(ip+2)=xcoor((i-1)*(idim+1)+2)
  103. xcoor(ip+3)=xcoor((i-1)*(idim+1)+3)
  104. endif
  105. endif
  106. enddo
  107. *
  108. meleme=ipt4
  109. if (ipt4.lisous(/1).eq.1) then
  110. meleme=ipt4.lisous(1)
  111. segsup ipt4
  112. endif
  113.  
  114. goto 900
  115.  
  116. *============================
  117. * Elements de cable frottant
  118. *============================
  119. 100 continue
  120. *
  121. nbnnin = ipt1.num(/1)
  122. nbelin = ipt1.num(/2)
  123. *
  124. segact mcoord
  125. nbptin = xcoor(/1) / idimp1
  126. *
  127. * IDIM element(s) de frottement en chaque point geometrique definissant
  128. * le reseau des cables (un seul element associe au noeud commun a
  129. * plusieurs elements de cable pour chaque direction de l'espace)
  130. nbptr = nbptin
  131. segini icpr
  132. nbs = 0
  133. do 101 iel = 1, nbelin
  134. do 102 in = 1, nbnnin
  135. ia = ipt1.num(in,iel)
  136. if (icpr(ia).ne.0) goto 102
  137. nbs = nbs+1
  138. icpr(ia) = nbs
  139. 102 continue
  140. 101 continue
  141. *
  142. nbnn = 2
  143. nbelem = nbs*idim
  144. nbref = 0
  145. nbsous = 0
  146. segini meleme
  147. itypel = 22
  148. *
  149. nbpts = nbptin + (nbs*idim)
  150. segadj,mcoord
  151. *
  152. nbel = 0
  153. ndec = (nbptin-1) * idimp1
  154. do 103 iel = 1, nbelin
  155. do 104 in = 1, nbnnin
  156. ia = ipt1.num(in,iel)
  157. if (icpr(ia).eq.0) goto 104
  158. icpr(ia) = 0
  159. ip = (ia-1)*idimp1
  160. xb = xcoor(ip+1)
  161. yb = xcoor(ip+2)
  162. zb = xcoor(ip+3)
  163. if (idim.eq.3) tb = xcoor(ip+4)
  164. do 105 id = 1,idim
  165. nbel = nbel+1
  166. ndec = ndec+idimp1
  167. xcoor(ndec+1) = xb
  168. xcoor(ndec+2) = yb
  169. xcoor(ndec+3) = zb
  170. if (idim.eq.3) xcoor(ndec+4) = tb
  171. num(1,nbel) = nbptin + nbel
  172. num(2,nbel) = ia
  173. 105 continue
  174. 104 continue
  175. 103 continue
  176. *
  177. segsup icpr
  178. c* goto 900
  179. *
  180. *=======
  181. * Fin : Ecriture du MELEME de frottement
  182. *=======
  183. 900 CONTINUE
  184. segdes,meleme
  185. call ecrobj('MAILLAGE',meleme)
  186.  
  187. 990 CONTINUE
  188. segdes,ipt1
  189.  
  190. return
  191. end
  192.  
  193.  
  194.  
  195.  
  196.  
  197.  
  198.  
  199.  
  200.  

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