Télécharger rfco.eso

Retour à la liste

Numérotation des lignes :

  1. C RFCO SOURCE CB215821 19/08/20 21:21:43 10287
  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. call actobj ('MMODEL ',mmodel,1)
  23. if(ierr.ne.0) return
  24. call lirlog(lconv,1,iretou)
  25. * call lirobj('CHPOINT', mchip1,0,irchp1)
  26. call lirobj('MCHAML ', mchel1,0,ircha1)
  27. if(ircha1.eq.1) call actobj('MCHAML ', mchel1,1)
  28. if(ierr.ne.0) return
  29. mrigid=0
  30. mforc=0
  31. irigi2=0
  32. irrr=0
  33. ifff=0
  34. irff=0
  35. segact mmodel
  36. nsous= kmodel(/1)
  37. do isous=1,nsous
  38. imodel=kmodel(isous)
  39. segact imodel
  40. * write(6,*) ' boucfle sur modele isous ', isous,imamod
  41. * pour l'instant
  42. * imate=1 unilateral; imate=2 maintenu; inatu=0 pas de frottement
  43. * inatu=1 coulomb; inatu=2 frocable ( voir nomate)
  44. if( imatee.eq.0) then
  45. * cas de maintenu avec ou sans coulomb pas encore traité
  46. elseif(imatee.eq.1) then
  47. * cas de contact unilateral
  48. if(inatuu.eq.2) then
  49. if( lconv) then
  50. *cas de frocable
  51. * pour les cables la notion maintenu n'existe pas ifff=0
  52. irff=1
  53. * Petit modele unitaire local (a detruire en fin de traitement)
  54. n1=1
  55. segini,mmode2
  56. * Option accro 'GLISS'
  57. igliss=1
  58. segact imodel
  59. if(ivamod(/1).ne.2) call erreur(5)
  60. ri2 = 0
  61. meleme=ivamod(2)
  62. ipt1= ivamod(1)
  63. * call ecmail( meleme,1)
  64. * call ecmail ( ipt1,1)
  65. nfor=0
  66. nobmod=1
  67. mn3=0
  68. nmat=0
  69. segini mmode3
  70. segini imode2
  71. imode2.imamod=imamod
  72. imode2.ivamod(1)=mmode3
  73. imode2.tymode(1)='MMODEL'
  74. mmode2.kmodel(1)=imode2
  75. segini imode3
  76. imode3.imamod=ipt1
  77. mmode3.kmodel(1)=imode3
  78. call ecrree(1.d-3)
  79. call ecrobj('MAILLAGE',meleme)
  80. call ecrobj('MMODEL ',mmode2)
  81. call accro(igliss)
  82. if (ierr.ne.0) goto 9000
  83. call lirobj('RIGIDITE',ri2,1,iretou)
  84. if (ierr.ne.0) goto 9000
  85. segsup mmode2
  86. if( irigi2.eq.0) then
  87. irigi2=ri2
  88. else
  89. call fusrig(irigi2,ri2,Inoup)
  90. irigi2= inoup
  91. endif
  92. * dessous fin du cas frocable
  93. endif
  94. else
  95. * cas du frottement de coulomb ou de pas de frottement
  96. * on commence par le contact unilateral
  97. ipoin1=imamod
  98. call ecrobj('MAILLAGE',ipoin1)
  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. enddo
  163. *
  164. * on reordonne mrigid pour mettre en premier toutes
  165. * les relations unilatérales ( frocables peut en sortir des pas unil)
  166. *
  167. * la premiere raideur ne contient que des relations unilaterales pour
  168. * l'instant
  169. * la deuxieme continet aussi les relations normales d'encasdtrement des
  170. * cables glissants
  171. iraid1=mrigid
  172. mrigid=irigi2
  173. if( mrigid.ne.0) then
  174. segini,ri1=mrigid
  175. ide=0
  176. segact mrigid
  177. ifi=irigel(/2)+1
  178. do i=1,irigel(/2)
  179. if( irigel(6,i). eq .0) then
  180. ifi=ifi-1
  181. ipla=ifi
  182. else
  183. ide=ide+1
  184. ipla=ide
  185. endif
  186. do ib=1,irigel(/1)
  187. ri1.irigel(ib,ipla)=irigel(ib,i)
  188. enddo
  189. ri1.coerig(ipla)= coerig(i)
  190. enddo
  191. segdes ri1
  192. segsup mrigid
  193. mrigid=ri1
  194. endif
  195. if(mrigid.eq.0) then
  196. call ecrent ( mrigid)
  197. else
  198. call ecrobj('RIGIDITE',mrigid)
  199. endif
  200. if(iraid1.eq.0) then
  201. call ecrent ( iraid1)
  202. else
  203. call ecrobj('RIGIDITE',iraid1)
  204. endif
  205. if( mforc.eq.0) then
  206. call ecrent (mforc)
  207. else
  208. call actobj('CHPOINT', mforc,1)
  209. call ecrobj('CHPOINT', mforc)
  210. endif
  211. return
  212. 9000 continue
  213. call erreur (19)
  214. end
  215.  
  216.  
  217.  

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