Sources Esope | Cast3M

smacre
C SMACRE    SOURCE    CHAT      06/03/29    21:34:11     5360
      SUBROUTINE SMACRE(IDE,ITRI,NBE,NBPMAX,
     >                  ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,
     >                  ITVL,NBTRAV,iarr)
C     *****************************************************************
C     OBJET : CREER LA STRUCTURE DE DONNEE MAILLAGE
C             ITRI -> ITRNOE, ITRTRI, NOETRI
C     EN ENTREE:
C      IDE    :  (1..3) DIMENSION DES ELEMENTS
C      NBE    :  NOMBRE D'ELEMENTS DU MAILLAGE
C      NBPMAX : NOMBRE MAXIMUM DE POINTS
C               IL PEUT ETRE SUPERIEUR AUX NOEUDS CONNECTES DANS ITRI
C               0 SI ON NE LE CONNAIT PAS
C      ITRI   : ITRI(I,J) EST LE NOEUD J DE L'ELEMENT I
C      NBNMAX :  (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS
C      NBCMAX :  (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS
C      NOEMAX : TAILLE DU TABLEAU NOETRI
C                SI NOEMEMAX = 0 NOETRI NE SERA PAS REMPLI
C       ITVL   : TABLEAU DE TRAVAIL
C       NBTRAV : TAILLE DU TABLEAU DE TRAVAIL
C                AU MIN = 0 => O(N2)
C                AU MAX = (NBR MAX D'ELEMENTS EN 1 NOEUD + 1) *
C                         (NUMERO MAXI DU NOEUD DANS ITRI)
C                         => O(N)
C     EN SORTIE:
C       ITRNOE : ITRNOE(I,J) EST LE NOEUD J DU TRIANGLE I
C                LES ELEMENTS NE SONT PAS ORIENTES
C                PEUT ETRE LE MEME TABLEAU QUE ITRI
C       ITRTRI : ITRTRI(I,J) EST LE TRIANGLE INCIDENT AU TRIANGLE I SUR
C                L'ARETE J
C       NOETRI : NOETRI(I) EST UN DES TRIANGLES CONTENANT LE NOEUD I
C       iarr   : CODE D'ERREUR 0 => OK
C                -NB => TABLEAU NOETRI TROP PETIT TAILLE SOUHAITE = NB
C     CONDITION D'APPLICATION : ARETE, TRIANGLE, QUADRANGLE, TETRA
C     *****************************************************************
      IMPLICIT INTEGER(I-N)
      INTEGER   IDE,ITRI(*),NBE,NBPMAX
      INTEGER   ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX
      INTEGER   NOETRI(*), NOEMAX, ITVL(*), NBTRAV, iarr
C
      EXTERNAL  SFAIDE,STRKFS
      INTEGER   SFAIDE,STRKFS
      INTEGER   I,J,K, IT1,IT2, IT, NBNOE, N1,N2, NBTMAX, ITNV, NIJ
C     --- POUR LES TESTS ---
C      REAL    X(2),Z(3)
      INTEGER   NBATST, NBLIN,IFAC(3),NBFN,KK,IFVUE
C     EXTERNAL  ETIME
C     REAL    ETIME
C
      iarr = 0
      IF( NBE.EQ. 0 )GOTO 9999
      IF( NBE.LT. 0 )THEN
        iarr = -1
        GOTO 9999
      ENDIF
      NBATST = 0
      NBLIN = 0
C
C         ================
C     ---- INITIALISATION  ----
C         ================
C
      DO 10 I=1,(NBE*NBCMAX)
          ITRTRI(I) = -1
   10 CONTINUE
      NBNOE = 0
      DO 20 I=1,(NBE*NBNMAX)
        IF( ITRI(I).GT.NBNOE )NBNOE = ITRI(I)
   20 CONTINUE
C
C     L'INDICE D'UN NOEUD DEPASSE LA TAILLE DU TABLEAU
C
C     --- BUG10 25.10.96 -------------------------------
      IF((NOEMAX.GT.0).AND.
     >   ((NBNOE.GT.NOEMAX).OR.(NBPMAX.GT.NOEMAX)))THEN
        iarr = -2
        GO TO 9999
      ENDIF
C     --- INITIALISATION DU TABLEAU DE TRAVAIL ---
      NBTMAX = NBTRAV / NBNOE
      IF( NBTMAX .LT. 2 )GO TO 90
      DO 30 I=1,(NBNOE * NBTMAX)
        ITVL(I) = 0
   30 CONTINUE
C
C         =============================
C     ---- CALCUL DES VOISINS : ITRTRI ----
C         =============================
C
C      Z(1) =ETIME(X)
      DO 50 I=1,NBE
C     ----------------------------------------------------------
C     REMPLISSAGE LINEAIRE MAIS PROBABILISTE (2/5) DES VOISINS
C     PRINCIPE : SI UN AUTRE ELEMENT PARTAGE UN NOEUD AVEC
C     UN AUTRE ELEMENT, ALORS PEUT ETRE PARTAGE T'IL UNE ARETE ?
C     ----------------------------------------------------------
C
       N1 = NBNMAX
       IF( (NBNMAX.EQ.4).AND.(IDE.EQ.2).AND.
     >     (ITRI((I-1)*NBNMAX+4).EQ.0))N1= 3
       DO 40 J=1,N1
         IT = ITRI((I-1)*NBNMAX+J)
         IF(IT.LE.0)GOTO 40
         K = ITVL((IT-1)*NBTMAX+1)
         IF(K.LT.(NBTMAX-1))THEN
           ITVL((IT-1)*NBTMAX+1)  = K+1
           ITVL((IT-1)*NBTMAX+K+2)= I
         ENDIF
   40  CONTINUE
   50 CONTINUE
C
C
      NBLIN = 0
      DO 80 I=1,NBE
        N1 = NBNMAX
C       --- BUG6 05.09.96 : ITRTRI(4) = 0 -----
        IF( (IDE.EQ.2).AND.(NBNMAX.EQ.4).AND.
     >      (ITRI((I-1)*NBNMAX+4).EQ.0))THEN
          N1= 3
          ITRTRI((I-1)*NBCMAX + 4) = 0
        ENDIF
*        WRITE(*,*)' ELEMENT ',I
        DO 70 J=1,N1
C
C       POUR TOUTES LES FACES INCIDENTES AU NOEUD J
C
          NBFN = STRKFS(IDE,J,N1,IFAC)
*          WRITE(*,*)' NOEUD = ',J
          DO 55 K=1,NBFN
*          WRITE(*,*)' IFAC(',K,') = ',IFAC(K)
*          WRITE(*,*)' VOISIN = ',ITRTRI((I-1)*NBCMAX + IFAC(K))
            IF( ITRTRI((I-1)*NBCMAX + IFAC(K)).EQ.-1)GOTO 56
   55     CONTINUE
          GOTO 70
C         --- REMPLACE :
C          IF( ITRTRI((I-1)*NBCMAX + J).EQ.0)THEN
C
   56      IT = ITRI((I-1)*NBNMAX+J)
*           WRITE(*,*) 'ON TESTE LE NOEUD ',J,' DE L ELEMENT ',I
           IF(IT.LE.0)GOTO 70
C         ---- DANS LE TABLEAU DES ELEMENTS INCIDENTS ---
*          WRITE(*,*)'LISTE ='
          DO 65 K=1,ITVL((IT-1)*NBTMAX+1)
           ITNV = ITVL((IT-1)*NBTMAX+K+1)
*           WRITE(*,*)'ELEMENT SUR ',J,' ITNV = ',ITNV
           IF(ITNV.NE.I)THEN
            N2 =NBNMAX
            IF( (NBNMAX.EQ.4).AND.(IDE.EQ.2).AND.
     >          (ITRI((ITNV-1)*NBNMAX+4).EQ.0))N2= 3
            IF(SFAIDE(ITRI((I-1)*NBNMAX+1),
     >                  ITRI((ITNV-1)*NBNMAX+1),
     >                  N1,N2,IDE,IT1,IT2 ).NE.0)THEN
*            WRITE(*,*) ITNV,' ET ',I,' SONT ADJACENTS SUR ',IT1,IT2
                 ITRTRI((I-1)*NBCMAX + IT1) = ITNV
                 ITRTRI((ITNV-1)*NBCMAX + IT2) = I
                 NBLIN = NBLIN + 1
            ENDIF
           ENDIF
   65     CONTINUE
C          ENDIF
   70   CONTINUE
   80  CONTINUE
C      Z(2) = ETIME( X )
C
C     ----------------------------------------------------------
C     REMPLISSAGE EN O(N2) DES VOISINS
C     ----------------------------------------------------------
C
   90 NBATST = 0
C     ------------------------------- POUR TOUTES LES MAILLES: I
      DO 100 I=1,NBE-1
        N1 = NBNMAX
        IF( (NBNMAX.EQ.4).AND.(IDE.EQ.2).AND.
     >      (ITRI((I-1)*NBNMAX+4).EQ.0))N1= 3
C
C       ------(A) PRE-TRAITEMENT DES FACES INCIDENTES AUX NOEUDS
C       ----------------- POUR TOUS LES NOEUDS DE LA MAILLE I: J
        DO 110 J=1,N1
          IT = ITRI((I-1)*NBNMAX+J)
          IF(IT.LE.0)GOTO 110
C              ----------------------------------------
C         ---- AUCUNE MAILLE INCIDENTE A J N'A DE FACE
C              COMMUNE AVEC I : ON LES A TOUTES TESTEES :
C              ON EST SUR LA FRONTIERE                 ----
C              ----------------------------------------
          IF((NBTMAX.GT.2).AND.
     >       (ITVL((IT-1)*NBTMAX+1).LT.(NBTMAX-1)))THEN
            NBFN = STRKFS(IDE,J,N1,IFAC)
            DO 91 KK=1,NBFN
              IF( ITRTRI((I-1)*NBCMAX + IFAC(KK)).EQ.-1)
     >            ITRTRI((I-1)*NBCMAX + IFAC(KK)) = 0
   91       CONTINUE
          ENDIF
C       ----------------------------------- FIN DE BOUCLE SUR J
  110   CONTINUE
C
C       -----(B) TRAITEMENT SYSTEMATIQUE DES FACES NON VISITEES
C       -------------------------------------------------------
C       RECHERCHE D'UNE FACE DE LA MAILLE I NON ENCORE VISITEE
C       -------------------------------------------------------
        IFVUE = 0
        DO 95 KK=1,NBCMAX
          IF( ITRTRI((I-1)*NBCMAX + KK).EQ.-1)IFVUE=IFVUE+1
   95   CONTINUE
C
C       -------------------------------------------------------
C       IL EXISTE UNE FACE DE LA MAILLE I NON ENCORE VISITEE
C       ON PARCOURS TOUTES LES MAILLES DE KK=I+1 A NBE
C       -------------------------------------------------------
        IF(IFVUE.GT.0)THEN
          NBATST = NBATST+1
C       ------------------ POUR TOUS LE ELEMENTS DE I A NBE: K
          DO 120 K=I+1,NBE
           N2 = NBNMAX
           IF( (NBNMAX.EQ.4).AND.(IDE.EQ.2).AND.
     >         (ITRI((K-1)*NBNMAX+4).EQ.0))N2= 3
           IF(SFAIDE(ITRI((I-1)*NBNMAX+1),
     >               ITRI((K-1)*NBNMAX+1),
     >               N1,N2,IDE,IT1,IT2).NE.0)
     >     THEN
            ITRTRI((I-1)*NBCMAX + IT1) = K
            ITRTRI((K-1)*NBCMAX + IT2) = I
           ENDIF
  120     CONTINUE
C       -------------------------- FIN DE BOUCLE DE I A NBE: K
C
C       ------------- LES FACES JAMAIS VISITEES SONT FRONTIERE
          DO 196 KK=1,NBCMAX
            IF( ITRTRI((I-1)*NBCMAX + KK).EQ.-1)
     >          ITRTRI((I-1)*NBCMAX + KK) = 0
  196     CONTINUE
        ENDIF
  100 CONTINUE
C     ----------------- PARCOURS DES FACES DU DERNIER ELEMENT
      DO 197 KK=1,NBCMAX
              IF( ITRTRI((NBE-1)*NBCMAX + KK).EQ.-1)
     >         ITRTRI((NBE-1)*NBCMAX + KK) = 0
  197 CONTINUE
C
C      Z(3)=ETIME(X)
C     --------------------------------------------
C      PRINT *,'NB DE TRIANGLES STOQUES = ',NBTMAX
C      PRINT *,'NB EN QUADRATIQUE       = ',NBATST
C      PRINT *,'NB LINEAIRE             = ',NBLIN
C      PRINT *,'NB TOTAL                = ',(NBE*NBCMAX)
C      PRINT *,'TEMPS LINEAIRE          = ',(Z(2)-Z(1))
C      PRINT *,'TEMPS QUADRATI          = ',(Z(3)-Z(2))
C
C     INITIALISATION DE ITRNOE
C     -------------------------
      DO 130 I=1,(NBE*NBNMAX)
          ITRNOE(I) = ITRI(I)
  130 CONTINUE
C
C     INITIALISATION DE  NOETRI
C     -------------------------
      IF(NOEMAX.GT.0)THEN
      DO 135 I=1,MAX(NBNOE,NBPMAX)
        NOETRI(I) = 0
  135 CONTINUE
      DO 140 I=1,NBE
C       --- BUG17 AJOUT DE LA LIGNE QUI SUIT O.STAB 07/02/96
        N1 = NBNMAX
        IF( (NBNMAX.EQ.4).AND.(IDE.EQ.2).AND.
     >      (ITRI((I-1)*NBNMAX+4).EQ.0))N1= 3
       DO 150 J=1, N1
          NIJ  = ITRI((I-1)*NBNMAX+J)
          IF(NIJ.GT.0)NOETRI(NIJ) = I
  150  CONTINUE
  140 CONTINUE
      ENDIF
C     ---- POUR LE DEBUG ----------------------------------
*        CALL PRITAB('ITRINOE ',ITRNOE,NBE,NBNMAX,1)
*        CALL PRITAB('ITRITRI ',ITRTRI,NBE,NBCMAX,1)
*        CALL PRITAB('NOETRI  ',NOETRI,NBNOE,1,1)
C
 9999 END