Télécharger frig2c.eso

Retour à la liste

Numérotation des lignes :

  1. C FRIG2C SOURCE MB234859 16/06/16 21:15:00 8975
  2.  
  3. SUBROUTINE FRIG2C (maifro,IPRIGI,IPCHJE,IPRIG2)
  4.  
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8(A-H,O-Z)
  7.  
  8. * Ce sous-programme calcule la raideur de frottement en 2D.
  9. * il a besoin pour cela du maillage de frottement et de la raideur
  10. * de contact (ou la raideur totale si c'est plus simple)
  11.  
  12. -INC CCOPTIO
  13. -INC CCREEL
  14.  
  15. -INC SMCHPOI
  16. -INC SMCOORD
  17. -INC SMELEME
  18. -INC SMRIGID
  19.  
  20. * icpr lx du contact ==> lx du frottement
  21. segment icpr(xcoor(/1)/(idim+1))
  22. * xjeu champs de jeux initiaux
  23. segment xjeu(xcoor(/1)/(idim+1))
  24. *
  25. *
  26. * creation et remplissage de icpr
  27. *
  28. segact mcoord
  29. segini icpr
  30. nbp=0
  31. meleme=maifro
  32. segact meleme
  33. ipt1=meleme
  34. do is=1,max(1,lisous(/1))
  35. if (lisous(/1).ne.0) ipt1=lisous(is)
  36. segact ipt1
  37. if (ipt1.itypel.ne.22) call erreur(16)
  38. if (ierr.ne.0) return
  39. do iel=1,ipt1.num(/2)
  40. il=ipt1.num(1,iel)
  41. if (icpr(il).eq.0) then
  42. nbp=nbp+1
  43. icpr(il)=ipt1.num(ipt1.num(/1),iel)
  44. endif
  45. if(icpr(il).ne.ipt1.num(ipt1.num(/1),iel)) call erreur(5)
  46. enddo
  47. if (lisous(/1).ne.0) segdes ipt1
  48. enddo
  49. segdes meleme
  50.  
  51. * remplissage du champ de jeux (demi-frottement si jeu non nul)
  52.  
  53. segini xjeu
  54. mchpoi = IPCHJE
  55. segact mchpoi
  56. do 15 isoupo = 1, ipchp(/1)
  57. msoupo = ipchp(isoupo)
  58. segact msoupo
  59. mpoval=ipoval
  60. segact mpoval
  61. if (vpocha(/2).ne.1) call erreur(16)
  62. ipt8=igeoc
  63. segact ipt8
  64. if (ipt8.num(/1).ne.vpocha(/2)) call erreur(16)
  65. do 16 i=1,vpocha(/1)
  66. xjeu(ipt8.num(1,i))=vpocha(i,1)
  67. 16 continue
  68. segdes ipt8,mpoval,msoupo
  69. 15 continue
  70. segdes mchpoi
  71. IF (ierr.ne.0) return
  72.  
  73.  
  74.  
  75. *
  76. * boucle sur les raideurs de contact pour les transformer en frottement
  77. *
  78. mrigid=iprigi
  79. segact mrigid
  80. segini,ri1=mrigid
  81. do 10 ir=1,irigel(/2)
  82. ri1.irigel(1,ir)=0
  83. ri1.irigel(4,ir)=0
  84. if (irigel(6,ir).eq.0) goto 10
  85. meleme=irigel(1,ir)
  86. SEGACT MELEME
  87. if (itypel.ne.22) goto 11
  88. segini,ipt1=meleme
  89. xmatri=irigel(4,ir)
  90. segact xmatri
  91. segini,xmatr1=xmatri
  92. do iel=1,ipt1.num(/2)
  93. * si mult de lagrange pas connu on a 0
  94. il=ipt1.num(1,iel)
  95. if=icpr(il)
  96. * coefficient multiplicateur suivant le jeu par rapport a la taille de l'element
  97. * taille de l'element au carre
  98. ip1=num(1,iel)
  99. ip2=num(2,iel)
  100. xp1=xcoor((ip1-1)*3+1)
  101. yp1=xcoor((ip1-1)*3+2)
  102. xp2=xcoor((ip2-1)*3+1)
  103. yp2=xcoor((ip2-1)*3+2)
  104. xcr2=(xp2-xp1)**2+(yp2-yp1)**2
  105. xcr=sqrt(xcr2)
  106. ** write (6,*) ' xcr2 xjeu ',xcr2,xjeu(il)
  107. if (xjeu(il).gt.xcr/16.d0) then
  108. xcof=0.5d0
  109. else
  110. xcof=1.d0
  111. endif
  112. ipt1.num(1,iel)=if
  113. ipt1.icolor(iel)=icolor(iel)
  114. do ic=2,re(/1),2
  115. xmatr1.re(1,ic,iel)=-re(1,ic+1,iel)*xcof
  116. xmatr1.re(1,ic+1,iel)=re(1,ic,iel)*xcof
  117. xmatr1.re(ic,1,iel)=-re(ic+1,1,iel)*xcof
  118. xmatr1.re(ic+1,1,iel)=re(ic,1,iel)*xcof
  119. enddo
  120. enddo
  121. segdes xmatri
  122. ri1.irigel(1,ir)=ipt1
  123. ri1.irigel(4,ir)=xmatr1
  124. ri1.irigel(6,ir)=2
  125. 11 SEGDES MELEME
  126. 10 continue
  127. segdes mrigid
  128. *
  129. * boucle de compaction du resultat
  130. *
  131. mrigid=ri1
  132. irr=0
  133. do 100 ir=1,irigel(/2)
  134. meleme=irigel(1,ir)
  135. xmatri=irigel(4,ir)
  136. if (meleme.eq.0) goto 100
  137. ill=0
  138. do iel=1,num(/2)
  139. if (num(1,iel).ne.0) then
  140. ill=ill+1
  141. if (ill.ne.0) then
  142. do in=1,num(/1)
  143. num(in,ill)=num(in,iel)
  144. enddo
  145. icolor(ill)=icolor(iel)
  146. do ic=1,re(/1)
  147. re(1,ic,ill)=re(1,ic,iel)
  148. re(ic,1,ill)=re(ic,1,iel)
  149. enddo
  150. endif
  151. endif
  152. enddo
  153. if (ill.eq.0) goto 100
  154. if (ill.ne.num(/2)) then
  155. nbsous=0
  156. nbref=0
  157. nbnn=num(/1)
  158. nbelem=ill
  159. segadj meleme
  160. endif
  161. ** write (6,*) ' meleme sortie dans frig2c '
  162. ** call ecmail(meleme,0)
  163.  
  164.  
  165. irr=irr+1
  166. if (irr.ne.ir) then
  167. do ir1=1,irigel(/1)
  168. irigel(ir1,irr)=irigel(ir1,ir)
  169. enddo
  170. coerig(irr)=coerig(ir)
  171. endif
  172. 100 continue
  173. nrigel=irr
  174. if (irigel(/2).ne.irr) segadj mrigid
  175. iprig2=mrigid
  176. segsup icpr,xjeu
  177. return
  178. end
  179.  
  180.  
  181.  
  182.  
  183.  
  184.  

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