C CCON1     SOURCE    PV        20/03/30    21:15:43     10567          
      SUBROUTINE CCON1(MELEME,IRETO)
      IMPLICIT INTEGER(I-N)
-INC SMCOORD
-INC SMELEME

-INC PPARAM
-INC CCOPTIO
-INC SMLENTI
      REAL*8 XDE
      CHARACTER*1 CHE
      LOGICAL LOGE
      SEGMENT ICPR(nbpts)
      SEGMENT INUINV(nbpts)
      SEGMENT JMEM(NODES)
      SEGMENT MEMJT(NKON)
      SEGMENT IPOME(NODES+1)
      SEGMENT ICONC(NODES)
      SEGMENT IDEJ(NODES)
      SEGMENT IPRI(NODES)
***   SEGACT MELEME
*
*   LOGIQUE : ON PREND UN POINT PUIS TOUS LES ELEMENTS TOUCHANT
* POINT PUIS ON DIT LE S NOEUDS VOISINS ET ON BOUCLE SUR LES NOEUDS
* CONCERNEES NON DEJA TRAITES
*
* ON REGARDE L'ENSEMBLE DES NOEUDS DES NOEUDS DE MELEME ET ON CONSTRUIT
* LE TABLEAU DONNANT LES ELEMENTS TOUCHANT CHAQUE NOEUD
*
      SEGINI ICPR,INUINV
      SEGACT MELEME*MOD
      IPT1=MELEME
      IRETO=0
      IKOU=0
      DO 202 IO=1,MAX(1,LISOUS(/1))
      IF (LISOUS(/1).NE.0) THEN
       IPT1=LISOUS(IO)
       SEGACT IPT1*MOD
      ENDIF
      DO 203 I=1,IPT1.NUM(/1)
      DO 203 J=1,IPT1.NUM(/2)
      IJ=IPT1.NUM(I,J)
      IF (ICPR(IJ).NE.0) GOTO 203
       IKOU=IKOU+1
      ICPR(IJ)=IKOU
      INUINV(IKOU)=IJ
 203  CONTINUE
 202  CONTINUE
      NODES=IKOU
      SEGINI JMEM ,IPOME
      IPT1=MELEME
      NGRAND=0
      NMAX=0
      DO 3 IO=1,MAX(1,LISOUS(/1))
      IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
      DO 4 I=1,IPT1.NUM(/1)
      DO 4 J=1,IPT1.NUM(/2)
      JMEM(ICPR(IPT1.NUM(I,J)))=JMEM(ICPR(IPT1.NUM(I,J)))+1
   4  CONTINUE
      NGRAND=MAX(NGRAND,IPT1.NUM(/2))
      NMAX=NMAX+IPT1.NUM(/2)
   3  CONTINUE
      NGRAND=NGRAND+1
      IPOME(1)=0
      DO 6 I=1,NODES
      IPOME(I+1)=IPOME (I) + JMEM(I)
   6  CONTINUE
      DO 7 I=1,NODES
      JMEM(I)=0
   7  CONTINUE
      NKON=IPOME(NODES+1)
      SEGINI MEMJT
      IPT1=MELEME
      DO 101 IO=1,MAX(1,LISOUS(/1))
      IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
      DO 100 I=1,IPT1.NUM(/2)
      DO 100 J=1,IPT1.NUM(/1)
      IND=ICPR(IPT1.NUM(J,I))
      JMEM(IND)=JMEM(IND)+1
      MEMJT(IPOME(IND)+JMEM(IND))=I+NGRAND*IO
 100  CONTINUE
 101  CONTINUE
*
*    quelques initialisations
*
*      WRITE(6,FMT='(''  NODES '' ,I5)') NODES
      SEGINI IDEJ,ICONC,IPRI
      INDE=0
*
*  debut de tourner en rond.
*
   50 CONTINUE
      DO 51 I=1,NODES
      ICONC(I)=0
      IPRI(I)=0
   51 CONTINUE
      DO 52 I=1,NODES
      IF(IDEJ(I).EQ.0) GO TO 54
   52 CONTINUE
      GO TO 59
   54 CONTINUE
      IDEP=I
