Sources Esope | Cast3M

uniqm1
C UNIQM1    SOURCE    PV090527  23/02/02    21:15:08     11577          
*
      subroutine uniqm1(ipt1,meleme,nbdif,iordre)
*
*  construit un maillage constitue des elements unique d'un autre maillage
*  le maillage est elementaire et l'ordre de description est ou n'est pas
*  significatif selon la valeur de iordre
*
      implicit real*8 (a-h,o-z)
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMELEME
-INC SMCOORD
      segment netn(nbpts+1+nbhash)
      segment ietn(letn)
      segment ihash2(nbelem)
*
*  pas de test sur le type 22 car peut etre tres long
      if (ipt1.itypel.eq.22) then
       segact ipt1
       if (ipt1.num(/2).gt.3*nbpts) then
        meleme=ipt1
        nbdif=0
        return
       endif
      endif
      numnp=nbpts
*  construction des tableaux noeuds => elements
*  on rejoute un hashcode comme noeud supplementaire de l'element car il est moins partage que les noeuds 
*  dans le cas des elements de contact
      segact ipt1
      nbnn=ipt1.num(/1)
      nbelem=ipt1.num(/2)
      numnp=max(nbnn,numnp)
      nbhash=min(numnp*nbnn,nbelem)
      segini netn,ihash2
      do 1055 j=1,nbelem
           ihash=0
           ihashb=0
      do 1050 i=1,nbnn
           ip=ipt1.num(i,j)
           netn(ip)=netn(ip)+1
         ir=1
* tri des noeuds pour calculer le hash car ils peuvent etre dans le desordre
         do k=1,nbnn
          if (ipt1.num(k,j).gt.ip) ir=ir+1
         enddo   
           ihash=ip*ir+ihash
* le deuxieme hash sert a accelerer les comparaisons entre elements. On le prend indifferent a l'ordre.
           ihashb=ipt1.num(i,j)+ihashb
1050  continue
           ihash=mod(ihash,nbhash)+numnp+1
           netn(ihash)=netn(ihash)+1
           ihash2(j)=ihashb
1055  continue
      do 1060 i=2,netn(/1)
          netn(i)=netn(i)+netn(i-1)
1060  continue
      letn=netn(netn(/1))
      segini ietn
      do 1075 j=1,nbelem
           ihash=0
      do 1070 i=1,nbnn
           ip=ipt1.num(i,j)
           ietn(netn(ip))=j
           netn(ip)=netn(ip)-1
         ir=1
         do k=1,nbnn
          if (ipt1.num(k,j).gt.ip) ir=ir+1
         enddo   
           ihash=ip*ir+ihash
1070  continue
           ihash=mod(ihash,nbhash)+numnp+1
           ietn(netn(ihash))=j
           netn(ihash)=netn(ihash)-1
1075  continue
*
*  recherche et elimination des doublons
*
      segini,meleme=ipt1
      nbnn=num(/1)
      DO 150 IEF=1,nbelem
*  recherche du noeud ayant le moins d'elements et calcul simultanement du hash
           nbel=letn+1
           ino=0
           ihash=0
           do 160 inf=1,nbnn
             ip=num(inf,ief)
             ir=1
             do k=1,nbnn
              if (ipt1.num(k,ief).gt.ip) ir=ir+1
             enddo
             ihash=ip*ir+ihash
              id=netn(ip)+1
              if=netn(ip+1)
              if (nbel.gt.(if-id)) then
               ino=inf
               nbel=if-id
              endif
 160       continue
           ihash=mod(ihash,nbhash)+numnp+1
              id=netn(ihash)+1
              if=netn(ihash+1)
              if (nbel.gt.(if-id)) then
               ino=ihash
               nbel=if-id
              endif
*  test sur les elements connectes a ce noeud
           if (ino.le.numnp) then
            ip=num(ino,ief)
**         write(6,*) ' utilisation du noeud ',ino,ip
           else
            ip=ino
**          write(6,*) ' utilisation du hash ',ip
           endif
           id=netn(ip)+1
           if=netn(ip+1)
           do 165 itn=id,if
              iem=ietn(itn)
*  les elements sont ranges par ordre decroissant dans ietn car il est rempli a partir de la fin
*  on peut donc s'arreter des qu'on s'est atteint
              if (iem.le.ief) goto 150
              if (ihash2(iem).ne.ihash2(ief)) goto 165
               do 167 i0=1,nbnn
*  pas le meme test si optio ordre
               if (iordre.eq.0) then
                do 166 i1b=i0,nbnn+i0-1
                 i1=mod(i1b-1,nbnn)+1
                 if (num(i0,ief).eq.num(i1,iem)) goto 167
 166            continue
               else
                 if (num(i0,ief).eq.num(i0,iem)) goto 167
               endif
               goto 165
 167           continue
**             write (6,*) ' ief elimine ',ief
                  num(1,ief)=0
                  icolor(iem)=itabm(icolor(ief),icolor(iem))
                  goto 150
 165         continue
 150  continue
* compression du résultat
      nbelem=0
      do 200 iel=1,num(/2)
        if (num(1,iel).ne.0) then
          nbelem=nbelem+1
          do i=1,num(/1)
           num(i,nbelem)=num(i,iel)
          enddo
          icolor(nbelem)=icolor(iel)
        endif
 200  continue
      nbnn=num(/1)
      nbsous=0
      nbref=0
      nbdif = num(/2)-nbelem
      if (nbdif.ne.0) then
        interr(1)=nbdif
        moterr(1:4)=noms(itypel)
        call erreur(-354)
        segadj meleme
      else 
        segsup meleme
        meleme = ipt1
      endif
 
c     if (nbelem.eq.0) then
c      segsup meleme
c      meleme=0
c     endif
      segsup netn,ietn,ihash2
 
      return
      end