Sources Esope | Cast3M

renuel
C RENUEL    SOURCE    PV        20/03/30    21:24:02     10567          
      subroutine renuel(ipt6)
*
*   renumerote les elements dans un meleme de proche en proche
*   ne fonctionne que pour un meleme simple
*
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMCOORD
        SEGMENT IADJ(NODES+1)
        SEGMENT JADJC(JADDIM)
C       IADJ(i) pointe sur JADJC qui contient les voisins de i entre
C       IADJ(i) et IADJ(i+1)-1
        SEGMENT IELFAI(NBELEM)
        SEGMENT IPTFAI(NODES)
        SEGMENT ICPR(nbpts)
        SEGMENT IPLIST(NODES)
*
        segini icpr
        segact ipt6*mod
        meleme=ipt6
        do 10000 isous=1,max(1,ipt6.lisous(/1))
        if (ipt6.lisous(/1).ne.0) meleme=ipt6.lisous(isous)
        segact meleme*mod
        segini,ipt1=meleme
        ipt2=meleme
        nodes=0
        do 100 il=1,ipt1.num(/2)
        do 100 ip=1,ipt1.num(/1)
         if (icpr(num(ip,il)).ne.0) goto 100
         nodes=nodes+1
         icpr(num(ip,il))=nodes
 100    continue
**  iadj: nombre d'elements touchant un noeud
        segini iadj
        do 200 il=1,ipt1.num(/2)
        do 200 ip=1,ipt1.num(/1)
         ipt=icpr(num(ip,il))
         iadj(ipt)=iadj(ipt)+1
 200    continue
**  position fin dans jadjc
         do ipt=1,nodes
          iadj(ipt+1)=iadj(ipt)+iadj(ipt+1)
         enddo
**  iadjc: element touchant noeud
         JADDIM=iadj(nodes+1)
         segini jadjc
        do 300 il=1,ipt1.num(/2)
        do 300 ip=1,ipt1.num(/1)
         ipt=icpr(num(ip,il))
         jadjc(iadj(ipt))=il
         iadj(ipt)=iadj(ipt)-1
 300    continue
*  creation tableau des elements faits, tableau des noeuds faits, et
*  et nouveau meleme
        nbsous=0
        nbref=0
        nbnn=ipt1.num(/1)
        nbelem=ipt1.num(/2)
        segini ielfai,iptfai
        ipt2.itypel=ipt1.itypel
*  remplissage maillage ordonnee et noeuds ordonné
        ielcou=0
        segini iplist
*  point de depart chosi par minimum degre
        nbconn=100000
        idep=0
        do ip=1,nodes
         nbc=iadj(ip+1)-iadj(ip)
         if (nbc.lt.nbconn) then
          nbconn=nbc
          idep=ip
         endif
        enddo
        if (idep.eq.0) call erreur(5)
        iplist(1)=idep
        iptfai(idep)=1
        ipc=1
        ipf=1
 1000   continue
          if (ipc.gt.nodes) goto 2000
          i=iplist(ipc)
          ipre=iadj(i)+1
          ider=iadj(i+1)
          do 1010 jel=ipre,ider
           iel=jadjc(jel)
           if (ielfai(iel).eq.1) goto 1010
           ielcou=ielcou+1
           do ip=1,nbnn
            ipt2.num(ip,ielcou)=ipt1.num(ip,iel)
            ipt=icpr(ipt1.num(ip,iel))
            if (iptfai(ipt).eq.0) then
             ipf=ipf+1
             iplist(ipf)=ipt
             iptfai(ipt)=1
            endif
           enddo
           ielfai(iel)=1
 1010     continue
          ipc=ipc+1
          if (ipc.le.ipf) goto 1000
          if (ipc.gt.nodes) goto 2000
*  plusieurs composantes connexes on cherche un nouveau point de depart
          nbconn=100000
          idep=0
          do ip=1,nodes
           if (iptfai(ip).eq.0) then
            nbc=iadj(ip+1)-iadj(ip)
            if (nbc.lt.nbconn) then
             nbconn=nbc
             idep=ip
            endif
           endif
          enddo
          if (idep.eq.0) call erreur(5)
          ipf=ipf+1
          iptfai(idep)=1
          iplist(ipf)=idep
          goto 1000
*  on a fini
 2000     continue
          if (ipf.ne.nodes) write (6,*) ' probleme ',ipc,ipf,nodes
          segsup iadj,jadjc,ielfai,iptfai,icpr,iplist
          segdes ipt1,ipt2
10000     continue
          return
          end