Sources Esope | Cast3M

sfac3d
C SFAC3D    SOURCE    CHAT      05/01/13    03:15:00     5004
C     *****************************************************************
C     MODULE  : ST (STRUCTURE DES DONNEES)
C     FICHIER : ST3D_STRUCT.F
C     OBJET   : CONSULTATION, CONSTRUCTION ET MODIFICATION DE LA
C               STRUCTURE DE DONNE DU MAILLAGE 3D
C     FONCT.  :
C
C       SFAC3D :   RECHERCHE LA FACE COMMUNE A 2 ELEMENTS 3D
C
C       S3NBCO :   CALCUL DU NOMBRE DE COTE D'UN ELEMENT
C       S3NBCF :   CALCUL DU NOMBRE DE COTE DE LA FACE D'UN ELEMENT
C
C       S3FDIA :   FACE DIRECTE SUR UNE ARETE  (INDICE RELATIF)
C       S3A2FA :   ARETE COMMUNE A 2 FACES (INDICE RELATIF)
C       S3FASO :   K SOMMETS DE LA FACE (INDICE RELATIF)
C       S3SOFA :   K FACES AU SOMMET (INDICE RELATIF)
C       S3OPFA :   ENTITE OPPOSEE A FACE (INDICE RELATIF)
C
C       S3INVE :   INVERSE L'ORIENTATION D'UN ELEMENT 3D
C
C     AUTEUR  : O. STAB
C     DATE    : 03.95
C     TESTS   : A FAIRE
C
C     MODIFICATIONS :
C      AUTEUR : O.STAB
C      DATE   : 26.06.96
C      OBJET  : AJOUT SFAC3D (A TERMINER)
C
C     MODIFICATIONS :
C      AUTEUR, DATE, OBJET :
C
C
C     *****************************************************************
C
      INTEGER FUNCTION SFAC3D( IT1, IT2, N1, N2, I1, I2 )
C     *****************************************************************
C     OBJET : RECHERCHE LA FACE COMMUME A 2 ELEMENTS
C         RENVOI LES INDICES I1 ET I2 CORRESPONDANTS AUX FRONTIERES
C         COMMUNES DES ELEMENTS IT1 ET IT2.
C
C     EN ENTREE:
C      IT1,IT2:  LES ELEMENTS A TESTER
C      N1     :  (2..4) NOMBRE DE NOEUDS DE IT1
C      N2     :  (2..4) NOMBRE DE NOEUDS DE IT2
C
C     EN SORTIE:
C      I1,I2  :  INDICES DES FRONTIERES COMMUNES
C      SFAC3D :  0 SI AUCUNE ARETE COMMUNE
C            -1 SI I1 ET I2 SONT PARCOURUS DANS LE MEME
C               SENS POUR IT1 ET IT2
C             1 SI "  "     "   "         DANS LE SENS INVERSE
C
C     CONDITION D'APPLICATION : TETRA, HEXA...
C     REMARQUE : N'UTILISE PAS LA STRUCTURE DE DONNEES MAILLAGE
C                N'EXPLOITE AUCUNE HYPOTHESE SUR IT1 ET IT2
C     *****************************************************************
      IMPLICIT INTEGER(I-N)
      INTEGER IT1(N1), IT2(N2), N1,N2, I1, I2
C
      INTEGER IT12(16),ISOM(16)
      INTEGER NBNF1(6),NBNF2(6),ISOMT1(4,6),ISOMT2(4,6)
      INTEGER I,IFF,IFF1,IFF2,NBF1,NBF2,INO,IDE,ISENS,NBNC,INO2
      INTEGER  S3NBCO,S3FASO
      EXTERNAL S3NBCO,S3FASO
C
C      WRITE(6,*) 'ON ENTRE DANS SFAC3D it1,it2 = ',IT1,IT2
      IDE = 3
C      WRITE(*,*) 'ON COMPARE :'
C      WRITE(*,*) (IT1(I),I=1,N1), 'ET '
C      WRITE(*,*) (IT2(I),I=1,N2)
C
C     COMPARER LA SIGNATURE DES 4 NOEUDS POUR OPTIMISER
C     --------------------------------------------------
      DO 50 I=1,N1
       ISOM(I) = IT1(I)
   50 CONTINUE
      DO 51 I=1,N2
       ISOM(I+N1) = IT2(I)
   51 CONTINUE
      CALL KNUTA(N1+N2,ISOM)
      NBNC = 0
      DO 52 I=1,(N1+N2-1)
        IF(ISOM(I).EQ.ISOM(I+1))NBNC = NBNC+1
   52 CONTINUE
