C FUITE1    SOURCE    CB215821  17/11/30    21:16:16     9639           
      SUBROUTINE FUITE1
C
C  FONCTION:   DRIVER DE L'OPÉRATEUR FUITE
C
C              recupere l'intersection de MAIL1 et MAIL2 et de MAIL1 et MAIL3
C              determine le segment de fuite
C              appelle fuite2.eso
C
C
C  ENTREES:
C
C    MAIL1:   (objet de type MAILLAGE) contour orienté fermé formé d'éléments
C             de type SEG2 ou SEG3.
C
C    MAIL2:   (objet de type MAILLAGE) dont un des points sera le support d'une
C             des extremité de l'élément de fuite.
C
C    MAIL3:   (objet de type MAILLAGE) dont un des points sera le support de
C             l'autre extremité de l'élément de fuite.
C
C  SORTIES:
C
C    MAIL4:   (objet de type MAILLAGE) contenant un élément de type SEG2 et qui
C             est l'élément de fuite. (MAIL4 est aussi contenu dans MAIL5 et son
C             inverse dans MAIL6).
C
C    MAIL5:   (objet de type MAILLAGE) contenant un des deux contours fermés
C             orientés issu de MAIL1.
C
C    MAIL6:   (objet de type MAILLAGE) contenant le second contour fermé
C             orienté issu de MAIL1.
C
C
C
C A de Gayffier
C
C FORTRAN + ESOPE
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC SMELEME

-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
C
      SEGMENT MPACTIF
C     ce segment contient les noeuds actifs de MAIL2 et MAIL3
C     et leur adresse dans MELEME
        INTEGER NMAIL2(NBN2),NMAIL3(NBN3)
      ENDSEGMENT
C
C   l'opérateur ne marche qu'en dimension 2
C
      IF (IDIM .NE. 2 ) THEN
       INTERR(1) = IDIM
       CALL ERREUR(709)
       RETURN
      ENDIF
C
C    on recupere MAIL1 meleme , MAIL2 ipt1 et MAIL3 ipt2
C
      CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
      IF (IERR .NE. 0) RETURN
      CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
      IF (IERR .NE. 0) RETURN
      CALL LIROBJ('MAILLAGE',IPT3,1,IRETOU)
      IF (IERR .NE. 0) RETURN
C
C
C
      SEGACT MELEME
      IF (LISOUS(/1) .NE. 0 .OR. ITYPEL .NE. 2) THEN
         CALL ERREUR(164)
         RETURN
      ENDIF
C
C    intersection de MAIL1 et MAIL2
C
C       changement de MAIL2 et MAIL3 en maillage formé de points
      CALL CHANGE(IPT2,1)
      CALL CHANGE(IPT3,1)
      NBN2 = IPT2.NUM(/2)
      NBN3 = IPT3.NUM(/2)
      SEGINI MPACTIF
C
C       ipt1 et ipt2 sont actifs et formé d'une seule sous zone
C
      NNBN2 = 0
      DO 140  I=1,NBN2
           DO 120 K=1,NUM(/2)
               IF (IPT2.NUM(1,I) .EQ. NUM(1,K)) THEN
                    NNBN2 = NNBN2 + 1
                    NMAIL2(NNBN2) = IPT2.NUM(1,I)
                    GOTO 140
               ENDIF
 120       CONTINUE
 140   CONTINUE
       NBN2 = NNBN2
C
C
C
      NNBN3 = 0
      DO 180  I=1,NBN3
           DO 160 K=1,NUM(/2)
               IF (IPT3.NUM(1,I) .EQ. NUM(1,K)) THEN
                    NNBN3 = NNBN3 + 1
                    NMAIL3(NNBN3) = IPT3.NUM(1,I)
                    GOTO 180
               ENDIF
 160      CONTINUE
 180  CONTINUE
      NBN3 = NNBN3
C
C            erreur si nbn2 = 0  ou nbn3 = 0
C
       IF ( (NBN3*NBN2) .EQ. 0) THEN
           GOTO 1000
       ENDIF
C
       SEGADJ MPACTIF
C
C     RECHERCHE DU MINIMUM
C
       N1 = 0
       N2 = 0
       DMINI = 1.D50
       DO 200 I=1,NBN2
         DO 190 J=1,NBN3
           X2=XCOOR((NMAIL2(I)-1)*(IDIM+1)+1)
           Y2=XCOOR((NMAIL2(I)-1)*(IDIM+1)+2)
           X3=XCOOR((NMAIL3(J)-1)*(IDIM+1)+1)
           Y3=XCOOR((NMAIL3(J)-1)*(IDIM+1)+2)
           DIST = (X2-X3)*(X2-X3) + (Y2-Y3)*(Y2-Y3)
           IF (DIST .LT. DMINI) THEN
              DMINI = DIST
              N1 = NMAIL2(I)
              N2 = NMAIL3(J)
           ENDIF
 190     CONTINUE
 200   CONTINUE
C
C     erreur mail2 et mail3 on un point en commun inclus dans MAIL1
C
       IF (N1 .EQ. N2 ) THEN
           GOTO 1000
       ENDIF

C
C
C
       SEGDES IPT2,IPT3
C
       CALL FUITE2(MELEME,N1,N2)
C
C
C
       SEGDES MELEME
       SEGSUP MPACTIF
       RETURN
C
C    gestion des erreurs
C
 1000  CONTINUE
       NBELEM = 0
       NBREF = 0
       NBNN = 0
       NBSOUS = 0
       SEGINI IPT4,IPT5
       IPT4.ITYPEL=2
       IPT5.ITYPEL=2
C
       SEGDES MELEME,IPT4,IPT5
       SEGSUP MPACTIF
C
       CALL ECROBJ('MAILLAGE',IPT4)
       CALL ECROBJ('MAILLAGE',IPT5)
       CALL ECROBJ('MAILLAGE',MELEME)
C
       RETURN
       END