Télécharger chleha.eso

Retour à la liste

Numérotation des lignes :

  1. C CHLEHA SOURCE PV 17/12/05 21:15:12 9646
  2. *
  3. * appele dans menage: elimination des meleme dupliques
  4. *
  5. subroutine chleha(ifonc,mele,mels,itab,ilisse)
  6. save ih1,ih2,ih3,nbmelr
  7. integer ifonc,mele,mels
  8. integer nbmel,nbmelr
  9. integer i,j,k,iel
  10. integer il,in,ipos
  11. integer mh1,mh2,mh3
  12. data ih1,ih2,ih3/0,0,0/
  13. -INC CCOPTIO
  14. -INC SMELEME
  15. -INC TMCOLAC
  16. -INC SMCOORD
  17. segment itab(0)
  18. segment ih1(nbmel)
  19. segment ih2(nbmel)
  20. segment ih3(nbmel)
  21. *
  22. * ifonc = 1 initialisation des structures
  23. if (ifonc.eq.1) then
  24. nbmel=100
  25. segini ih1,ih2,ih3
  26. nbmelr=0
  27. segdes ih1
  28. segdes ih2
  29. segdes ih3
  30. return
  31. * ifonc = 2 suppression des structures
  32. elseif (ifonc.eq.2) then
  33. if (ih1.ne.0) segsup ih1,ih2,ih3
  34. ih1=0
  35. ih2=0
  36. ih3=0
  37. return
  38. endif
  39. * test si fontion activee
  40. mels = 0
  41. if (ih1.eq.0) then
  42. return
  43. endif
  44. *
  45. * mise a jour des hashcodes des segments de itab
  46. *
  47. segact ih1*mod
  48. segact ih2*mod
  49. segact ih3*mod
  50. nbmel=ih1(/1)
  51. if (nbmel.lt.itab(/1)) then
  52. nbmel = itab(/1)+100
  53. segadj ih1,ih2,ih3
  54. endif
  55. * write (6,*) ' nbmelr itab ',nbmelr,itab(/1)
  56. do 10 iel=nbmelr+1,itab(/1)
  57. meleme=itab(iel)
  58. if (meleme.eq.0) goto 10
  59. segact meleme
  60. * ne tester que les supports des chpts
  61. if (num(/1).ne.1) goto 10
  62. if (num(/2).gt.xcoor(/1)/(idim+1)) goto 10
  63. do il=1,num(/2)
  64. do in=1,num(/1)
  65. ipos=in+num(/1)*(il-1)
  66. if (mod(ipos,3).eq.0) ih1(iel) = ih1(iel)+num(in,il)
  67. if (mod(ipos,3).eq.1) ih2(iel) = ih2(iel)+num(in,il)
  68. if (mod(ipos,3).eq.2) ih3(iel) = ih3(iel)+num(in,il)
  69. enddo
  70. enddo
  71. 10 continue
  72. nbmelr = itab(/1)
  73. *
  74. * verication identite avec mele
  75. *
  76. mels = 0
  77. meleme = mele
  78. segact meleme
  79.  
  80. i=iliseg((meleme-1)/npgcd)
  81. if (i.ne.0) then
  82. * meleme deja connu
  83. if (itab(i).ne.meleme) call erreur(5)
  84. mh1=ih1(i)
  85. mh2=ih2(i)
  86. mh3=ih3(i)
  87. else
  88. * meleme pas connu il faut recalculer le hash code
  89. if (num(/1).ne.1) goto 150
  90. if (num(/2).gt.xcoor(/1)/(idim+1)) goto 150
  91. mh1=0
  92. mh2=0
  93. mh3=0
  94. do il=1,num(/2)
  95. do in=1,num(/1)
  96. ipos=in+num(/1)*(il-1)
  97. if (mod(ipos,3).eq.0) mh1 = mh1+num(in,il)
  98. if (mod(ipos,3).eq.1) mh2 = mh2+num(in,il)
  99. if (mod(ipos,3).eq.2) mh3 = mh3+num(in,il)
  100. enddo
  101. enddo
  102. endif
  103. * write (6,*) ' mh1 mh2 mh3 ',mh1,mh2,mh3
  104. *
  105. do 100 i = 1,nbmelr
  106. if (mele.eq.itab(i)) goto 150
  107. if (mh1.ne.ih1(i)) goto 100
  108. if (mh2.ne.ih2(i)) goto 100
  109. if (mh3.ne.ih3(i)) goto 100
  110. * hash identiques verification complete
  111. ipt1 = itab(i)
  112. segact ipt1
  113. if (itypel.ne.ipt1.itypel) goto 100
  114. if (lisous(/1).ne.ipt1.lisous(/1)) goto 100
  115. do j=1,lisous(/1)
  116. if (lisous(j).ne.ipt1.lisous(j)) goto 100
  117. enddo
  118. if (lisref(/1).ne.ipt1.lisref(/1)) goto 100
  119. do j=1,lisref(/1)
  120. if (lisref(j).ne.ipt1.lisref(j)) goto 100
  121. enddo
  122. * enddo
  123. if (icolor(/1).ne.ipt1.icolor(/1)) goto 100
  124. do j=1,icolor(/1)
  125. if (icolor(j).ne.ipt1.icolor(j)) goto 100
  126. enddo
  127. if (num(/1).ne.ipt1.num(/1)) goto 100
  128. if (num(/2).ne.ipt1.num(/2)) goto 100
  129. do k=1,num(/2)
  130. do j=1,num(/1)
  131. if (num(j,k).ne.ipt1.num(j,k)) goto 100
  132. enddo
  133. enddo
  134. ** write (6,*) ' maillages identiques trouves',mele,itab(i),
  135. ** > num(/1),num(/2)
  136.  
  137.  
  138. * maillages identiques!
  139. mels = itab(i)
  140. goto 150
  141. 100 continue
  142. 150 continue
  143. segdes ih1
  144. segdes ih2
  145. segdes ih3
  146. return
  147. end
  148.  
  149.  
  150.  
  151.  
  152.  
  153.  
  154.  
  155.  
  156.  

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