C PRCONT    SOURCE    CHAT      07/10/29    21:25:46     5940           
C   CE SOUS PROGRAMME RETROUVE LE CONTOUR D'UN OBJET
C   IL FONCTIONNE SUIVANT UN PRINCIPE DERIVE DES TRACES
C
      SUBROUTINE PRCONT
      IMPLICIT INTEGER(I-N)
-INC CCOPTIO
-INC CCGEOME
-INC SMELEME
-INC SMCOORD
        character*4 lmot(1)
        data lmot/'NOID'/
        SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
        SEGMENT IDCP(ITE)
        SEGMENT NTSEG(0)
        SEGMENT KON(NBCON,NMAX,3)
        INTEGER NBNN,COMPT,NNOEUD,NKON,NINT
        CHARACTER*8 CHAIN1
        call lirmot(lmot,1,imot,0)
        CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
        IF (IERR.NE.0) RETURN
        IPT8=MELEME
        SEGACT MELEME
        IF (LISREF(/1).EQ.1) THEN
*  LE CONTOUR EXISTE DEJA
           IPT1=LISREF(1)
           CALL ECROBJ('MAILLAGE',IPT1)
           SEGDES MELEME
           RETURN
        ENDIF
        SEGINI ICPR
c
        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.NE.KSURF(K)) GOTO 8
             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 (IFEP.LT.IDEP) GOTO 8
             DO 4 JJ=IDEP,IFEP
                  J=IBSOM(JJ)
                  DO 4 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
   8         CONTINUE
             IF (LISOUS(/1).NE.0) SEGDES IPT1
   3    CONTINUE
        SEGDES MELEME
        IF (ITE.NE.0) GOTO 6
        SEGSUP ICPR
        CALL ERREUR(16)
        RETURN
   6    CONTINUE
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)/NBCON
        SEGINI KON
C   MISE A ZERO DU TABLEAU KON
        DO 10 K=1,3
              DO 10 I=1,NMAX
                    DO 10 J=1,NBCON
  10                      KON(J,I,K)=0
C   FABRICATION DU TABLEAU DES CONNECTIONS
C    1  POINT FINAL
C    2  POINT INTERMEDIAIRE EVENTUEL ET SENS
        NBNN=0
        COMPT=0
        ICHAIN=ITE
        SEGACT MELEME
        IPT1=MELEME
        DO 30 IO=1,MAX(1,LISOUS(/1))
              IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
              SEGACT IPT1
              K=IPT1.ITYPEL
              IF (K.NE.KSURF(K)) GOTO 21
C  LE NOMBRE DE FACE EST 1 QUEL EST SON TYPE
              KK=LTEL(2,K)
              ITYP=LDEL(1,KK)
              IF (NBNN.NE.KDEGRE(K)) THEN
                 NBNN=KDEGRE(K)
                 COMPT=COMPT+1
              ENDIF
              IPAS=NBNN-1
              IDEP=LDEL(2,KK)
              IF (ITYP.NE.6) THEN
                 IFEP=IDEP+KDFAC(1,ITYP)-1
              ELSE
