C CHANLG    SOURCE    GOUNAND   26/07/30    21:15:05     12610          
C   CE SOUS PROGRAMME FABRIQUE L'ENSEMBLE DES ARETES D'UN MAILLAGE
C   IL FONCTIONNE SUIVANT UN PRINCIPE DERIVE DES TRACES
C
      SUBROUTINE CHANLG
      IMPLICIT INTEGER(I-N)

-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMELEME
-INC SMCOORD
      PARAMETER(ndegma=2)
      SEGMENT ICPR(nbpts)
      SEGMENT IDCP(ITE)
      SEGMENT NTSEG(0)
      SEGMENT NELTOT(ndegma)
      SEGMENT JELTOT(NBSOR)
      SEGMENT KON(NBCON,NMAX,3,nbsor)

      ICPR = 0
      IDCP = 0
      KON = 0

      CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
      IF (IERR.NE.0) RETURN
      CALL ACTOBJ('MAILLAGE',MELEME,1)
*
      SEGINI ICPR
      ITE=0
      SEGINI NELTOT
      idegre=0

      SEGACT MELEME
*      IPT8 = MELEME
      NBSOU8 = meleme.LISOUS(/1)
      IPT1=MELEME
      DO 3 I=1,MAX(1,NBSOU8)
         IF (NBSOU8.NE.0) THEN
            IPT1 = meleme.LISOUS(I)
         ENDIF
         NBNOE1=IPT1.NUM(/1)
         NBELT1=IPT1.NUM(/2)
         K=IPT1.ITYPEL
         IDEP=NSPOS(K)
         if (idep.eq.0) goto 8
         idegre=KDEGRE(K)
* Pour l'instant, on ne fait que les lineaires et quadratiques
         if (idegre.le.0) goto 8
         if (idegre.ge.ndegma+2.or.idegre.eq.1) then
*Le type d'element fini %m1:8 ne convient pas.
            MOTERR(1:8)=NOMS(K)
            call erreur(927)
            return
         ENDIF
         NELTOT(idegre-1)=NELTOT(idegre-1)+NBELT1
*
         IF (NBSOM(K).GT.0) THEN
            IFEP=IDEP+NBSOM(K)-1
         ELSE
C            Cas du polygone
            IFEP=IDEP+NBNOE1-1
         ENDIF
         DO 4 JJ=IDEP,IFEP
            J=IBSOM(JJ)
            DO 41 K=1,NBELT1
               IPOIT=IPT1.NUM(J,K)
               IF (ICPR(IPOIT).NE.0) GOTO 41
               ITE=ITE+1
               ICPR(IPOIT)=ITE
 41         CONTINUE
 4       CONTINUE
 8       CONTINUE
 3    CONTINUE
*
      IF (ITE.NE.0) GOTO 6
      SEGSUP,ICPR
* sg 2016/11/29 gestion maillage vide
* Par défaut SEG2, sinon en fonction du dernier KDEGRE lu.
      ity=2
      IF (idegre.ge.1.and.idegre.le.3) ity=idegre
      CALL melvid(ity,meleme)
      CALL ECROBJ('MAILLAGE',MELEME)
      RETURN
 6    CONTINUE
C
C Nombre de sous-maillages en sortie
C
      nbsor=ndegma
      SEGINI JELTOT
      nbsor=0
      DO idg=1,ndegma
         IF (NELTOT(idg).gt.0) then
            nbsor=nbsor+1
            JELTOT(nbsor)=idg
            NELTOT(idg)=nbsor
         ENDIF
      ENDDO
      if (nbsor.eq.0) then
         call erreur(5)
         return
      endif
      SEGADJ JELTOT
C
C   ITE EST LE NOMBRE DE POINTS A CONSIDERER  ICPR LE TABLEAU
C   ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS
      NBCON=7
      NBCONR=NBCON-1
      NMAX= 10*ITE
      SEGINI KON
C   FABRICATION DU TABLEAU DES CONNECTIONS
C    1  POINT FINAL
C    2  POINT INTERMEDIAIRE EVENTUEL ET SENS
      ICHAIN=ITE
      SEGACT MELEME
      IOO=0
      IPT1=MELEME
      DO 30 IO=1,MAX(1,NBSOU8)
         IF (NBSOU8.NE.0) IPT1=LISOUS(IO)
         SEGACT IPT1
         K=IPT1.ITYPEL
         If ((K.eq.22).or.(K.eq.48)) then
            segdes ipt1
            goto 30
         endif
         NBNN=KDEGRE(K)
         ibsor=neltot(nbnn-1)
         IPAS=NBNN-1
         KKK=LTEL(1,K)