C      WRITE(*,*) 'NOMBRE DE NOEUDS EN COMMUN :',NBNC
C
      IF( NBNC.LT.3 )THEN
        SFAC3D = 0
        GOTO 9999
      ENDIF
C
      IF(((N1.EQ.8).OR.(N2.EQ.8)).AND.(NBNC.EQ.3))THEN
        SFAC3D = 0
        GOTO 9999
      ENDIF
C      WRITE(6,*) 'IT1,IT2 = ',IT1,IT2
C
C     --- IL Y A AU MOINS 3 NOEUDS EN COMMUN ---
C         IL FAUT TROUVER LES FACES ET LEURS INDICES
C
C     --- LES FACES DE IT1 ---
C
C      WRITE(*,*) 'PREMIER ELEMENT'
      ISENS = 1
      NBF1 = S3NBCO(N1)
      DO 61 IFF=1,NBF1
        NBNF1(IFF) = S3FASO(IFF,N1,ISENS,ISOMT1(1,IFF))
C        WRITE(*,*) 'FACE :',IFF,' DE ',NBNF1(IFF),' SOMMETS ='
C        WRITE(*,*) (ISOMT1(INO,IFF),INO=1,3)
C        WRITE(*,*) 'ELEMENT =',(IT1(INO),INO=1,4)
        DO 60 INO=1,NBNF1(IFF)
          ISOMT1(INO,IFF)= IT1(ISOMT1(INO,IFF))
C          WRITE(*,*) ISOMT1(INO,IFF)
   60   CONTINUE
C        CALL KNUTA(NBNF1(IFF),ISOMT1(1,IFF))
   61 CONTINUE
C
C     --- LES FACES DE IT2 ---
C
C      WRITE(*,*) 'SECOND ELEMENT'
      NBF2 = S3NBCO(N2)
      DO 63 IFF=1,NBF2
        NBNF2(IFF) = S3FASO(IFF,N2,ISENS,ISOMT2(1,IFF))
C        WRITE(*,*) 'FACE :',IFF,' DE ',NBNF2(IFF),' SOMMETS ='
C        WRITE(*,*) (ISOMT2(INO,IFF),INO=1,3)
        DO 62 INO=1,NBNF2(IFF)
          ISOMT2(INO,IFF)= IT2(ISOMT2(INO,IFF))
   62   CONTINUE
C        CALL KNUTA(NBNF2(IFF),ISOMT2(1,IFF))
   63 CONTINUE
C
C     --- COMPARAISON ---
C
C      WRITE(*,*) 'COMPARAISON'
C      WRITE(*,*) 'FACES = ',((ISOMT1(INO,IFF1),INO=1,3),'/',IFF1=1,4)
C      WRITE(*,*) 'FACES = ',((ISOMT2(INO,IFF1),INO=1,3),'/',IFF1=1,4)
      DO 80 IFF1=1,NBF1
        DO 75 IFF2=1,NBF2
          IF( NBNF1(IFF1).EQ.NBNF2(IFF2) )THEN
            INO = 1
            INO2 = 1
C           ---- ON CHERCHE LE DEBUT ---------------------
   74       IF( ISOMT1(INO,IFF1).NE.ISOMT2(INO2,IFF2))THEN
              INO2 = INO2 + 1
              IF( INO2.GT.NBNF2(IFF2) ) GOTO 75
              GOTO 74
            ENDIF
C           ---- ON RECHERCHE LE SENS --------------------
            IF( ISOMT1(INO+1,IFF1).NE.
     >          ISOMT2(MOD(INO2,NBNF2(IFF2))+1,IFF2))THEN
              ISENS = -1
            ELSE
              ISENS = 1
            ENDIF
C
C           ---- ON COMPARE 2 LISTES CIRCULAIRES ---------
C
   77       INO  = INO+1
            IF(ISENS.EQ.1)THEN
              INO2 = MOD(INO2,NBNF2(IFF2)) + 1
            ELSE
              INO2 = NBNF2(IFF2) - MOD(NBNF2(IFF2)+1-INO2,NBNF2(IFF2))
            ENDIF
            IF( ISOMT1(INO,IFF1).NE.ISOMT2(INO2,IFF2))GOTO 75
C           ----
            IF( INO.EQ. NBNF1(IFF1) )THEN
              I1 = IFF1
              I2 = IFF2
              SFAC3D = -ISENS
C              WRITE(*,*) 'FACE COMMUNE :',I1,I2
              GOTO 9999
            ENDIF
            GOTO 77
          ENDIF
   75   CONTINUE
   80 CONTINUE
C
      SFAC3D = 0
C
 9999 END