1 : C SMACRE SOURCE CHAT 06/03/29 21:34:11 5360
2 : SUBROUTINE SMACRE(IDE,ITRI,NBE,NBPMAX,
3 : > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,
4 : > ITVL,NBTRAV,iarr)
5 : C *****************************************************************
6 : C OBJET : CREER LA STRUCTURE DE DONNEE MAILLAGE
7 : C ITRI -> ITRNOE, ITRTRI, NOETRI
8 : C EN ENTREE:
9 : C IDE : (1..3) DIMENSION DES ELEMENTS
10 : C NBE : NOMBRE D'ELEMENTS DU MAILLAGE
11 : C NBPMAX : NOMBRE MAXIMUM DE POINTS
12 : C IL PEUT ETRE SUPERIEUR AUX NOEUDS CONNECTES DANS ITRI
13 : C 0 SI ON NE LE CONNAIT PAS
14 : C ITRI : ITRI(I,J) EST LE NOEUD J DE L'ELEMENT I
15 : C NBNMAX : (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS
16 : C NBCMAX : (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS
17 : C NOEMAX : TAILLE DU TABLEAU NOETRI
18 : C SI NOEMEMAX = 0 NOETRI NE SERA PAS REMPLI
19 : C ITVL : TABLEAU DE TRAVAIL
20 : C NBTRAV : TAILLE DU TABLEAU DE TRAVAIL
21 : C AU MIN = 0 => O(N2)
22 : C AU MAX = (NBR MAX D'ELEMENTS EN 1 NOEUD + 1) *
23 : C (NUMERO MAXI DU NOEUD DANS ITRI)
24 : C => O(N)
25 : C EN SORTIE:
26 : C ITRNOE : ITRNOE(I,J) EST LE NOEUD J DU TRIANGLE I
27 : C LES ELEMENTS NE SONT PAS ORIENTES
28 : C PEUT ETRE LE MEME TABLEAU QUE ITRI
29 : C ITRTRI : ITRTRI(I,J) EST LE TRIANGLE INCIDENT AU TRIANGLE I SUR
30 : C L'ARETE J
31 : C NOETRI : NOETRI(I) EST UN DES TRIANGLES CONTENANT LE NOEUD I
32 : C iarr : CODE D'ERREUR 0 => OK
33 : C -NB => TABLEAU NOETRI TROP PETIT TAILLE SOUHAITE = NB
34 : C CONDITION D'APPLICATION : ARETE, TRIANGLE, QUADRANGLE, TETRA
35 : C *****************************************************************
36 : IMPLICIT INTEGER(I-N)
37 : INTEGER IDE,ITRI(*),NBE,NBPMAX
38 : INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX
39 : INTEGER NOETRI(*), NOEMAX, ITVL(*), NBTRAV, iarr
40 : C
41 : EXTERNAL SFAIDE,STRKFS
42 : INTEGER SFAIDE,STRKFS
43 : INTEGER I,J,K, IT1,IT2, IT, NBNOE, N1,N2, NBTMAX, ITNV, NIJ
44 : C --- POUR LES TESTS ---
45 : C REAL X(2),Z(3)
46 : INTEGER NBATST, NBLIN,IFAC(3),NBFN,KK,IFVUE
47 : C EXTERNAL ETIME
48 : C REAL ETIME
49 : C
50 : iarr = 0
51 : IF( NBE.EQ. 0 )GOTO 9999
52 : IF( NBE.LT. 0 )THEN
53 : iarr = -1
54 : GOTO 9999
55 : ENDIF
56 : NBATST = 0
57 : NBLIN = 0
58 : C
59 : C ================
60 : C ---- INITIALISATION ----
61 : C ================
62 : C
63 : DO 10 I=1,(NBE*NBCMAX)
64 : ITRTRI(I) = -1
65 : 10 CONTINUE
66 : NBNOE = 0
67 : DO 20 I=1,(NBE*NBNMAX)
68 : IF( ITRI(I).GT.NBNOE )NBNOE = ITRI(I)
69 : 20 CONTINUE
70 : C
71 : C L'INDICE D'UN NOEUD DEPASSE LA TAILLE DU TABLEAU
72 : C
73 : C --- BUG10 25.10.96 -------------------------------
74 : IF((NOEMAX.GT.0).AND.
75 : > ((NBNOE.GT.NOEMAX).OR.(NBPMAX.GT.NOEMAX)))THEN
76 : iarr = -2
77 : GO TO 9999
78 : ENDIF
79 : C --- INITIALISATION DU TABLEAU DE TRAVAIL ---
80 : NBTMAX = NBTRAV / NBNOE
81 : IF( NBTMAX .LT. 2 )GO TO 90
82 : DO 30 I=1,(NBNOE * NBTMAX)
83 : ITVL(I) = 0
84 : 30 CONTINUE
85 : C
86 : C =============================
87 : C ---- CALCUL DES VOISINS : ITRTRI ----
88 : C =============================
89 : C
90 : C Z(1) =ETIME(X)
91 : DO 50 I=1,NBE
92 : C ----------------------------------------------------------
93 : C REMPLISSAGE LINEAIRE MAIS PROBABILISTE (2/5) DES VOISINS
94 : C PRINCIPE : SI UN AUTRE ELEMENT PARTAGE UN NOEUD AVEC
95 : C UN AUTRE ELEMENT, ALORS PEUT ETRE PARTAGE T'IL UNE ARETE ?
96 : C ----------------------------------------------------------
97 : C
98 : N1 = NBNMAX
99 : IF( (NBNMAX.EQ.4).AND.(IDE.EQ.2).AND.
100 : > (ITRI((I-1)*NBNMAX+4).EQ.0))N1= 3
101 : DO 40 J=1,N1
102 : IT = ITRI((I-1)*NBNMAX+J)
103 : IF(IT.LE.0)GOTO 40
104 : K = ITVL((IT-1)*NBTMAX+1)
105 : IF(K.LT.(NBTMAX-1))THEN
106 : ITVL((IT-1)*NBTMAX+1) = K+1
107 : ITVL((IT-1)*NBTMAX+K+2)= I
108 : ENDIF
109 : 40 CONTINUE
110 : 50 CONTINUE
111 : C
112 : C
113 : NBLIN = 0
114 : DO 80 I=1,NBE
115 : N1 = NBNMAX
116 : C --- BUG6 05.09.96 : ITRTRI(4) = 0 -----
117 : IF( (IDE.EQ.2).AND.(NBNMAX.EQ.4).AND.
118 : > (ITRI((I-1)*NBNMAX+4).EQ.0))THEN
119 : N1= 3
120 : ITRTRI((I-1)*NBCMAX + 4) = 0
121 : ENDIF
122 : * WRITE(*,*)' ELEMENT ',I
123 : DO 70 J=1,N1
124 : C
125 : C POUR TOUTES LES FACES INCIDENTES AU NOEUD J
126 : C
127 : NBFN = STRKFS(IDE,J,N1,IFAC)
128 : * WRITE(*,*)' NOEUD = ',J
129 : DO 55 K=1,NBFN
130 : * WRITE(*,*)' IFAC(',K,') = ',IFAC(K)
131 : * WRITE(*,*)' VOISIN = ',ITRTRI((I-1)*NBCMAX + IFAC(K))
132 : IF( ITRTRI((I-1)*NBCMAX + IFAC(K)).EQ.-1)GOTO 56
133 : 55 CONTINUE
134 : GOTO 70
135 : C --- REMPLACE :
136 : C IF( ITRTRI((I-1)*NBCMAX + J).EQ.0)THEN
137 : C
138 : 56 IT = ITRI((I-1)*NBNMAX+J)
139 : * WRITE(*,*) 'ON TESTE LE NOEUD ',J,' DE L ELEMENT ',I
140 : IF(IT.LE.0)GOTO 70
141 : C ---- DANS LE TABLEAU DES ELEMENTS INCIDENTS ---
142 : * WRITE(*,*)'LISTE ='
143 : DO 65 K=1,ITVL((IT-1)*NBTMAX+1)
144 : ITNV = ITVL((IT-1)*NBTMAX+K+1)
145 : * WRITE(*,*)'ELEMENT SUR ',J,' ITNV = ',ITNV
146 : IF(ITNV.NE.I)THEN
147 : N2 =NBNMAX
148 : IF( (NBNMAX.EQ.4).AND.(IDE.EQ.2).AND.
149 : > (ITRI((ITNV-1)*NBNMAX+4).EQ.0))N2= 3
150 : IF(SFAIDE(ITRI((I-1)*NBNMAX+1),
151 : > ITRI((ITNV-1)*NBNMAX+1),
152 : > N1,N2,IDE,IT1,IT2 ).NE.0)THEN
153 : * WRITE(*,*) ITNV,' ET ',I,' SONT ADJACENTS SUR ',IT1,IT2
154 : ITRTRI((I-1)*NBCMAX + IT1) = ITNV
155 : ITRTRI((ITNV-1)*NBCMAX + IT2) = I
156 : NBLIN = NBLIN + 1
157 : ENDIF
158 : ENDIF
159 : 65 CONTINUE
160 : C ENDIF
161 : 70 CONTINUE
162 : 80 CONTINUE
163 : C Z(2) = ETIME( X )
164 : C
165 : C ----------------------------------------------------------
166 : C REMPLISSAGE EN O(N2) DES VOISINS
167 : C ----------------------------------------------------------
168 : C
169 : 90 NBATST = 0
170 : C ------------------------------- POUR TOUTES LES MAILLES: I
171 : DO 100 I=1,NBE-1
172 : N1 = NBNMAX
173 : IF( (NBNMAX.EQ.4).AND.(IDE.EQ.2).AND.
174 : > (ITRI((I-1)*NBNMAX+4).EQ.0))N1= 3
175 : C
176 : C ------(A) PRE-TRAITEMENT DES FACES INCIDENTES AUX NOEUDS
177 : C ----------------- POUR TOUS LES NOEUDS DE LA MAILLE I: J
178 : DO 110 J=1,N1
179 : IT = ITRI((I-1)*NBNMAX+J)
180 : IF(IT.LE.0)GOTO 110
181 : C ----------------------------------------
182 : C ---- AUCUNE MAILLE INCIDENTE A J N'A DE FACE
183 : C COMMUNE AVEC I : ON LES A TOUTES TESTEES :
184 : C ON EST SUR LA FRONTIERE ----
185 : C ----------------------------------------
186 : IF((NBTMAX.GT.2).AND.
187 : > (ITVL((IT-1)*NBTMAX+1).LT.(NBTMAX-1)))THEN
188 : NBFN = STRKFS(IDE,J,N1,IFAC)
189 : DO 91 KK=1,NBFN
190 : IF( ITRTRI((I-1)*NBCMAX + IFAC(KK)).EQ.-1)
191 : > ITRTRI((I-1)*NBCMAX + IFAC(KK)) = 0
192 : 91 CONTINUE
193 : ENDIF
194 : C ----------------------------------- FIN DE BOUCLE SUR J
195 : 110 CONTINUE
196 : C
197 : C -----(B) TRAITEMENT SYSTEMATIQUE DES FACES NON VISITEES
198 : C -------------------------------------------------------
199 : C RECHERCHE D'UNE FACE DE LA MAILLE I NON ENCORE VISITEE
200 : C -------------------------------------------------------
201 : IFVUE = 0
202 : DO 95 KK=1,NBCMAX
203 : IF( ITRTRI((I-1)*NBCMAX + KK).EQ.-1)IFVUE=IFVUE+1
204 : 95 CONTINUE
205 : C
206 : C -------------------------------------------------------
207 : C IL EXISTE UNE FACE DE LA MAILLE I NON ENCORE VISITEE
208 : C ON PARCOURS TOUTES LES MAILLES DE KK=I+1 A NBE
209 : C -------------------------------------------------------
210 : IF(IFVUE.GT.0)THEN
211 : NBATST = NBATST+1
212 : C ------------------ POUR TOUS LE ELEMENTS DE I A NBE: K
213 : DO 120 K=I+1,NBE
214 : N2 = NBNMAX
215 : IF( (NBNMAX.EQ.4).AND.(IDE.EQ.2).AND.
216 : > (ITRI((K-1)*NBNMAX+4).EQ.0))N2= 3
217 : IF(SFAIDE(ITRI((I-1)*NBNMAX+1),
218 : > ITRI((K-1)*NBNMAX+1),
219 : > N1,N2,IDE,IT1,IT2).NE.0)
220 : > THEN
221 : ITRTRI((I-1)*NBCMAX + IT1) = K
222 : ITRTRI((K-1)*NBCMAX + IT2) = I
223 : ENDIF
224 : 120 CONTINUE
225 : C -------------------------- FIN DE BOUCLE DE I A NBE: K
226 : C
227 : C ------------- LES FACES JAMAIS VISITEES SONT FRONTIERE
228 : DO 196 KK=1,NBCMAX
229 : IF( ITRTRI((I-1)*NBCMAX + KK).EQ.-1)
230 : > ITRTRI((I-1)*NBCMAX + KK) = 0
231 : 196 CONTINUE
232 : ENDIF
233 : 100 CONTINUE
234 : C ----------------- PARCOURS DES FACES DU DERNIER ELEMENT
235 : DO 197 KK=1,NBCMAX
236 : IF( ITRTRI((NBE-1)*NBCMAX + KK).EQ.-1)
237 : > ITRTRI((NBE-1)*NBCMAX + KK) = 0
238 : 197 CONTINUE
239 : C
240 : C Z(3)=ETIME(X)
241 : C --------------------------------------------
242 : C PRINT *,'NB DE TRIANGLES STOQUES = ',NBTMAX
243 : C PRINT *,'NB EN QUADRATIQUE = ',NBATST
244 : C PRINT *,'NB LINEAIRE = ',NBLIN
245 : C PRINT *,'NB TOTAL = ',(NBE*NBCMAX)
246 : C PRINT *,'TEMPS LINEAIRE = ',(Z(2)-Z(1))
247 : C PRINT *,'TEMPS QUADRATI = ',(Z(3)-Z(2))
248 : C
249 : C INITIALISATION DE ITRNOE
250 : C -------------------------
251 : DO 130 I=1,(NBE*NBNMAX)
252 : ITRNOE(I) = ITRI(I)
253 : 130 CONTINUE
254 : C
255 : C INITIALISATION DE NOETRI
256 : C -------------------------
257 : IF(NOEMAX.GT.0)THEN
258 : DO 135 I=1,MAX(NBNOE,NBPMAX)
259 : NOETRI(I) = 0
260 : 135 CONTINUE
261 : DO 140 I=1,NBE
262 : C --- BUG17 AJOUT DE LA LIGNE QUI SUIT O.STAB 07/02/96
263 : N1 = NBNMAX
264 : IF( (NBNMAX.EQ.4).AND.(IDE.EQ.2).AND.
265 : > (ITRI((I-1)*NBNMAX+4).EQ.0))N1= 3
266 : DO 150 J=1, N1
267 : NIJ = ITRI((I-1)*NBNMAX+J)
268 : IF(NIJ.GT.0)NOETRI(NIJ) = I
269 : 150 CONTINUE
270 : 140 CONTINUE
271 : ENDIF
272 : C ---- POUR LE DEBUG ----------------------------------
272 : * CALL PRITAB('ITRINOE ',ITRNOE,NBE,NBNMAX,1)
272 : * CALL PRITAB('ITRITRI ',ITRTRI,NBE,NBCMAX,1)
272 : * CALL PRITAB('NOETRI ',NOETRI,NBNOE,1,1)
273 : C
274 : 9999 END
275 :
276 :
277 :
278 :
© Cast3M 2003 - All rights reserved.
Disclaimer