C VTOP2D    SOURCE    PV        20/03/30    21:25:51     10567          
       SUBROUTINE VTOP2D(meleme)
       IMPLICIT INTEGER(I-N)
       IMPLICIT REAL*8(A-H,O-Z)

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     Appelée par VERMAI
C
C     vérifie qu'il n'y a pas d'éléments de degré un accolé à un
C     élément de degré 2.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     Modifications :
C
C       P. Maugis (04/08/2005) :
C         on lieu de faire une erreur sur une sous-zone non pertinente,
C         on passe à la sous-zone suivante
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMELEME
-INC SMCOORD
C
      SEGMENT ICPR(nbpts)
      SEGMENT IDCP(ITE)
      SEGMENT INTER
      INTEGER INTE(NBSOUS)
      ENDSEGMENT
      SEGMENT KON(NBCON,NMAX,3)
      CHARACTER*6 CHAIN1
      CHARACTER*6 CHAIN2
C
*dbg      write(ioimp,*) 'coucou vtop2d'
      SEGACT MELEME
      SEGINI ICPR
c
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C       Création d'un tableau de connexions :
C               comme la numérotation des noeuds est aléatoire, on
C       utilise un vecteur réduit (de dimension le nombre de noeuds ITE)
C       noté ICPR qui renumérote les noeuds.
C               1 point final connecté
C               2 point intermédiaire éventuel (si de deg3) et sens
C
C       Si un point est connecté à la fois à un autre point par un
C       élément de degré 2 et un élément de degré 3, il apparait deux
C       fois dans la meme ligne du tableau.
C

C       ICPR contient le numéro du noeud intéressant à traiter,
C       ou 0 s'il n'a aucune connection.
      ITE=0
      IPT1=MELEME
      DO 3 I=1,MAX(1,LISOUS(/1))
         IF (LISOUS(/1).NE.0) THEN
            IPT1=LISOUS(I)
            SEGACT IPT1
         ENDIF
         K=IPT1.ITYPEL
         IF (K.EQ.KDEGRE(K)) THEN
*           On ne veut pas de POI1, SEG2 ni SEG3
*            CALL ERREUR(16)
*            RETURN
            IF (LISOUS(/1).NE.0) SEGDES IPT1
            GOTO 3
         ENDIF

         IDEP=NSPOS(K)
         IF (NBSOM(K).GT.0) THEN
            IFEP=IDEP+NBSOM(K)-1
         ELSE
C           Cas du polygone
            IFEP=IDEP+IPT1.NUM(/1)-1
         ENDIF
         IF (IDEP.GT.IFEP) THEN
            write(IOIMP,*) 'Une face doit avoir au moins 3 points'
            CALL ERREUR (16)
            RETURN
         ENDIF

         DO 4 JJ=IDEP,IFEP
            J=IBSOM(JJ)
            DO 7 K=1,IPT1.NUM(/2)
               IPOIT=IPT1.NUM(J,K)
               IF (ICPR(IPOIT).NE.0) GOTO 7
               ITE=ITE+1
               ICPR(IPOIT)=ITE
 7          CONTINUE
 4       CONTINUE
         IF (LISOUS(/1).NE.0) SEGDES IPT1
 3    CONTINUE
      SEGDES MELEME
C
      IF (ITE.EQ.0) THEN
*         Aucun element n a de point sommet
         SEGSUP ICPR
*          CALL ERREUR(16)
         RETURN
      ENDIF
C
C       on initialise le tableau de connexions
C       on définit les paramètres
C
      NBCON=7
      NBCONR=NBCON-1
      NMAX=(10*ITE)/NBCON
      SEGINI KON
C
C       on remplit le tableau :
C       la 1ère coordonnée est le n° du noeud final
C       la 2ème est le n° du noeud intermédiare éventuel
C       (sinon 1) et le sens (signe)
C       la 3ème code la couleur
C
      ICHAIN=ITE
      SEGACT MELEME
      IPT1=MELEME
      K1=0
      K2=0
      NBSOUS=LISOUS(/1)+1
      SEGINI INTER
      IF (LISOUS(/1).NE.0) THEN
         DO 300 IO=1,LISOUS(/1)
            IPT2=LISOUS(IO)
            SEGACT IPT2
            K=IPT2.ITYPEL
            SEGDES IPT2
            IF (K.EQ.KDEGRE(K)) THEN
