1 : C TRIA SOURCE SH236661 13/11/25 21:15:09 7869
2 : SUBROUTINE TRIA
3 : C ******************************************************************
4 : C INTERFACE CASTEM 2000
5 : C
6 : C
7 : C (1) SURF1 = TRIANGULATION LIG1 (N1) ;
8 : C
9 : C (2) MAIL2 = TRIANGULATION MAIL1 ('CONV') (FLOT1) ;
10 : C
11 : C (3) MAIL2 = TRIANGULATION MAIL1 (FLOT1) ;
12 : C
13 : C OBJET :
14 : C _______
15 : C
16 : C (1) L'OPERATEUR TRIANGULATION CONSTRUIT UN MAILLAGE D'UN DOMAINE
17 : C PLAN DEFINI PAR SA FRONTIERE (OBJET LIG1). LES ELEMENTS SONT DES
18 : C TRIANGLES LINEAIRES QUELLES QUE SOIENT LES DIRECTIVES D'OPTION.
19 : C LE NOMBRE DE NOEUDS GENERES EST MINIMUM, IL PEUT ETRE ENCORE
20 : C LIMITE EN FIXANT LA VALEUR DE N1.
21 : C
22 : C
23 : C (2) L'OPERATEUR TRIANGULATION CONSTRUIT LE MAILLAGE (OBJET MAIL2)
24 : C DE LA TRIANGULATION DE DELAUNAY D'UN MAILLAGE DE POINTS (OBJET
25 : C MAIL1).
26 : C - LE MOT CLEF 'CONV' IMPOSE DE VERIFIER LA CONVEXITE DE MAIL2
27 : C (APPEL A VERCON), LA TAILLE DE LA BOITE EST AUGMENTEE SI BESOIN.
28 : C - FLOT1 EST UNE TAILLE DE MAILLE CIBLE A RESPECTER POUR MAIL2:
29 : C APRES UNE TRIANGULATION, UN NOEUD EST AJOUTE AU MILIEU DE CHAQUE
30 : C LIGNE DONT LA LONGEUR EXCEDE (4/3)*FLOT1, LE NOUVEL ENSEMBLE DE
31 : C POINTS EST ALORS RE-TRIANGULE.
32 : C
33 : C (3) L'OPERATEUR TRIANGULATION CONSTRUIT LE MAILLAGE (OBJET MAIL2)
34 : C DE L'INTERIEUR D'UNE SURFACE (D'UN VOLUME) EN DIMENSION 2 (3)
35 : C DEFINIE PAR UN CONTOUR (UNE ENVELOPPE) MAIL1 PAR TRIANGULATION.
36 : C MAIL1 PEUT EGALEMENT ETRE UNE SURFACE (UN VOLUME), DANS CE CAS LES
37 : C NOEUDS SITUES A L'INTERIEURS SERONT PRIS EN COMPTE DANS LA
38 : C TRIANGULATION.
39 : C - FLOT1 EST UNE TAILLE DE MAILLE CIBLE A RESPECTER POUR MAIL2:
40 : C APRES UNE TRIANGULATION, UN NOEUD EST AJOUTE AU MILIEU DE CHAQUE
41 : C LIGNE DONT LA LONGEUR EXCEDE (4/3)*FLOT1, LE NOUVEL ENSEMBLE DE
42 : C POINTS EST ALORS RE-TRIANGULE.
43 : C
44 : C DATE : 10.04.96 / 03.05.96 / 04.04.97 / 17.02.12
45 : C ______
46 : C
47 : C AUTEURS : T. CHARRAS ET O. STAB
48 : C _________
49 : C
50 : C ******************************************************************
51 : IMPLICIT INTEGER(I-N)
52 : IMPLICIT REAL*8 (A-H,O-Z)
53 : C
54 : -INC SMCHPOI
55 : -INC CCOPTIO
56 : -INC SMELEME
57 : -INC SMCOORD
58 : -INC CCGEOME
59 : -INC SMLENTI
60 : SEGMENT ITRAVX
61 : INTEGER ITVL (ITOTAI)
62 : ENDSEGMENT
63 : SEGMENT RTRAV
64 : REAL*8 RTVL (ITOTAR)
65 : ENDSEGMENT
66 : SEGMENT ICPR (XCOOR(/1)/(IDIM+1))
67 : SEGMENT ICPP (XCOOR(/1)/(IDIM+1))
68 : INTEGER NITMAX,NRTMAX,NPONEW,ITRACE,IERRDS
69 : C
70 : C --- VARIABLES INTERNES ---
71 : INTEGER NBN,NBE,IDIMC,NBNMAX,NBCMAX,IDE,NBPMAX,NBEMAX,ITRNOE
72 : INTEGER ITRTRI,NOETRI,ITRAV,IRTRAV,NITMX2,NRTMX2,ICOORD
73 : INTEGER NMT,I,NBNARE, IARETE
74 : INTEGER IMAT,IFRL,NBFRL,IMATE,NOEMAX,MAT
75 : INTEGER ITRIRG,NMTCC,IRGREF,IMATCC
76 : INTEGER NCC,NBENEW
77 : C
78 : C (S. PASCAL)
79 : CHARACTER*4 MOT1
80 : C
81 : C --- CONSTANTES DE DIMENSIONNEMENT ---
82 : C POUR LE RESPECT DE LA FRONTIERE :
83 : C --------------------------------
84 : C NCMAX : LE NOMBRE MAXIMUM DE COTE DU POLYGONE
85 : C NPMAX : LE NOMBRE MAXIMUM DE POLYGONES EMPILES
86 : C EN ENTIER => ((2*(2*NCMAX+1))* NPMAX) + 3*(NCMAX-2)
87 : C EN REELS => 2 * NPMAX
88 : C NPMAX = 1000, NCMAX = 20 => 82054 ENTIERS
89 : C => 2000 REELS
90 : C --- CONSTANTES ---
91 : IDIMC = 2
91 : CALL DSINIT
92 : C
93 : C =======================
94 : C --- 1.LECTURE DES DONNEES ---
95 : C =======================
96 : *
97 : * LECTURE DES OBJETS COURANTS (ENTREES)
98 : * =====================================
98 : CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
99 : IF (IERR.NE.0) THEN
100 : C ON A PAS TROUVE LE MAILLAGE
100 : CALL ERREUR(503)
101 : GOTO 999
102 : ENDIF
103 : SEGACT IPT1
104 : NBSZ=IPT1.LISOUS(/1)
105 : NTYP=IPT1.ITYPEL
106 : C
107 : C---- SI PRESENCE D'UN ENTIER, SYNTAXE PREMIERE (O. STAB) --------------
108 : C
108 : CALL LIRENT(IVAL,0,IRETOU)
109 : IF (IRETOU.EQ.1) GOTO 100
110 : C
111 : C---- SI MAILLAGE DE POI1 : TRIANGULATION DE POINTS (S. PASCAL) --------
112 : C
113 : IF ((IDIM.NE.1).AND.(IDIM.NE.2).AND.(IDIM.NE.3)) THEN
114 : INTERR(1)=IDIM
115 : C FONCTION INDISPONIBLE EN DIMENSION %I1
115 : CALL ERREUR(709)
116 : GOTO 999
117 : ENDIF
118 : IF ((NBSZ.EQ.0).AND.(NTYP.EQ.1)) THEN
119 : C Parametre optionnel : mot-clef CONV pour verifier la convexite
120 : IVC=0
120 : CALL LIRCHA(MOT1,0,IRETOU)
121 : IF (IRETOU.NE.0) THEN
122 : IF (MOT1(1:4).EQ.'CONV') IVC=1
123 : ENDIF
124 : C Parametre optionnel : taille de maille pour re-maillage
124 : CALL LIRREE(XDEN,0,IRETOU)
125 : IF (IRETOU.EQ.0) XDEN=0.
126 : XDEN43=XDEN*4./3.
127 : C
128 : MPOVAL = 0
128 : CALL LIROBJ('CHPOINT ',MCHPOI,0,IRETOU)
129 : IF(IRETOU.EQ.1) THEN
130 : SEGACT MCHPOI
131 : MSOUPO=IPCHP(1)
132 : SEGACT MSOUPO
133 : MPOVAL = IPOVAL
134 : SEGACT MPOVAL
135 : ENDIF
136 : C
137 : C Appel a TRIA1 pour le calcul de la triangulation de Delaunay
137 : CALL TRIA1(MPOVAL,IPT1,IVC,XDEN43,IPT2)
138 : C Ecriture sortie/fin
139 : SEGDES,IPT1
140 : C
141 : IF (MCHPOI .GT. 0) SEGDES,MCHPOI,MSOUPO,MPOVAL
142 : C
142 : IF (IERR.EQ.0) CALL ECROBJ('MAILLAGE',IPT2)
143 : GOTO 999
144 : ENDIF
145 : C
146 : C---- AUTRES DISTINCTIONS ----------------------------------------------
147 : C
148 : C Parametre optionnel : taille de maille pour re-maillage
148 : CALL LIRREE(XDEN,0,IRETOU)
149 : IF (IRETOU.EQ.0) XDEN=0.
150 : XDEN43=XDEN*4./3.
151 : C
152 : C---- SI DIMENSION 2 ET PAS DE FLOTTANT : SYNTAXE PREMIERE (O. STAB) ---
153 : C
154 : IF ((IDIM.EQ.2).AND.(XDEN.EQ.0.)) THEN
155 : GOTO 100
156 : ENDIF
157 : C
158 : C---- MAILLAGE DE L'INTERIEUR D'UN CONTOUR EN DIMENSION 2 OU BIEN DE ---
159 : C L'INTERIEUR D'UN VOLUME EN DIMENSION 3 (S. PASCAL)
160 : C
161 : IF (NBSZ.NE.0) THEN
162 : C Operation interdite sur un objet complexe
162 : CALL ERREUR(25)
163 : GOTO 999
164 : ENDIF
165 : IF (((IDIM.EQ.2).AND.(NTYP.NE.2).AND.(NTYP.NE.4)).OR.
166 : & ((IDIM.EQ.3).AND.(NTYP.NE.4).AND.(NTYP.NE.23))) THEN
167 : C Type d'element incorrect
167 : CALL ERREUR(16)
168 : GOTO 999
169 : ENDIF
170 : C Appel a TRIA2 pour la construction du maillage par triangulation
170 : CALL TRIA2(IPT1,XDEN43,IPT2)
171 : C Ecriture sortie/fin
172 : SEGDES,IPT1
172 : IF (IERR.EQ.0) CALL ECROBJ('MAILLAGE',IPT2)
173 : GOTO 999
174 : C
175 : C---- DANS LES AUTRES CAS : TRIANGULATION CONTRAINTE D'UN CONTOUR ------
176 : C (O. STAB)
177 : C
178 : 100 CONTINUE
179 : IF(IDIM.NE.2) THEN
180 : INTERR(1)=IDIM
181 : C FONCTION INDISPONIBLE EN DIMENSION %I1
181 : CALL ERREUR(709)
182 : GOTO 999
183 : ENDIF
184 : C
185 : NBNARE = IPT1.NUM(/2)
186 : NBNTOT = -1
187 : IF(IRETOU.NE.0) THEN
188 : IF( IVAL.LT.NBNARE )THEN
189 : C Le nombre de noeuds ne peut ètre inférieur à %i1
190 : C (nombre d'arètes)
191 : INTERR(1) = NBNARE
191 : CALL ERREUR(849)
192 : SEGDES IPT1
193 : GOTO 999
194 : ENDIF
195 : NBNTOT = IVAL
196 : ENDIF
197 : C
198 : IF((IPT1.LISOUS(/1).NE.0).OR.
199 : > (IPT1.ITYPEL.NE.2).OR.
200 : > (NBNARE.LT.3))THEN
201 : C DONNEES INCOMPATIBLES
201 : CALL ERREUR(21)
202 : SEGDES IPT1
203 : GOTO 999
204 : ENDIF
205 : SEGDES IPT1
206 : *
207 : * ALLOCATION DE LA MEMOIRE
208 : * =====================================
209 : ICMEMO = 1
210 : C NBNREL = (NBNARE**2 ) / 2
211 : C
212 : NBNREL = NBNARE * 3
213 : C --- POUR TESTER LES MESSAGE D'ERREUR ET LA REALLOCATION :
214 : C NBNREL = NBNARE + 50
215 : NBNABS = 20000
216 : 5 CONTINUE
217 : ICOORD = 1
218 : IARETE = 1
219 : NMT=1
220 : NBN= NBNARE
221 : IF(NBNTOT.NE.-1) THEN
222 : NBPTMX = NBNTOT*ICMEMO + 50
223 : NPONEW = NBNTOT*ICMEMO -NBN
224 : ELSE
225 : NBPTMX = NBNREL*ICMEMO + 50
226 : NPONEW = NBNREL*ICMEMO - NBN
227 : ENDIF
228 : NITMAX = 20 * NBPTMX + 288 + 310 + 82054
229 : NRTMAX = 12 * (NBPTMX + 12) + 2000
230 : *
231 : * TRANSFERT DANS LA STRUCTURE DE L'ALGO
232 : * =====================================
233 : *
234 : * REMPLISSAGE DU TABLEAU DE CONNEXION
235 : * ===================================
236 : SEGACT IPT1
237 : ITOTAI= NITMAX
238 : SEGINI ITRAVX
239 : NBANC = XCOOR(/1) /( IDIM+1)
240 : SEGINI,ICPR,ICPP
241 : ITOTAR = NRTMAX
242 : SEGINI RTRAV
243 : INO = 0
244 : DO 7764 I=1,NBNARE
245 : DO 7764 J=1,2
246 : IA = IPT1.NUM(J,I)
247 : IF( ICPR(IA).EQ.0) THEN
248 : INO = INO+1
249 : ICPR(IA) = INO
250 : ICPP(INO)=IA
251 : RTVL((INO-1)*2 +1) = XCOOR( ( IA-1) * 3 +1)
252 : RTVL((INO-1)*2 +2) = XCOOR( ( IA-1) * 3 +2)
253 : ENDIF
254 : ITVL ((I-1)*2 +J) = ICPR(IA)
255 : 7764 CONTINUE
256 : NBN=INO
257 : SEGDES IPT1
258 : C
259 : C --- IL FAUT ANTICIPER LE NOMBRE DE NOEUDS GENERES ---
260 : C NBPMAX SERT A DIMENSIONNER NOETRI, COORD
261 : C NBEMAX SERT A DIMENSIONNER ITRNOE, ITRTRI
262 : C
263 : NBPMAX = NBN + MAX(NPONEW,50)
264 : NBEMAX = 2 * NBN + 2 * MAX(NPONEW,50) - 2
265 : C
266 : C ==============================
267 : C --- 2. CALCUL DE LA TRIANGULATION ---
268 : C ==============================
269 : C
270 : NBNMAX = 3
271 : NBCMAX = 3
272 : NBE = 0
273 : IDE = 2
274 : C
275 : C ----------------
276 : C --- 2.1 ALLOCATION ---
277 : C ----------------
278 : C ITVL = |IARETE|IMAT| ITRNOE | ITRTRI | NOETRI | ITRAV
279 : C NBEMAX*3 NBEMAX*3 NBPMAX 310
280 : C TNUPOT
281 : C
282 : C =========== BUG 1 ============
283 : ITRNOE = (NBNARE * 2) + 1
284 : ITRTRI = ITRNOE + (NBEMAX * NBNMAX)
285 : NOETRI = ITRTRI + (NBEMAX * NBCMAX)
286 : ITRAV = NOETRI + NBPMAX
287 : NITMX2 = NITMAX - ITRAV
288 : IRTRAV = NBPMAX * IDIMC + 1
289 : NRTMX2 = NRTMAX - IRTRAV
290 : C
291 : C --------------------------------------------
292 : C --- 2.2 CALCUL DE LA TRIANGULATION DE DELAUNAY ---
293 : C --------------------------------------------
294 : C
294 : CALL TNUPOT(RTVL(ICOORD),NBN,ITVL(ITRNOE),
295 : > NBNMAX,ITVL(ITRTRI),NBCMAX,ITVL(NOETRI),NBE,
296 : > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),IERRDS)
297 : NCC = 1
298 : C
299 : IF(IERRDS.NE.0)THEN
300 : IF(IERRDS.EQ.-2)THEN
301 : IERRDS = 0
302 : ICMEMO = ICMEMO + 1
303 : SEGSUP ITRAVX,ICPR,ICPP,RTRAV
304 : C Patience on reprend avec plus de mémoire...
304 : CALL ERREUR(850)
305 : GOTO 5
306 : ENDIF
307 : C Erreur de triangulation : vérifiez qu'il n'y a pas de points
308 : C confondus
308 : CALL ERREUR(846)
309 : C ERREUR GENERATION DE MAILLAGE. IL EST NEANMOINS CREE POUR CONTROLE
309 : C CALL ERREUR(27)
310 : IERRDS = 0
311 : GOTO 40
312 : ENDIF
313 : C
314 : C
315 : C ==================================
316 : C --- 3. FORCAGE DES ARETES FRONTIERES
317 : C DANS LA TRIANGULATION ---
318 : C ==================================
319 : C
320 : IRTRAV = NBPMAX * IDIMC + 1
321 : NRTMX2 = NRTMAX - IRTRAV
322 : DO 10 I=1,NBNARE
322 : CALL RF2RAR(ITVL((I-1)*2+IARETE),
323 : > ITVL(ITRNOE),NBNMAX,
324 : > ITVL(ITRTRI),NBCMAX,ITVL(NOETRI),NBE,
325 : > RTVL(ICOORD),ITVL(ITRAV),NITMX2,
326 : > RTVL(IRTRAV),NRTMX2,
327 : > NBENEW,IERRDS)
328 : C
329 : IF( IERRDS .NE. 0 )THEN
330 : IF(IERRDS.EQ.-2)THEN
331 : IERRDS = 0
332 : ICMEMO = ICMEMO + 1
333 : SEGSUP ITRAVX,ICPR,ICPP,RTRAV
334 : C Patience on reprend avec plus de mémoire...
334 : CALL ERREUR(850)
335 : GOTO 5
336 : ELSE
337 : C Erreur de frontière : Vérifiez que le contour n'est pas croisée
337 : CALL ERREUR(847)
338 : C ERREUR GENERATION DE MAILLAGE. IL EST NEANMOINS CREE POUR CONTROLE
338 : C CALL ERREUR(27)
339 : IERRDS = 0
340 : GOTO 40
341 : ENDIF
342 : ENDIF
343 : C
344 : 10 CONTINUE
345 : C
346 : C ==================================
347 : C --- 4. DESTRUCTION DES ELEMENTS
348 : C EXTERIEURS : SCULPT ---
349 : C ==================================
350 : C
351 : C ----------------
352 : C --- 4.1 ALLOCATION ---
353 : C ----------------
354 : C ITVL = ...ITRTRI|NOETRI| IFRL | ITRAV
355 : C NBFRL*2 2*NBE+PILE
356 : C SCULPT
357 : C
358 : IFRL = IARETE
359 : NBFRL = NBNARE
360 : NITMX2 = NITMAX - ITRAV
361 : IF(NBNARE.NE.0)
361 : > CALL SCULPT(ITVL(IFRL),2,NBFRL,
362 : > IDE,ITVL(ITRNOE),NBNMAX,
363 : > ITVL(ITRTRI),NBCMAX,ITVL(NOETRI),
364 : > NBE,ITVL(ITRAV),NITMX2,NCC,IERRDS)
365 : C
366 : IF( IERRDS .NE. 0 )THEN
367 : IF(IERRDS.EQ.-2)THEN
368 : IERRDS = 0
369 : ICMEMO = ICMEMO + 1
370 : SEGSUP ITRAVX,ICPR,ICPP,RTRAV
371 : C Patience on reprend avec plus de mémoire...
371 : CALL ERREUR(850)
372 : GOTO 5
373 : ELSE
374 : C Erreur de frontière : Vérifiez que le contour est fermé
374 : CALL ERREUR(848)
375 : C ERREUR GENERATION DE MAILLAGE. IL EST NEANMOINS CREE POUR CONTROLE
375 : C CALL ERREUR(27)
376 : IERRDS = 0
377 : GOTO 40
378 : ENDIF
379 : ENDIF
380 : C
381 : C ==================================
382 : C --- 5. CALCUL DES NOEUDS INTERIEURS ---
383 : C ==================================
384 : C
385 : C ----------------
386 : C --- 5.1 ALLOCATION ---
387 : C ----------------
388 : C ITVL = ...ITRTRI|NOETRI| ITRAV
389 : C 310 (DELAJOUTPT)
390 : C
391 : NBPMAX = NBN + NPONEW
392 : ITRAV = NOETRI + NBPMAX
393 : NITMX2 = NITMAX - ITRAV
394 : IRTRAV = NBPMAX * IDIMC + 1
395 : NRTMX2 = NRTMAX - IRTRAV
396 : NOEMAX = NBPMAX
397 : C
397 : CALL R2RAF(ITVL(ITRNOE),NBNMAX,ITVL(ITRTRI),NBCMAX,
398 : > ITVL(NOETRI),NOEMAX,
399 : > RTVL(ICOORD),NBN,NBE,NBPMAX,NBEMAX,
400 : > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,
401 : > IERRDS)
402 : C
403 : IF(IERRDS.NE.0)THEN
404 : IF(IERRDS.EQ.-2)THEN
405 : IF(NBNTOT.EQ.-1)THEN
406 : C PAS DE LIMITATION SUR LES NOEUDS, LA MEMOIRE EVALUEE
407 : C EST INSUFFISANTE
408 : C Patience on reprend avec plus de mémoire...
409 : IERRDS = 0
410 : ICMEMO = ICMEMO + 1
411 : SEGSUP ITRAVX,ICPR,ICPP,RTRAV
411 : CALL ERREUR(850)
412 : GOTO 5
413 : ENDIF
414 : C LIMITATION SUR LES NOEUDS DONNE PAR L'UTILISATEUR
415 : IERRDS = 0
416 : GOTO 40
417 : ENDIF
418 : C IERRDS = -1 ...
418 : CALL ERREUR(848)
419 : C ERREUR GENERATION DE MAILLAGE. IL EST NEANMOINS CREE POUR CONTROLE
419 : C CALL ERREUR(27)
420 : IERRDS = 0
421 : GOTO 40
422 : ENDIF
423 : *
424 : * REMPLISSAGE NOUVEL OBJET MAILLAGE ET TABLEAU DES COORDONNEES
425 : * ============================================================
426 : 40 CONTINUE
427 : NBELEM=NBE
428 : NBNN=3
429 : NBREF=0
430 : NBSOUS=0
431 : SEGINI MELEME
432 : NBPTS = NBN-INO+NBANC
433 : SEGADJ MCOORD
434 : DO 7781 I=1,NBN-INO
435 : XCOOR((NBANC +I-1)*(IDIM+1) +1) = RTVL((INO+I-1)*2+1)
436 : XCOOR((NBANC +I-1)*(IDIM+1) +2) = RTVL((INO+I-1)*2+2)
437 : * ---- POUR LA DENSITE : DENSITE COURANTE ----
438 : XCOOR((NBANC +I-1)*(IDIM+1) +3) = DENSIT
439 : 7781 CONTINUE
440 : *
441 : DO 7782 I=1,NBE
442 : DO 7783 J=1,3
443 : IA=ITVL( (I-1)*3+J-1+ITRNOE)
444 : C
445 : C III = ITVL( (I-1)*3+J-1+ITRTRI)
446 : C IF( III.LT. 0 )THEN
447 : C WRITE(6,*) ' ARETE ',J,' DU TRIANGLE ',I,' NEGATIVE ', III
448 : C ENDIF
449 : C
450 : IF ( IA .LE.INO) THEN
451 : IB = ICPP(IA)
452 : ELSE
453 : IB = IA -INO +NBANC
454 : ENDIF
455 : NUM(J,I)=IB
456 : 7783 CONTINUE
457 : ICOLOR(I) = IDCOUL
458 : 7782 CONTINUE
459 : ITYPEL=4
460 : SEGDES MELEME
460 : CALL ECROBJ('MAILLAGE',MELEME)
461 : C
462 : C ---- DESALLOCATION ET FIN SUR ERREUR ----
463 : 9990 SEGSUP ITRAVX,RTRAV,ICPR,ICPP
464 : C
465 : 999 END
466 :
467 :
468 :
469 :
© Cast3M 2003 - All rights reserved.
Disclaimer