c IPAS = 1 & KKK = 1
* Cas des segments
         IF (KKK.EQ.0) THEN
            DO 122 I=1,IPT1.NUM(/2)
               NMIL=1
               N1=ICPR(IPT1.NUM(1,I))
               JSUIV=1+IPAS
               N2=ICPR(IPT1.NUM(JSUIV,I))
               IF (N1*N2.EQ.0) THEN
                 CALL ERREUR(26)
                 GOTO 64
               ENDIF
               IF (IPAS.EQ.2) NMIL=IPT1.NUM(1+1,I)
               NI=N1
               NJ=N2
               KSCOL=IPT1.ICOLOR(I)
*                           PRINT *,'*KSCOL',KSCOL
               IPO=0
 123           CONTINUE
               DO 125 IK=1,NBCONR
                  IF (KON(IK,NI,1,ibsor).EQ.0) GOTO 126
                  IF (KON(IK,NI,1,ibsor).EQ.NJ) GOTO 129
 125           CONTINUE
               IF (KON(NBCON,NI,1,ibsor).EQ.0) GOTO 128
               NI=KON(NBCON,NI,1,ibsor)
               GOTO 123
 126           CONTINUE
               KON(IK,NI,1,ibsor)=NJ
               KON(IK,NI,2,ibsor)=NMIL
               KON(IK,NI,3,ibsor)=KSCOL
               GOTO 129
 128           ICHAIN=ICHAIN+1
               IF (ICHAIN.GE.NMAX) THEN
                 CALL ERREUR(26)
                 GOTO 64
               ENDIF
               KON(NBCON,NI,1,ibsor)=ICHAIN
               IK=1
               NI=ICHAIN
               GOTO 126
 129           CONTINUE
               IF (IPO.EQ.1) GOTO 122
               NMIL=-NMIL
               NI=N2
               NJ=N1
               IPO=1
               GOTO 123
 122        CONTINUE
         ELSE
            IOO=1
            KK=LTEL(2,K)-1
c KKK = 1 && KK = 49
            DO 300 III=1,KKK
C ****BOUCLE PERMETTANT D'ALLER RECHERCHER TOUTES LES FACES
               KK=KK+1
               ITYP=LDEL(1,KK)
               IDEP=LDEL(2,KK)
               IF (K.EQ.32) ITYP = 0
               IF (ITYP.GT.0) THEN
                  IFEP=IDEP+KDFAC(1,ITYP)-1
*     SG 20160711 pour les faces TRI7 et QUA9, on ignore le dernier
*     point (centre de la face)
                  IF (ITYP.EQ.7.OR.ITYP.EQ.8) IFEP=IFEP-1
               ELSE
C                    Cas du polygone
                  IFEP= IDEP+IPT1.NUM(/1)-1
               ENDIF
               DO 22 I=1,IPT1.NUM(/2)
                  KSCOL=IPT1.ICOLOR(I)
                  DO 221 J=IDEP,IFEP,IPAS
                     NMIL=1
                     N1=ICPR(IPT1.NUM(LFAC(J),I))
                     JSUIV=J+IPAS
                     IF (JSUIV.GT.IFEP) JSUIV=IDEP
                     N2=ICPR(IPT1.NUM(LFAC(JSUIV),I))
                     IF (IPAS.EQ.2) NMIL=IPT1.NUM(LFAC(J+1),I)
                     NI=N1
                     NJ=N2
                     IF (N1*N2.EQ.0) THEN
                       CALL ERREUR(26)
                       GOTO 64
                     ENDIF
                     IPO=0
 23                  CONTINUE
                     DO 25 IK=1,NBCONR
                        IF (KON(IK,NI,1,ibsor).EQ.0) GOTO 26
                        IF (KON(IK,NI,1,ibsor).EQ.NJ) GOTO 29
 25                  CONTINUE
                     IF (KON(NBCON,NI,1,ibsor).EQ.0) GOTO 28
                     NI=KON(NBCON,NI,1,ibsor)
                     GOTO 23
 26                  KON(IK,NI,1,ibsor)=NJ
                     KON(IK,NI,2,ibsor)=NMIL
                     KON(IK,NI,3,ibsor)=KSCOL
                     GOTO 29
 28                  ICHAIN=ICHAIN+1
                     IF (ICHAIN.GE.NMAX) THEN
                       CALL ERREUR(26)
                       GOTO 64
                     ENDIF
                     KON(NBCON,NI,1,ibsor)=ICHAIN
                     IK=1
                     NI=ICHAIN
                     GOTO 26
 29                  IF (IPO.EQ.1) GOTO 221
                     NMIL=-NMIL
                     NI=N2
                     NJ=N1
                     IPO=1
                     GOTO 23
 221              CONTINUE
 22            CONTINUE
 300        CONTINUE
         ENDIF
 30   CONTINUE

      IF (IIMPI.EQ.2)WRITE (IOIMP,1122) ((((KON(I,J,K,ibsor),K=1
     $     ,2),I=1,NBCON),J=1,NMAX),ibsor=1,nbsor)
 1122 FORMAT(1X,14I5)

      SEGINI IDCP

      DO 40 I=1,ICPR(/1)
         IF (ICPR(I).EQ.0) GOTO 40
         IDCP(ICPR(I))=I
 40   CONTINUE

