Télécharger reduri.eso

Retour à la liste

Numérotation des lignes :

  1. C REDURI SOURCE PASCAL 20/07/03 21:15:05 10635
  2. subroutine reduri(mrigid,moleme,irigre)
  3. implicit real*8(a-h,o-z)
  4. implicit integer (i-n)
  5. -INC SMRIGID
  6. -INC SMELEME
  7.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC SMCOORD
  11. segment icpr(nbpts)
  12. segment inode(ino)
  13. segment jelnum(imaxel,ino)
  14. segment izone(imaxel,ino)
  15. irigre=0
  16. ipt1=moleme
  17. segact ipt1
  18. meleme=ipt1
  19. nbso1=ipt1.lisous(/1)
  20. ino=0
  21.  
  22. C Cas d'un MELEME vide => RIGIDITE vide
  23. segact mrigid
  24. IF (nbso1.eq.0) THEN
  25. IF (IPT1.NUM(/2).EQ.0) THEN
  26. NRIGEL = 0
  27. SEGINI,RI1
  28. RI1.MTYMAT = MTYMAT
  29. irigre = RI1
  30. segdes mrigid
  31. RETURN
  32. ENDIF
  33. ENDIF
  34. *
  35. * creation, d'une numerotation locale
  36. *
  37. segini icpr
  38. do 1 i =1, max(nbso1,1)
  39. if(nbso1.ne.0) then
  40. meleme=ipt1.lisous(i)
  41. segact meleme
  42. endif
  43. do 2 j=1,num(/2)
  44. do 22 k=1,num(/1)
  45. ia= num(k,j)
  46. if(icpr(ia).eq.0) then
  47. ino=ino+1
  48. icpr(ia)=ino
  49. endif
  50. 22 continue
  51. 2 continue
  52. 1 continue
  53. *
  54. * on compte combien d'elements touche un noeud
  55. *
  56. segini inode
  57. do 3 i=1,max(nbso1,1)
  58. if(nbso1.ne.0) then
  59. meleme=ipt1.lisous(i)
  60. endif
  61. do 4 j=1,num(/2)
  62. do 42 k=1,num(/1)
  63. ia=num(k,j)
  64. ib= icpr(ia)
  65. inode(ib)=inode(ib)+1
  66. 42 continue
  67. 4 continue
  68. 3 continue
  69. imaxel=0
  70. do i=1,ino
  71. imaxel=max(imaxel,inode(i))
  72. inode(i)=0
  73. enddo
  74. segini jelnum,izone
  75. *
  76. * jelnum(i,k) dira le Ieme element qui touche le noeud k
  77. * izone (i,k) dira dans quel lisous le ieme element se trouve
  78. * attention le noeud K est le plus petit de l'élément
  79. do 5 i=1,max(nbso1,1)
  80. if(nbso1.ne.0) then
  81. meleme=ipt1.lisous(i)
  82. endif
  83. do 6 j=1,num(/2)
  84. ipeti=nbpts*(idim+1)
  85. do k=1,num(/1)
  86. ipeti=min(num(k,j),ipeti)
  87. enddo
  88. ib= icpr(ipeti)
  89. inode(ib)=inode(ib)+1
  90. ic=inode(ib)
  91. jelnum(ic,ib)=j
  92. izone(ic,ib)=i
  93. 6 continue
  94. 5 continue
  95. *
  96. * travail sur les rigidites elementaires
  97. *
  98. nrigel=coerig(/1)
  99. nrige=irigel(/1)
  100. segini ri1
  101. irzon=0
  102. do 10 i=1,irigel(/2)
  103. ipt3=irigel(1,i)
  104. segact ipt3
  105. xmatri=irigel(4,i)
  106. ielzo=0
  107. do 11 j=1,ipt3.num(/2)
  108. ipeti=nbpts*(idim+1)
  109. do k=1,ipt3.num(/1)
  110. ipeti=min(ipeti,ipt3.num(k,j))
  111. enddo
  112.  
  113.  
  114. * on regarde s'il existe un element de ipt1 ayant ce noeud en plus
  115. * petitre position si non on passe a l'élément suivant
  116. ib=icpr(ipeti)
  117. if(ib.eq.0) go to 11
  118. if(inode(ib).eq.0) go to 11
  119. do 13 mm=1,inode(ib)
  120. if(nbso1.ne.0)then
  121. meleme= ipt1.lisous(izone(mm,ib))
  122. endif
  123. if(ipt3.num(/1).ne.num(/1)) go to 13
  124. iel=jelnum(mm,ib)
  125. do in=1,ipt3.num(/1)
  126. if( ipt3.num(in,j).ne.num(in,iel))go to 13
  127. enddo
  128. * on a trouver un element a conserver
  129. if(ielzo.eq.0) then
  130. segini,ipt4=ipt3
  131. irzon=irzon+1
  132. do kk=1,irigel(/1)
  133. ri1.irigel(kk,irzon)=irigel(kk,i)
  134. enddo
  135. ri1.irigel(1,irzon)=ipt4
  136. ri1.coerig(irzon)=coerig(i)
  137. ri1.mtymat=mtymat
  138. xmatri=irigel(4,i)
  139. segact xmatri
  140. segini,xmatr1=xmatri
  141. ri1.irigel(4,irzon)= xmatr1
  142. endif
  143. ielzo=ielzo+1
  144. do io=1,re(/2)
  145. do iu=1,re(/1)
  146. xmatr1.re(iu,io,ielzo)=re(iu,io,j)
  147. enddo
  148. enddo
  149. * imatr1.imattt(ielzo)=imattt(j)
  150. do kk=1,ipt3.num(/1)
  151. ipt4.num(kk,ielzo)=ipt3.num(kk,j)
  152. enddo
  153. 13 continue
  154. 11 continue
  155. * on ajuste les longueur si besoin
  156. if(ielzo.ne.0) then
  157. if(ielzo.ne.ipt4.num(/2)) then
  158. nbsous=0
  159. nbelem= ielzo
  160. nbnn=ipt4.num(/1)
  161. nbref=0
  162. segadj ipt4
  163. nelrig=ielzo
  164. nligrp= xmatr1.re(/2)
  165. nligrd= xmatr1.re(/1)
  166. segadj xmatr1
  167. segdes ipt4,xmatr1
  168. else
  169. ri1.irigel(4,irzon)=xmatri
  170. ri1.irigel(1,irzon)=ipt3
  171. segsup xmatr1,ipt4
  172. endif
  173. endif
  174. segdes xmatri
  175. 10 continue
  176. if(irzon.eq.0) then
  177. segdes mrigid
  178. call erreur(21)
  179. return
  180. elseif(irzon.ne.coerig(/1)) then
  181. nrigel=irzon
  182. nrige=irigel(/1)
  183. segadj ri1
  184. segdes ri1
  185. irigre=ri1
  186. else
  187. do io=1,irzon
  188. if( ri1.irigel(1,io).ne.irigel(1,io) )go to 20
  189. enddo
  190. irigre= mrigid
  191. go to 21
  192. 20 continue
  193. irigre=ri1
  194.  
  195. 21 continue
  196. endif
  197. do iou=1,irigel(/2)
  198. ipt3=irigel(1,iou)
  199. segdes ipt3
  200. enddo
  201. segdes mrigid
  202. if(irigre.eq.mrigid) then
  203. segsup ri1
  204. else
  205. segdes ri1
  206. endif
  207. segsup izone,icpr,jelnum,inode
  208. return
  209. end
  210.  
  211.  
  212.  
  213.  
  214.  
  215.  

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