Sources Esope | Cast3M

vmdisc
C VMDISC    SOURCE    BP208322  16/11/18    21:21:55     9177           
        SUBROUTINE VMDISC(melle)
        IMPLICIT INTEGER(I-N)
        IMPLICIT REAL*8(A-H,O-Z)
C
C=======================================================================
C       Le but de cette subroutine est de savoir s'il n'y a pas
C  d'éléments connectés à des éléments d'une autre forme.
C  Ex: un CUB8 connecté à deux PRI6.
C       On utilise l'enveloppe car  elle détecte ce genre de connexions.
C       On lit les sous objets et on compare leurs éléments.
C       Si un élément a tous ses points qui appartiennent aussi à un
C  autre élément on est dans le cas de figure à détecter.
C
C=======================================================================
C
C     NB: On considère qu'il n'y a plus de points doubles inopportuns.
C
C=======================================================================
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
C=======================================================================
C
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMELEME
-INC SMCOORD
C
C
C=======================================================================
C       STOCK EST UN SEGMENT QUI CONTIENT UN VECTEUR STOCKANT LES
C  NUMEROS DES POINTS D'UN ELEMENT
C=======================================================================
        SEGMENT STOCK
           INTEGER ivnum(jTAIL)
        ENDSEGMENT
        POINTEUR VINT.STOCK
C
C=======================================================================
C       UTILISATION D'ENVELOPPE (ON OBTIENT DES SURFACES)
C=======================================================================
 
C       Uniquement en 3D
        IF(IDIM.NE.3) RETURN
 
C       On récupère l'enveloppe (plante si doublons)
        CALL ECROBJ('MAILLAGE',MELLE)
        CALL ENVELO
        CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
        IF (IERR.NE.0) RETURN
 
        SEGACT MELEME
        IPT1=MELEME
C
C       Si l'on obtient un objet géométrique simple : pas de problème
        IF (LISOUS(/1).EQ.0) GOTO 14
 
 
C=======================================================================
C       BOUCLE SUR LES SOUS OBJETS
C=======================================================================
 
        DO 1 I=1,LISOUS(/1)-1
          IPT1=LISOUS(I)
          SEGACT IPT1
 
*         Vérifications d'usage
          K=IPT1.ITYPEL
C         on ne traite que les éléments surfaciques
          IF (K.NE.KSURF(K)) GOTO 1
 
          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
 
*         Il faut au moins deux points par face
          IF (IDEP.GT.IFEP) THEN
            write(IOIMP,*) 'Une face doit avoir au moins 3 points'
            CALL ERREUR (16)
            RETURN
          ENDIF
 
          jtail=IFEP-IDEP+1
          SEGINI STOCK
 
C=======================================================================
C         BOUCLE SUR LES ELEMENTS DU SOUS OBJET N° I
C=======================================================================
          vint=0
          DO 2 NEL=1,IPT1.NUM(/2)
            II=0
C           Enregistrement des n° des sommets de l'élément
            DO 3 NSP=IDEP,IFEP
              NSO=IBSOM(NSP)
              II=II+1
              ivnum(II)=IPT1.NUM(NSO,NEL)
  3         CONTINUE
            MARQUE=0
 
C=======================================================================
C           2e BOUCLE SUR LES SOUS OBJETS (IS>I)
C=======================================================================
 
            DO 4 IS=I+1,LISOUS(/1)
 
              IPT2=LISOUS(IS)
              SEGACT IPT2
              KS=IPT2.ITYPEL
              IDEPS=NSPOS(KS)
              IF (NBSOM(KS).GT.0) THEN
                IFEPS=IDEPS+NBSOM(KS)-1
              ELSE
C               Cas du polygone
                IFEPS=IDEPS+IPT1.NUM(/1)-1
              ENDIF
              IF (IDEPS.GT.IFEPS) THEN
                write(IOIMP,*) 'Une face doit avoir au moins 3 points'
                CALL ERREUR (16)
                RETURN
              ENDIF
 
C=======================================================================
C             BOUCLE SUR LES ELEMENTS DU SOUS OBJET N° IS
C=======================================================================
 
              DO 5 NELS=1,IPT2.NUM(/2)
C               Relecture de ivnum s'il avait été modifié
                IF (MARQUE.EQ.1) THEN
                  jtail=mtailm
                  SEGADJ STOCK
                  DO 6 L=1,jtail
                    ivnum(L)=VINT.ivnum(L)
  6               CONTINUE
                  MARQUE=0
                ENDIF
 
C=======================================================================
C               On parcourt les sommets de nels, on parcourt
C               les coordonnées de vecnum en testant s'ils
C               ont les memes n°.
C=======================================================================
 
                NSPS=IDEPS-1
  7             CONTINUE
 
                NSPS=NSPS+1
                NSOS=IBSOM(NSPS)
                IF (NSPS.GT.IFEPS) GOTO 10
                jcp=0
  8             CONTINUE
 
                jcp=jcp+1
                IF (jcp.GT.jtail) GOTO 5
                IF (IPT2.NUM(NSOS,NELS).EQ.ivnum(jcp)) THEN
C                 On enregistre ivnum avant de le modifier
                  IF (MARQUE.EQ.0) THEN
                    mtailm=jtail
                    SEGINI VINT
                    DO 9 L=1,mtailm
                      VINT.ivnum(L)=ivnum(L)
  9                 CONTINUE
                    MARQUE=1
                  ENDIF
C                 On supprime la coordonée n° jcp de ivnum
                  INT=ivnum(jtail)
                  ivnum(jtail)=ivnum(jcp)
                  ivnum(jcp)=INT
                  jtail=jtail-1
                  IF (jtail.EQ.0) GOTO 11
                    SEGADJ STOCK
                    GOTO 7
                  ELSE
                    GOTO 8
                  ENDIF
 
  10              CONTINUE
                  INTERR(1)=NELS
                  MOTERR(1:4)=NOMS(KS)
                  INTERR(2)=NEL
                  MOTERR(5:8)=NOMS(K)
                  CALL ERREUR(-334)
                  GOTO 12
 
  11              CONTINUE
                  INTERR(1)=NEL
                  MOTERR(1:4)=NOMS(K)
                  INTERR(2)=NELS
                  MOTERR(5:8)=NOMS(KS)
                  CALL ERREUR(-334)
 
  12              CONTINUE
  5             CONTINUE
  4           CONTINUE
              IF (MARQUE.EQ.1) THEN
                jtail=mtailm
                SEGADJ STOCK
                DO 13 L=1,jtail
                  ivnum(L)=VINT.ivnum(L)
  13            CONTINUE
                MARQUE=0
              ENDIF
 
  2       CONTINUE
          SEGDES STOCK
          IF(VINT.NE.0)SEGSUP VINT
  1     CONTINUE
 
 14     CONTINUE
        SEGDES MELEME
 
        RETURN
        END