Télécharger chleha.eso

Retour à la liste

Numérotation des lignes :

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

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