The TELEMAC-MASCARET system  trunk
decoup.f
Go to the documentation of this file.
1 ! *****************
2  SUBROUTINE decoup
3 ! *****************
4 !
5  &(isurc,x,y,ikle,ncolor,ifabor, nelem2,npoin2,color)
6 !
7 !***********************************************************************
8 ! PROGICIEL: STBTEL V5.2 19/04/91 J-C GALLAND (LNH)
9 ! 19/02/93 J-M JANIN (LNH)
10 !***********************************************************************
11 !
12 ! FONCTION : DECOUPAGE DES TRIANGLES SURCONTRAINTS :
13 ! ILS SONT COUPES EN TROIS PAR AJOUT D'UN POINT A
14 ! LEUR BARYCENTRE
15 !
16 !
17 !-----------------------------------------------------------------------
18 ! ARGUMENTS
19 ! .________________.____.______________________________________________.
20 ! | NOM |MODE| ROLE |
21 ! |________________|____|______________________________________________|
22 ! | ISURC | -->| NUMERO DE L'ELEMENT SURCONTRAINT A TRAITER
23 ! | X,Y |<-->| COORDONNEES DU MAILLAGE .
24 ! | IKLE |<-->| LISTE DES POINTS DE CHAQUE ELEMENT
25 ! | NCOLOR |<-->| TABLEAU DES COULEURS DES POINTS
26 ! | IFABOR |<-->| TABLEAU DES VOISINS DES ELEMENTS
27 ! | NELEM2 |<-->| NOUVEAU NOMBRE D'ELEMENTS APRES DECOUP
28 ! | NPOIN2 |<-->| NOUVEAU NOMBRE DE POINTS APRES DECOUP
29 ! | COLOR |<-->| STOCKAGE COULEURS DES NOEUDS SUR FICHIER GEO
30 ! |________________|____|______________________________________________|
31 ! MODE : -->(DONNEE NON MODIFIEE), <--(RESULTAT), <-->(DONNEE MODIFIEE)
32 !-----------------------------------------------------------------------
33 ! APPELE PAR : SURCON
34 ! APPEL DE : -
35 !***********************************************************************
36 !
38  USE declarations_stbtel, ONLY: nelmax
39  IMPLICIT NONE
40 !
41  DOUBLE PRECISION, INTENT(INOUT) :: X(*) , Y(*)
42  INTEGER, INTENT(IN) :: ISURC
43  INTEGER, INTENT(INOUT) :: NELEM2 , NPOIN2
44  INTEGER, INTENT(INOUT) :: IKLE(nelmax,4) , NCOLOR(*)
45  INTEGER, INTENT(INOUT) :: IFABOR(nelmax,*)
46  LOGICAL, INTENT(INOUT) :: COLOR
47 !
48  INTEGER KELEM
49  INTEGER IFAC , ICOLOR , I , I1 , I2 , I3
50 !
51 !
52 !
53 !=======================================================================
54 ! CALCUL DES COORDONNEES DU NOUVEAU NOEUD 4 (DE NUMERO NPOIN2)
55 !=======================================================================
56 !
57  npoin2 = npoin2 + 1
58  i1 = ikle(isurc,1)
59  i2 = ikle(isurc,2)
60  i3 = ikle(isurc,3)
61 !
62  x(npoin2) = (x(i1) + x(i2) + x(i3))/3.d0
63  y(npoin2) = (y(i1) + y(i2) + y(i3))/3.d0
64 !
65 !=======================================================================
66 ! DEFINITION DE LA COULEUR DU NOEUD CREE (C'EST CELLE DU NOEUD NON POINT
67 ! DE BORD DE L'ELEMENT VOISIN)
68 !=======================================================================
69 !
70  IF (color) THEN
71  DO ifac=1,3
72  IF(ifabor(isurc,ifac).GT.0) icolor = ifabor(isurc,ifac)
73  ENDDO
74 !
75  DO i=1,3
76  IF(ikle(icolor,i).NE.i1.AND.ikle(icolor,i).NE.i2.AND.
77  & ikle(icolor,i).NE.i3)
78  & ncolor(npoin2) = ncolor(ikle(icolor,i))
79  ENDDO
80  ENDIF
81 !
82 !=======================================================================
83 ! CALCUL DES NOUVEAUX IKLE : L'ELEMENT (1,2,4) CONSERVE LE NUMERO ISURC
84 ! L'ELEMENT (2,3,4) PREND LE NUMERO NELEM2+1
85 ! L'ELEMENT (3,1,4) PREND LE NUMERO NELEM2+2
86 !=======================================================================
87 !
88  ikle(isurc,3) = npoin2
89 !
90  nelem2 = nelem2 + 1
91  ikle(nelem2,1) = i2
92  ikle(nelem2,2) = i3
93  ikle(nelem2,3) = npoin2
94 !
95  kelem = ifabor(isurc,2)
96  ifabor(nelem2,1) = kelem
97  ifabor(nelem2,2) = nelem2+1
98  ifabor(nelem2,3) = isurc
99  IF (kelem.GT.0) THEN
100  IF (ifabor(kelem,1).EQ.isurc) ifabor(kelem,1) = nelem2
101  IF (ifabor(kelem,2).EQ.isurc) ifabor(kelem,2) = nelem2
102  IF (ifabor(kelem,3).EQ.isurc) ifabor(kelem,3) = nelem2
103  ENDIF
104  ifabor(isurc,2) = nelem2
105 !
106  nelem2 = nelem2 + 1
107  ikle(nelem2,1) = i3
108  ikle(nelem2,2) = i1
109  ikle(nelem2,3) = npoin2
110 !
111  kelem = ifabor(isurc,3)
112  ifabor(nelem2,1) = ifabor(isurc,3)
113  ifabor(nelem2,2) = isurc
114  ifabor(nelem2,3) = nelem2-1
115  IF (kelem.GT.0) THEN
116  IF (ifabor(kelem,1).EQ.isurc) ifabor(kelem,1) = nelem2
117  IF (ifabor(kelem,2).EQ.isurc) ifabor(kelem,2) = nelem2
118  IF (ifabor(kelem,3).EQ.isurc) ifabor(kelem,3) = nelem2
119  ENDIF
120  ifabor(isurc,3) = nelem2
121 !
122 !=======================================================================
123 !
124  RETURN
125  END
subroutine decoup(ISURC, X, Y, IKLE, NCOLOR, IFABOR, NELEM2, NPOIN2, COLOR)
Definition: decoup.f:7