C FUSE      SOURCE    CHAT      07/10/31    16:40:18     5941           
      SUBROUTINE FUSE(IPT1,IPT2,IPT3,LTELQ)
*=============================================================
*
* Ce sous-programme réalise l'operation "ET" sur les deux objets
* maillages IPT1 et IPT2.
* Le resultat est rangé dans IPT3
*
*=============================================================
*
* Modifications :
*
*   PM 09/10/2007 : respecte l'ordre y compris avec éléments
*                   dégénérés (points doubles)
*
*=============================================================
*
* Remarques :
*
*=============================================================

      IMPLICIT INTEGER(I-N)
-INC CCOPTIO
-INC CCGEOME
-INC SMELEME
      LOGICAL LTELQ
      SEGMENT ISO1(NBSOU1)
      SEGMENT ISO2(NBSOU2)

      ITEMP=0

*     Aiguillage
*     ----------
*     Cas de deux maillages identiques
      IF (IPT1.GT.0.AND.IPT2.EQ.IPT1) THEN
         IPT3 = IPT1
         RETURN
      ENDIF

*     Deux maillages différents
      SEGACT IPT1,IPT2
      ISAUV1=IPT1
      ISAUV2=IPT2

*     Premier maillage complexe
      IF (IPT1.LISOUS(/1).NE.0) GOTO 100
*     Seul le 2e maillage est complexe
      IF (IPT2.LISOUS(/1).NE.0) GOTO 101
*     Deux maillages simples
      IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 50

*     1) Deux maillages simples de même type
*     --------------------------------------
*     CAS DES MULTIPLICATEURS: le nb de points par élément est différent
      IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 50

*     1) Deux maillages simples de même type de même nb de points par élément
      IF (KSURF(IPT1.ITYPEL).NE.0) GOTO 70
*     a) Deux objets de type ligne ou point
      CALL FUSELI(IPT1,IPT2,IPT3,LTELQ)
      GOTO 200 

  70  IF (KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) GOTO 71
*     b) Deux objets surfaciques
      CALL FUSESU(IPT1,IPT2,IPT3,LTELQ)
      GOTO 200

*     c) Deux objets volumiques
  71  CALL FUSEVO(IPT1,IPT2,IPT3,LTELQ)

 200  SEGDES IPT1,IPT2,IPT3
      RETURN

*     2) Deux maillages simples de type ou de nb d'éléments différents
*     ----------------------------------------------------------------
  50  CONTINUE
      NBSOUS= 2
      NBREF = 0
      NBNN  = 0
      NBELEM= 0
      SEGINI IPT3
      IPT3.LISOUS(1)=IPT1
      IPT3.LISOUS(2)=IPT2
      SEGDES IPT1,IPT2,IPT3
      RETURN

*     3) Un seul maillage complexe
*     ----------------------------
*     qu'on s'arrange pour être le deuxième, 
*     mais ITEMP<>0 permet de savoir qu'on les a intervertis
 100  CONTINUE
      IF (IPT2.LISOUS(/1).NE.0) GOTO 110
      ITEMP=IPT1
      IPT1=IPT2
      IPT2=ITEMP
 101  CONTINUE

      NBSOU2=IPT2.LISOUS(/1)
      DO I=1,NBSOU2
         IPT3=IPT2.LISOUS(I)
         SEGACT IPT3
         IF (IPT3.NUM(/1).EQ.IPT1.NUM(/1)) THEN
*           une partition du bon type existe déjà
            IF (IPT3.ITYPEL.EQ.IPT1.ITYPEL) THEN
               IPT5=IPT1
               IPT6=IPT3            
               if(ltelq)then
                 IF (ITEMP.ne.0) THEN                   
                  IPT5=IPT3
                  IPT6=IPT1
                 ENDIF 
               endif           
               GOTO 301
            ENDIF 
         ENDIF
         SEGDES IPT3
      ENDDO 
