C ELIMIN    SOURCE    PV        12/12/06    21:15:07     7594           
C     
      SUBROUTINE ELIMIN(ICPR,CRIT,ITE,IAPOB1,IAPOB2,MELEME,MELEM2,ICLE)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C======================================================================
C   FUSION DES NOEUDS AYANT DES COORDONNEES TROP VOISINES
C     UTILISE PAR L'OPERATEUR ELIM ICLE=0 ET PAR L'OPERATEUR VISA ICLE=1
C     APPEL PRELIMINAIRE DE PRELIM QUI CREE LES TABLEAUX
C     
C      ICPR EST LA MOUVELLE NUMEROTATION
C          ICPR(ANCIEN N°)= NOUVEAU N°
C          ICPR(ANCIEN N°)= 0 SI LE NOEUDS N'APPARTIENT PAS AU MAILLAGE(S
C ) ARGUMENT(S)
C     IAPOB1 EST UN TABLEAU SUR LA NOUVELLE NUMEROTATION
C           =1 SI LE NOEUD EST DANS LE 1ER MAILLGE  =0 SINON
C           =2 SI LE NOEUD SUPPORTE UN MULTIPLICATEUR
C     IAPOB2 EST UN TABLEAU SUR LA NOUVELLE NUMEROTATION
C           =1 SI LE NOEUD EST DANS LE 2IEME MAILLGE  =0 SINON
C======================================================================
-INC CCOPTIO
-INC SMCOORD

-INC SMLENTI
-INC SMELEME
      POINTEUR MELEM2.MELEME
      SEGMENT /STRAV/(NP1(ITF),NP2(ITF),NP3(ITF),NPI(ITF),IDCP(ITF))
      SEGMENT ICPR(1)
      SEGMENT IAPOB1(1)
      SEGMENT IAPOB2(1)
      SEGMENT ITLAC(0)
      INTEGER TRUC,TRUC1,TRUC3
      G(A,B,C,D,E,F)=((A-D)*(A-D)+(B-E)*(B-E)+(C-F)*(C-F))
C======================================================================
      SEGACT MCOORD*MOD
      IF (ITE.LE.1) RETURN
      ITF=ITE+3+1
      SEGINI STRAV
*     IDCP = tableau reciproque de ICPR     
      DO 250 I=1,ICPR(/1)
         IF (ICPR(I).NE.0) IDCP(ICPR(I))=I
 250  CONTINUE
      NUMNP=ITE
      PREC=CRIT
      PREC2=PREC*PREC
      NCO2=0
      DO 5 I=1,NUMNP
         NPI(I)=I
    5 CONTINUE
C     
C       APPEL DE TRISUP QUI CREE LES TABLEAUX CONTENUS DANS STRAV
      CALL TRISUP(NUMNP,PREC,NG,TRUC,TRUC1,CRIT,XMIN,YMIN,ZMIN,STRAV)
      IF (IIMPI.NE.0) WRITE (IOIMP,74) NUMNP,NG,TRUC,TRUC1
 74   FORMAT (1X,'NUMNP=',I5,2X,'NG=',I5,2X,'TRUC=',I8,2X,'TRUC1=',I8)
      KELI=0
      TRUC3=TRUC*TRUC1
      ID=NUMNP
      IA=1
      IB=ITE-1
      CRUT=1.D0/CRIT
      IF(ICLE.EQ.1) THEN
         JG=20
         SEGINI MLENTI,MLENT1
      ENDIF
C     
      XI2=0.D0
      XI3=0.D0
C       BOUCLE SUR LES POINTS DU(DES) MAILLAGE(S)
      DO 6 I=IA,IB
         IREF=IDCP(I)*(IDIM+1)-IDIM
         XI1=XCOOR(IREF)
         NX1=INT((XI1-PREC-XMIN)*CRUT+2.D0)
         NX2=INT((XI1+PREC-XMIN)*CRUT+2.D0)
         IF (IDIM.GE.2) THEN
            XI2=XCOOR(IREF+1)
            NY1=INT((XI2-PREC-YMIN)*CRUT+1.D0)*TRUC
            NY2=INT((XI2+PREC-YMIN)*CRUT+1.D0)*TRUC
         ELSE
C*          XI2=0
            NY1=INT(1.D0-PREC*CRUT)*TRUC
            NY2=INT(1.D0+PREC*CRUT)*TRUC
         ENDIF
         IF (IDIM.GE.3) THEN
            XI3=XCOOR(IREF+2)
            NZ1=INT((XI3-PREC-ZMIN)*CRUT+1.D0)*TRUC3
            NZ2=INT((XI3+PREC-ZMIN)*CRUT+1.D0)*TRUC3
         ELSE
C*          XI3=0
            NZ1=INT(1.D0-PREC*CRUT)*TRUC3
            NZ2=INT(1.D0+PREC*CRUT)*TRUC3
         ENDIF
         IC=I+1
