Télécharger frig2c.eso

Retour à la liste

Numérotation des lignes :

  1. C FRIG2C SOURCE MB234859 19/10/10 21:15:02 10331
  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. iOK=0
  57. do 15 isoupo = 1, ipchp(/1)
  58. msoupo = ipchp(isoupo)
  59. segact msoupo
  60. DO 16 i=1,nocomp(/2)
  61. IF (NOCOMP(i).NE.'FLX ') GOTO 16
  62. mpoval=ipoval
  63. segact mpoval
  64. ipt8=igeoc
  65. segact ipt8
  66. DO 17 j=1,vpocha(/1)
  67. xjeu(ipt8.num(1,j))=vpocha(j,i)
  68. 17 CONTINUE
  69. iOK=1
  70. segdes ipt8,mpoval,msoupo
  71. 16 CONTINUE
  72. 15 continue
  73. segdes mchpoi
  74. IF (iOK.NE.1) THEN
  75. MOTERR(1:4)='FLX '
  76. MOTERR(5:8)='DEPI'
  77. CALL ERREUR(77)
  78. ENDIF
  79. IF (ierr.ne.0) return
  80.  
  81.  
  82.  
  83. *
  84. * boucle sur les raideurs de contact pour les transformer en frottement
  85. *
  86. mrigid=iprigi
  87. segact mrigid
  88. segini,ri1=mrigid
  89. do 10 ir=1,irigel(/2)
  90. ri1.irigel(1,ir)=0
  91. ri1.irigel(4,ir)=0
  92. if (irigel(6,ir).eq.0) goto 10
  93. meleme=irigel(1,ir)
  94. SEGACT MELEME
  95. if (itypel.ne.22) goto 11
  96. segini,ipt1=meleme
  97. xmatri=irigel(4,ir)
  98. segact xmatri
  99. segini,xmatr1=xmatri
  100. do iel=1,ipt1.num(/2)
  101. * si mult de lagrange pas connu on a 0
  102. il=ipt1.num(1,iel)
  103. if=icpr(il)
  104. * coefficient multiplicateur suivant le jeu par rapport a la taille de l'element
  105. * taille de l'element au carre
  106. **** ip1=num(1,iel)
  107. **** ip2=num(2,iel)
  108. **** xp1=xcoor((ip1-1)*3+1)
  109. **** yp1=xcoor((ip1-1)*3+2)
  110. **** xp2=xcoor((ip2-1)*3+1)
  111. **** yp2=xcoor((ip2-1)*3+2)
  112. **** xcr2=(xp2-xp1)**2+(yp2-yp1)**2
  113. **** xcr=sqrt(xcr2)
  114. ** write (6,*) ' xcr2 xjeu ',xcr2,xjeu(il)
  115. **** if (xjeu(il).gt.xcr/16.d0) then
  116. **** xcof=0.5d0
  117. **** else
  118. **** xcof=1.d0
  119. **** endif
  120. xcof = 1.d0
  121. ipt1.num(1,iel)=if
  122. ipt1.icolor(iel)=icolor(iel)
  123. do ic=2,re(/1),2
  124. xmatr1.re(1,ic,iel)=-re(1,ic+1,iel)*xcof
  125. xmatr1.re(1,ic+1,iel)=re(1,ic,iel)*xcof
  126. xmatr1.re(ic,1,iel)=-re(ic+1,1,iel)*xcof
  127. xmatr1.re(ic+1,1,iel)=re(ic,1,iel)*xcof
  128. enddo
  129. enddo
  130. segdes xmatri
  131. ri1.irigel(1,ir)=ipt1
  132. ri1.irigel(4,ir)=xmatr1
  133. ri1.irigel(6,ir)=2
  134. 11 SEGDES MELEME
  135. 10 continue
  136. segdes mrigid
  137. *
  138. * boucle de compaction du resultat
  139. *
  140. mrigid=ri1
  141. irr=0
  142. do 100 ir=1,irigel(/2)
  143. meleme=irigel(1,ir)
  144. xmatri=irigel(4,ir)
  145. if (meleme.eq.0) goto 100
  146. ill=0
  147. do iel=1,num(/2)
  148. if (num(1,iel).ne.0) then
  149. ill=ill+1
  150. if (ill.ne.0) then
  151. do in=1,num(/1)
  152. num(in,ill)=num(in,iel)
  153. enddo
  154. icolor(ill)=icolor(iel)
  155. do ic=1,re(/1)
  156. re(1,ic,ill)=re(1,ic,iel)
  157. re(ic,1,ill)=re(ic,1,iel)
  158. enddo
  159. endif
  160. endif
  161. enddo
  162. if (ill.eq.0) goto 100
  163. if (ill.ne.num(/2)) then
  164. nbsous=0
  165. nbref=0
  166. nbnn=num(/1)
  167. nbelem=ill
  168. segadj meleme
  169. endif
  170. ** write (6,*) ' meleme sortie dans frig2c '
  171. ** call ecmail(meleme,0)
  172.  
  173.  
  174. irr=irr+1
  175. if (irr.ne.ir) then
  176. do ir1=1,irigel(/1)
  177. irigel(ir1,irr)=irigel(ir1,ir)
  178. enddo
  179. coerig(irr)=coerig(ir)
  180. endif
  181. 100 continue
  182. nrigel=irr
  183. if (irigel(/2).ne.irr) segadj mrigid
  184. iprig2=mrigid
  185. segsup icpr,xjeu
  186. return
  187. end
  188.  
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  

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