*     on ajoute au 2e une partition avec ce nouveau type d'élément
      NBSOUS = NBSOU2+1
      NBREF  = 0
      NBNN   = 0
      NBELEM = 0
      SEGINI IPT3
      DO I=1,NBSOU2
         IPT3.LISOUS(I)=IPT2.LISOUS(I)
      ENDDO
      IPT3.LISOUS(NBSOUS)=IPT1
      SEGDES IPT1,IPT2,IPT3
      RETURN

*     On fusionne le 1er avec la partition existante du 2e
 301  CONTINUE 
      IF (KSURF(IPT1.ITYPEL).EQ.0) THEN
         CALL FUSELI(IPT5,IPT6,IPT4,LTELQ)
      ELSEIF (KSURF(IPT1.ITYPEL).EQ.IPT1.ITYPEL) THEN
         CALL FUSESU(IPT5,IPT6,IPT4,LTELQ)
      ELSE
         CALL FUSEVO(IPT5,IPT6,IPT4,LTELQ)
      ENDIF 
      SEGDES IPT1,IPT3
      SEGDES IPT4
      NBSOUS = NBSOU2
      NBREF  = 0
      NBNN   = 0
      NBELEM = 0
      SEGINI IPT3
      DO II=1,NBSOU2
         IPT3.LISOUS(II)=IPT2.LISOUS(II)
      ENDDO 
      IPT3.LISOUS(I)=IPT4
      SEGDES IPT2
      SEGDES IPT3
      RETURN

*     4) Deux maillages complexes
*     ---------------------------
 110  CONTINUE
      NBSOU1=IPT1.LISOUS(/1)
      NBSOU2=IPT2.LISOUS(/1)
      NBSOUS=NBSOU1+NBSOU2
      SEGINI ISO1,ISO2
      DO I=1,NBSOU1
         ISO1(I)=IPT1.LISOUS(I)
      ENDDO 
      DO I=1,NBSOU2
         ISO2(I)=IPT2.LISOUS(I)
      ENDDO 
      SEGDES IPT1,IPT2

*--   Fusion des partitions de mêmes caractéristiques
      DO I1=1,NBSOU1
         IPT1=ISO1(I1)
         SEGACT IPT1
         DO 311 I2=1,NBSOU2
            SEGACT IPT1
            IPT2=ISO2(I2)
            IF (IPT2.EQ.0) GOTO 311
            SEGACT IPT2
            IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 312
            IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 312