C     
C       BOUCLE SUR LES ZONES CREE PAR TRISUP
         XJ2=0.D0
         XJ3=0.D0
         DO 7 II=NZ1,NZ2,TRUC3
            DO 71 JJ=NY1,NY2,TRUC
               NTEST1=II+JJ+NX1
               NTEST3=II+JJ+NX2
               NZON1=NTEST1/NG+1
               NZON3=NTEST3/NG+1
               ND=NP1(NZON1)+1
               NF=NP1(NZON3+1)
               IF(ND.GT.NF) GO TO 71
               DO 72 M=ND,NF
                  IF(NP3(M).LT.NTEST1)  GO TO 72
                  IF(NP3(M).GT.NTEST3)  GO TO 71
                  J=NP2(M)
                  IF(J.GT.ID.OR.J.LT.IC) GO TO 72
                  IREF=IDCP(J)*(IDIM+1)-IDIM
                  XJ1=XCOOR(IREF)
                  IF (IDIM.GE.2) XJ2=XCOOR(IREF+1)
                  IF (IDIM.GE.3) XJ3=XCOOR(IREF+2)
                  A=G(XI1,XI2,XI3,XJ1,XJ2,XJ3)
                  NCO2=NCO2+1
                  IF (A.GT.PREC2) GO TO 72
                  IF (NPI(J).LT.0.AND.ICLE.EQ.0) GOTO 72
                  IF ((IAPOB1(I) .EQ. 2) .OR. (IAPOB1(J) .EQ. 2)) GOTO
     $                 72
                  IF (((IAPOB1(I).EQ.0).AND.(IAPOB1(J).EQ.0)).OR.
     #                 ((IAPOB2(I).EQ.0).AND.(IAPOB2(J).EQ.0)))    GOTO
     $                 72
                  IF (IAPOB1(I).NE.0) THEN
                     IREF1=(IDCP(I)-1)*(IDIM+1)
                     IREF2=(IDCP(J)-1)*(IDIM+1)
                  ELSE
                     IREF1=(IDCP(J)-1)*(IDIM+1)
                     IREF2=(IDCP(I)-1)*(IDIM+1)
                  ENDIF
                  NPI(J)=-I
                  KELI=KELI+1
C     
                  IF(ICLE.EQ.0) THEN
*  ON SOUDE LE PREMIER POINT SUR LE SECOND
                     DO 10 III=1,IDIM+1
                        XCOOR(IREF1+III)=XCOOR(IREF2+III)
 10                  CONTINUE
C     
                  ELSEIF(ICLE.EQ.1) THEN
                     IF(KELI.GT.JG) THEN
                        JG=JG+20
                        SEGADJ MLENTI,MLENT1
                     ENDIF
                     LECT(KELI)=IDCP(I)
                     MLENT1.LECT(KELI)=IDCP(J)
                  ENDIF
C     
 72            CONTINUE
 71         CONTINUE
 7       CONTINUE
 6    CONTINUE
C     
      IJ=0
      ICONT=0
      DO 101 I=1,NUMNP
 102     IF(NPI(I).GT.0)  GOTO 101
         IJ=-NPI(I)
         NPI(I)=NPI(IJ)
         ICONT=ICONT+1
         GOTO 102
 101  CONTINUE
C     
      IF(ICLE.EQ.0) THEN
         INTERR(1) = ICONT
C Erreur -293 : Nombre de noeuds eliminés %i1
         CALL ERREUR(-293)
         DO 103 I=1,XCOOR(/1)/(IDIM+1)
            IPC=ICPR(I)
            IF (IPC.EQ.0)GOTO 103
            ICPR(I)=NPI(IPC)
 103     CONTINUE
         SEGSUP STRAV
         NUMNP=0
         DO 104 I=1,XCOOR(/1)/(IDIM+1)
            NUMNP=MAX(NUMNP,ICPR(I))
 104     CONTINUE
         SEGINI ITLAC
         IF (MELEME.NE.0) CALL AJOU(ITLAC,MELEME)
         IF (MELEM2.NE.0) CALL AJOU(ITLAC,MELEM2)
C       il reste a renumeroter les coordonnes(tasser la pile des points)
C       et a changer les references dans tous les objets qui pointent
C       sur des noeuds
         CALL TASSP2(ITLAC,ICPR,NUMNP,ICOLAC,0)
C TASSP2 nous a cree un ICOLAC dont on n'a que faire.
C l'appel suivant supprime ICOLAC et ses sous-objets (donc ITLAC)
         CALL SUPPIL(ICOLAC,-1)
C     
      ELSEIF(ICLE.EQ.1) THEN
         SEGSUP STRAV
         IF(KELI.NE.0) THEN
            NBELEM=KELI
            NBNN=1
            NBREF=0
            NBSOUS=0
            SEGINI IPT3,IPT2
            IPT2.ITYPEL=1
            IPT3.ITYPEL=1
            DO 105 I=1,KELI
               IPT2.NUM(1,I)=LECT(I)
               IPT3.NUM(1,I)=MLENT1.LECT(I)
 105        CONTINUE
            SEGDES IPT3,IPT2
            SEGSUP MLENTI,MLENT1
            CALL ECROBJ('MAILLAGE',IPT3)
            CALL ECROBJ('MAILLAGE',IPT2)
C Erreur 22 : Opération malvenue. Résultat douteux
            IF(ICONT.NE.KELI) CALL ERREUR(22)
         ELSE
C Erreur 26 : Tache impossible. Probablement données erronées
            CALL ERREUR(26)
         ENDIF
      ENDIF
      RETURN
      END