Sources Esope | Cast3M

versen
C VERSEN    SOURCE    PV        20/03/30    21:25:46     10567          
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
C     SG 2016/06/22 : on saute les elements de dimension 3 pour lesquels
C     la verification de sens des aretes ne semble pas avoir de sens
C     Peut-etre faudrait-il comparer l'orientation des faces plutot que des
C     aretes mais on ne le fait pas encore.  
C
C
      SUBROUTINE VERSEN
      IMPLICIT INTEGER(I-N)
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMELEME
-INC SMCOORD
      SEGMENT ICPR(nbpts)
      SEGMENT KON(NBCON,NMAX,2)
*
*dbg      write(ioimp,*) 'coucou versen'
      CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
      IF (IERR.NE.0) RETURN
      SEGINI ICPR
      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
*
         idiml=ldlr(k)
         if (idiml.eq.3) goto 3
*
         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 3
         DO 4 JJ=IDEP,IFEP
            J=IBSOM(JJ)
            DO 41 K=1,IPT1.NUM(/2)
               IPOIT=IPT1.NUM(J,K)
               IF (ICPR(IPOIT).EQ.0) THEN
                  ITE=ITE+1
                  ICPR(IPOIT)=ITE
               ENDIF
 41         CONTINUE
 4       CONTINUE
 3    CONTINUE
 
      IF (ite.eq.0) then
C         DO I=1,MAX(1,LISOUS(/1))
C            IF (LISOUS(/1).NE.0) THEN
C               IPT1=LISOUS(I)
C               SEGDES IPT1
C            ENDIF
C         ENDDO
C         SEGDES MELEME
         goto 101
      ENDIF
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
*     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
        NBNN=KDEGRE(K)
        IPAS=NBNN-1
        IF (K.EQ.KDEGRE(K)) IFEP=IDEP
        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.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
              IPO=0
 23           CONTINUE
              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 23
 27           CONTINUE
              IF(IIMPI.EQ.123)WRITE(IOIMP,1122) KON(K,NI,2),NMIL
* 319 : Verification d'orientation impossible car une arete
*       appartient a plus de deux elements
              IF (KON(K,NI,2).EQ.0) CALL ERREUR(319)
* 318 : Deux elements adjacents ont des orientations opposees
              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 221
              NMIL=-NMIL
              NI=N2
              NJ=N1
              IPO=1
              GOTO 23
 221       CONTINUE
 22     CONTINUE
 21     CONTINUE
C        IF (LISOUS(/1).NE.0) SEGDES IPT1
 30   CONTINUE
      GOTO 31
* Tache impossible. Probablement donnees erronees
  32  CALL ERREUR(26)
      SEGSUP KON,ICPR
C      SEGDES MELEME
      RETURN
  31  CONTINUE
C      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
      SEGSUP KON
 101  CONTINUE
      CALL REFUS
      SEGSUP ICPR
      END