*           On peut fusionner
            IF (KSURF(IPT1.ITYPEL).EQ.0) 
     #          CALL FUSELI(IPT1,IPT2,IPT3,LTELQ)
            IF (KSURF(IPT1.ITYPEL).NE.0.AND.
     #          KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) 
     #          CALL FUSEVO(IPT1,IPT2,IPT3,LTELQ)
            IF (KSURF(IPT1.ITYPEL).EQ.IPT1.ITYPEL) 
     $          CALL FUSESU(IPT1,IPT2,IPT3,LTELQ)
            ISO1(I1)=IPT3
            ISO2(I2)=0
            SEGDES IPT3
            NBSOUS=NBSOUS-1
 312        CONTINUE
            SEGDES IPT2
 311     CONTINUE
         SEGDES IPT1
      ENDDO

*--   Gestion des sous-références (en évitant les redondances)
      NBREF = 0
      IPT1  = ISAUV1
      IPT2  = ISAUV2
      SEGACT IPT1,IPT2
C     POUR LE CAS DES VOLUMES ET DES SURFACES  SI UN DES DEUX UNE SEULE
C     REFERENCE ON FAIT LA DIFFERENCE SYMETRIQUE
C     SI LES DEUX 2 OU 3 REFERENCE 1<-1.1  2<-2.2  3<-DIFF DES AUTRES
C                     SI 1.2=2.1
      IF (IPT1.LISREF(/1).EQ.0.OR.IPT2.LISREF(/1).EQ.0) GOTO 1000
      IF (IPT1.LISREF(/1).EQ.1.OR.IPT2.LISREF(/1).EQ.1) THEN
         NBREF=1
         GOTO 1001
      ENDIF 
C     Chaque maillage a au moins deux sous-références
      IPT3=IPT1.LISREF(2)
      IPT4=IPT2.LISREF(1)
      IF (IPT3.EQ.IPT4) GOTO 1002
      SEGACT IPT3,IPT4
      IF (IPT3.LISOUS(/1).EQ.0 .OR.
     #    IPT3.LISOUS(/1).NE.IPT4.LISOUS(/1)) GOTO 1001
      DO I=1,IPT3.LISOUS(/1)
         IF (IPT3.LISOUS(I).NE.IPT4.LISOUS(I)) GOTO 1001
      ENDDO 
      SEGDES IPT3,IPT4

 1002 CONTINUE
C     Deux sous-réf. chaque dont au moins 1 commune
      NBREF=3
      IF (IPT1.LISREF(/1).EQ.2 .OR. IPT2.LISREF(/1).EQ.2) THEN 
         NBREF=2
         GOTO 1011
      ENDIF 
C     A REVOIR NE MARCHE QUE SI LE POURTOUR EST FORME D'UN TYPE D'ELEMENT
      IPT3=IPT1.LISREF(3)
      SEGACT IPT3
      IF (IPT1.LISREF(/1).EQ.3) GOTO 1004
      DO 1005 I=4,IPT1.LISREF(/1)
         IPT4=IPT1.LISREF(I)
         SEGACT IPT4
         IF (IPT4.NUM(/2).NE.0) GOTO 1006
         NBREF=2
         SEGDES IPT4
         GOTO 1011
 1006    IF (KSURF(IPT4.ITYPEL).EQ.0) CALL FUSELI(IPT3,IPT4,IPT5,LTELQ)
         IF (KSURF(IPT4.ITYPEL).NE.0) CALL FUSESU(IPT3,IPT4,IPT5,LTELQ)
         SEGDES IPT3,IPT4
         IPT3=IPT5
 1005 CONTINUE
 1004 CONTINUE
      IPT6=IPT2.LISREF(3)
      SEGACT IPT6
      IF (IPT2.LISREF(/1).EQ.3) GOTO 1010
      DO 1009 I=4,IPT2.LISREF(/1)
         IPT4=IPT2.LISREF(I)
         SEGACT IPT4
         IF (IPT4.NUM(/2).NE.0) GOTO 1008
         NBREF=2
         SEGDES IPT4
         GOTO 1011
 1008    IF (KSURF(IPT4.ITYPEL).EQ.0) CALL FUSELI(IPT6,IPT4,IPT5,LTELQ)
         IF (KSURF(IPT4.ITYPEL).NE.0) CALL FUSESU(IPT6,IPT4,IPT5,LTELQ)
         SEGDES IPT6,IPT4
         IPT6=IPT5
 1009 CONTINUE
 1010 CONTINUE
      CALL OUEXCL(IPT3,IPT6,IPT7)
      SEGDES IPT3,IPT6,IPT7
      GOTO 1011

 1001 CONTINUE
C     ON EST SENSE TOUT FUSIONNER A VOIR PLUS TARD
      NBREF=0

 1011 CONTINUE

*--   Construction du maillage final et de ses sous-références
 1000 CONTINUE
      NBNN   = 0
      NBELEM = 0
      SEGINI IPT3
      DO I=1,NBSOU1
         IPT3.LISOUS(I)=ISO1(I)
      ENDDO 
      II=NBSOU1+1
      DO 112 I=1,NBSOU2
*        on n'ajoute que les partitions n'existant pas encore
         IF (ISO2(I).EQ.0) GOTO 112
         IPT3.LISOUS(II)=ISO2(I)
         II=II+1
 112  CONTINUE
      SEGSUP ISO1,ISO2

      IF (NBREF.EQ.0) GOTO 1020
      IPT3.LISREF(1)=IPT1.LISREF(1)
      IPT3.LISREF(2)=IPT2.LISREF(2)
      IF (NBREF.EQ.2) GOTO 1020
      IPT3.LISREF(3)=IPT7

 1020 SEGDES IPT1,IPT2,IPT3
      RETURN

      END