************************************************************************
** TEST VERIFIANT SI AU DEPART ON A DEJA DES POINTS,SEG2 OU SEG3
      IF (IOO.EQ.0) THEN
*        LE MAILLAGE EXISTE DEJA
*        PRINT *,'*LE MAILLAGE EXISTE DEJA'
         CALL ECROBJ('MAILLAGE',IPT1)
         GOTO 64
      ENDIF
* CREATION DE L'OBJET MAILLAGE

      NBREF=0
      NBELEM=0
      NBNN=0
      IF (NBSOR.GT.1) THEN
         NBSOUS=NBSOR
         SEGINI IPT1
      ENDIF
      NBSOUS=0

      DO ibsor=1,NBSOR
C ****ON COMPTE LE NOMBRE D'ELEMENTS POUR ACTIVER LE SEGMENT
         NBELEM=0
         DO 170 J=1,ITE
            JJ=J
 179        CONTINUE
            DO 180 I=1,NBCONR
               M=KON(I,JJ,1,ibsor)
               IF(M.LT.J) GOTO 180
               NBELEM=NBELEM+1
 180        CONTINUE

            IF (KON(NBCON,JJ,1,ibsor) .EQ. 0) GOTO 170
            JJ=KON(NBCON,JJ,1,ibsor)
            GOTO 179
 170     CONTINUE
         IF (NBELEM.EQ.0) THEN
            CALL ERREUR(5)
            GOTO 64
         ENDIF
C****ETABLISSEMENT DU MAILLAGE
C****CONSTRUCTION DU TABLEAU NUM
         NBNN=jeltot(ibsor)+1
         SEGINI,MELEME
         ITYPEL=NBNN
         IEL=0
         DO 100 J=1,ITE
            JJ=J
 109        CONTINUE
            DO 110 I=1,NBCONR
               M=KON(I,JJ,1,ibsor)
               IF (M.LT.J) GOTO 110
               IEL=IEL+1
               NUM(1,IEL)=IDCP(J)
               NUM(NBNN,IEL)=IDCP(M)
               ICOLOR(IEL)=KON(I,JJ,3,ibsor)
               IF (NBNN.EQ.3) NUM(2,IEL)=ABS(KON(I,JJ,2,ibsor))
 110        CONTINUE

            IF (KON(NBCON,JJ,1,ibsor).EQ.0) GOTO 100
            JJ=KON(NBCON,JJ,1,ibsor)
            GOTO 109
 100     CONTINUE
         IF (NBSOR.GT.1) IPT1.LISOUS(ibsor)=MELEME
      ENDDO
      IF (NBSOR.GT.1) MELEME=IPT1

      CALL ACTOBJ('MAILLAGE',MELEME,1)
      CALL ECROBJ('MAILLAGE',MELEME)

*  ON INSCRIT LE MAILLAGE  DANS LE MAILLAGE INITIAL
*      SEGACT,IPT8*MOD
*      IF (IPT8.LISREF(/1).EQ.0) THEN
*          NBREF=1
*          NBNN=IPT8.NUM(/1)
*          NBELEM=IPT8.NUM(/2)
*          NBSOUS=IPT8.LISOUS(/1)
*          SEGADJ IPT8
*          IPT8.LISREF(1)=MELEME
*      ENDIF
*      SEGDES IPT8

 64   CONTINUE
      IF (KON.GT.0)  SEGSUP,KON
      IF (IDCP.GT.0) SEGSUP,IDCP
      IF (ICPR.GT.0) SEGSUP,ICPR
c      CALL ACTOBJ pour meleme=ipt8
*      SEGDES,IPT8

      RETURN
      END