Télécharger rfco.eso

Retour à la liste

Numérotation des lignes :

  1. C RFCO SOURCE CHLOE 16/01/08 21:15:13 8771
  2. subroutine rfco
  3. implicit real*8(a-h,o-z)
  4. implicit integer (i-n)
  5. *
  6. * calcul des raideurs et des jeux dans le cas de modeles de contact
  7. * avec ou sans frottements
  8. * le chpoint existe en cas de contacts ( pas pour les frocable)
  9. * en sortie : une raideur et un chpoint et une deuxieme raideur.
  10. * La premiere raideur est celle des contacts, n'existe pas pour frocable
  11. * la deuxieme raisdeur existe si lconv est vrai et si contact frottant(
  12. * frocable ou coulomb)
  13. *
  14. -INC CCOPTIO
  15. -INC SMMODEL
  16. pointeur mmode3.mmodel,imode3.imodel
  17. -INC SMRIGID
  18. -INC SMCHPOI
  19. -INC SMELEME
  20. logical lconv
  21. call lirobj ('MMODEL',mmodel,1,iretou)
  22. if(ierr.ne.0) return
  23. call lirlog(lconv,1,iretou)
  24. * call lirobj('CHPOINT', mchip1,0,irchp1)
  25. call lirobj('MCHAML', mchel1,0,ircha1)
  26. if(ierr.ne.0) return
  27. mrigid=0
  28. mforc=0
  29. irigi2=0
  30. irrr=0
  31. ifff=0
  32. irff=0
  33. segact mmodel
  34. nsous= kmodel(/1)
  35. do isous=1,nsous
  36. imodel=kmodel(isous)
  37. segact imodel
  38. * write(6,*) ' boucfle sur modele isous ', isous,imamod
  39. * pour l'instant
  40. * imate=1 unilateral; imate=2 maintenu; inatu=0 pas de frottement
  41. * inatu=1 coulomb; inatu=2 frocable ( voir nomate)
  42. if( imatee.eq.0) then
  43. * cas de maintenu avec ou sans coulomb pas encore traité
  44. elseif(imatee.eq.1) then
  45. * cas de contact unilateral
  46. if(inatuu.eq.2) then
  47. if( lconv) then
  48. *cas de frocable
  49. * pour les cables la notion maintenu n'existe pas ifff=0
  50. irff=1
  51. * Petit modele unitaire local (a detruire en fin de traitement)
  52. n1=1
  53. segini,mmode2
  54. * Option accro 'GLISS'
  55. igliss=1
  56. segact imodel
  57. if(ivamod(/1).ne.2) call erreur(5)
  58. ri2 = 0
  59. meleme=ivamod(2)
  60. ipt1= ivamod(1)
  61. * call ecmail( meleme,1)
  62. * call ecmail ( ipt1,1)
  63. nfor=0
  64. nobmod=1
  65. mn3=0
  66. nmat=0
  67. segini mmode3
  68. segini imode2
  69. imode2.imamod=imamod
  70. imode2.ivamod(1)=mmode3
  71. imode2.tymode(1)='MMODEL'
  72. segdes imode2
  73. mmode2.kmodel(1)=imode2
  74. segini imode3
  75. imode3.imamod=ipt1
  76. mmode3.kmodel(1)=imode3
  77. segdes mmode3
  78. segdes imodel
  79. call ecrree(1.d-3)
  80. call ecrobj('MAILLAGE',meleme)
  81. call ecrobj('MMODEL ',mmode2)
  82. call accro(igliss)
  83. if (ierr.ne.0) goto 9000
  84. call lirobj('RIGIDITE',ri2,1,iretou)
  85. if (ierr.ne.0) goto 9000
  86. segsup mmode2
  87. if( irigi2.eq.0) then
  88. irigi2=ri2
  89. else
  90. call fusrig(irigi2,ri2,Inoup)
  91. irigi2= inoup
  92. endif
  93. * dessous fin du cas frocable
  94. endif
  95. else
  96. * cas du frottement de coulomb ou de pas de frottement
  97. * on commence par le contact unilateral
  98. call ecrobj('MAILLAGE',imamod)
  99. ipt6=0
  100. if (inatuu.eq.1) then
  101. ipt6 = ivamod(1)
  102. segact ipt6*mod
  103. endif
  104. call ecrent(mchel1)
  105. call ecrent(isous)
  106. if(idim.eq.3) call impo32(ipt6)
  107. if(idim.eq.2) then
  108. if (ifomod .ne. -1 .and. ifomod .ne. 0) then
  109. call erreur(710)
  110. return
  111. endif
  112. call impos2
  113. endif
  114. call lirobj('RIGIDITE',ri2,1,iretou)
  115. call lirobj('CHPOINT',mchpo2,1,iretou)
  116. irrr=1
  117. ifff=1
  118. if( mrigid.eq.0) then
  119. mrigid=ri2
  120. else
  121. call fusrig ( ri2 , mrigid, inoup)
  122. mrigid=inoup
  123. endif
  124. if( mforc.eq.0) then
  125. mforc=mchpo2
  126. else
  127. call adchpo(mchpo2,mforc,iret,1.d0,1.D0)
  128. mforc=iret
  129. endif
  130. *** if( lconv) then
  131. if( .true.) then
  132. * on fait aussi le frottement si on avait convergé.
  133. if( inatuu.eq.1 ) then
  134. meleme=ivamod(1)
  135. if(mchpo2.eq.0) then
  136. call erreur (19)
  137. return
  138. endif
  139. ri1=0
  140. call lirobj('MCHAML', mchel1,0,ircha1)
  141. if (idim .eq. 3) then
  142. call frig3C(meleme,ri2,mchpo2, ri1)
  143. else
  144. call frig2C(meleme,ri2,mchpo2, ri1)
  145. * write(6,*) ' sortie de frig2c ri2 '
  146. * call prrigi ( ri2,1)
  147. * write(6,*) ' sortie de frig2c ri1'
  148. * call prrigi( ri1,1)
  149. * write(6,*) ' fin ecrituere apres frig2c'
  150. endif
  151. if (ierr.ne.0 .or. ri2.eq.0) goto 9000
  152. if(irigi2.eq.0) then
  153. irigi2=ri1
  154. else
  155. call fusrig(irigi2,ri1,inoup)
  156. irigi2=inoup
  157. endif
  158. endif
  159. endif
  160. endif
  161. endif
  162. segdes imodel
  163. enddo
  164. segdes mmodel
  165. *
  166. * on reordonne mrigid pour mettre en premier toutes
  167. * les relations unilatérales ( frocables peut en sortir des pas unil)
  168. *
  169. * la premiere raideur ne contient que des relations unilaterales pour
  170. * l'instant
  171. * la deuxieme continet aussi les relations normales d'encasdtrement des
  172. * cables glissants
  173. iraid1=mrigid
  174. mrigid=irigi2
  175. if( mrigid.ne.0) then
  176. segini,ri1=mrigid
  177. ide=0
  178. segact mrigid
  179. ifi=irigel(/2)+1
  180. do i=1,irigel(/2)
  181. if( irigel(6,i). eq .0) then
  182. ifi=ifi-1
  183. ipla=ifi
  184. else
  185. ide=ide+1
  186. ipla=ide
  187. endif
  188. do ib=1,irigel(/1)
  189. ri1.irigel(ib,ipla)=irigel(ib,i)
  190. enddo
  191. ri1.coerig(ipla)= coerig(i)
  192. enddo
  193. segdes ri1
  194. segsup mrigid
  195. mrigid=ri1
  196. endif
  197. if(mrigid.eq.0) then
  198. call ecrent ( mrigid)
  199. else
  200. call ecrobj('RIGIDITE',mrigid)
  201. endif
  202. if(iraid1.eq.0) then
  203. call ecrent ( iraid1)
  204. else
  205. call ecrobj('RIGIDITE',iraid1)
  206. endif
  207. if( mforc.eq.0) then
  208. call ecrent (mforc)
  209. else
  210. call ecrobj('CHPOINT', mforc)
  211. endif
  212. return
  213. 9000 continue
  214. call erreur (19)
  215. return
  216. end
  217.  
  218.  
  219.  
  220.  
  221.  
  222.  
  223.  

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