C FUSEBO    SOURCE    CB215821  19/08/20    21:17:59     10287          

C    CE SOUS-PROGRAMME L'OPERATION "ET" SUR UN maillage pas beau
C   ( qui ne respecte pas la partition par type)pour le rendre beau.
C   On ne s'occupe pas des references
C    IPT1:  en entree  IPT3:  en sortie
C
      SUBROUTINE FUSEBO(IPT1,IPT3)
      IMPLICIT INTEGER(I-N)

-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMELEME
      SEGMENT ISO1(NBSOU1)
      SEGMENT ISO2(NBSOU1)
      segment iso3(nbsou1)
      SEGACT IPT1
      NBSOU1= IPT1.LISOUS(/1)
*      write(6,*) ' entree dans fusebo  nbsou1 ' , nbsou1
      segact ipt1
      SEGINI ISO1,ISO2,iso3
      DO 350 I=1,NBSOU1
 350  ISO1(I)=IPT1.LISOUS(I)
      ity=0
      nbref=0
      nbsous=0
      DO 310 I1=1,NBSOU1
      IPT1=ISO1(I1)
      if(IPT1.EQ.0) go to 310
      ity = 1 + ity
      ias = 1
      iso3(ias)=ipt1
      segact ipt1
      nbnn = ipt1.num(/1)
      nbelem = ipt1.num(/2)
      do 330 i2 = i1+1, nbsou1
      IPT2=ISO1(I2)
      IF (IPT2.EQ.0) GOTO 330
      IPT2=ISO1(I2)
      IF (IPT2.EQ.0) GOTO 330
      SEGACT IPT2
      IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 340
      IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 340
      ias = ias+1
      iso3(ias)= ipt2
      iso1(i2)=0
      nbelem = nbelem + ipt2.num(/2)
  340 continue
  330 continue
      if(ias.eq.1) then
        iso2(ity) = ipt1
      else
        segini meleme
        idec=0
        itypel = ipt1.itypel
        DO 311 I2=1,ias
          IPT1=ISO3(I2)
          segact ipt1
          do 351 nbe=1,ipt1.num(/2)
          do 352 nbn=1,nbnn
            num(nbn,idec+nbe)=ipt1.num(nbn,nbe)
  352     continue
  351     continue
         do 353 nbe=1,ipt1.num(/2)
  353    icolor(idec+nbe)=ipt1.icolor(nbe)
          idec = idec + ipt1.num(/2)
  311   continue
        iso2(ity)=meleme
      endif
 310  CONTINUE
      if( ity.eq.1) then
        ipt3 = iso2(1)
      else
        NBREF=0
        NBNN=0
        NBELEM=0
        nbsous = ity
        SEGINI IPT3
        DO 111 I=1,NBSOUs
        IPT3.LISOUS(I)=ISO2(I)
 111    CONTINUE
      endif
      SEGSUP ISO1,ISO2,iso3
 1020 RETURN
      END