Télécharger uniqm1.eso

Retour à la liste

Numérotation des lignes :

  1. C UNIQM1 SOURCE PV 20/03/30 21:25:29 10567
  2. *
  3. subroutine uniqm1(ipt1,meleme,nbdif)
  4. *
  5. * construit un maillage constitué des éléments unique d'un autre maillage
  6. * le maillage est elementaire et l'ordre de description n'est pas significatif
  7. *
  8. *
  9. implicit real*8 (a-h,o-z)
  10. -INC CCOPTIO
  11. -INC CCGEOME
  12. -INC SMELEME
  13. -INC SMCOORD
  14. segment netn(nbpts+1+nbhash)
  15. segment ietn(letn)
  16. segment ihash2(nbelem)
  17. *
  18. * pas de test sur le type 22 car peut etre tres long
  19. if (ipt1.itypel.eq.22) then
  20. segact ipt1
  21. if (ipt1.num(/2).gt.3*nbpts) then
  22. meleme=ipt1
  23. nbdif=0
  24. return
  25. endif
  26. endif
  27. numnp=nbpts
  28. * construction des tableaux noeuds => elements
  29. * on rejoute un hashcode comme noeud supplementaire de l'element car il est moins partage que les noeuds
  30. * dans le cas des elements de contact
  31. segact ipt1
  32. nbnn=ipt1.num(/1)
  33. nbelem=ipt1.num(/2)
  34. numnp=max(nbnn,numnp)
  35. nbhash=min(numnp*nbnn,nbelem)
  36. segini netn,ihash2
  37. do 1055 j=1,nbelem
  38. ihash=0
  39. ihashb=0
  40. do 1050 i=1,nbnn
  41. ip=ipt1.num(i,j)
  42. netn(ip)=netn(ip)+1
  43. ir=1
  44. * tri des noeuds pour calculer le hash car ils peuvent etre dans le desordre
  45. do k=1,nbnn
  46. if (ipt1.num(k,j).gt.ip) ir=ir+1
  47. enddo
  48. ihash=ip*ir+ihash
  49. * le deuxieme hash sert a accelerer les comparaisons entre elements. On le prend indifferent a l'ordre.
  50. ihashb=ipt1.num(i,j)+ihashb
  51. 1050 continue
  52. ihash=mod(ihash,nbhash)+numnp+1
  53. netn(ihash)=netn(ihash)+1
  54. ihash2(j)=ihashb
  55. 1055 continue
  56. do 1060 i=2,netn(/1)
  57. netn(i)=netn(i)+netn(i-1)
  58. 1060 continue
  59. letn=netn(netn(/1))
  60. segini ietn
  61. do 1075 j=1,nbelem
  62. ihash=0
  63. do 1070 i=1,nbnn
  64. ip=ipt1.num(i,j)
  65. ietn(netn(ip))=j
  66. netn(ip)=netn(ip)-1
  67. ir=1
  68. do k=1,nbnn
  69. if (ipt1.num(k,j).gt.ip) ir=ir+1
  70. enddo
  71. ihash=ip*ir+ihash
  72. 1070 continue
  73. ihash=mod(ihash,nbhash)+numnp+1
  74. ietn(netn(ihash))=j
  75. netn(ihash)=netn(ihash)-1
  76. 1075 continue
  77. *
  78. * recherche et elimination des doublons
  79. *
  80. segini,meleme=ipt1
  81. nbnn=num(/1)
  82. DO 150 IEF=1,nbelem
  83. * recherche du noeud ayant le moins d'elements et calcul simultanement du hash
  84. nbel=letn+1
  85. ino=0
  86. ihash=0
  87. do 160 inf=1,nbnn
  88. ip=num(inf,ief)
  89. ir=1
  90. do k=1,nbnn
  91. if (ipt1.num(k,ief).gt.ip) ir=ir+1
  92. enddo
  93. ihash=ip*ir+ihash
  94. id=netn(ip)+1
  95. if=netn(ip+1)
  96. if (nbel.gt.(if-id)) then
  97. ino=inf
  98. nbel=if-id
  99. endif
  100. 160 continue
  101. ihash=mod(ihash,nbhash)+numnp+1
  102. id=netn(ihash)+1
  103. if=netn(ihash+1)
  104. if (nbel.gt.(if-id)) then
  105. ino=ihash
  106. nbel=if-id
  107. endif
  108. * test sur les elements connectes a ce noeud
  109. if (ino.le.numnp) then
  110. ip=num(ino,ief)
  111. ** write(6,*) ' utilisation du noeud ',ino,ip
  112. else
  113. ip=ino
  114. ** write(6,*) ' utilisation du hash ',ip
  115. endif
  116. id=netn(ip)+1
  117. if=netn(ip+1)
  118. do 165 itn=id,if
  119. iem=ietn(itn)
  120. * les elements sont ranges par ordre decroissant dans ietn car il est rempli a partir de la fin
  121. * on peut donc s'arreter des qu'on s'est atteint
  122. if (iem.le.ief) goto 150
  123. if (ihash2(iem).ne.ihash2(ief)) goto 165
  124. do 167 i0=1,nbnn
  125. do 166 i1b=i0,nbnn+i0-1
  126. i1=mod(i1b-1,nbnn)+1
  127. if (num(i0,ief).eq.num(i1,iem)) goto 167
  128. 166 continue
  129. goto 165
  130. 167 continue
  131. ** write (6,*) ' ief elimine ',ief
  132. num(1,ief)=0
  133. icolor(iem)=itabm(icolor(ief),icolor(iem))
  134. goto 150
  135. 165 continue
  136. 150 continue
  137. * compression du résultat
  138. nbelem=0
  139. do 200 iel=1,num(/2)
  140. if (num(1,iel).ne.0) then
  141. nbelem=nbelem+1
  142. do i=1,num(/1)
  143. num(i,nbelem)=num(i,iel)
  144. enddo
  145. icolor(nbelem)=icolor(iel)
  146. endif
  147. 200 continue
  148. nbnn=num(/1)
  149. nbsous=0
  150. nbref=0
  151. nbdif = num(/2)-nbelem
  152. if (nbdif.ne.0) then
  153. interr(1)=nbdif
  154. moterr(1:4)=noms(itypel)
  155. call erreur(-354)
  156. segadj meleme
  157. else
  158. segsup meleme
  159. meleme = ipt1
  160. endif
  161.  
  162. c if (nbelem.eq.0) then
  163. c segsup meleme
  164. c meleme=0
  165. c endif
  166. segsup netn,ietn,ihash2
  167.  
  168. return
  169. end
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  

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