Télécharger relaba.eso

Retour à la liste

Numérotation des lignes :

  1. C RELABA SOURCE BP208322 16/11/18 21:20:54 9177
  2. SUBROUTINE RELABA
  3. *
  4. * relation barycentrique pour les ddl d'un noeud vis-à-vis
  5. * d'un maillage
  6. * rig1 = rela bary lmot1 (ou 'DEPL' ou 'ROTA') p1 geo1
  7. *
  8. *
  9. IMPLICIT INTEGER(I-N)
  10. IMPLICIT REAL*8 (A-H,O-Z)
  11. -INC CCOPTIO
  12. -INC CCGEOME
  13. -INC SMELEME
  14. -INC SMCOORD
  15. -INC SMRIGID
  16. -INC CCHAMP
  17. -INC SMLREEL
  18. -INC SMLMOTS
  19. c
  20. CHARACTER*4 ITCORI(2),LEMOT,LESDDL(6),LESDUA(6)
  21. CHARACTER*4 MODEPL(5),MODEDU(5),MOROTA(5),MORODU(5)
  22. DATA ITCORI(1)/'DEPL'/
  23. DATA ITCORI(2)/'ROTA'/
  24. DATA MODEPL / 'UX ','UY ','UZ ','UR ','UT ' /
  25. DATA MODEDU / 'FX ','FY ','FZ ','FR ','FT ' /
  26. DATA MOROTA / 'RX ','RY ','RZ ','RT ','RS ' /
  27. DATA MORODU / 'MX ','MY ','MZ ','MT ','MS ' /
  28.  
  29. CALL LIROBJ('LISTMOTS',IP0,0,IRETOU)
  30.  
  31. if (IP0.eq.0) then
  32. CALL LIRMOT(ITCORI,2,IMOT,0)
  33. if (imot.eq.0) then
  34. call erreur(5)
  35. return
  36. else if (imot.eq.1) then
  37. if (ifour.eq.2) then
  38. nosddl = 3
  39. lesddl(1) = modepl(1)
  40. lesddl(2) = modepl(2)
  41. lesddl(3) = modepl(3)
  42. else
  43. endif
  44. CALL LIRMOT(ITCORI,2,IMOT,0)
  45. if (imot.eq.2) then
  46. if (ifour.eq.2) then
  47. nosddl = 6
  48. lesddl(4) = morota(1)
  49. lesddl(5) = morota(2)
  50. lesddl(6) = morota(3)
  51. else
  52. endif
  53. endif
  54. else
  55. CALL LIRMOT(ITCORI,2,IMOT,0)
  56. if (imot.eq.1) then
  57. if (ifour.eq.2) then
  58. nosddl = 6
  59. iddl = 3
  60. else
  61. endif
  62. else
  63. if (ifour.eq.2) then
  64. nosddl = 3
  65. iddl = 0
  66. else
  67. endif
  68.  
  69. endif
  70. if (ifour.eq.2) then
  71. lesddl(iddl + 1) = morota(1)
  72. lesddl(iddl + 2) = morota(2)
  73. lesddl(iddl + 3) = morota(3)
  74. else
  75. endif
  76. endif
  77. else
  78. mlmots = ip0
  79. segact mlmots
  80. jgn = mots(/2)
  81. do 11 imo = 1,jgn
  82. do jde =1,5
  83. if (mots(imo).eq.modepl(jde)) then
  84. lesddl(imo) = modepl(jde)
  85. lesdua(imo) = modedu(jde)
  86. goto 11
  87. endif
  88. enddo
  89. do jde = 1,5
  90. if (mots(imo).eq.morota(jde)) then
  91. lesddl(imo) = morota(jde)
  92. lesdua(imo) = morodu(jde)
  93. goto 11
  94. endif
  95. enddo
  96. c le mot n est pas un ddl
  97. call erreur(5)
  98. return
  99. 11 continue
  100. nosddl = jgn
  101. endif
  102.  
  103.  
  104. CALL LIROBJ('POINT',IP1,1,IRETOU)
  105. CALL LIROBJ('MAILLAGE',IP2,1,IRETOU)
  106. meleme = ip2
  107. segact meleme
  108. if (itypel.ne.1) call change(ip2,1)
  109. meleme = ip2
  110. segact meleme
  111. nbele1 = num(/2)
  112. ipt1 = ip2
  113. CALL LIROBJ('LISTREEL',IP3,0,IRETOU)
  114. if (iretou.eq.1) then
  115. mlreel = ip3
  116. segact mlreel
  117. jg = prog(/1)
  118. if (jg.ne.nbele1) then
  119. c autant de coef que de points
  120. call erreur(5)
  121. return
  122. endif
  123. som1 = prog(1)
  124. do j = 2,jg
  125. som1 = som1 + prog(j)
  126. enddo
  127. if (som1.eq.0.D0) then
  128. c somme des coefs nulle
  129. call erreur(5)
  130. return
  131. endif
  132. else
  133. jg = 1
  134. endif
  135.  
  136.  
  137. * cree multiplicateur(s)
  138. NBPTI=XCOOR(/1)/(IDIM+1)
  139. NBPTS = NBPTI + nosddl
  140. segadj mcoord
  141. do j = 1,nosddl
  142. xcoor((nbpti - 1 + j)*(idim + 1) + 1) = 0.d0
  143. xcoor((nbpti - 1 + j)*(idim + 1) + 2) = 0.d0
  144. if (idim.eq.3) xcoor((nbpti - 1 + j)*(idim + 1) + 3) = 0.d0
  145. xcoor((nbpti + j)*(idim + 1)) = 0.d0
  146. enddo
  147.  
  148. * cree rigidite
  149. NRIGE = 6
  150. NRIGEL = nosddl
  151. segini mrigid
  152. ICHOLE=0
  153. IMGEO1=0
  154. IMGEO2=0
  155. ISUPEQ=0
  156. IFORIG=IFOMOD
  157. MTYMAT='RIGIDITE'
  158.  
  159. NLIGRP=nbele1 + 2
  160. NLIGRD=nbele1 + 2
  161. nelrig=1
  162. segini xmatri
  163. * nelrig = 1
  164. * segini imatri
  165. * imattt(1) = xmatri
  166. re(1,1,1) = 0.d0
  167. if (jg.eq.1) then
  168. re(1,2,1) = 1.D0/nbele1
  169. re(2,1,1) = re(1,2,1)
  170. do l = 1, nbele1
  171. re(1,2 + l,1) = -1.D0
  172. re(2+l,1,1) = -1.D0
  173. enddo
  174. else
  175. re(1,2,1) = 1.D0/som1
  176. re(2,1,1) = re(1,2,1)
  177. do l = 1, nbele1
  178. re(1,2 + l,1) = -1.D0*prog(l)
  179. re(2+l,1,1) = re(1,2+l,1)
  180. enddo
  181. endif
  182. segdes xmatri
  183.  
  184. do ir = 1,nosddl
  185. ipmu = NBPTI + ir
  186. nbnn = nbele1 + 2
  187. nbelem = 1
  188. nbsous = 0
  189. nbref = 0
  190. segini meleme
  191. itypel = 22
  192. num(1,1) = ipmu
  193. num(2,1) = ip1
  194. segact ipt1
  195. do in = 1,nbele1
  196. num(2+in,1) = ipt1.num(1,in)
  197. enddo
  198. icolor(1) = idcoul
  199. segdes meleme
  200.  
  201. SEGINI DESCR
  202. NOELEP(1)= 1
  203. NOELED(1)= 1
  204. LISINC(1)='LX'
  205. LISDUA(1)='FLX'
  206. do l = 1,nbele1+1
  207. LISINC(1 + l)=lesddl(ir)
  208. LISDUA(1 + l)=lesdua(ir)
  209. NOELEP(1+l)= 1 + l
  210. NOELED(1+l)= 1 + l
  211. enddo
  212. SEGDES DESCR
  213.  
  214. coerig(ir) = 1.d0
  215. IRIGEL(2,ir) = 0
  216. IRIGEL(5,ir) = NIFOUR
  217. IRIGEL(6,ir) = 0
  218. IRIGEL(1,ir) = meleme
  219. IRIGEL(3,ir) = descr
  220. IRIGEL(4,ir) = xmatri
  221.  
  222.  
  223. enddo
  224. segdes mrigid
  225.  
  226. CALL ECROBJ('RIGIDITE',mrigid)
  227. RETURN
  228. END
  229.  
  230.  
  231.  
  232.  
  233.  
  234.  

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