*      WRITE(6,FMT='('' POINT DE DEPART '',I5)') IDEP
      INC=1
      INA=1
      ICONC(INC)=IDEP
      IPRI(IDEP)=1
   55 CONTINUE
      INO=INC
      DO 57 I=INA,INO
      INU=ICONC(I)
      IF(IDEJ(INU).NE.0) THEN
         CALL ERREUR (5)
      ELSE
        IDEJ(INU)=1
      ENDIF
      K4=JMEM(INU)
      JSUB=IPOME(INU)
*      WRITE(6,FMT='(''  NOEUD  NBVOIS DDEB'',3I5)')INUINV(INU),
*     $  K4,JSUB
      DO 40 JJ=1,K4
      IND=JSUB+JJ
      K6=MEMJT(IND)
      IAIA= K6/NGRAND
      IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA)
      SEGACT IPT1*MOD
      K6=MOD(K6,NGRAND)
      IF(IPT1.NUM(1,K6).LE.0)  GO TO 40
      IPT1.NUM(1,K6)=-IPT1.NUM(1,K6)
*      WRITE(6,FMT='(''       ELEMENT NUMERO '',I5)') K6
      DO 85 L=1,IPT1.NUM(/1)
      K5=ICPR(ABS(IPT1.NUM(L,K6)))
      IF (IPRI(K5).GT.0) GO TO 85
      INC=INC+1
      ICONC(INC)=K5
      IPRI(K5)=1
*      WRITE(6,FMT= '('' NOEUD NUMERO '',I5)') INUINV(K5)
   85 CONTINUE
   40 CONTINUE
   57 CONTINUE
      IF(INO.NE.INC) THEN
*         WRITE(6,FMT='(''  ON BOUCLE INA INO INC'',3I5)') INA,INO,INC
         INA=INO+1
         GO TO 55
      ENDIF
*
*   on vient de trouver une composante connexe
*
   59 CONTINUE
*      WRITE(6,FMT=' ('' UNE COMPOSANTE CONNEXES TROUVEE '')')
*
* on cree une table si pas deja fait puis remise de meleme en positif
*
      IF(IRETO.EQ.0) THEN
        JG=1
        SEGINI MLENTI
        IRETO=MLENTI
      ELSE
        SEGACT MLENTI
        JG=JG+1
        SEGADJ MLENTI
      ENDIF
      DO 71 K=1,MAX(1,LISOUS(/1))
      IF(LISOUS(/1).NE.0) IPT1=LISOUS(K)
      DO 73 KI=1,IPT1.NUM(/2)
      IPT1.NUM(1,KI)=ABS(IPT1.NUM(1,KI))
   73 CONTINUE
   71 CONTINUE
      NBNN=1
      NBELEM=INO
      NBSOUS=0
      NBREF=0
      SEGINI IPT2
      DO 70 I=1,INO
      IPT2.NUM(1,I)=INUINV(ICONC(I))
 70   CONTINUE
      IPT2.ITYPEL=1
       SEGDES IPT2
      CALL ECRCHA('APPUYER')
      CALL ECROBJ('MAILLAGE',IPT2)
      CALL ECROBJ('MAILLAGE',MELEME)
      CALL EXTREL (IRR,1,LIEL)
      SEGSUP IPT2
      CALL LIROBJ('MAILLAGE',IPT,1,IRETAY)
      IF(IERR.NE.0) THEN
        CALL ERREUR(5)
        RETURN
      ENDIF
      SEGACT MELEME*MOD
      DO 2020 IO=1,MAX(1,LISOUS(/1))
      IF (LISOUS(/1).NE.0) THEN
       IPT1=LISOUS(IO)
       SEGACT IPT1*MOD
      ENDIF
 2020 CONTINUE
      LECT(JG)=IPT
      INDE=INDE+INO
      IF(INDE.NE.NODES) GO TO 50
 1000 CONTINUE
      SEGDES MLENTI
      IF(LISOUS(/1).NE.0) THEN
        DO 74 K=1,LISOUS(/1)
        IPT1=LISOUS(K)
        SEGDES IPT1
   74   CONTINUE
      ENDIF
      SEGDES MELEME
      SEGSUP ICPR,ICONC,IDEJ,IPRI,MEMJT,JMEM,INUINV,IPOME
      RETURN
      END