*     On ne veut pas de POI1, SEG2 ni SEG3
*              CALL ERREUR(16)
*              RETURN
               GOTO 300
            ENDIF

C           LE NOMBRE DE FACE EST 1 QUEL EST SON TYPE
C
C           ON ORDONNE LES SOUS OBJETS : LES SOUS OBJ DE DEGRE 3 D'ABORD
C           LES AUTRES ENSUITES
            NBNN=KDEGRE(K)
            IF (NBNN.EQ.3) THEN
               K1=K1+1
               INTE(K1)=LISOUS(IO)
            ELSE
               K2=K2+1
               INTE(LISOUS(/1)-K2+1)=LISOUS(IO)
            ENDIF
 300     CONTINUE
      ELSE
         INTE(1)=MELEME
      ENDIF

      DO 30 IO=1,MAX(1,LISOUS(/1))
         IPT1=INTE(IO)
         SEGACT IPT1
         K=IPT1.ITYPEL
         IF (K.EQ.KDEGRE(K)) THEN
*           On ne veut pas de POI1, SEG2 ni SEG3
*            CALL ERREUR(16)
*            RETURN
            IF (LISOUS(/1).NE.0) SEGDES IPT1
            GOTO 30
         ENDIF

         NBFA=LTEL(1,K)
         IF (NBFA.EQ.0) THEN
*           données incompatibles
*            Ces elements n'ont pas de face.
*            CALL ERREUR(21)
*            RETURN
            GOTO 30
         ENDIF

         KK=LTEL(2,K)
         NBNN=KDEGRE(K)
         IPAS=NBNN-1
         DO 301 K1=1,NBFA
            ITYP=LDEL(1,KK+K1-1)
            IDEP=LDEL(2,KK+K1-1)
            IF (ITYP.NE.6) 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)
               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)  THEN
                     NMIL=IPT1.NUM(LFAC(J+1),I)
                     IF (ICPR(NMIL).NE.0) THEN
                        NMIL=ICPR(NMIL)
                     ELSE
                        NMIL=0
                     ENDIF
                  ENDIF
                  NI=N1
                  NJ=N2
                  IF ((N1.EQ.0).OR.(N2.EQ.0)) THEN
*                Tache impossible. Probablement données erronées
                     CALL ERREUR(26)
                     SEGSUP KON,ICPR
                     SEGDES MELEME
                     RETURN
                  ENDIF
                  KSCOL=IPT1.ICOLOR(I)
                  IPO=0
 23               CONTINUE
                  KINT=1

 251              CONTINUE
 24               DO 25 K=KINT,NBCONR
                     IF (KON(K,NI,1).EQ.0) GOTO 26
                     IF (KON(K,NI,1).EQ.NJ) GOTO 27
 25               CONTINUE
                  
                  IF (KON(NBCON,NI,1).EQ.0) GOTO 28
                  NI=KON(NBCON,NI,1)
                  KINT=1
                  GOTO 24
 27               IF (ABS(NMIL).EQ.1) THEN
                     IF (ABS(KON(K,NI,2)).NE.1) THEN
                        KINT=K+1
                        GOTO 251
                     ENDIF
                  ENDIF
                  GOTO 29
                  
 26               KON(K,NI,1)=NJ
                  KON(K,NI,2)=NMIL
                  KON(K,NI,3)=KSCOL
                  GOTO 29

 28               ICHAIN=ICHAIN+1
                  IF (ICHAIN.GE.NMAX) THEN
                     NMAX = NMAX * 2
                     SEGADJ KON
                  ENDIF
                  KON(NBCON,NI,1)=ICHAIN
                  K=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
 301     CONTINUE
         SEGDES IPT1
 30   CONTINUE

      SEGSUP INTER
      IF (IIMPI.EQ.2) THEN
         WRITE (IOIMP,1122)
     #        (((KON(I,J,K),K=1,2),I=1,NBCON),J=1,NMAX)
 1122    FORMAT(1X,14I5)
      ENDIF
      SEGDES MELEME
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
C       Création de idcp
C               Vecteur permettant de revenir à la numérotation initiale
C
      SEGINI IDCP
      DO 40 I=1,ICPR(/1)
         IF (ICPR(I).EQ.0) GOTO 40
         IDCP(ICPR(I))=I
 40   CONTINUE
      SEGSUP ICPR
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C       ECRITURE DE L'AVERTISSEMENT
C
C       Deux cas de figures possibles :
C               un élément de degré 3 et un élément de degré 2 sont
C       connectés par leus extrémités (ITEST1)
C               deux éléments de degré 2 sont connectés aux trois
C       points d'un élément de degré 3
C
C
      NNOEUD=0
      DO 50 NI=1,ITE