C                Cas du polygone
                 IFEP= IDEP+IPT1.NUM(/1)-1
              ENDIF
              DO 22 I=1,IPT1.NUM(/2)
                    DO 22 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) GOTO 32
                          KSCOL=IPT1.ICOLOR(I)
                          IPO=0
  23                      CONTINUE
                          KINT=1
 120                      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)
                          GOTO 24
  27                      IF (ABS(KON(K,NI,2)).EQ.ABS(NMIL)) THEN
                             KON(K,NI,1)=-1
                             GOTO 29
                          ELSE
                             KINT=K+1
                             GOTO 120
                          ENDIF   
  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 22
                         NMIL=-NMIL
                         NI=N2
                         NJ=N1
                         IPO=1
                         GOTO 23
  22           CONTINUE
  21           CONTINUE
               IF (LISOUS(/1).NE.0) SEGDES IPT1
  30    CONTINUE
        GOTO 31
  32    CALL ERREUR(26)
        SEGSUP KON,ICPR
        SEGDES MELEME
        RETURN
  31    CONTINUE
        IF (COMPT.GT.1) THEN
           CALL ERREUR(-333)
        ENDIF
        IF (IIMPI.EQ.2)WRITE (IOIMP,1122) (((KON(I,J,K),K=1,2),I=1,NBCON
     # ),J=1,NMAX)
 1122   FORMAT(1X,14I5)
        SEGDES MELEME
        SEGINI IDCP
        DO 40 I=1,ICPR(/1)
              IF (ICPR(I).EQ.0) GOTO 40
              IDCP(ICPR(I))=I
  40    CONTINUE
C
C       ON VERIFIE SI CHAQUE NOEUD DU CONTOUR EST BIEN RELIE UNIQUEMENT
C       A DEUX ELEMENTS
C
        if( iimpi.ne.0) then
        NNOEUD=0
        CHAIN1='NODE'
        DO 70 NI=1,ITE
          if(icpr(ni).eq.0) go to 70
           NINT=NI
           NKON=0
  72       CONTINUE
           DO 71 J=1,NBCONR
              IF (KON(J,NINT,1).EQ.0) GOTO 71
              IF (KON(J,NINT,1).NE.-1) THEN
                 NKON=NKON+1
              ENDIF
  71       CONTINUE
           IF (KON(NBCON,NINT,1).NE.0) THEN
              NINT=KON(NBCON,NINT,1)
              GOTO 72
           ENDIF
           IF (NKON.GT.2) THEN 
             
              NNOEUD=NNOEUD+1
              JP1=IDCP(NI)
*              write(6,*) ' p1 ', Jp1
              nno=nnoeud
            IF (NNO.LE.9) THEN
              WRITE(CHAIN1(5:5),111)NNO
           ELSEif(NNO.LE.99) THEN
              WRITE(CHAIN1(5:6),222)NNO
           ELSEif(NNO.LE.999) THEN
              WRITE(CHAIN1(5:7),333)NNO
           ELSEif(NNO.LE.9999) THEN
              WRITE(CHAIN1(5:8),444)NNO
           ELSEif(NNO.LE.99999) THEN
              WRITE(CHAIN1(4:8),555)NNO
           ELSEif(NNO.LE.999999) THEN
              WRITE(CHAIN1(3:8),666)NNO
           ENDIF   
  111   FORMAT(I1)
  222   FORMAT(I2)
 333    format (i3)
  444   format (i4)
  555    format(i5)
  666   format(i6)
              CALL NOMOBJ('POINT   ',CHAIN1,JP1)
              MOTERR(1:8)=chain1
              INTERR(1)=NKON              
              CALL ERREUR(-335)
            END IF 
  70    CONTINUE
        endif
        SEGSUP ICPR
C      
C  
C  CREATION DE L'OBJET CONTOUR. ON COMMENCE PAR COMPTER LENOMBRE D'ELEME
C 
C  Cas où le contour est un objet géométrique simple 
C  (uniquement des seg2 ou uniquement des seg3)
C
      IF (COMPT.EQ.1) THEN
        NBSOUS=0
        NBREF=0
        NBELEM=0
        DO 41 J=1,ITE
           JJ=J
  43       DO 42 I=1,NBCONR
                 IF (KON(I,JJ,1).LT.J) GOTO 42
                 NBELEM=NBELEM+1
  42       CONTINUE
           IF (KON(NBCON,JJ,1).EQ.0) GOTO 41
           JJ=KON(NBCON,JJ,1)
           GOTO 43
  41    CONTINUE
        IF (IIMPI.NE.0) WRITE(IOIMP,1111) NBELEM
 1111   FORMAT(' NOMBRE D''ELEMENTS DU CONTOUR : ',I6)
        IF (NBELEM.EQ.0.and.imot.eq.0) CALL ERREUR(26)
        IF (IERR.NE.0) GOTO 64
        SEGINI MELEME
        ITYPEL=NBNN
        IEL=0
        KAUX=1
  50    K=KAUX
        KAUXR=KAUX
  51    DO 52 KL=1,NBCONR
              ITRA=KON(KL,K,1)
              IF (ITRA.EQ.-1) GOTO 52
              IF (ITRA.EQ.0) GOTO 53
              IF (KON(KL,K,2).LT.0) GOTO 52
              GOTO 54
  52    CONTINUE
        K=KON(NBCON,K,1)
        IF (K.NE.0) GOTO 51
  53    KAUX=KAUX+1
        IF (KAUX.EQ.ITE+1) GOTO 63
        GOTO 50
  54     KPRESS=KAUXR
        GOTO 55
  57    KL=1
  55    DO 56 L=KL,NBCONR
              M=KON(L,K,1)
              IF (M.EQ.0) GOTO 53
              IF (M.EQ.-1) GOTO 56
              GOTO 58
  56    CONTINUE
        K=KON(NBCON,K,1)
        IF (K.EQ.0) GOTO 53
        GOTO 57
  58    IEL=IEL+1
        NUM(1,IEL)=IDCP(KPRESS)
        NUM(NBNN,IEL)=IDCP(M)
        ICOLOR(IEL)=KON(L,K,3)
        IF (NBNN.EQ.3) NUM(2,IEL)=ABS(KON(L,K,2))
        KON(L,K,1)=-1
        M1=M
  59    DO 60 L=1,NBCONR
              IF (KON(L,M1,1).EQ.0) GOTO 62
              IF (KON(L,M1,1).EQ.KPRESS) GOTO 61
  60    CONTINUE
        M1=KON(NBCON,M1,1)
        IF (M1.EQ.0) GOTO 62
        GOTO 59
  61    KON(L,M1,1)=-1
  62    KPRESS=M
        K=KPRESS
        GOTO 57
  63    CONTINUE
        SEGDES MELEME
        CALL ECROBJ('MAILLAGE',MELEME)
*  ON INSCRIT LE CONTOUR DANS LE MAILLAGE INITIAL
        SEGACT IPT8
        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
C
C    Cas où le contour est objet géométrique complexe
C
C
      ELSE
        NBSOUS=2
        NBREF=0
        NBELEM=0
        SEGINI MELEME
        NBSOUS=0
        NBREF=0
        NBELEM=0
        DO 141 J=1,ITE
               JJ=J
  143          DO 142 I=1,NBCONR
                      IF (KON(I,JJ,1).LT.J) GOTO 142
                      IF (ABS(KON(I,JJ,2)).EQ.1) GOTO 142
                      NBELEM=NBELEM+1
  142          CONTINUE
               IF (KON(NBCON,JJ,1).EQ.0) GOTO 141
               JJ=KON(NBCON,JJ,1)
               GOTO 143
  141   CONTINUE
        IF (IIMPI.NE.0) WRITE(IOIMP,1111) NBELEM
        IF (IERR.NE.0) GOTO 64
        NBNN=3
        SEGINI IPT3
        IPT3.ITYPEL=NBNN
        IEL=0
        KAUX=1
  150   K=KAUX
        KAUXR=KAUX
  151   DO 152 KL=1,NBCONR
               IF (ABS(KON(KL,K,2)).EQ.1) GOTO 152
               ITRA=KON(KL,K,1)
               IF (ITRA.EQ.-1) GOTO 152
               IF (ITRA.EQ.0) GOTO 153
               IF (KON(KL,K,2).LT.0) GOTO 152
               GOTO 154
  152   CONTINUE
        K=KON(NBCON,K,1)
        IF (K.NE.0) GOTO 151
  153   KAUX=KAUX+1
        IF (KAUX.EQ.ITE+1) GOTO 163
        GOTO 150
  154   KPRESS=KAUXR
        GOTO 155
  157   KL=1
  155   DO 156 L=KL,NBCONR
               IF (ABS(KON(L,K,2)).EQ.1) GOTO 156
               M=KON(L,K,1)
               IF (M.EQ.0) GOTO 153
               IF (M.EQ.-1) GOTO 156
               IF (KON(L,K,2).LT.0) GOTO 156
               GOTO 158
  156   CONTINUE
        K=KON(NBCON,K,1)
        IF (K.EQ.0) GOTO 153
        GOTO 157
  158   IEL=IEL+1     
        IPT3.NUM(1,IEL)=IDCP(KPRESS)
        IPT3.NUM(NBNN,IEL)=IDCP(M)
        IPT3.ICOLOR(IEL)=KON(L,K,3)
        IPT3.NUM(2,IEL)=ABS(KON(L,K,2))
        KON(L,K,1)=-1
        M1=M
  159   DO 160 L=1,NBCONR
               IF (KON(L,M1,1).EQ.0) GOTO 162
               IF (KON(L,M1,1).EQ.KPRESS) GOTO 161
  160   CONTINUE
        M1=KON(NBCON,M1,1)
        IF (M1.EQ.0) GOTO 162
        GOTO 159
  161   KON(L,M1,1)=-1
  162   KPRESS=M
        K=KPRESS
        GOTO 157
  163   CONTINUE
        LISOUS(1)=IPT3
        SEGDES IPT3
        NBSOUS=0
        NBREF=0
        NBELEM=0
        DO 241 J=1,ITE
               JJ=J
  243          DO 242 I=1,NBCONR
                      IF (KON(I,JJ,1).LT.J) GOTO 242
                      IF (ABS(KON(I,JJ,2)).NE.1) GOTO 242
                      NBELEM=NBELEM+1
  242          CONTINUE
               IF (KON(NBCON,JJ,1).EQ.0) GOTO 241
               JJ=KON(NBCON,JJ,1)
               GOTO 243
  241   CONTINUE
        IF (IIMPI.NE.0) WRITE(IOIMP,1111) NBELEM
        IF (IERR.NE.0) GOTO 64
        NBNN=2
        SEGINI IPT2
        IPT2.ITYPEL=NBNN
        IEL=0
        KAUX=1
  250   K=KAUX
        KAUXR=KAUX
  251   DO 252 KL=1,NBCONR
               IF (ABS(KON(KL,K,2)).NE.1) GOTO 252
               ITRA=KON(KL,K,1)
               IF (ITRA.EQ.-1) GOTO 252
               IF (ITRA.EQ.0) GOTO 253
               IF (KON(KL,K,2).LT.0) GOTO 252
               GOTO 254
  252   CONTINUE
        K=KON(NBCON,K,1)
        IF (K.NE.0) GOTO 251
  253   KAUX=KAUX+1
        IF (KAUX.EQ.ITE+1) GOTO 263
        GOTO 250
  254   KPRESS=KAUXR
        GOTO 255
  257   KL=1
  255   DO 256 L=KL,NBCONR
               IF (ABS(KON(L,K,2)).NE.1) GOTO 256
               M=KON(L,K,1)
               IF (M.EQ.0) GOTO 253
               IF (M.EQ.-1) GOTO 256
               IF (KON(L,K,2).LT.0) GOTO 256
               GOTO 258
  256   CONTINUE
        K=KON(NBCON,K,1)
        IF (K.EQ.0) GOTO 253
        GOTO 257
  258   IEL=IEL+1
        IPT2.NUM(1,IEL)=IDCP(KPRESS)
        IPT2.NUM(NBNN,IEL)=IDCP(M)
        IPT2.ICOLOR(IEL)=KON(L,K,3)
        KON(L,K,1)=-1
        M1=M
  259   DO 260 L=1,NBCONR
               IF (KON(L,M1,1).EQ.0) GOTO 262
               IF (KON(L,M1,1).EQ.KPRESS) GOTO 261
  260   CONTINUE
        M1=KON(NBCON,M1,1)
        IF (M1.EQ.0) GOTO 262
        GOTO 259
  261   KON(L,M1,1)=-1
  262   KPRESS=M
        K=KPRESS
        GOTO 257
  263   CONTINUE
        LISOUS(2)=IPT2      
        SEGDES IPT2
        SEGDES MELEME
        CALL ECROBJ('MAILLAGE',MELEME)
        SEGACT IPT8
        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
        ENDIF
  64    CONTINUE
        SEGSUP KON,IDCP
        RETURN
        END