Télécharger rfco.eso

Retour à la liste

Numérotation des lignes :

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

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