Sources Esope | Cast3M

deda
C DEDA      SOURCE    CB215821  23/01/25    21:15:10     11573          
      SUBROUTINE DEDA
C     ******************************************************************
C
C     LOG1 = DEDA PO1 MAIL1 (FLO1) ;
C
C     OBJET :
C     _______
C
C     L'OPERATEUR DEDA DETERMINE SI UN POINT PO1 EST SITUE A L'INTERIEUR
C     DU MAILLAGE D'UN CONTOUR (EN 2D) OU D'UNE ENVELOPPE (EN 3D)
C
C     DATE : 25.07.14
C     ______
C
C     AUTEURS : F. DI PAOLA
C     _________
C
C     ******************************************************************
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMELEME
-INC CCGEOME
-INC SMLENTI
C
C     Un logique, resultat du programme
      LOGICAL BOOL1
C
C     Une liste d'entiers ca sert toujours
      POINTEUR LV1.MLENTI
C
C     Une structure pour decrire les elements adjacents du maillage
C     contour/enveloppe
      SEGMENT,MADJACEN
         INTEGER LEAC(NBL1,IDIM,2)
      ENDSEGMENT
      POINTEUR ILEA1.MADJACEN
C
C
C        ===============================
C     --- 1.LECTURE DES DONNEES ET TESTS ---
C        ===============================
C
C     Acquisition du point
      CALL LIROBJ('POINT',NP1,1,IRETOU)
      IF (IERR.NE.0) THEN
C        ON A PAS TROUVE LE POINT
         CALL ERREUR(504)
         GOTO 999
      ENDIF
C
C     Acquisition du maillage
      CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
      IF (IERR.NE.0) THEN
C        ON A PAS TROUVE LE MAILLAGE
         CALL ERREUR(503)
         GOTO 999
      ENDIF
      SEGACT IPT1
      NBSZ=IPT1.LISOUS(/1)
      NTYP=IPT1.ITYPEL
C
C     Acquisition d'une tolerance pour la mesure de l'angle solide
C     (facultative, 1E-9 par defaut)
      CALL LIRREE(XTOL,0,IRETOU)
      IF (IRETOU.EQ.0) XTOL=1D-9
C
C        ====================================
C     --- 2.TESTS SUR LA VALIDITE DES DONNEES ---
C           ET AJUSTEMENTS EVENTUELS
C        ====================================
C
C     Valeur de la dimension
      IF ((IDIM.LT.2).OR.(IDIM.GT.3)) THEN
         INTERR(1)=IDIM
C        FONCTION INDISPONIBLE EN DIMENSION %I1
         SEGDES IPT1
         CALL ERREUR(709)
         GOTO 999
      ENDIF
C
C     Maillage elementaire
      IF (NBSZ.NE.0) THEN
C        OPERATION INTERDITE SUR UN OBJET COMPLEXE
         SEGDES IPT1
         CALL ERREUR(25)
         GOTO 999
      ENDIF
C
C     Type d'elements
      IF (((IDIM.EQ.2).AND.(NTYP.NE.2)).OR.
     &    ((IDIM.EQ.3).AND.(NTYP.NE.4))) THEN
C        TYPE D'ELEMENTS INCORRECT
         SEGDES IPT1
         CALL ERREUR(16)
         GOTO 999
      ENDIF
C
C     Orientation des elements du maillage (appel a VERSENS)
      CALL ECROBJ('MAILLAGE',IPT1)
      CALL VERSEN
      CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
      IF (IERR.NE.0) THEN
         GOTO 999
      ENDIF
      SEGACT IPT1
C
C     Le maillage doit etre ferme, on le verifie en construisant la
C     table des elements adjacents
C     Le tableau ILEA1.LEAC comporte 3 dimensions : ILEA1.LEAC(I,J,K)
C     dimension 1 : I est le numero de l'element du contour/enveloppe
C     dimension 2 : J est le numero du noeud de l'element I
C     dimension 3 : K=1 --> renvoie le numero de l'element adjacent a
C                           l'element I par rapport au noeud J
C                   K=2 --> renvoie le numero du noeud de l'element
C                           adjacent situe en vis a vis du noeud J
C     On a donc les symetries suivantes :
C     si     ILEA1.LEAC(I,J,1)   = I' et  ILEA1.LEAC(I,J,2)   = J'
C     alors  ILEA1.LEAC(I',J',1) = I  et  ILEA1.LEAC(I',J',2) = J
C
C     Initialisation de la table des elements adjacents
      NBL1=IPT1.NUM(/2)
      SEGINI ILEA1
      JG=IPT1.NUM(/1)
      SEGINI LV1
C     Nombre de noeuds en commun a trouver pour adjacence
      NNREF=IPT1.NUM(/1)-1
C     Somme des numeros des noeuds
      IF (IDIM.EQ.2) THEN
         NSREF=1+2
      ELSE
         NSREF=1+2+3
      ENDIF
C     Boucle sur les elements de IPT1
      DO I=1,IPT1.NUM(/2)
C        Numeros des noeuds de l'element I
         DO J=1,IPT1.NUM(/1)
            LV1.LECT(J)=IPT1.NUM(J,I)
         ENDDO
C        On va detrminer tous les voisins de l'element I
C        Deuxieme boucle sur les elements de numero superieurs a I
         DO II=I+1,IPT1.NUM(/2)
            NNC=0
            NSOMA=0
            NSOMB=0
C           Test si l'element II a des noeuds communs a l'element I
            DO J=1,IPT1.NUM(/1)
               NTEST=IPT1.NUM(J,II)
               DO K=1,IPT1.NUM(/1)
                  IF (NTEST.EQ.LV1.LECT(K)) THEN
                     NNC=NNC+1
                     NSOMA=NSOMA+K
                     NSOMB=NSOMB+J
                  ENDIF
               ENDDO
            ENDDO
C           Si l'element II est bien adjacent a l'element I
            IF (NNC.EQ.NNREF) THEN
               NI=NSREF-NSOMA
               NII=NSREF-NSOMB
               ILEA1.LEAC(I,NI,1)=II
               ILEA1.LEAC(I,NI,2)=NII
               ILEA1.LEAC(II,NII,1)=I
               ILEA1.LEAC(II,NII,2)=NI
            ENDIF
         ENDDO
C        Test si on a bien trouve un voisin pour chaque cote de I
         DO J=1,IPT1.NUM(/1)
            IF (ILEA1.LEAC(I,J,1).EQ.0) THEN
C              Le contour n'est pas reconnu ferme
               SEGDES IPT1
               SEGSUP ILEA1
               CALL ERREUR(28)
               GOTO 999
            ENDIF
         ENDDO
      ENDDO
C
C
C        ==========================
C     --- 3.REALISATION DE LA TACHE ---
C        ==========================
C
      SEGACT,MCOORD
      CALL DEDANS(NP1,IPT1,XTOL,BOOL1)
      SEGDES,MCOORD
 
      IF (IERR.EQ.0) CALL ECRLOG(BOOL1)
      GOTO 999
C
  999 END