Sources Esope | Cast3M

chleha
C CHLEHA    SOURCE    PV        20/03/30    21:16:05     10567          
*
*  appele dans menage: elimination des meleme dupliques
*
      subroutine chleha(ifonc,mele,mels,itab,ilisse)
      save ih1,ih2,ih3,nbmelr
      integer ifonc,mele,mels
      integer nbmel,nbmelr
      integer i,j,k,iel
      integer il,in,ipos
      integer mh1,mh2,mh3
      data ih1,ih2,ih3/0,0,0/
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC TMCOLAC
-INC SMCOORD
      segment itab(0)
      segment ih1(nbmel)
      segment ih2(nbmel)
      segment ih3(nbmel)
*
*  ifonc = 1 initialisation des structures
      if (ifonc.eq.1) then
       nbmel=100
       segini ih1,ih2,ih3
       nbmelr=0
       segdes ih1
       segdes ih2
       segdes ih3
       return
*  ifonc = 2 suppression des structures
      elseif (ifonc.eq.2) then
       if (ih1.ne.0) segsup ih1,ih2,ih3
       ih1=0
       ih2=0
       ih3=0
       return
      endif
*  test si fontion activee
       mels = 0
       if (ih1.eq.0) then
        return
       endif
*
*  mise a jour des hashcodes des segments de itab
*
      segact ih1*mod
      segact ih2*mod
      segact ih3*mod
      nbmel=ih1(/1)
      if (nbmel.lt.itab(/1)) then
       nbmel = itab(/1)+100
       segadj ih1,ih2,ih3
      endif
*     write (6,*) ' nbmelr itab ',nbmelr,itab(/1)
      do 10 iel=nbmelr+1,itab(/1)
       meleme=itab(iel)
       if (meleme.eq.0) goto 10
       segact meleme
* ne tester que les supports des chpts
       if (num(/1).ne.1) goto 10
       if (num(/2).gt.nbpts)  goto 10
        do il=1,num(/2)
        do in=1,num(/1)
          ipos=in+num(/1)*(il-1)
          if (mod(ipos,3).eq.0) ih1(iel) = ih1(iel)+num(in,il)
          if (mod(ipos,3).eq.1) ih2(iel) = ih2(iel)+num(in,il)
          if (mod(ipos,3).eq.2) ih3(iel) = ih3(iel)+num(in,il)
        enddo
        enddo
  10  continue
      nbmelr = itab(/1)
*
*  verication identite avec mele
*
      mels = 0
      meleme = mele
      segact meleme
 
      i=iliseg((meleme-1)/npgcd)
      if (i.ne.0) then
*   meleme deja connu
        if (itab(i).ne.meleme) call erreur(5)
        mh1=ih1(i) 
        mh2=ih2(i)
        mh3=ih3(i)
      else
*  meleme pas connu il faut recalculer le hash code
       if (num(/1).ne.1) goto 150
       if (num(/2).gt.nbpts) goto 150
        mh1=0
        mh2=0
        mh3=0
        do il=1,num(/2)
        do in=1,num(/1)
          ipos=in+num(/1)*(il-1)
          if (mod(ipos,3).eq.0) mh1 = mh1+num(in,il)
          if (mod(ipos,3).eq.1) mh2 = mh2+num(in,il)
          if (mod(ipos,3).eq.2) mh3 = mh3+num(in,il)
        enddo
        enddo
      endif
*       write (6,*) ' mh1 mh2 mh3 ',mh1,mh2,mh3
*
      do 100 i = 1,nbmelr
       if (mele.eq.itab(i)) goto 150
       if (mh1.ne.ih1(i)) goto 100
       if (mh2.ne.ih2(i)) goto 100
       if (mh3.ne.ih3(i)) goto 100
*  hash identiques verification complete
       ipt1 = itab(i)
       segact ipt1
       if (itypel.ne.ipt1.itypel) goto 100
       if (lisous(/1).ne.ipt1.lisous(/1)) goto 100
       do j=1,lisous(/1)
        if (lisous(j).ne.ipt1.lisous(j)) goto 100
       enddo
       if (lisref(/1).ne.ipt1.lisref(/1)) goto 100
       do j=1,lisref(/1)
        if (lisref(j).ne.ipt1.lisref(j)) goto 100
       enddo
*       enddo
       if (icolor(/1).ne.ipt1.icolor(/1)) goto 100
       do j=1,icolor(/1)
        if (icolor(j).ne.ipt1.icolor(j)) goto 100
       enddo
       if (num(/1).ne.ipt1.num(/1)) goto 100
       if (num(/2).ne.ipt1.num(/2)) goto 100
       do k=1,num(/2)
       do j=1,num(/1)
        if (num(j,k).ne.ipt1.num(j,k)) goto 100
       enddo
       enddo
**     write (6,*) ' maillages identiques trouves',mele,itab(i),
**   >       num(/1),num(/2)
 
 
*  maillages identiques!
       mels = itab(i)
       goto 150
 100   continue
 150   continue
       segdes ih1
       segdes ih2
       segdes ih3
       return
       end