C VERSEN    SOURCE    CHAT      07/10/29    21:30:14     5940           
C   CE SOUS PROGRAMME TRES ATTENDU VERIFIE QUE DANS UN MAILLAGE
C   1 DEUX ELEMENTS AU PLUS ONT UNE ARETE COMMUNE
C   2 CETTE ARETE EST ORIENTE DE MANIERE OPPOSEE DANS CHACUN DES 2
C
C     CECI EXISTAIT DEJA DANS COCO (REALISATION THIERRY CHARRAS)
C   LA PRESENTE PROGRAMMATION EST HONTEUSEMENT INSPIREE DE CELLE
C   DE PRCONT
C
C   COPYRIGHT P VERPEAUX & CEA/IRDI/DEDR/DEMT/SMTS/LAMS
C
      SUBROUTINE VERSEN
      IMPLICIT INTEGER(I-N)
-INC CCOPTIO
-INC CCGEOME
-INC SMELEME
-INC SMCOORD
      SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
      SEGMENT KON(NBCON,NMAX,2)
      CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
      IF (IERR.NE.0) RETURN
      SEGINI ICPR
      DO 1 I=1,ICPR(/1)
   1  ICPR(I)=0
      ITE=0
      SEGACT MELEME
      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
      IDEP=NSPOS(K)
      IF (NBSOM(K).GT.0) THEN
        IFEP=IDEP+NBSOM(K)-1
      ELSE
C       Cas du polygone
        IFEP=IDEP+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
   3  CONTINUE
      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+10
      SEGINI KON
C   FABRICATION DU TABLEAU DES CONNECTIONS
C    1  POINT FINAL
C    2  POINT INTERMEDIAIRE EVENTUEL ET SENS
      ICHAIN=ITE
      DO 30 IO=1,MAX(1,LISOUS(/1))
      IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
      K=IPT1.ITYPEL
      KTYPEL=K
C  LE NOMBRE DE FACE EST 1 QUEL EST SON TYPE
      KK=LTEL(2,K)
*  POUR LE CAS DES LIGNE ON PREND LES FACES TRIANGLE  CORRESPONDANTES
      IF (K.EQ.KDEGRE(K)) THEN
        KA=2*K
        KK=LTEL(2,KA)
      ENDIF
        IF (KK.EQ.0) GOTO 21
      ITYP=LDEL(1,KK)
      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
      NBNN=KDEGRE(K)
      IPAS=NBNN-1
      IF (K.EQ.KDEGRE(K)) IFEP=IDEP
      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.AND.(KTYPEL.NE.KDEGRE(KTYPEL))) THEN
        JSUIV=IDEP
      ENDIF
      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
  24  DO 25 K=1,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  CONTINUE
      IF(IIMPI.EQ.123)WRITE(IOIMP,1122) KON(K,NI,2),NMIL
      IF (KON(K,NI,2).EQ.0) CALL ERREUR(319)
      IF (1.*KON(K,NI,2)*NMIL.GT.0.) CALL ERREUR(318)
*     IF (IERR.NE.0) GOTO 32
      KON(K,NI,2)=0
      GOTO 29
  26  KON(K,NI,1)=NJ
      KON(K,NI,2)=NMIL
      GOTO 29
  28  ICHAIN=ICHAIN+1
      IF (ICHAIN.GE.NMAX) THEN
         NMAX=NMAX+250
         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
      SEGDES MELEME
      IF (IIMPI.EQ.2)WRITE (IOIMP,1122) (((KON(I,J,K),K=1,2),I=1,NBCON),
     # J=1,NMAX)
 1122 FORMAT(1X,14I5)
*  TEST QUE LES ARETES RESTANTES TOURNENT DANS LE MEME SENS
      DO 100 I=1,ITE
      IF(IIMPI.EQ.123)WRITE(IOIMP,1122) KON(1,I,2),KON(2,I,2)
      IF (1.*KON(1,I,2)*KON(2,I,2).GT.0.) CALL ERREUR(318)
 100  CONTINUE
      CALL REFUS
      SEGSUP ICPR,KON
      END