Télécharger frig.eso

Retour à la liste

Numérotation des lignes :

  1. C FRIG SOURCE FANDEUR 11/10/07 21:15:27 7159
  2.  
  3. SUBROUTINE FRIG
  4.  
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8(A-H,O-Z)
  7.  
  8. * Ce sous-programme calcule la raideur de frottement.
  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 SMMODEL
  19. -INC SMRIGID
  20.  
  21. logical ltelq
  22.  
  23. idimp1 = IDIM + 1
  24. *
  25. * Test sur les options de calcul
  26. if (idim .ne. 3) then
  27. if (ifomod .ne. -1 .and. ifomod .ne. 0) then
  28. call erreur(710)
  29. return
  30. endif
  31. endif
  32. *
  33. * Lecture obligatoire du modele de frottement
  34. *
  35. call LIROBJ('MMODEL' , modini,1,iretou)
  36. if (ierr.ne.0) return
  37. *
  38. * Quelques initialisations
  39. *
  40. mmodel = modini
  41. segact mmodel
  42. nsous = kmodel(/1)
  43. n1 = nsous
  44. segini,mmode1
  45. segini,mmode2
  46. *
  47. * Travail préparatoire de separation des modeles de frottement
  48. *
  49. icoulo = 0
  50. icable = 0
  51. ipp2 = 0
  52. ltelq=.false.
  53. do 700 imod = 1, nsous
  54. imodel= kmodel(imod)
  55. segact imodel
  56. if (matmod(1).eq.'COULOMB') then
  57. icoulo=icoulo+1
  58. mmode1.kmodel(icoulo) = imodel
  59. * modele(s) de Coulomb : on agglomere les maillages sous-jacents
  60. if (icoulo.eq.1) then
  61. ipp2 = imamod
  62. else
  63. meleme = ipp2
  64. ipp1 = imamod
  65. call fuse(meleme,ipp1,ipp2,ltelq)
  66. if (icoulo.ge.3) segsup,meleme
  67. endif
  68. else if (matmod(1).eq.'FROCABLE') then
  69. icable = icable+1
  70. mmode2.kmodel(icable) = imodel
  71. else
  72. segdes,imodel
  73. endif
  74. 700 continue
  75. segdes mmodel
  76. n1 = icoulo
  77. segadj,mmode1
  78. modcou = mmode1
  79. n1 = icable
  80. segadj,mmode2
  81. modcab = mmode2
  82. if (icoulo.eq.0 .and. icable.eq.0) then
  83. call erreur(21)
  84. goto 9000
  85. endif
  86. *
  87. * Lecture conditionnelle des arguments (selon les modeles de frottement)
  88. *
  89. lecond = 0
  90. if (icoulo.ne.0) lecond = 1
  91. *
  92. iraidc = 0
  93. ichjeu = 0
  94. *
  95. * Lecture de la raideur de contact
  96. call lirobj('RIGIDITE',iraidc,lecond,iretou)
  97. if (ierr.ne.0) GOTO 9000
  98. *
  99. * Lecture du champ de jeux
  100. call lirobj('CHPOINT ',ichjeu,lecond,iretou)
  101. if (ierr.ne.0) GOTO 9000
  102. *
  103. * Initialisation de la raideur (totale) de frottement
  104. *
  105. mrigid = 0
  106. *
  107. * Traitement des modeles de Coulomb
  108. *
  109. if (icoulo.ne.0) then
  110. ri1 = 0
  111. meleme = ipp2
  112. if (idim .eq. 3) then
  113. call frig3C(meleme,iraidc,ichjeu, ri1)
  114. else
  115. call frig2C(meleme,iraidc,ichjeu, ri1)
  116. endif
  117. if (icoulo.ge.2) segsup meleme
  118. if (ierr.ne.0 .or. ri1.eq.0) goto 9000
  119. mrigid = ri1
  120. endif
  121. *
  122. * Traitement des modeles Frocable
  123. *
  124. if (icable.ne.0) then
  125. mmodel = modcab
  126. * Petit modele unitaire local (a detruire en fin de traitement)
  127. n1=1
  128. segini,mmode2
  129. * Option accro 'GLISS'
  130. igliss=1
  131. DO 500 imod=1,icable
  132. imodel = kmodel(imod)
  133. C* segact imodel
  134. segact,mmode2*mod
  135. mmode2.kmodel(1)=imodel
  136. do io=1,ivamod(/1)
  137. if (tymode(io).eq.'MAILLAGE') go to 510
  138. enddo
  139. call erreur(16)
  140. goto 9000
  141. 510 continue
  142. ri2 = 0
  143. meleme=ivamod(io)
  144. call ecrobj('MAILLAGE',meleme)
  145. call ecrobj('MMODEL ',mmode2)
  146. call accro(igliss)
  147. if (ierr.ne.0) goto 9000
  148. call lirobj('RIGIDITE',ri2,1,iretou)
  149. if (ierr.ne.0) goto 9000
  150. c* segdes imodel (desactive par accro)
  151. c* On fusionne ri2 dans la rigidite (totale) mrigid
  152. if (mrigid.eq.0) then
  153. mrigid = ri2
  154. else
  155. segact,mrigid*mod,ri2
  156. nriav = irigel(/2)
  157. nrigel = nriav + ri2.irigel(/2)
  158. segadj,mrigid
  159. do io = 1, ri2.irigel(/2)
  160. do iu = 1, ri2.irigel(/1)
  161. irigel(iu,io+nriav) = ri2.irigel(iu,io)
  162. enddo
  163. coerig(io+nriav) = ri2.coerig(io)
  164. enddo
  165. segsup ri2
  166. endif
  167. 500 continue
  168. segdes mrigid
  169. segsup mmode2
  170. endif
  171. *
  172. * traitement des modeles ...
  173. *
  174. * -> Brancher ici le traitement specifique a chaque autre modele de
  175. * frottement qui doit fournir la rigidite de frottement associee
  176. * qui sera fusionnee dans la rigidite mrigid (cf. modeles frocable)
  177. *
  178. * Fin du traitement :
  179. *
  180. call ecrobj('RIGIDITE',mrigid)
  181. * call prrigi(mrigid)
  182.  
  183. 9000 CONTINUE
  184. mmode1 = modcou
  185. segsup,mmode1
  186. mmode1 = modcab
  187. segsup,mmode1
  188. *
  189. return
  190. end
  191.  
  192.  
  193.  

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