C
C       Recherche du nombre de connexions d'un noeud et des numéros de lignes
C       où sont stockées les n° des noeuds connectés
C
C       COMPTEUR compte le nombre de lignes utilisées pour enregistrer le
C       nombre de noeuds connectés au noeud n° NI
C
C       NKON est le nombre de noeuds connectés dans la dernière ligne
C
         NINT=NI
         icompt=1

 90      CONTINUE
         iAD=KON(NBCON,NINT,1)
         IF (iAD.NE.0) THEN
            NINT=iAD
            INTEG=icompt
            icompt=INTEG+1
            GOTO 90
         ELSE
            J=0
 91         CONTINUE
            J=J+1
            IF (KON(J,NINT,1).NE.0) THEN
               GOTO 91
            ENDIF
            NKON=J-1
         ENDIF
C
C     Recherche du dernier noeud qui constitue un élément de degré 3
C
         I=0
         NINT=NI
         
 92      CONTINUE
         I=I+1
         jcompt=-1
         IF (I.LE.icompt) THEN
            J=0
 93         CONTINUE
            J=J+1
            IF (J.LE.NBCONR) THEN
               IF (KON(J,NINT,1).EQ.0) GOTO 50
               IF (ABS(KON(J,NINT,2)).NE.1) GOTO 93
               NCOMPT=NINT
               jcompt=J-1
            ELSE
               NINT=KON(NBCON,NINT,1)
               GOTO 92
            ENDIF
         ENDIF
C
C     Lecture du tableau de connexions et comparaison
C
C     CAS OU LES ELEMENTS ONT LA MEME TAILLE
C
         iadi=NI
         IF (I.EQ.1) GOTO 100
         DO 52 LI=1,I-1
            DO 53 J=1,NBCONR
               ITEST1=KON(J,iadi,1)
               ITEST2=KON(J,iadi,2)
               IF (ITEST2.LT.0) GOTO 53
               JJ=jcompt
               IF (I.EQ.icompt) GOTO 98
               if (jcompt.lt.0) goto 53
 94            CONTINUE
               JJ=JJ+1
               IF (JJ.LE.NBCONR) THEN
                  IF (KON(JJ,NCOMPT,2).LT.0) GOTO 94
                  IF (ITEST1.NE.KON(JJ,NCOMPT,1)) GOTO 94
                  ipoin1=IDCP(NI)
                  ipoin2=IDCP(ITEST1)
                  CALL ETEST1(ipoin1,ipoin2,NNOEUD)
                  IDCP(NI)=ipoin1
                  IDCP(ITEST1)=ipoin2
                  GOTO 53
               ENDIF
C
C         Cas où il ya plus de deux lignes de connections pour un noeud
C
               NINT=NCOMPT
               IF (I.LE.icompt-1) THEN
                  II=I
 96               CONTINUE
                  II=II+1
                  NINT=KON(NBCON,NINT,1)
                  IF (II.LE.icompt-1) THEN
                     JJ=0
 97                  CONTINUE
                     JJ=JJ+1
                     IF (JJ.LE.NBCONR) THEN
                        IF (KON(JJ,NINT,2).LT.0) GOTO 97
                        IF (ITEST1.NE.KON(JJ,NINT,1)) GOTO 97
                        ipoin1=IDCP(NI)
                        ipoin2=IDCP(ITEST1)
                        CALL ETEST1(ipoin1,ipoin2,NNOEUD)
                        IDCP(NI)=ipoin1
                        IDCP(ITEST1)=ipoin2
                        GOTO 53
                     ENDIF
                     GOTO 96
                  ENDIF
               ENDIF
C     
C         On finit de lire la ligne
C
               NINT=KON(NBCON,NINT,1)
               JJ=0
 98            CONTINUE
               JJ=JJ+1
               IF (JJ.LE.NKON) THEN
                  IF (KON(JJ,NINT,2).LT.0) GOTO 98
                  IF (ITEST1.NE.KON(JJ,NINT,1)) GOTO 98
                  ipoin1=IDCP(NI)
                  ipoin2=IDCP(ITEST1)
                  CALL ETEST1(ipoin1,ipoin2,NNOEUD)
                  IDCP(NI)=ipoin1
                  IDCP(ITEST1)=ipoin2
                  GOTO 53
               ENDIF
 53         CONTINUE
            iadi=KON(NBCON,iadi,1)
 52      CONTINUE
