The TELEMAC-MASCARET system  trunk
remail.f
Go to the documentation of this file.
1 ! *****************
2  SUBROUTINE remail
3 ! *****************
4 !
5  &(ikle,ncolor,new,x,y,epsi,ndp,npoin,nelem,nelmax)
6 !
7 !***********************************************************************
8 ! PROGICIEL : STBTEL V5.2 17/08/89 J.M. JANIN (LNH)
9 !
10 !***********************************************************************
11 !
12 ! FONCTION : ELIMINATION DES POINTS COINCIDENTS ET DES TROUS DU
13 ! MAILLAGE , RECONSTRUCTION DES TABLEAUX IKLE ET NCOLOR
14 !
15 !-----------------------------------------------------------------------
16 ! ARGUMENTS
17 ! .________________.____.______________________________________________.
18 ! | NOM |MODE| ROLE |
19 ! |________________|____|______________________________________________|
20 ! | IKLE |<-->| NUMEROS GLOBAUX DES POINTS DE CHAQUE ELEMENT |
21 ! | NCOLOR |<-->| TABLEAU DES COULEURS DES POINTS |
22 ! | PTELI |<-->| TABLEAU DE TRAVAIL ENTIER. |
23 ! | NEW |<-->| TABLEAU DE TRAVAIL ENTIER. |
24 ! | X,Y |<-->| COORDONNEES DES POINTS |
25 ! | EPSI | -->| DISTANCE MINIMALE ENTRE 2 NOEUDS DU MAILLAGE |
26 ! |________________|____|______________________________________________
27 ! | COMMON: | |
28 ! | GEO: | |
29 ! | NDP | -->| NOMBRE DE NOEUDS PAR ELEMENTS
30 ! | NPOIN | -->| NOMBRE TOTAL DE NOEUDS DU MAILLAGE
31 ! | NELEM | -->| NOMBRE TOTAL D'ELEMENTS DU MAILLAGE
32 ! | NELMAX | -->| DIMENSION EFFECTIVE DES TABLEAUX CONCERNANT
33 ! | | | LES ELEMENTS (NELMAX = NELEM + 0.2*NELEM)
34 ! |________________|____|______________________________________________|
35 ! MODE: -->(DONNEE NON MODIFIEE),<--(RESULTAT),<-->(DONNEE MODIFIEE)
36 !-----------------------------------------------------------------------
37 ! APPELE PAR : LECSTB
38 ! APPEL DE : -
39 !***********************************************************************
40 !
41  USE declarations_special
42  IMPLICIT NONE
43 !
44  INTEGER, INTENT(IN) :: NDP , NELMAX
45  INTEGER, INTENT(INOUT) :: NPOIN, NELEM
46  INTEGER, INTENT(INOUT) :: IKLE(nelmax,4) , NEW(*) , NCOLOR(*)
47  DOUBLE PRECISION, INTENT(INOUT) :: X(*) , Y(*), EPSI
48 
49  INTEGER I, J , NPTELI , NELELI
50  INTEGER I1, I2, I3, I4, J1, J2, J3, J4
51 !
52 !
53  LOGICAL PTPRO , PTELI , ELELI
54 !
55 !
56 !=======================================================================
57 ! RECHERCHE DES POINTS N'APPARTENANT A AUCUN ELEMENT
58 !=======================================================================
59 !
60  DO i=1,npoin
61  new(i) = 0
62  ENDDO
63 !
64  DO i=1,nelem
65  new(ikle(i,1)) = ikle(i,1)
66  new(ikle(i,2)) = ikle(i,2)
67  new(ikle(i,3)) = ikle(i,3)
68  IF(ndp.EQ.4) new(ikle(i,4)) = ikle(i,4)
69  ENDDO
70 !
71 !=======================================================================
72 ! RECHERCHE DES POINTS TROP PROCHES
73 !=======================================================================
74 !
75  epsi = epsi * epsi
76  ptpro = .false.
77  pteli = .false.
78  npteli = 0
79 !
80  DO i=1,npoin-1
81  IF(new(i).EQ.i) THEN
82  DO j=i+1,npoin
83  IF((x(i)-x(j))**2+(y(i)-y(j))**2.LT.epsi
84  & .AND.new(j).EQ.j) THEN
85  ptpro = .true.
86  new(j) = i
87  ENDIF
88  ENDDO
89  ELSE
90  pteli = .true.
91  ENDIF
92  ENDDO
93 !
94 !=======================================================================
95 ! SEUL LE DERNIER POINT EST A ELIMINER
96 !=======================================================================
97 !
98  IF(.NOT.pteli.AND.new(npoin).NE.npoin) npteli = 1
99 !
100 !=======================================================================
101 ! MODIFICATION DES IKLE SI DETECTION DE POINTS TROP PROCHES
102 !=======================================================================
103 !
104  IF(ptpro) THEN
105  DO i=1,nelem
106  ikle(i,1) = new(ikle(i,1))
107  ikle(i,2) = new(ikle(i,2))
108  ikle(i,3) = new(ikle(i,3))
109  IF(ndp.EQ.4) ikle(i,4) = new(ikle(i,4))
110  ENDDO
111  ENDIF
112 !
113 !=======================================================================
114 ! REMPLISSAGE DES TROUS LAISSES PAR L'ELIMINATION DE POINTS
115 !=======================================================================
116 !
117  IF(pteli) THEN
118  DO i=1,npoin
119  IF(new(i).EQ.i) THEN
120  new(i) = i - npteli
121  x(i-npteli) = x(i)
122  y(i-npteli) = y(i)
123  ncolor(i-npteli) = ncolor(i)
124  ELSE
125  npteli = npteli + 1
126  ENDIF
127  ENDDO
128 !
129 !=======================================================================
130 ! MODIFICATION DES IKLE DUE AU REMPLISSAGE DES TROUS
131 !=======================================================================
132 !
133  DO i=1,nelem
134  ikle(i,1) = new(ikle(i,1))
135  ikle(i,2) = new(ikle(i,2))
136  ikle(i,3) = new(ikle(i,3))
137  IF(ndp.EQ.4) ikle(i,4) = new(ikle(i,4))
138  ENDDO
139  ENDIF
140 !
141  npoin = npoin - npteli
142 !
143 !=======================================================================
144 ! RECHERCHE ET ELIMINATION DES ELEMENTS DEGENERES
145 ! RECHERCHE ET ELIMINATION DES ELEMENTS SUPERPOSES
146 !=======================================================================
147 !
148  eleli = .false.
149  neleli = 0
150 !
151  IF (ndp.EQ.3) THEN
152 !
153  DO i=1,nelem
154  i1 = ikle(i,1)
155  i2 = ikle(i,2)
156  i3 = ikle(i,3)
157  new(i) = 0
158  IF (i1.EQ.i2.OR.i1.EQ.i3.OR.i2.EQ.i3) new(i) = 1
159  ENDDO
160 !
161  DO i=1,nelem-1
162  IF (new(i).EQ.0) THEN
163  i1 = ikle(i,1)
164  i2 = ikle(i,2)
165  i3 = ikle(i,3)
166  DO j=i+1,nelem
167  IF (new(j).EQ.0) THEN
168  j1 = ikle(j,1)
169  j2 = ikle(j,2)
170  j3 = ikle(j,3)
171  IF ((i1.EQ.j1.OR.i1.EQ.j2.OR.i1.EQ.j3).AND.
172  & (i2.EQ.j1.OR.i2.EQ.j2.OR.i2.EQ.j3).AND.
173  & (i3.EQ.j1.OR.i3.EQ.j2.OR.i3.EQ.j3)) new(j) = 1
174  ENDIF
175  ENDDO
176  ELSE
177  eleli = .true.
178  ENDIF
179  ENDDO
180 !
181  ELSE
182 !
183  DO i=1,nelem
184  i1 = ikle(i,1)
185  i2 = ikle(i,2)
186  i3 = ikle(i,3)
187  i4 = ikle(i,4)
188  new(i) = 0
189  IF (i1.EQ.i2.OR.i1.EQ.i3.OR.i1.EQ.i4.OR.
190  & i2.EQ.i3.OR.i2.EQ.i4.OR.i3.EQ.i4) new(i) = 1
191  ENDDO
192 !
193  DO i=1,nelem-1
194  IF (new(i).EQ.0) THEN
195  i1 = ikle(i,1)
196  i2 = ikle(i,2)
197  i3 = ikle(i,3)
198  i4 = ikle(i,4)
199  DO j=i+1,nelem
200  IF (new(j).EQ.0) THEN
201  j1 = ikle(j,1)
202  j2 = ikle(j,2)
203  j3 = ikle(j,3)
204  j4 = ikle(j,4)
205  IF((i1.EQ.j1.OR.i1.EQ.j2.OR.i1.EQ.j3.OR.i1.EQ.j4).AND.
206  & (i2.EQ.j1.OR.i2.EQ.j2.OR.i2.EQ.j3.OR.i2.EQ.j4).AND.
207  & (i3.EQ.j1.OR.i3.EQ.j2.OR.i3.EQ.j3.OR.i3.EQ.j4).AND.
208  & (i4.EQ.j1.OR.i4.EQ.j2.OR.i4.EQ.j3.OR.i4.EQ.j4)) new(j)=1
209  ENDIF
210  ENDDO
211  ELSE
212  eleli = .true.
213  ENDIF
214  ENDDO
215 !
216  ENDIF
217 !
218 !=======================================================================
219 ! SEUL LE DERNIER ELEMENT EST A ELIMINER
220 !=======================================================================
221 !
222  IF(.NOT.eleli.AND.new(nelem).EQ.1) neleli = 1
223 !
224 !=======================================================================
225 ! REMPLISSAGE DES TROUS LAISSES PAR L'ELIMINATION D'ELEMENTS
226 !=======================================================================
227 !
228  IF(eleli) THEN
229  DO i=1,nelem
230  IF(new(i).EQ.0) THEN
231  ikle(i-neleli,1) = ikle(i,1)
232  ikle(i-neleli,2) = ikle(i,2)
233  ikle(i-neleli,3) = ikle(i,3)
234  IF(ndp.EQ.4) ikle(i-neleli,4) = ikle(i,4)
235  ELSE
236  neleli = neleli + 1
237  ENDIF
238  ENDDO
239  ENDIF
240 !
241  nelem = nelem - neleli
242 !
243 !=======================================================================
244 ! SORTIE LISTING
245 !=======================================================================
246 !
247  WRITE(lu,3130) npteli,neleli,npoin,nelem
248  3130 FORMAT(//,1x,'SETTING TELEMAC STANDARD',
249  & /,1x,'------------------------',/,
250  & /,1x,'RENUMBERING DONE :',
251  & /,6x,i9,' POINTS CANCELLED',
252  & /,6x,i9,' ELEMENTS CANCELLED',
253  & /,1x,'NEW NUMBER OF POINTS : ',i9,
254  & /,1x,'NEW NUMBER OF ELEMENTS : ',i9)
255 !
256  RETURN
257  END
declarations_special
Definition: declarations_special.F:3
declarations_special::lu
integer lu
Definition: declarations_special.F:45
remail
subroutine remail(IKLE, NCOLOR, NEW, X, Y, EPSI, NDP, NPOIN, NELEM, NELMAX)
Definition: remail.f:7
Generated on Tue Jan 5 2021 14:35:01 for The TELEMAC-MASCARET system by doxygen 1.8.13