Télécharger fpshb8.eso

Retour à la liste

Numérotation des lignes :

  1. C FPSHB8 SOURCE CHAT 11/03/16 21:23:09 6902
  2. subroutine fpshb8(mmodel,mchpo1,p,mchpoi)
  3. implicit real*8(a-h,o-z)
  4. implicit integer (i-n)
  5. -INC CCOPTIO
  6. -INC SMCHPOI
  7. -INC SMELEME
  8. -INC SMMODEL
  9. -INC SMCOORD
  10. character*4 moopt(2)
  11. segment tratra
  12. real *8 propel(2),out(3,8),re(1),d(1),xe(3,8),work(3)
  13. endsegment
  14. segment icpr(xcoor(/1)/(idim+1))
  15. segment icprp(xcoor(/1)/(idim+1))
  16. data moopt/'INTE','EXTE'/
  17. *
  18. * verif que les surfaces interne ou externe existent
  19. *
  20. icpr=0
  21. icprp=0
  22. mchpoi=0
  23. segact mmodel
  24. do ia=1,kmodel(/1)
  25. imodel=kmodel(ia)
  26. segact imodel
  27. if(nefmod.ne.260) then
  28. call erreur (19)
  29. return
  30. endif
  31. meleme=imamod
  32. segact meleme
  33. if(lisref(/1).ne.2) then
  34. call erreur(1004)
  35. return
  36. endif
  37. ipt1=lisref(1)
  38. segact ipt1
  39. if(ipt1.itypel.ne.8) then
  40. call erreur (1004)
  41. return
  42. endif
  43. segdes ipt1
  44. ipt1=lisref(2)
  45. segact ipt1
  46. if(ipt1.itypel.ne.8) then
  47. call erreur (1004)
  48. return
  49. endif
  50. segdes ipt1
  51. enddo
  52. *
  53. * reperage du champpointy de pression si necessaire
  54. *
  55. if( mchpo1.ne.0) then
  56. segini icpr
  57. segact mchpo1
  58. if(mchpo1.ipchp(/1).ne.1) then
  59. call erreur(180)
  60. mchpoi=0
  61. return
  62. endif
  63. msoupo=mchpo1.ipchp(1)
  64. segact msoupo
  65. ipt1=igeoc
  66. segact ipt1
  67. do i=1,ipt1.num(/2)
  68. ia=ipt1.num(1,i)
  69. icpr(ia)=i
  70. enddo
  71. mpova2=ipoval
  72. segact mpova2
  73. segdes msoupo,ipt1
  74. endif
  75. *
  76. * lecture du mot interne ou externe et debut de la
  77. * fabrication du chpoint résultat
  78. *
  79. call lirmot(moopt,2,isur,0)
  80. if(isur.eq.0) then
  81. * on a pas lu ni interne ni externe on essaye de savoir
  82. * sur qui le chpoint de pression est appliqué
  83. if(mchpo1.eq.0) then
  84. call erreur(1005)
  85. return
  86. endif
  87. isur1=0
  88. do ia=1,kmodel(/1)
  89. imodel=kmodel(ia)
  90. meleme=imamod
  91. do 321 io=1,2
  92. ipt3=lisref(io)
  93. segact ipt3
  94. do iel=1,ipt3.num(/2)
  95. iell=ipt3.num(1,iel)
  96. if( icpr(iell).eq.0) go to 321
  97. enddo
  98. if(isur1.eq.0) then
  99. isur1=io
  100. go to 322
  101. else
  102. if(isur1.ne.io)then
  103. call erreur(1006)
  104. return
  105. endif
  106. endif
  107. 321 continue
  108. 322 continue
  109. enddo
  110. if(isur1.eq.0) call erreur(286)
  111. isur=isur1
  112. endif
  113. *
  114. * reperage de la surface
  115. *
  116. segini icprp
  117. nbelem=0
  118. do ia=1,kmodel(/1)
  119. imodel=kmodel(ia)
  120. meleme=imamod
  121. ipt3=lisref(isur)
  122. segact ipt3
  123. do ib=1,ipt3.num(/2)
  124. do ic=1,ipt3.num(/1)
  125. ie=ipt3.num(ic,ib)
  126. if(icprp(ie).eq.0) then
  127. nbelem=nbelem+1
  128. icprp(ie)=nbelem
  129. endif
  130. enddo
  131. enddo
  132. enddo
  133. *
  134. * debut de la fabrication du chpoint résultat
  135. *
  136. nbnn=1
  137. nbref=0
  138. nbsous=0
  139. segini ipt4
  140. nsoupo=1
  141. nat=1
  142. segini mchpoi
  143. ifopoi=ifour
  144. mtypoi='FORCES'
  145. mochde='crée par fpshb8 '
  146. nc=3
  147. segini msoupo
  148. ipchp(1)=msoupo
  149. segdes mchpoi
  150. n=nbelem
  151. segini mpoval
  152. ipoval=mpoval
  153. igeoc=ipt4
  154. nocomp(1)='F '
  155. nocomp(2)='FY '
  156. nocomp(3)='FZ '
  157. noharm(1)=nifour
  158. noharm(2)=nifour
  159. noharm(3)=nifour
  160. segdes msoupo
  161. do ib=1,icprp(/1)
  162. ia=icprp(ib)
  163. if(ia.ne.0) ipt4.num(1,ia)=ib
  164. enddo
  165. segdes ipt4
  166. *
  167. * boucle sur les élements
  168. *
  169. segini tratra
  170. idim1=idim+1
  171. do ir=1,kmodel(/1)
  172. imodel=kmodel(ir)
  173. meleme=imamod
  174. segact meleme
  175. ipt3=lisref(isur)
  176. segact ipt3
  177. propel(2)=isur
  178. propel(1)=p
  179. do iel=1,num(/2)
  180. if( mchpo1.ne.0) then
  181. p=0.d0
  182. do j=1,ipt3.num(/1)
  183. ih=ipt3.num(j,iel)
  184. if(icpr(ih).ne.0) then
  185. p=p+mpova2.vpocha(icpr(ih),1)/4
  186. endif
  187. enddo
  188. propel(1)=p
  189. endif
  190. do io=1,8
  191. ia=num(io,iel)
  192. xe(1,io)=xcoor((ia-1)*idim1+1)
  193. xe(2,io)=xcoor((ia-1)*idim1+2)
  194. xe(3,io)=xcoor((ia-1)*idim1+3)
  195. enddo
  196. call shb8(5,xe,D,propel,work,re,out)
  197. * assemblage
  198.  
  199. do io=1,8
  200. ia=num(io,iel)
  201. ib=icprp(ia)
  202. if(ib.ne.0) then
  203. vpocha(ib,1)=out(1,io)+vpocha(ib,1)
  204. vpocha(ib,2)=out(2,io)+vpocha(ib,2)
  205. vpocha(ib,3)=out(3,io)+vpocha(ib,3)
  206. endif
  207. enddo
  208. enddo
  209. segdes imodel,meleme,ipt3
  210. enddo
  211. segdes mpoval
  212. segdes mmodel
  213. segsup icprp,tratra
  214. if(icpr.ne.0) then
  215. segsup icpr
  216. segdes mpova2
  217. endif
  218. return
  219. end
  220.  
  221.  
  222.  
  223.  

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