C
C
 100     CONTINUE
         DO 54 J=1,jcompt
            ITEST1=KON(J,NCOMPT,1)
            ITEST2=KON(J,NCOMPT,2)
            IF (ITEST2.LT.0) GOTO 54
            JJ=jcompt
            IF (I.EQ.icompt) GOTO 198
 194        CONTINUE
            JJ=JJ+1
            IF (JJ.LE.NBCONR) THEN
               IF (KON(JJ,NCOMPT,2).LT.0) GOTO 194
               IF (ITEST1.NE.KON(JJ,NCOMPT,1)) GOTO 194
               ipoin1=IDCP(NI)
               ipoin2=IDCP(ITEST1)
               CALL ETEST1(ipoin1,ipoin2,NNOEUD)
               IDCP(NI)=ipoin1
               IDCP(ITEST1)=ipoin2
               GOTO 54
            ENDIF
C
C        Cas où il ya plus de deux lignes de connections pour un noeud
C
            NINT=NCOMPT
            IF (I.LT.icompt-1) THEN
               
               II=I
 196           CONTINUE
               II=II+1
               NINT=KON(NBCON,NINT,1)
               IF (II.LE.icompt-1) THEN
                  JJ=0
 197              CONTINUE
                  JJ=JJ+1
                  IF (JJ.LE.NBCONR) THEN
                     IF (KON(JJ,NINT,2).LT.0) GOTO 197
                     IF (ITEST1.NE.KON(JJ,NINT,1)) GOTO 197
                     ipoin1=IDCP(NI)
                     ipoin2=IDCP(ITEST1)
                     CALL ETEST1(ipoin1,ipoin2,NNOEUD)
                     IDCP(NI)=ipoin1
                     IDCP(ITEST1)=ipoin2
                     GOTO 54
                  ENDIF
                  GOTO 196
               ENDIF
            ENDIF
C
C        On finit de lire la ligne
C

            NINT=KON(NBCON,NINT,1)
            JJ=0
 198        CONTINUE
            JJ=JJ+1
            IF (JJ.LE.NKON) THEN
               IF (KON(JJ,NINT,2).LT.0) GOTO 198
               IF (ITEST1.NE.KON(JJ,NINT,1)) GOTO 198
               ipoin1=IDCP(NI)
               ipoin2=IDCP(ITEST1)
               CALL ETEST1(ipoin1,ipoin2,NNOEUD)
               IDCP(NI)=ipoin1
               IDCP(ITEST1)=ipoin2
               GOTO 54
            ENDIF
 54      CONTINUE
C
C       CAS OU IL Y A DEUX SEG2 POUR UN SEG3
C
         iadi=NI
         IF (I.EQ.1) GOTO 200
         DO 252 LI=1,I-1
            DO 253 J=1,NBCONR
               ITEST1=KON(J,iadi,1)
               ITEST2=KON(J,iadi,2)
               IF (ITEST2.LE.0) GOTO 253
               JJ=jcompt
               WRITE(IOIMP, *)I
               WRITE(IOIMP,*)icompt
               IF (I.EQ.icompt) GOTO 298
 294           CONTINUE
               JJ=JJ+1
               IF (JJ.LE.NBCONR) THEN
                  IF (ITEST2.NE.KON(JJ,NCOMPT,1)) GOTO 294
                  ipoin1=IDCP(NI)
                  ipoin2=IDCP(ITEST2)
                  ipoin3=IDCP(ITEST1)
                  CALL ETEST2(ipoin1,ipoin2,ipoin3,NNOEUD)
                  IDCP(NI)=ipoin1
                  IDCP(ITEST2)=ipoin2
                  IDCP(ITEST1)=ipoin3
                  GOTO 253
               ENDIF
C
C           Cas où il ya plus de deux lignes de connections pour un noeud
C
               NINT=NCOMPT
               IF (I.LE.icompt-1) THEN
                  II=I
 296              CONTINUE
                  II=II+1
                  NINT=KON(NBCON,NINT,1)
                  IF (II.LE.icompt-1) THEN
                     JJ=0
 297                 CONTINUE
                     JJ=JJ+1
                     IF (JJ.LE.NBCONR) THEN
                        IF (ABS(ITEST2).NE.KON(JJ,NINT,1)) GOTO 297
                        ipoin1=IDCP(NI)
                        ipoin2=IDCP(ITEST2)
                        ipoin3=IDCP(ITEST1)
                        CALL ETEST2(ipoin1,ipoin2,ipoin3,NNOEUD)
                        IDCP(NI)=ipoin1
                        IDCP(ITEST2)=ipoin2
                        IDCP(ITEST1)=ipoin3
                        GOTO 253
                     ENDIF
                     GOTO 296
                  ENDIF
               ENDIF
C
C           On finit de lire la ligne
C
               NINT=KON(NBCON,NINT,1)
               JJ=0
 298           CONTINUE
               JJ=JJ+1
               IF (JJ.LE.NKON) THEN
                  IF (ABS(ITEST2).NE.KON(JJ,NINT,1)) GOTO 298
                  ipoin1=IDCP(NI)
                  ipoin2=IDCP(ITEST2)
                  ipoin3=IDCP(ITEST1)
                  CALL ETEST2(ipoin1,ipoin2,ipoin3,NNOEUD)
                  IDCP(NI)=ipoin1
                  IDCP(ITEST2)=ipoin2
                  IDCP(ITEST1)=ipoin3
                  GOTO 253
               ENDIF
 253        CONTINUE
            iadi=KON(NBCON,iadi,1)
 252     CONTINUE
C
C
 200     CONTINUE
         DO 254 J=1,jcompt
            ITEST1=KON(J,NCOMPT,1)
            ITEST2=KON(J,NCOMPT,2)
            IF (ITEST2.LT.0) GOTO 254
            JJ=jcompt
            IF (I.EQ.icompt) GOTO 398
 394        CONTINUE
            JJ=JJ+1
            IF (JJ.LE.NBCONR) THEN
               IF (ABS(ITEST2).NE.KON(JJ,NCOMPT,1)) GOTO 394
               ipoin1=IDCP(NI)
               ipoin2=IDCP(ITEST2)
               ipoin3=IDCP(ITEST1)
               CALL ETEST2(ipoin1,ipoin2,ipoin3,NNOEUD)
               IDCP(NI)=ipoin1
               IDCP(ITEST2)=ipoin2
               IDCP(ITEST1)=ipoin3
               GOTO 254
            ENDIF
C
C         Cas où il y a plus de deux lignes de connections pour un noeud
C
            NINT=NCOMPT
            IF (I.LT.icompt-1) THEN
               II=I
 396           CONTINUE
               II=II+1
               NINT=KON(NBCON,NINT,1)
               IF (II.LE.icompt-1) THEN
                  JJ=0
 397              CONTINUE
                  JJ=JJ+1
                  IF (JJ.LE.NBCONR) THEN
                     IF (ABS(ITEST2).NE.KON(JJ,NINT,1)) GOTO 397
                     ipoin1=IDCP(NI)
                     ipoin2=IDCP(ITEST2)
                     ipoin3=IDCP(ITEST1)
                     CALL ETEST2(ipoin1,ipoin2,ipoin3,NNOEUD)
                     IDCP(NI)=ipoin1
                     IDCP(ITEST2)=ipoin2
                     IDCP(ITEST1)=ipoin3
                     GOTO 254
                  ENDIF
                  GOTO 396
               ENDIF
            ENDIF
C
C         On finit de lire la ligne
C
            NINT=KON(NBCON,NINT,1)
            JJ=0
 398        CONTINUE
            JJ=JJ+1
            IF (JJ.LE.NKON) THEN
               IF (ABS(ITEST2).NE.KON(JJ,NINT,1)) GOTO 398
               ipoin1=IDCP(NI)
               ipoin2=IDCP(ITEST2)
               ipoin3=IDCP(ITEST1)
               CALL ETEST2(ipoin1,ipoin2,ipoin3,NNOEUD)
               IDCP(NI)=ipoin1
               IDCP(ITEST2)=ipoin2
               IDCP(ITEST1)=ipoin3
               GOTO 254
            ENDIF
 254     CONTINUE
         
 50   CONTINUE

      SEGSUP KON,IDCP
      END