1 c MEFISTO2: a library to compute 2D triangulation from segmented boundaries
3 c Copyright (C) 2006 Laboratoire J.-L. Lions UPMC Paris
5 c This library is free software; you can redistribute it and/or
6 c modify it under the terms of the GNU Lesser General Public
7 c License as published by the Free Software Foundation; either
8 c version 2.1 of the License.
10 c This library is distributed in the hope that it will be useful,
11 c but WITHOUT ANY WARRANTY; without even the implied warranty of
12 c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 c Lesser General Public License for more details.
15 c You should have received a copy of the GNU Lesser General Public
16 c License along with this library; if not, write to the Free Software
17 c Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19 c See http://www.ann.jussieu.fr/~perronnet or email perronnet@ann.jussieu.fr
21 c File : trte.f le Fortran du trianguleur plan
23 c Author : Alain PERRONNET
26 subroutine qutr2d( p1, p2, p3, qualite )
27 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
28 c but : calculer la qualite d'un triangle de r**2
29 c ----- 2 coordonnees des 3 sommets en double precision
33 c p1,p2,p3 : les 3 coordonnees des 3 sommets du triangle
34 c sens direct pour une surface et qualite >0
37 c qualite: valeur de la qualite du triangle entre 0 et 1 (equilateral)
38 c 1 etant la qualite optimale
39 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
40 c auteur : alain perronnet analyse numerique upmc paris janvier 1995
41 c2345x7..............................................................012
42 parameter ( d2uxr3 = 3.4641016151377544d0 )
43 c d2uxr3 = 2 * sqrt(3)
44 double precision p1(2), p2(2), p3(2), qualite, a, b, c, p
46 c la longueur des 3 cotes
47 a = sqrt( (p2(1)-p1(1))**2 + (p2(2)-p1(2))**2 )
48 b = sqrt( (p3(1)-p2(1))**2 + (p3(2)-p2(2))**2 )
49 c = sqrt( (p1(1)-p3(1))**2 + (p1(2)-p3(2))**2 )
54 if ( (a*b*c) .ne. 0d0 ) then
55 c critere : 2 racine(3) * rayon_inscrit / plus longue arete
56 qualite = d2uxr3 * sqrt( abs( (p-a) / p * (p-b) * (p-c) ) )
63 c autres criteres possibles:
64 c critere : 2 * rayon_inscrit / rayon_circonscrit
65 c qualite = 8d0 * (p-a) * (p-b) * (p-c) / (a * b * c)
67 c critere : 3*sqrt(3.) * ray_inscrit / demi perimetre
68 c qualite = 3*sqrt(3.) * sqrt ((p-a)*(p-b)*(p-c) / p**3)
70 c critere : 2*sqrt(3.) * ray_inscrit / max( des aretes )
71 c qualite = 2*sqrt(3.) * sqrt( (p-a)*(p-b)*(p-c) / p ) / max(a,b,c)
75 double precision function surtd2( p1 , p2 , p3 )
76 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
77 c but : calcul de la surface d'un triangle defini par 3 points de R**2
79 c parametres d entree :
80 c ---------------------
81 c p1 p2 p3 : les 3 fois 2 coordonnees des sommets du triangle
83 c parametre resultat :
84 c --------------------
85 c surtd2 : surface du triangle
86 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
87 c auteur : alain perronnet analyse numerique upmc paris fevrier 1992
88 c2345x7..............................................................012
89 double precision p1(2), p2(2), p3(2)
91 c la surface du triangle
92 surtd2 = ( ( p2(1)-p1(1) ) * ( p3(2)-p1(2) )
93 % - ( p2(2)-p1(2) ) * ( p3(1)-p1(1) ) ) * 0.5d0
96 integer function nopre3( i )
97 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
98 c but : numero precedent i dans le sens circulaire 1 2 3 1 ...
100 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
101 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
102 c2345x7..............................................................012
110 integer function nosui3( i )
111 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
112 c but : numero suivant i dans le sens circulaire 1 2 3 1 ...
114 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
115 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
116 c2345x7..............................................................012
124 subroutine provec( v1 , v2 , v3 )
125 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
126 c but : v3 vecteur = produit vectoriel de 2 vecteurs de r ** 3
130 c v1, v2 : les 2 vecteurs de 3 composantes
134 c v3 : vecteur = v1 produit vectoriel v2
135 cc++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
136 c auteur : perronnet alain upmc analyse numerique paris mars 1987
137 c2345x7..............................................................012
138 double precision v1(3), v2(3), v3(3)
140 v3( 1 ) = v1( 2 ) * v2( 3 ) - v1( 3 ) * v2( 2 )
141 v3( 2 ) = v1( 3 ) * v2( 1 ) - v1( 1 ) * v2( 3 )
142 v3( 3 ) = v1( 1 ) * v2( 2 ) - v1( 2 ) * v2( 1 )
147 subroutine norme1( n, v, ierr )
148 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
149 c but : normalisation euclidienne a 1 d un vecteur v de n composantes
153 c n : nombre de composantes du vecteur
157 c v : le vecteur a normaliser a 1
161 c ierr : 1 si la norme de v est egale a 0
163 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
164 c auteur : alain perronnet analyse numerique paris mars 1987
165 c ......................................................................
166 double precision v( n ), s, sqrt
170 s = s + v( i ) * v( i )
173 c test de nullite de la norme du vecteur
174 c --------------------------------------
175 if( s .le. 0.0d0 ) then
176 c norme nulle du vecteur non normalisable a 1
181 s = 1.0d0 / sqrt( s )
190 subroutine insoar( mxsomm, mosoar, mxsoar, n1soar, nosoar )
191 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
192 c but : initialiser le tableau nosoar pour le hachage des aretes
197 c mxsomm : plus grand numero de sommet d'une arete au cours du calcul
198 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
199 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
200 c avec mxsoar>=3*mxsomm
204 c n1soar : numero de la premiere arete vide dans le tableau nosoar
205 c une arete i de nosoar est vide <=> nosoar(1,i)=0
206 c chainage des aretes vides amont et aval
207 c l'arete vide qui precede=nosoar(4,i)
208 c l'arete vide qui suit =nosoar(5,i)
209 c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
210 c chainage momentan'e d'aretes, chainage du hachage des aretes
211 c hachage des aretes = min( nosoar(1), nosoar(2) )
212 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
213 c auteur : alain perronnet analyse numerique paris upmc mars 1997
214 c2345x7..............................................................012
215 integer nosoar(mosoar,mxsoar)
217 c initialisation des aretes 1 a mxsomm
220 c sommet 1 = 0 <=> temoin d'arete vide pour le hachage
223 c arete sur aucune ligne
226 c la position de l'arete interne ou frontaliere est inconnue
229 c fin de chainage du hachage pas d'arete suivante
230 nosoar( mosoar, i ) = 0
234 c la premiere arete vide chainee est la mxsomm+1 du tableau
235 c car ces aretes ne sont pas atteignables par le hachage direct
238 c initialisation des aretes vides et des chainages
239 do 20 i = n1soar, mxsoar
241 c sommet 1 = 0 <=> temoin d'arete vide pour le hachage
244 c arete sur aucune ligne
247 c chainage sur l'arete vide qui precede
248 c (si arete occupee cela deviendra le no du triangle 1 de l'arete)
251 c chainage sur l'arete vide qui suit
252 c (si arete occupee cela deviendra le no du triangle 2 de l'arete)
255 c chainages des aretes frontalieres ou internes ou ...
258 c fin de chainage du hachage
259 nosoar( mosoar, i ) = 0
263 c la premiere arete vide n'a pas de precedent
264 nosoar( 4, n1soar ) = 0
266 c la derniere arete vide est mxsoar sans arete vide suivante
267 nosoar( 5, mxsoar ) = 0
271 subroutine azeroi ( l , ntab )
272 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
273 c but : initialisation a zero d un tableau ntab de l variables entieres
275 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
276 c auteur : alain perronnet analyse numerique upmc paris septembre 1988
277 c23456---------------------------------------------------------------012
285 subroutine fasoar( ns1, ns2, nt1, nt2, nolign,
286 % mosoar, mxsoar, n1soar, nosoar, noarst,
288 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
289 c but : former l'arete de sommet ns1-ns2 dans le hachage du tableau
290 c ----- nosoar des aretes de la triangulation
294 c ns1 ns2: numero pxyd des 2 sommets de l'arete
295 c nt1 : numero du triangle auquel appartient l'arete
296 c nt1=-1 si numero inconnu
297 c nt2 : numero de l'eventuel second triangle de l'arete si connu
298 c nt2=-1 si numero inconnu
299 c nolign : numero de la ligne de l'arete dans ladefi(wulftr-1+nolign)
300 c =0 si l'arete n'est une arete de ligne
301 c ce numero est ajoute seulement si l'arete est creee
302 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
303 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
307 c n1soar : numero de la premiere arete vide dans le tableau nosoar
308 c une arete i de nosoar est vide <=> nosoar(1,i)=0
309 c chainage des aretes vides amont et aval
310 c l'arete vide qui precede=nosoar(4,i)
311 c l'arete vide qui suit =nosoar(5,i)
312 c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
313 c chainage momentan'e d'aretes, chainage du hachage des aretes
314 c hachage des aretes = min( nosoar(1), nosoar(2) )
315 c noarst : noarst(np) numero d'une arete du sommet np
317 c ierr : si < 0 en entree pas d'affichage en cas d'erreur du type
318 c "arete appartenant a plus de 2 triangles et a creer!"
319 c si >=0 en entree affichage de ce type d'erreur
323 c noar : >0 numero de l'arete retrouvee ou ajoutee
324 c ierr : =0 si pas d'erreur
325 c =1 si le tableau nosoar est sature
326 c =2 si arete a creer et appartenant a 2 triangles distincts
327 c des triangles nt1 et nt2
328 c =3 si arete appartenant a 2 triangles distincts
329 c differents des triangles nt1 et nt2
330 c =4 si arete appartenant a 2 triangles distincts
331 c dont le second n'est pas le triangle nt2
332 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
333 c auteur : alain perronnet analyse numerique paris upmc mars 1997
334 c2345x7..............................................................012
335 common / unites / lecteu, imprim, nunite(30)
336 integer nosoar(mosoar,mxsoar), noarst(*)
339 c ajout eventuel de l'arete s1 s2 dans nosoar
343 c hachage de l'arete de sommets nu2sar
344 call hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar, noar )
345 c en sortie: noar>0 => no arete retrouvee
346 c <0 => no arete ajoutee
347 c =0 => saturation du tableau nosoar
349 if( noar .eq. 0 ) then
351 c saturation du tableau nosoar
352 write(imprim,*) 'fasoar: tableau nosoar sature'
356 else if( noar .lt. 0 ) then
358 c l'arete a ete ajoutee. initialisation des autres informations
360 c le numero de la ligne de l'arete
361 nosoar(3,noar) = nolign
362 c le triangle 1 de l'arete => le triangle nt1
364 c le triangle 2 de l'arete => le triangle nt2
367 c le sommet appartient a l'arete noar
368 noarst( nu2sar(1) ) = noar
369 noarst( nu2sar(2) ) = noar
373 c l'arete a ete retrouvee.
374 c si elle appartient a 2 triangles differents de nt1 et nt2
375 c alors il y a une erreur
376 if( nosoar(4,noar) .gt. 0 .and.
377 % nosoar(5,noar) .gt. 0 ) then
378 if( nosoar(4,noar) .ne. nt1 .and.
379 % nosoar(4,noar) .ne. nt2 .or.
380 % nosoar(5,noar) .ne. nt1 .and.
381 % nosoar(5,noar) .ne. nt2 ) then
382 c arete appartenant a plus de 2 triangles => erreur
383 if( ierr .ge. 0 ) then
384 write(imprim,*) 'erreur fasoar: arete ',noar,
385 % ' dans 2 triangles et a creer!'
392 c mise a jour du numero des triangles de l'arete noar
393 c le triangle 2 de l'arete => le triangle nt1
394 if( nosoar(4,noar) .lt. 0 ) then
395 c pas de triangle connu pour cette arete
398 c deja un triangle connu. ce nouveau est le second
399 if( nosoar(5,noar) .gt. 0 .and. nt1 .gt. 0 .and.
400 % nosoar(5,noar) .ne. nt1 ) then
401 c arete appartenant a plus de 2 triangles => erreur
402 write(imprim,*) 'erreur fasoar: arete ',noar,
403 % ' dans plus de 2 triangles'
411 c cas de l'arete frontaliere retrouvee comme diagonale d'un quadrangle
412 if( nt2 .gt. 0 ) then
413 c l'arete appartient a 2 triangles
414 if( nosoar(5,noar) .gt. 0 .and.
415 % nosoar(5,noar) .ne. nt2 ) then
416 c arete appartenant a plus de 2 triangles => erreur
417 write(imprim,*) 'erreur fasoar: arete ',noar,
418 % ' dans plus de 2 triangles'
431 subroutine fq1inv( x, y, s, xc, yc, ierr )
432 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
433 c but : calcul des 2 coordonnees (xc,yc) dans le carre (0,1)
434 c ----- image par f:carre unite-->quadrangle appartenant a q1**2
435 c par une resolution directe due a nicolas thenault
439 c x,y : coordonnees du point image dans le quadrangle de sommets s
440 c s : les 2 coordonnees des 4 sommets du quadrangle
444 c xc,yc : coordonnees dans le carre dont l'image par f vaut (x,y)
445 c ierr : 0 si calcul sans erreur, 1 si quadrangle degenere
446 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
447 c auteurs: thenault tulenew analyse numerique paris janvier 1998
448 c modifs : perronnet alain analyse numerique paris janvier 1998
449 c234567..............................................................012
450 real s(1:2,1:4), dist(2)
451 double precision a,b,c,d,alpha,beta,gamma,delta,x0,y0,t(2),u,v,w
456 d = s(1,1) - s(1,2) + s(1,3) - s(1,4)
459 beta = s(2,2) - s(2,1)
460 gamma = s(2,4) - s(2,1)
461 delta = s(2,1) - s(2,2) + s(2,3) - s(2,4)
463 u = beta * c - b * gamma
465 c quadrangle degenere
469 v = delta * c - d * gamma
470 w = b * delta - beta * d
472 x0 = c * (y-alpha) - gamma * (x-a)
473 y0 = b * (y-alpha) - beta * (x-a)
476 b = u * u - w * x0 - v * y0
481 delta = sqrt( b*b-4*a*c )
482 if( b .ge. 0.0 ) then
487 c la racine de plus grande valeur absolue
488 c (elle donne le plus souvent le point exterieur au carre unite
489 c donc a tester en second pour reduire les calculs)
490 t(2) = t(2) / ( 2 * a )
491 c calcul de la seconde racine a partir de la somme => plus stable
496 c la solution i donne t elle un point interne au carre unite?
497 xc = ( x0 - v * t(i) ) / u
498 yc = ( w * t(i) - y0 ) / u
499 if( 0.0 .le. xc .and. xc .le. 1.0 ) then
500 if( 0.0 .le. yc .and. yc .le. 1.0 ) goto 9000
503 c le point (xc,yc) n'est pas dans le carre unite
504 c cela peut etre du aux erreurs d'arrondi
505 c => choix par le minimum de la distance aux bords du carre
506 dist(i) = max( 0.0, -xc, xc-1.0, -yc, yc-1.0 )
510 if( dist(1) .gt. dist(2) ) then
511 c f(xc,yc) pour la racine 2 est plus proche de x,y
512 c xc yc sont deja calcules
516 else if ( b .ne. 0 ) then
522 c les 2 coordonnees du point dans le carre unite
523 xc = ( x0 - v * t(1) ) / u
524 yc = ( w * t(1) - y0 ) / u
531 subroutine ptdatr( point, pxyd, nosotr, nsigne )
532 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
533 c but : le point est il dans le triangle de sommets nosotr
538 c point : les 2 coordonnees du point
539 c pxyd : les 2 coordonnees et distance souhaitee des points du maillage
540 c nosotr : le numero des 3 sommets du triangle
544 c nsigne : >0 si le point est dans le triangle ou sur une des 3 aretes
545 c =0 si le triangle est degenere ou indirect ou ne contient pas le poin
546 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
547 c auteur : alain perronnet analyse numerique paris upmc mars 1997
548 c....................................................................012
550 double precision point(2), pxyd(3,*)
551 double precision xp,yp, x1,x2,x3, y1,y2,y3, d,dd, cb1,cb2,cb3
568 c 2 fois la surface du triangle = determinant de la matrice
569 c de calcul des coordonnees barycentriques du point p
570 d = ( x2 - x1 ) * ( y3 - y1 ) - ( x3 - x1 ) * ( y2 - y1 )
574 c triangle non degenere
575 c =====================
576 c calcul des 3 coordonnees barycentriques du
577 c point xp yp dans le triangle
578 cb1 = ( ( x2-xp ) * ( y3-yp ) - ( x3-xp ) * ( y2-yp ) ) / d
579 cb2 = ( ( x3-xp ) * ( y1-yp ) - ( x1-xp ) * ( y3-yp ) ) / d
581 ccc cb3 = ( ( x1-xp ) * ( y2-yp ) - ( x2-xp ) * ( y1-yp ) ) / d
583 ccc if( cb1 .ge. -0.00005d0 .and. cb1 .le. 1.00005d0 .and.
584 if( cb1 .ge. 0d0 .and. cb1 .le. 1d0 .and.
585 % cb2 .ge. 0d0 .and. cb2 .le. 1d0 .and.
586 % cb3 .ge. 0d0 .and. cb3 .le. 1d0 ) then
588 c le triangle nosotr contient le point
598 c le point est il du meme cote que le sommet oppose de chaque arete?
601 c le sinus de l'angle p1 p2-p1 point
604 d = ( pxyd(1,n2) - x1 ) * ( point(2) - y1 )
605 % - ( pxyd(2,n2) - y1 ) * ( point(1) - x1 )
606 dd = ( pxyd(1,n2) - x1 ) * ( pxyd(2,n3) - y1 )
607 % - ( pxyd(2,n2) - y1 ) * ( pxyd(1,n3) - x1 )
608 cb1 = ( pxyd(1,n2) - x1 ) ** 2
609 % + ( pxyd(2,n2) - y1 ) ** 2
610 cb2 = ( point(1) - x1 ) ** 2
611 % + ( point(2) - y1 ) ** 2
612 cb3 = ( pxyd(1,n3) - x1 ) ** 2
613 % + ( pxyd(2,n3) - y1 ) ** 2
614 if( abs( dd ) .le. 1e-4 * sqrt( cb1 * cb3 ) ) then
615 c le point 3 est sur l'arete 1-2
616 c le point doit y etre aussi
617 if( abs( d ) .le. 1e-4 * sqrt( cb1 * cb2 ) ) then
622 c le point 3 n'est pas sur l'arete . test des signes
623 if( d * dd .ge. 0 ) then
627 c permutation circulaire des 3 sommets et aretes
633 if( nsigne .ne. 3 ) nsigne = 0
637 integer function nosstr( p, pxyd, nt, letree )
638 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
639 c but : calculer le numero 0 a 3 du sous-triangle te contenant
644 c p : point de r**2 contenu dans le te nt de letree
645 c pxyd : x y distance des points
646 c nt : numero letree du te de te voisin a calculer
647 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
648 c letree(0,0) no du 1-er te vide dans letree
649 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
650 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
651 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
652 c si letree(0,.)>0 alors
653 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
655 c letree(0:3,j) :-no pxyd des 1
\85a 4 points internes au triangle j
657 c ( j est alors une feuille de l'arbre )
658 c letree(4,j) : no letree du sur-triangle du triangle j
659 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
660 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
664 c nosstr : 0 si le sous-triangle central contient p
665 c i =1,2,3 numero du sous-triangle contenant p
666 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
667 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
668 c2345x7..............................................................012
669 integer letree(0:8,0:*)
670 double precision pxyd(3,*), p(2),
671 % x1, y1, x21, y21, x31, y31, d, xe, ye
673 c le numero des 3 sommets du triangle
674 ns1 = letree( 6, nt )
675 ns2 = letree( 7, nt )
676 ns3 = letree( 8, nt )
678 c les coordonnees entre 0 et 1 du point p
682 x21 = pxyd(1,ns2) - x1
683 y21 = pxyd(2,ns2) - y1
685 x31 = pxyd(1,ns3) - x1
686 y31 = pxyd(2,ns3) - y1
688 d = 1.0 / ( x21 * y31 - x31 * y21 )
690 xe = ( ( p(1) - x1 ) * y31 - ( p(2) - y1 ) * x31 ) * d
691 ye = ( ( p(2) - y1 ) * x21 - ( p(1) - x1 ) * y21 ) * d
693 if( xe .gt. 0.5d0 ) then
694 c sous-triangle droit
696 else if( ye .gt. 0.5d0 ) then
699 else if( xe+ye .lt. 0.5d0 ) then
700 c sous-triangle gauche
703 c sous-triangle central
709 integer function notrpt( p, pxyd, notrde, letree )
710 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
711 c but : calculer le numero letree du sous-triangle feuille contenant
712 c ----- le point p a partir du te notrde de letree
716 c p : point de r**2 contenu dans le te nt de letree
717 c pxyd : x y distance des points
718 c notrde : numero letree du triangle depart de recherche (1=>racine)
719 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
720 c letree(0,0) no du 1-er te vide dans letree
721 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
722 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
723 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
724 c si letree(0,.)>0 alors
725 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
727 c letree(0:3,j) :-no pxyd des 1
\85 4 points internes au triangle j
729 c ( j est alors une feuille de l'arbre )
730 c letree(4,j) : no letree du sur-triangle du triangle j
731 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
732 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
736 c notrpt : numero letree du triangle contenant le point p
737 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
738 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
739 c2345x7..............................................................012
740 integer letree(0:8,0:*)
741 double precision pxyd(1:3,*), p(2)
743 c la racine depart de la recherche
746 c tant que la feuille n'est pas atteinte descendre l'arbre
747 10 if( letree(0,notrpt) .gt. 0 ) then
749 c recherche du sous-triangle contenant p
750 nsot = nosstr( p, pxyd, notrpt, letree )
752 c le numero letree du sous-triangle
753 notrpt = letree( nsot, notrpt )
760 subroutine teajpt( ns, nbsomm, mxsomm, pxyd, letree,
762 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
763 c but : ajout du point ns de pxyd dans letree
768 c ns : numero du point a ajouter dans letree
769 c mxsomm : nombre maximal de points declarables dans pxyd
770 c pxyd : tableau des coordonnees des points
771 c par point : x y distance_souhaitee
775 c nbsomm : nombre actuel de points dans pxyd
777 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
778 c letree(0,0) : no du 1-er te vide dans letree
779 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
780 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
781 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
782 c si letree(0,.)>0 alors
783 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
785 c letree(0:3,j) :-no pxyd des 1
\85a 4 points internes au triangle j
787 c ( j est alors une feuille de l'arbre )
788 c letree(4,j) : no letree du sur-triangle du triangle j
789 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
790 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
794 c ntrp : numero letree du triangle te ou a ete ajoute le point
795 c ierr : 0 si pas d'erreur, 51 saturation letree, 52 saturation pxyd
796 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
797 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
798 c2345x7..............................................................012
799 integer letree(0:8,0:*)
800 double precision pxyd(3,mxsomm)
802 c depart de la racine
805 c recherche du triangle contenant le point pxyd(ns)
806 1 ntrp = notrpt( pxyd(1,ns), pxyd, ntrp, letree )
808 c existe t il un point libre
810 if( letree(i,ntrp) .eq. 0 ) then
811 c la place i est libre
817 c pas de place libre => 4 sous-triangles sont crees
818 c a partir des 3 milieux des aretes
819 call te4ste( nbsomm, mxsomm, pxyd, ntrp, letree, ierr )
820 if( ierr .ne. 0 ) return
826 subroutine n1trva( nt, lar, letree, notrva, lhpile )
827 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
828 c but : calculer le numero letree du triangle voisin du te nt
829 c ----- par l'arete lar (1 a 3 ) de nt
830 c attention : notrva n'est pas forcement minimal
834 c nt : numero letree du te de te voisin a calculer
835 c lar : numero 1 a 3 de l'arete du triangle nt
836 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
837 c letree(0,0) no du 1-er te vide dans letree
838 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
839 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
840 c letree(0:8,1) : racine de l'arbre (triangle sans sur-triangle)
841 c si letree(0,.)>0 alors
842 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
844 c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
846 c ( j est alors une feuille de l'arbre )
847 c letree(4,j) : no letree du sur-triangle du triangle j
848 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
849 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
853 c notrva : >0 numero letree du te voisin par l'arete lar
854 c =0 si pas de te voisin (racine , ... )
855 c lhpile : =0 si nt et notrva ont meme taille
856 c >0 nt est 4**lhpile fois plus petit que notrva
857 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
858 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
859 c2345x7..............................................................012
860 integer letree(0:8,0:*)
863 c initialisation de la pile
864 c le triangle est empile
868 c tant qu'il existe un sur-triangle
869 10 ntr = lapile( lhpile )
870 if( ntr .eq. 1 ) then
871 c racine atteinte => pas de triangle voisin
877 c le type du triangle ntr
878 nty = letree( 5, ntr )
879 c l'eventuel sur-triangle
880 nsut = letree( 4, ntr )
882 if( nty .eq. 0 ) then
884 c triangle de type 0 => triangle voisin de type precedent(lar)
885 c dans le sur-triangle de ntr
886 c ce triangle remplace ntr dans lapile
887 lapile( lhpile ) = letree( nopre3(lar), nsut )
891 c triangle ntr de type nty>0
892 if( nosui3(nty) .eq. lar ) then
894 c le triangle voisin par lar est le triangle 0
895 lapile( lhpile ) = letree( 0, nsut )
899 c triangle sans voisin direct => passage par le sur-triangle
900 if( nsut .eq. 0 ) then
902 c ntr est la racine => pas de triangle voisin par cette arete
907 c le sur-triangle est empile
909 lapile(lhpile) = nsut
913 c descente aux sous-triangles selon la meme arete
914 20 notrva = lapile( lhpile )
916 30 lhpile = lhpile - 1
917 if( letree(0,notrva) .le. 0 ) then
918 c le triangle est une feuille de l'arbre 0 sous-triangle
919 c lhpile = nombre de differences de niveaux dans l'arbre
922 c le triangle a 4 sous-triangles
923 if( lhpile .gt. 0 ) then
925 c bas de pile non atteint
926 nty = letree( 5, lapile(lhpile) )
927 if( nty .eq. lar ) then
928 c l'oppose est suivant(nty) de notrva
929 notrva = letree( nosui3(nty) , notrva )
931 c l'oppose est precedent(nty) de notrva
932 notrva = letree( nopre3(nty) , notrva )
938 c meme niveau dans l'arbre lhpile = 0
942 subroutine cenced( xy1, xy2, xy3, cetria, ierr )
943 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
944 c but : calcul des coordonnees du centre du cercle circonscrit
945 c ----- du triangle defini par ses 3 sommets de coordonnees
946 c xy1 xy2 xy3 ainsi que le carre du rayon de ce cercle
950 c xy1 xy2 xy3 : les 2 coordonnees des 3 sommets du triangle
951 c ierr : <0 => pas d'affichage si triangle degenere
952 c >=0 => affichage si triangle degenere
956 c cetria : cetria(1)=abcisse du centre
957 c cetria(2)=ordonnee du centre
958 c cetria(3)=carre du rayon 1d28 si triangle degenere
959 c ierr : 0 si triangle non degenere
960 c 1 si triangle degenere
961 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
962 c auteur : perronnet alain upmc analyse numerique paris juin 1995
963 c2345x7..............................................................012
964 parameter (epsurf=1d-7)
965 common / unites / lecteu,imprim,nunite(30)
966 double precision x1,y1,x21,y21,x31,y31,
968 % xy1(2),xy2(2),xy3(2),cetria(3)
970 c le calcul de 2 fois l'aire du triangle
971 c attention l'ordre des 3 sommets est direct ou non
980 aire2 = x21 * y31 - x31 * y21
982 c recherche d'un test relatif peu couteux
983 c pour reperer la degenerescence du triangle
985 % epsurf*(abs(x21)+abs(x31))*(abs(y21)+abs(y31)) ) then
986 c triangle de qualite trop faible
987 if( ierr .ge. 0 ) then
989 c kerr(1) = 'erreur cenced: triangle degenere'
991 write(imprim,*) 'erreur cenced: triangle degenere'
992 write(imprim,10000) xy1,xy2,xy3,aire2
994 10000 format( 3(' x=',g24.16,' y=',g24.16/),' aire*2=',g24.16)
1002 c les 2 coordonnees du centre intersection des 2 mediatrices
1003 c x = (x1+x2)/2 + lambda * (y2-y1)
1004 c y = (y1+y2)/2 - lambda * (x2-x1)
1005 c x = (x1+x3)/2 + rot * (y3-y1)
1006 c y = (y1+y3)/2 - rot * (x3-x1)
1007 c ==========================================================
1008 rot = ((xy2(1)-xy3(1))*x21 + (xy2(2)-xy3(2))*y21) / (2 * aire2)
1010 xc = ( x1 + xy3(1) ) * 0.5d0 + rot * y31
1011 yc = ( y1 + xy3(2) ) * 0.5d0 - rot * x31
1017 cetria(3) = (x1-xc) ** 2 + (y1-yc) ** 2
1019 c pas d'erreur rencontree
1024 double precision function angled( p1, p2, p3 )
1025 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1026 c but : calculer l'angle (p1p2,p1p3) en radians
1031 c p1,p2,p3 : les 2 coordonnees des 3 sommets de l'angle
1032 c sens direct pour une surface >0
1035 c angled : angle (p1p2,p1p3) en radians entre [0 et 2pi]
1036 c 0 si p1=p2 ou p1=p3
1037 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1038 c auteur : alain perronnet analyse numerique upmc paris fevrier 1992
1039 c2345x7..............................................................012
1040 double precision p1(2),p2(2),p3(2),x21,y21,x31,y31,a1,a2,d,c
1048 c longueur des cotes
1049 a1 = x21 * x21 + y21 * y21
1050 a2 = x31 * x31 + y31 * y31
1057 c cosinus de l'angle
1058 c = ( x21 * x31 + y21 * y31 ) / d
1059 if( c .le. -1.d0 ) then
1060 c tilt sur apollo si acos( -1 -eps )
1061 angled = atan( 1.d0 ) * 4.d0
1063 else if( c .ge. 1.d0 ) then
1064 c tilt sur apollo si acos( 1 + eps )
1070 if( x21 * y31 - x31 * y21 .lt. 0 ) then
1071 c demi plan inferieur
1072 angled = 8.d0 * atan( 1.d0 ) - angled
1077 subroutine teajte( mxsomm, nbsomm, pxyd, comxmi,
1078 % aretmx, mxtree, letree,
1080 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1081 c but : initialisation des tableaux letree
1082 c ----- ajout des sommets 1 a nbsomm (valeur en entree) dans letree
1086 c mxsomm : nombre maximal de sommets permis pour la triangulation
1087 c mxtree : nombre maximal de triangles equilateraux (te) declarables
1088 c aretmx : longueur maximale des aretes des triangles equilateraux
1090 c entrees et sorties :
1091 c --------------------
1092 c nbsomm : nombre de sommets apres identification
1093 c pxyd : tableau des coordonnees 2d des points
1094 c par point : x y distance_souhaitee
1095 c tableau reel(3,mxsomm)
1099 c comxmi : coordonnees minimales et maximales des points frontaliers
1100 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
1101 c letree(0,0) : no du 1-er te vide dans letree
1102 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
1103 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
1104 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
1105 c si letree(0,.)>0 alors
1106 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
1108 c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
1110 c ( j est alors une feuille de l'arbre )
1111 c letree(4,j) : no letree du sur-triangle du triangle j
1112 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
1113 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
1115 c ierr : 0 si pas d'erreur
1116 c 51 saturation letree
1117 c 52 saturation pxyd
1118 c 7 tous les points sont alignes
1119 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1120 c auteur : alain perronnet analyse numerique paris upmc juillet 1994
1121 c....................................................................012
1122 integer letree(0:8,0:mxtree)
1123 double precision pxyd(3,mxsomm)
1124 double precision comxmi(3,2)
1125 double precision a(2),s,aretmx,rac3
1127 c protection du nombre de sommets avant d'ajouter ceux de tetree
1130 comxmi(1,1) = min( comxmi(1,1), pxyd(1,i) )
1131 comxmi(1,2) = max( comxmi(1,2), pxyd(1,i) )
1132 comxmi(2,1) = min( comxmi(2,1), pxyd(2,i) )
1133 comxmi(2,2) = max( comxmi(2,2), pxyd(2,i) )
1136 c creation de l'arbre tee
1137 c =======================
1138 c la premiere colonne vide de letree
1140 c chainage des te vides
1144 letree(0,mxtree) = 0
1145 c les maxima des 2 indices de letree
1147 letree(2,0) = mxtree
1150 c aucun point interne au triangle equilateral (te) 1
1155 c pas de sur-triangle
1158 c le numero pxyd des 3 sommets du te 1
1159 letree(6,1) = nbsomm + 1
1160 letree(7,1) = nbsomm + 2
1161 letree(8,1) = nbsomm + 3
1163 c calcul de la largeur et hauteur du rectangle englobant
1164 c ======================================================
1165 a(1) = comxmi(1,2) - comxmi(1,1)
1166 a(2) = comxmi(2,2) - comxmi(2,1)
1167 c la longueur de la diagonale
1168 s = sqrt( a(1)**2 + a(2)**2 )
1170 if( a(k) .lt. 1e-4 * s ) then
1172 write(imprim,*) 'tous les points sont alignes'
1179 c le maximum des ecarts
1182 c le triangle equilateral englobant
1183 c =================================
1184 c ecart du rectangle au triangle equilateral
1185 rac3 = sqrt( 3.0d0 )
1186 arete = a(1) + 2 * aretmx + 2 * ( a(2) + aretmx ) / rac3
1188 c le point nbsomm + 1 en bas a gauche
1190 pxyd(1,nbsomm) = (comxmi(1,1)+comxmi(1,2))*0.5d0 - arete*0.5d0
1191 pxyd(2,nbsomm) = comxmi(2,1) - aretmx
1194 c le point nbsomm + 2 en bas a droite
1196 pxyd(1,nbsomm) = pxyd(1,nbsomm-1) + arete
1197 pxyd(2,nbsomm) = pxyd(2,nbsomm-1)
1200 c le point nbsomm + 3 sommet au dessus
1202 pxyd(1,nbsomm) = pxyd(1,nbsomm-2) + arete * 0.5d0
1203 pxyd(2,nbsomm) = pxyd(2,nbsomm-2) + arete * 0.5d0 * rac3
1206 c ajout des sommets des lignes pour former letree
1207 c ===============================================
1209 c ajout du point i de pxyd a letree
1210 call teajpt( i, nbsomm, mxsomm, pxyd, letree,
1212 if( ierr .ne. 0 ) return
1219 subroutine tetaid( nutysu, dx, dy, longai, ierr )
1220 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1221 c but : calculer la longueur de l'arete ideale en dx,dy
1226 c nutysu : numero de traitement de areteideale() selon le type de surface
1227 c 0 pas d'emploi de la fonction areteideale() => aretmx active
1228 c 1 il existe une fonction areteideale(xyz,xyzdir)
1229 c ... autres options a definir ...
1230 c dx, dy : abscisse et ordonnee dans le plan du point (reel2!)
1234 c longai : longueur de l'areteideale(xyz,xyzdir) autour du point xyz
1235 c ierr : 0 si pas d'erreur, <>0 sinon
1236 c 1 calcul incorrect de areteideale(xyz,xyzdir)
1237 c 2 longueur calculee nulle
1238 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1239 c auteur : alain perronnet analyse numerique paris upmc mars 1997
1240 c2345x7..............................................................012
1241 common / unites / lecteu, imprim, nunite(30)
1243 double precision areteideale
1244 double precision dx, dy, longai
1245 double precision xyz(3), xyzd(3), d0
1248 if( nutysu .gt. 0 ) then
1250 c le point ou se calcule la longueur
1253 c z pour le calcul de la longueur (inactif ici!)
1255 c la direction pour le calcul de la longueur (inactif ici!)
1260 longai = areteideale(xyz,xyzd)
1261 if( longai .lt. 0d0 ) then
1262 write(imprim,10000) xyz
1263 10000 format('attention: longueur de areteideale(',
1264 % g14.6,',',g14.6,',',g14.6,')<=0! => rendue >0' )
1267 if( longai .eq. 0d0 ) then
1268 write(imprim,10001) xyz
1269 10001 format('erreur: longueur de areteideale(',
1270 % g14.6,',',g14.6,',',g14.6,')=0!' )
1278 subroutine tehote( nutysu,
1279 % nbarpi, mxsomm, nbsomm, pxyd,
1281 % letree, mxqueu, laqueu,
1283 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1284 c but : homogeneisation de l'arbre des te a un saut de taille au plus
1285 c ----- prise en compte des distances souhaitees autour des sommets initiaux
1289 c nutysu : numero de traitement de areteideale() selon le type de surface
1290 c 0 pas d'emploi de la fonction areteideale() => aretmx active
1291 c 1 il existe une fonction areteideale()
1292 c dont seules les 2 premieres composantes de uv sont actives
1293 c autres options a definir...
1294 c nbarpi : nombre de sommets de la frontiere + nombre de points internes
1295 c imposes par l'utilisateur
1296 c mxsomm : nombre maximal de sommets permis pour la triangulation et te
1297 c mxqueu : nombre d'entiers utilisables dans laqueu
1298 c comxmi : minimum et maximum des coordonnees de l'objet
1299 c aretmx : longueur maximale des aretes des triangles equilateraux
1300 c permtr : perimetre de la ligne enveloppe dans le plan
1301 c avant mise a l'echelle a 2**20
1305 c nbsomm : nombre de sommets apres identification
1306 c pxyd : tableau des coordonnees 2d des points
1307 c par point : x y distance_souhaitee
1308 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
1309 c letree(0,0) : no du 1-er te vide dans letree
1310 c letree(1,0) : maximum du 1-er indice de letree (ici 8)
1311 c letree(2,0) : maximum declare du 2-eme indice de letree (ici mxtree)
1312 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
1313 c si letree(0,.)>0 alors
1314 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
1316 c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
1318 c ( j est alors une feuille de l'arbre )
1319 c letree(4,j) : no letree du sur-triangle du triangle j
1320 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
1321 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
1325 c laqueu : mxqueu entiers servant de queue pour le parcours de letree
1329 c ierr : 0 si pas d'erreur
1330 c 51 si saturation letree dans te4ste
1331 c 52 si saturation pxyd dans te4ste
1332 c >0 si autre erreur
1333 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1334 c auteur : alain perronnet analyse numerique paris upmc avril 1997
1335 c2345x7..............................................................012
1336 double precision ampli
1337 parameter (ampli=1.34d0)
1338 common / unites / lecteu, imprim, intera, nunite(29)
1340 double precision pxyd(3,mxsomm), d2, aretm2
1341 double precision comxmi(3,2),aretmx,a,s,xrmin,xrmax,yrmin,yrmax
1342 double precision dmin, dmax
1343 integer letree(0:8,0:*)
1345 integer laqueu(1:mxqueu),lequeu
1346 c lequeu : entree dans la queue
1347 c lhqueu : longueur de la queue
1348 c gestion circulaire
1351 equivalence (nuste(1),ns1),(nuste(2),ns2),(nuste(3),ns3)
1353 c existence ou non de la fonction 'taille_ideale' des aretes
1354 c autour du point. ici la carte est supposee isotrope
1355 c ==========================================================
1356 c attention: si la fonction taille_ideale existe
1357 c alors pxyd(3,*) est la taille_ideale dans l'espace initial
1358 c sinon pxyd(3,*) est la distance calculee dans le plan par
1359 c propagation a partir des tailles des aretes de la frontiere
1361 if( nutysu .gt. 0 ) then
1363 c la fonction taille_ideale(x,y,z) existe
1364 c ---------------------------------------
1365 c initialisation de la distance souhaitee autour des points 1 a nbsomm
1367 c calcul de pxyzd(3,i)
1368 call tetaid( nutysu, pxyd(1,i), pxyd(2,i),
1370 if( ierr .ne. 0 ) goto 9999
1375 c la fonction taille_ideale(x,y,z) n'existe pas
1376 c ---------------------------------------------
1377 c prise en compte des distances souhaitees dans le plan
1378 c autour des points frontaliers et des points internes imposes
1379 c toutes les autres distances souhaitees ont ete mis a aretmx
1380 c lors de l'execution du sp teqini
1382 c le sommet i n'est pas un sommet de letree => sommet frontalier
1383 c recherche du sous-triangle minimal feuille contenant le point i
1385 2 nte = notrpt( pxyd(1,i), pxyd, nte, letree )
1386 c la distance au sommet le plus eloigne est elle inferieure
1387 c a la distance souhaitee?
1391 d2 = max( ( pxyd(1,i)-pxyd(1,ns1) )**2 +
1392 % ( pxyd(2,i)-pxyd(2,ns1) )**2
1393 % , ( pxyd(1,i)-pxyd(1,ns2) )**2 +
1394 % ( pxyd(2,i)-pxyd(2,ns2) )**2
1395 % , ( pxyd(1,i)-pxyd(1,ns3) )**2 +
1396 % ( pxyd(2,i)-pxyd(2,ns3) )**2 )
1397 if( d2 .gt. pxyd(3,i)**2 ) then
1398 c le triangle nte trop grand doit etre subdivise en 4 sous-triangle
1399 call te4ste( nbsomm, mxsomm, pxyd, nte, letree,
1401 if( ierr .ne. 0 ) return
1407 c le sous-triangle central de la racine est decoupe systematiquement
1408 c ==================================================================
1410 if( letree(0,2) .le. 0 ) then
1411 c le sous-triangle central de la racine n'est pas subdivise
1412 c il est donc decoupe en 4 soustriangles
1414 call te4ste( nbsomm, mxsomm, pxyd, nte, letree,
1416 if( ierr .ne. 0 ) return
1417 do 4 i=nbsom0+1,nbsomm
1418 c mise a jour de taille_ideale des nouveaux sommets de te
1419 call tetaid( nutysu, pxyd(1,i), pxyd(2,i), pxyd(3,i), ierr )
1420 if( ierr .ne. 0 ) goto 9999
1424 c le carre de la longueur de l'arete de triangles equilateraux
1425 c souhaitee pour le fond de la triangulation
1426 aretm2 = (aretmx*ampli) ** 2
1428 c tout te contenu dans le rectangle englobant doit avoir un
1429 c cote < aretmx et etre de meme taille que les te voisins
1430 c s'il contient un point; sinon un seul saut de taille est permis
1431 c ===============================================================
1432 c le rectangle englobant pour selectionner les te "internes"
1433 c le numero des 3 sommets du te englobant racine de l'arbre des te
1438 c abscisse du milieu de l'arete gauche du te 1
1439 s = ( pxyd(1,ns1) + pxyd(1,ns3) ) / 2
1440 xrmin = min( s, comxmi(1,1) - aretmx ) - a
1441 c abscisse du milieu de l'arete droite du te 1
1442 s = ( pxyd(1,ns2) + pxyd(1,ns3) ) / 2
1443 xrmax = max( s, comxmi(1,2) + aretmx ) + a
1444 yrmin = comxmi(2,1) - aretmx
1445 c ordonnee de la droite passant par les milieus des 2 aretes
1446 c droite gauche du te 1
1447 s = ( pxyd(2,ns1) + pxyd(2,ns3) ) / 2
1448 yrmax = max( s, comxmi(2,2) + aretmx ) + a
1450 c cas particulier de 3 ou 4 ou peu d'aretes frontalieres
1451 if( nbarpi .le. 8 ) then
1452 c tout le triangle englobant (racine) est a prendre en compte
1453 xrmin = pxyd(1,ns1) - a
1454 xrmax = pxyd(1,ns2) + a
1455 yrmin = pxyd(2,ns1) - a
1456 yrmax = pxyd(2,ns3) + a
1462 c initialisation de la queue
1463 5 nbiter = nbiter + 1
1466 c la racine de letree initialise la queue
1469 c tant que la longueur de la queue est >=0 traiter le debut de queue
1470 10 if( lhqueu .ge. 0 ) then
1472 c le triangle te a traiter
1474 if( i .le. 0 ) i = mxqueu + i
1476 c la longueur de la queue est reduite
1479 c nte est il un sous-triangle feuille minimal ?
1480 15 if( letree(0,nte) .gt. 0 ) then
1482 c non les 4 sous-triangles sont mis dans la queue
1483 if( lhqueu + 4 .ge. mxqueu ) then
1484 write(imprim,*) 'tehote: saturation de la queue'
1489 c ajout du sous-triangle i
1492 if( lequeu .gt. mxqueu ) lequeu = lequeu - mxqueu
1493 laqueu( lequeu ) = letree( i, nte )
1499 c ici nte est un triangle minimal non subdivise
1500 c ---------------------------------------------
1501 c le te est il dans le cadre englobant de l'objet ?
1505 if( pxyd(1,ns1) .gt. pxyd(1,ns2) ) then
1512 if( (xrmin .le. dmin .and. dmin .le. xrmax) .or.
1513 % (xrmin .le. dmax .and. dmax .le. xrmax) ) then
1514 if( pxyd(2,ns1) .gt. pxyd(2,ns3) ) then
1521 if( (yrmin .le. dmin .and. dmin .le. yrmax) .or.
1522 % (yrmin .le. dmax .and. dmax .le. yrmax) ) then
1524 c nte est un te feuille et interne au rectangle englobant
1525 c =======================================================
1526 c le carre de la longueur de l'arete du te de numero nte
1527 d2 = (pxyd(1,ns1)-pxyd(1,ns2)) ** 2 +
1528 % (pxyd(2,ns1)-pxyd(2,ns2)) ** 2
1530 if( nutysu .eq. 0 ) then
1532 c il n'existe pas de fonction 'taille_ideale'
1533 c -------------------------------------------
1534 c si la taille effective de l'arete du te est superieure a aretmx
1535 c alors le te est decoupe
1536 if( d2 .gt. aretm2 ) then
1537 c le triangle nte trop grand doit etre subdivise
1538 c en 4 sous-triangles
1539 call te4ste( nbsomm,mxsomm, pxyd,
1540 % nte, letree, ierr )
1541 if( ierr .ne. 0 ) return
1547 c il existe ici une fonction 'taille_ideale'
1548 c ------------------------------------------
1549 c si la taille effective de l'arete du te est superieure au mini
1550 c des 3 tailles_ideales aux sommets alors le te est decoupe
1552 if( d2 .gt. (pxyd(3,nuste(i))*ampli)**2 ) then
1553 c le triangle nte trop grand doit etre subdivise
1554 c en 4 sous-triangles
1556 call te4ste( nbsomm, mxsomm, pxyd,
1557 & nte, letree, ierr )
1558 if( ierr .ne. 0 ) return
1559 do 27 j=nbsom0+1,nbsomm
1560 c mise a jour de taille_ideale des nouveaux sommets de
1561 call tetaid( nutysu, pxyd(1,j), pxyd(2,j),
1563 if( ierr .ne. 0 ) goto 9999
1570 c recherche du nombre de niveaux entre nte et les te voisins par se
1571 c si la difference de subdivisions excede 1 alors le plus grand des
1572 c =================================================================
1575 c noteva triangle voisin de nte par l'arete i
1576 call n1trva( nte, i, letree, noteva, niveau )
1577 if( noteva .le. 0 ) goto 30
1578 c il existe un te voisin
1579 if( niveau .gt. 0 ) goto 30
1580 c nte a un te voisin plus petit ou egal
1581 if( letree(0,noteva) .le. 0 ) goto 30
1582 c nte a un te voisin noteva subdivise au moins une fois
1584 if( nbiter .gt. 0 ) then
1585 c les 2 sous triangles voisins sont-ils subdivises?
1586 ns2 = letree(i,noteva)
1587 if( letree(0,ns2) .le. 0 ) then
1588 c ns2 n'est pas subdivise
1589 ns2 = letree(nosui3(i),noteva)
1590 if( letree(0,ns2) .le. 0 ) then
1591 c les 2 sous-triangles ne sont pas subdivises
1597 c saut>1 => le triangle nte doit etre subdivise en 4 sous-triang
1598 c --------------------------------------------------------------
1600 call te4ste( nbsomm,mxsomm, pxyd, nte, letree,
1602 if( ierr .ne. 0 ) return
1603 if( nutysu .gt. 0 ) then
1604 do 32 j=nbsom0+1,nbsomm
1605 c mise a jour de taille_ideale des nouveaux sommets de te
1606 call tetaid( nutysu, pxyd(1,j), pxyd(2,j),
1608 if( ierr .ne. 0 ) goto 9999
1618 if( nbs0 .lt. nbsomm ) then
1624 c pb dans le calcul de la fonction taille_ideale
1626 9999 write(imprim,*) 'pb dans le calcul de taille_ideale'
1628 c kerr(1) = 'pb dans le calcul de taille_ideale'
1634 subroutine tetrte( comxmi, aretmx, nbarpi, mxsomm, pxyd,
1635 % mxqueu, laqueu, letree,
1636 % mosoar, mxsoar, n1soar, nosoar,
1637 % moartr, mxartr, n1artr, noartr, noarst,
1639 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1640 c but : trianguler les triangles equilateraux feuilles et
1641 c ----- les points de la frontiere et les points internes imposes
1643 c attention: la triangulation finale n'est pas de type delaunay!
1647 c comxmi : minimum et maximum des coordonnees de l'objet
1648 c aretmx : longueur maximale des aretes des triangles equilateraux
1649 c nbarpi : nombre de sommets de la frontiere + nombre de points internes
1650 c imposes par l'utilisateur
1651 c mxsomm : nombre maximal de sommets declarables dans pxyd
1652 c pxyd : tableau des coordonnees 2d des points
1653 c par point : x y distance_souhaitee
1655 c mxqueu : nombre d'entiers utilisables dans laqueu
1656 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
1657 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
1658 c moartr : nombre maximal d'entiers par arete du tableau noartr
1659 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
1660 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
1661 c letree(0,0) : no du 1-er te vide dans letree
1662 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
1663 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
1664 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
1665 c si letree(0,.)>0 alors
1666 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
1668 c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
1670 c ( j est alors une feuille de l'arbre )
1671 c letree(4,j) : no letree du sur-triangle du triangle j
1672 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
1673 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
1677 c n1soar : numero de la premiere arete vide dans le tableau nosoar
1678 c une arete i de nosoar est vide <=> nosoar(1,i)=0
1679 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
1680 c chainage des aretes frontalieres, chainage du hachage des aretes
1681 c hachage des aretes = nosoar(1)+nosoar(2)*2
1682 c noarst : noarst(i) numero d'une arete de sommet i
1686 c laqueu : mxqueu entiers servant de queue pour le parcours de letree
1690 c n1artr : numero du premier triangle vide dans le tableau noartr
1691 c le chainage des triangles vides se fait sur noartr(2,.)
1692 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
1693 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
1694 c ierr : =0 si pas d'erreur
1695 c =1 si le tableau nosoar est sature
1696 c =2 si le tableau noartr est sature
1697 c =3 si aucun des triangles ne contient l'un des points internes d'un t
1698 c =5 si saturation de la queue de parcours de l'arbre des te
1699 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1700 c auteur : alain perronnet analyse numerique paris upmc mars 1997
1701 c2345x7..............................................................012
1702 common / unites / lecteu, imprim, intera, nunite(29)
1704 double precision pxyd(3,mxsomm)
1705 double precision comxmi(3,2),aretmx,a,s,xrmin,xrmax,yrmin,yrmax
1706 double precision dmin, dmax
1708 integer nosoar(mosoar,mxsoar),
1709 % noartr(moartr,mxartr),
1712 integer letree(0:8,0:*)
1713 integer laqueu(1:mxqueu)
1714 c lequeu:entree dans la queue en gestion circulaire
1715 c lhqueu:longueur de la queue en gestion circulaire
1717 integer milieu(3), nutr(1:13)
1719 c le rectangle englobant pour selectionner les te "internes"
1720 c le numero des 3 sommets du te englobant racine de l'arbre des te
1725 c abscisse du milieu de l'arete gauche du te 1
1726 s = ( pxyd(1,ns1) + pxyd(1,ns3) ) / 2
1727 xrmin = min( s, comxmi(1,1) - aretmx ) - a
1728 c abscisse du milieu de l'arete droite du te 1
1729 s = ( pxyd(1,ns2) + pxyd(1,ns3) ) / 2
1730 xrmax = max( s, comxmi(1,2) + aretmx ) + a
1731 yrmin = comxmi(2,1) - aretmx
1732 c ordonnee de la droite passant par les milieus des 2 aretes
1733 c droite gauche du te 1
1734 s = ( pxyd(2,ns1) + pxyd(2,ns3) ) / 2
1735 yrmax = max( s, comxmi(2,2) + aretmx ) + a
1737 c cas particulier de 3 ou 4 ou peu d'aretes frontalieres
1738 if( nbarpi .le. 8 ) then
1739 c tout le triangle englobant (racine) est a prendre en compte
1740 xrmin = pxyd(1,ns1) - a
1741 xrmax = pxyd(1,ns2) + a
1742 yrmin = pxyd(2,ns1) - a
1743 yrmax = pxyd(2,ns3) + a
1746 c initialisation du tableau noartr
1748 c le numero de l'arete est inconnu
1750 c le chainage sur le triangle vide suivant
1753 noartr(2,mxartr) = 0
1756 c parcours des te jusqu'a trianguler toutes les feuilles (triangles eq)
1757 c =====================================================================
1758 c initialisation de la queue sur les te
1762 c la racine de letree initialise la queue
1765 c tant que la longueur de la queue est >=0 traiter le debut de queue
1766 10 if( lhqueu .ge. 0 ) then
1768 c le triangle te a traiter
1770 if( i .le. 0 ) i = mxqueu + i
1772 c la longueur est reduite
1775 c nte est il un sous-triangle feuille (minimal) ?
1776 15 if( letree(0,nte) .gt. 0 ) then
1777 c non les 4 sous-triangles sont mis dans la queue
1778 if( lhqueu + 4 .ge. mxqueu ) then
1779 write(imprim,*) 'tetrte: saturation de la queue'
1784 c ajout du sous-triangle i
1787 if( lequeu .gt. mxqueu ) lequeu = lequeu - mxqueu
1788 laqueu( lequeu ) = letree( i, nte )
1793 c ici nte est un triangle minimal non subdivise
1794 c ---------------------------------------------
1795 c le te est il dans le cadre englobant de l'objet ?
1799 if( pxyd(1,ns1) .gt. pxyd(1,ns2) ) then
1806 if( (xrmin .le. dmin .and. dmin .le. xrmax) .or.
1807 % (xrmin .le. dmax .and. dmax .le. xrmax) ) then
1808 if( pxyd(2,ns1) .gt. pxyd(2,ns3) ) then
1815 if( (yrmin .le. dmin .and. dmin .le. yrmax) .or.
1816 % (yrmin .le. dmax .and. dmax .le. yrmax) ) then
1818 c te minimal et interne au rectangle englobant
1819 c --------------------------------------------
1820 c recherche du nombre de niveaux entre nte et les te voisins
1825 c a priori pas de milieu de l'arete i du te nte
1828 c recherche de noteva te voisin de nte par l'arete i
1829 call n1trva( nte, i, letree, noteva, niveau )
1830 c noteva : >0 numero letree du te voisin par l'arete i
1831 c =0 si pas de te voisin (racine , ... )
1832 c niveau : =0 si nte et noteva ont meme taille
1833 c >0 nte est 4**niveau fois plus petit que noteva
1834 if( noteva .gt. 0 ) then
1835 c il existe un te voisin
1836 if( letree(0,noteva) .gt. 0 ) then
1837 c noteva est plus petit que nte
1838 c => recherche du numero du milieu du cote=sommet du te no
1839 c le sous-te 0 du te noteva
1840 nsot = letree(0,noteva)
1841 c le numero dans pxyd du milieu de l'arete i de nte
1842 milieu( i ) = letree( 5+nopre3(i), nsot )
1849 c triangulation du te nte en fonction du nombre de ses milieux
1850 goto( 50, 100, 200, 300 ) , nbmili + 1
1852 c 0 milieu => 1 triangle = le te nte
1853 c ----------------------------------
1854 50 call f0trte( letree(0,nte), pxyd,
1855 % mosoar, mxsoar, n1soar, nosoar,
1856 % moartr, mxartr, n1artr, noartr,
1858 % nbtr, nutr, ierr )
1859 if( ierr .ne. 0 ) return
1862 c 1 milieu => 2 triangles = 2 demi te
1863 c -----------------------------------
1864 100 call f1trte( letree(0,nte), pxyd, milieu,
1865 % mosoar, mxsoar, n1soar, nosoar,
1866 % moartr, mxartr, n1artr, noartr,
1868 % nbtr, nutr, ierr )
1869 if( ierr .ne. 0 ) return
1872 c 2 milieux => 3 triangles
1873 c -----------------------------------
1874 200 call f2trte( letree(0,nte), pxyd, milieu,
1875 % mosoar, mxsoar, n1soar, nosoar,
1876 % moartr, mxartr, n1artr, noartr,
1878 % nbtr, nutr, ierr )
1879 if( ierr .ne. 0 ) return
1882 c 3 milieux => 4 triangles = 4 quart te
1883 c -------------------------------------
1884 300 call f3trte( letree(0,nte), pxyd, milieu,
1885 % mosoar, mxsoar, n1soar, nosoar,
1886 % moartr, mxartr, n1artr, noartr,
1888 % nbtr, nutr, ierr )
1889 if( ierr .ne. 0 ) return
1898 subroutine aisoar( mosoar, mxsoar, nosoar, na1 )
1899 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1900 c but : chainer en colonne lchain les aretes non vides et
1901 c ----- non frontalieres du tableau nosoar
1905 c mosoar : nombre maximal d'entiers par arete dans le tableau nosoar
1906 c mxsoar : nombre maximal d'aretes frontalieres declarables
1910 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
1911 c nosoar(lchain,i)=arete interne suivante
1915 c na1 : numero dans nosoar de la premiere arete interne
1916 c les suivantes sont nosoar(lchain,na1), ...
1917 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1918 c auteur : alain perronnet analyse numerique paris upmc mars 1997
1919 c....................................................................012
1920 parameter (lchain=6)
1921 integer nosoar(mosoar,mxsoar)
1923 c formation du chainage des aretes internes a echanger eventuellement
1924 c recherche de la premiere arete non vide et non frontaliere
1926 if( nosoar(1,na1) .gt. 0 .and. nosoar(3,na1) .le. 0 ) goto 15
1929 c protection de la premiere arete non vide et non frontaliere
1931 do 20 na=na1+1,mxsoar
1932 if( nosoar(1,na) .gt. 0 .and. nosoar(3,na) .le. 0 ) then
1933 c arete interne => elle est chainee a partir de la precedente
1934 nosoar(lchain,na0) = na
1939 c la derniere arete interne n'a pas de suivante
1940 nosoar(lchain,na0) = 0
1944 subroutine tedela( pxyd, noarst,
1945 % mosoar, mxsoar, n1soar, nosoar, n1ardv,
1946 % moartr, mxartr, n1artr, noartr, modifs )
1947 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1948 c but : pour toutes les aretes chainees dans nosoar(lchain,*)
1949 c ----- du tableau nosoar
1950 c echanger la diagonale des 2 triangles si le sommet oppose
1951 c a un triangle ayant en commun une arete appartient au cercle
1952 c circonscrit de l'autre (violation boule vide delaunay)
1956 c pxyd : tableau des x y distance_souhaitee de chaque sommet
1960 c noarst : noarst(i) numero d'une arete de sommet i
1961 c mosoar : nombre maximal d'entiers par arete dans le tableau nosoar
1962 c mxsoar : nombre maximal d'aretes frontalieres declarables
1963 c n1soar : numero de la premiere arete vide dans le tableau nosoar
1964 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
1965 c n1ardv : numero dans nosoar de la premiere arete du chainage
1966 c des aretes a rendre delaunay
1968 c moartr : nombre d'entiers par triangle dans le tableau noartr
1969 c mxartr : nombre maximal de triangles declarables dans noartr
1970 c n1artr : numero du premier triangle vide dans le tableau noartr
1971 c le chainage des triangles vides se fait sur noartr(2,.)
1972 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
1973 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
1974 c modifs : nombre d'echanges de diagonales pour maximiser la qualite
1975 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1976 c auteur : alain perronnet analyse numerique paris upmc mars 1997
1977 c....................................................................012
1978 parameter (lchain=6)
1979 common / unites / lecteu, imprim, nunite(30)
1980 double precision pxyd(3,*), surtd2, s123, s142, s143, s234,
1981 % s12, s34, a12, cetria(3), r0
1982 integer nosoar(mosoar,mxsoar),
1983 % noartr(moartr,mxartr),
1986 c le nombre d'echanges de diagonales pour minimiser l'aire
1990 c la premiere arete du chainage des aretes a rendre delaunay
1993 c tant que la pile des aretes a echanger eventuellement est non vide
1994 c ==================================================================
1995 20 if( na0 .gt. 0 ) then
1999 c la prochaine arete a traiter
2000 na0 = nosoar(lchain,na0)
2002 c l'arete est marquee traitee avec le numero -1
2003 nosoar(lchain,na) = -1
2005 c l'arete est elle active?
2006 if( nosoar(1,na) .eq. 0 ) goto 20
2008 c si arete frontaliere pas d'echange possible
2009 if( nosoar(3,na) .gt. 0 ) goto 20
2011 c existe-t-il 2 triangles ayant cette arete commune?
2012 if( nosoar(4,na) .le. 0 .or. nosoar(5,na) .le. 0 ) goto 20
2014 c aucun des 2 triangles est-il desactive?
2015 if( noartr(1,nosoar(4,na)) .eq. 0 .or.
2016 % noartr(1,nosoar(5,na)) .eq. 0 ) goto 20
2018 c l'arete appartient a deux triangles actifs
2019 c le numero des 4 sommets du quadrangle des 2 triangles
2020 call mt4sqa( na, moartr, noartr, mosoar, nosoar,
2021 % ns1, ns2, ns3, ns4 )
2022 if( ns4 .eq. 0 ) goto 20
2024 c carre de la longueur de l'arete ns1 ns2
2025 a12 = (pxyd(1,ns2)-pxyd(1,ns1))**2+(pxyd(2,ns2)-pxyd(2,ns1))**2
2027 c comparaison de la somme des aires des 2 triangles
2028 c -------------------------------------------------
2029 c calcul des surfaces des triangles 123 et 142 de cette arete
2030 s123=surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
2031 s142=surtd2( pxyd(1,ns1), pxyd(1,ns4), pxyd(1,ns2) )
2032 s12 = abs( s123 ) + abs( s142 )
2033 if( s12 .le. 0.001*a12 ) goto 20
2035 c calcul des surfaces des triangles 143 et 234 de cette arete
2036 s143=surtd2( pxyd(1,ns1), pxyd(1,ns4), pxyd(1,ns3) )
2037 s234=surtd2( pxyd(1,ns2), pxyd(1,ns3), pxyd(1,ns4) )
2038 s34 = abs( s234 ) + abs( s143 )
2040 if( abs(s34-s12) .gt. 1d-15*s34 ) goto 20
2042 c quadrangle convexe : le critere de delaunay intervient
2043 c ------------------ ---------------------------------
2044 c calcul du centre et rayon de la boule circonscrite a 123
2045 c pas d'affichage si le triangle est degenere
2047 call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), cetria,
2049 if( ierr .gt. 0 ) then
2050 c ierr=1 si triangle degenere => abandon
2054 if( (cetria(1)-pxyd(1,ns4))**2+(cetria(2)-pxyd(2,ns4))**2
2055 % .lt. cetria(3) ) then
2057 c protection contre une boucle infinie sur le meme cercle
2058 if( r0 .eq. cetria(3) ) goto 20
2060 c oui: ns4 est dans le cercle circonscrit a ns1 ns2 ns3
2061 c => ns3 est aussi dans le cercle circonscrit de ns1 ns2 ns4
2063 cccc les 2 triangles d'arete na sont effaces
2065 ccc nt = nosoar(j,na)
2066 cccc trace du triangle nt
2067 ccc call mttrtr( pxyd, nt, moartr, noartr, mosoar, nosoar,
2068 ccc % ncnoir, ncjaun )
2071 c echange de la diagonale 12 par 34 des 2 triangles
2072 call te2t2t( na, mosoar, n1soar, nosoar, noarst,
2073 % moartr, noartr, na34 )
2074 if( na34 .eq. 0 ) goto 20
2077 c l'arete na34 est marquee traitee
2078 nosoar(lchain,na34) = -1
2081 c les aretes internes peripheriques des 2 triangles sont enchainees
2084 cccc trace du triangle nt
2085 ccc call mttrtr( pxyd, nt, moartr, noartr, mosoar, nosoar,
2086 ccc % ncoran, ncgric )
2088 n = abs( noartr(i,nt) )
2089 if( n .ne. na34 ) then
2090 if( nosoar(3,n) .eq. 0 .and.
2091 % nosoar(lchain,n) .eq. -1 ) then
2092 c cette arete marquee est chainee pour etre traitee
2093 nosoar(lchain,n) = na0
2102 c retour en haut de la pile des aretes a traiter
2108 subroutine terefr( nbarpi, pxyd,
2109 % mosoar, mxsoar, n1soar, nosoar,
2110 % moartr, n1artr, noartr, noarst,
2111 % mxarcf, n1arcf, noarcf, larmin, notrcf,
2113 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2114 c but : recherche des aretes de la frontiere non dans la triangulation
2115 c ----- triangulation frontale pour les reobtenir
2117 c attention: le chainage lchain de nosoar devient celui des cf
2122 c nbarpi : numero du dernier point interne impose par l'utilisateur
2123 c pxyd : tableau des coordonnees 2d des points
2124 c par point : x y distance_souhaitee
2125 c mosoar : nombre maximal d'entiers par arete et
2126 c indice dans nosoar de l'arete suivante dans le hachage
2127 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
2128 c attention: mxsoar>3*mxsomm obligatoire!
2129 c moartr : nombre maximal d'entiers par arete du tableau noartr
2130 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
2134 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
2135 c chainage des vides suivant en 3 et precedant en 2 de nosoar
2136 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
2137 c chainage des aretes frontalieres, chainage du hachage des aretes
2138 c hachage des aretes = nosoar(1)+nosoar(2)*2
2139 c avec mxsoar>=3*mxsomm
2140 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
2141 c nosoar(2,arete vide)=l'arete vide qui precede
2142 c nosoar(3,arete vide)=l'arete vide qui suit
2143 c n1artr : numero du premier triangle vide dans le tableau noartr
2144 c le chainage des triangles vides se fait sur noartr(2,.)
2145 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2146 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
2147 c noarst : noarst(i) numero d'une arete de sommet i
2152 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
2153 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
2154 c larmin : tableau (mxarcf) auxiliaire d'entiers
2155 c notrcf : tableau (mxarcf) auxiliaire d'entiers
2159 c nbarpe : nombre d'aretes perdues puis retrouvees
2160 c ierr : =0 si pas d'erreur
2161 c >0 si une erreur est survenue
2162 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2163 c auteur : alain perronnet analyse numerique paris upmc mars 1997
2164 c....................................................................012
2165 parameter (lchain=6)
2166 common / unites / lecteu,imprim,intera,nunite(29)
2167 double precision pxyd(3,*)
2168 integer nosoar(mosoar,mxsoar),
2176 c le nombre d'aretes de la frontiere non arete de la triangulation
2179 c initialisation du chainage des aretes des cf => 0 arete de cf
2180 do 10 narete=1,mxsoar
2181 nosoar( lchain, narete) = -1
2184 c boucle sur l'ensemble des aretes actuelles
2185 c ==========================================
2186 do 30 narete=1,mxsoar
2188 if( nosoar(3,narete) .gt. 0 ) then
2189 c arete appartenant a une ligne => frontaliere
2191 if(nosoar(4,narete) .le. 0 .or. nosoar(5,narete) .le. 0)then
2192 c l'arete narete frontaliere n'appartient pas a 2 triangles
2193 c => elle est perdue
2196 c le numero des 2 sommets de l'arete frontaliere perdue
2197 ns1 = nosoar( 1, narete )
2198 ns2 = nosoar( 2, narete )
2199 c write(imprim,10000) ns1,(pxyd(j,ns1),j=1,2),
2200 c % ns2,(pxyd(j,ns2),j=1,2)
2201 10000 format(' arete perdue a forcer',
2202 % (t24,'sommet=',i6,' x=',g13.5,' y=',g13.5))
2204 c traitement de cette arete perdue ns1-ns2
2205 call tefoar( narete, nbarpi, pxyd,
2206 % mosoar, mxsoar, n1soar, nosoar,
2207 % moartr, n1artr, noartr, noarst,
2208 % mxarcf, n1arcf, noarcf, larmin, notrcf,
2210 if( ierr .ne. 0 ) return
2212 c fin du traitement de cette arete perdue et retrouvee
2220 subroutine tesuex( nblftr, nulftr,
2221 % ndtri0, nbsomm, pxyd, nslign,
2222 % mosoar, mxsoar, nosoar,
2223 % moartr, mxartr, n1artr, noartr, noarst,
2224 % nbtria, letrsu, ierr )
2225 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2226 c but : supprimer du tableau noartr les triangles externes au domaine
2227 c ----- en annulant le numero de leur 1-ere arete dans noartr
2228 c et en les chainant comme triangles vides
2232 c nblftr : nombre de lignes fermees definissant la surface
2233 c nulftr : numero des lignes fermees definissant la surface
2234 c ndtri0 : plus grand numero dans noartr d'un triangle
2235 c pxyd : tableau des coordonnees 2d des points
2236 c par point : x y distance_souhaitee
2237 c nslign : tableau du numero de sommet dans sa ligne pour chaque
2239 c numero du point dans le lexique point si interne impose
2240 c 0 si le point est interne non impose par l'utilisateur
2241 c -1 si le sommet est externe au domaine
2242 c mosoar : nombre maximal d'entiers par arete et
2243 c indice dans nosoar de l'arete suivante dans le hachage
2244 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
2245 c attention: mxsoar>3*mxsomm obligatoire!
2246 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
2247 c chainage des aretes frontalieres, chainage du hachage des aretes
2248 c hachage des aretes = nosoar(1)+nosoar(2)*2
2249 c avec mxsoar>=3*mxsomm
2250 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
2251 c nosoar(2,arete vide)=l'arete vide qui precede
2252 c nosoar(3,arete vide)=l'arete vide qui suit
2253 c moartr : nombre maximal d'entiers par arete du tableau noartr
2254 c mxartr : nombre maximal de triangles declarables
2255 c n1artr : numero du premier triangle vide dans le tableau noartr
2256 c le chainage des triangles vides se fait sur noartr(2,.)
2257 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2258 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
2259 c noarst : noarst(i) numero nosoar d'une arete de sommet i
2263 c nbtria : nombre de triangles internes au domaine
2264 c letrsu : letrsu(nt)=numero du triangle interne, 0 sinon
2265 c noarst : noarst(i) numero nosoar d'une arete du sommet i (modifi'e)
2266 c ierr : 0 si pas d'erreur, >0 sinon
2267 cc++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2268 c auteur : alain perronnet analyse numerique paris upmc mai 1999
2269 c2345x7..............................................................012
2270 double precision pxyd(3,*)
2271 integer nulftr(nblftr),nslign(nbsomm),
2272 % nosoar(mosoar,mxsoar),
2273 % noartr(moartr,mxartr),
2275 integer letrsu(1:ndtri0)
2276 double precision dmin
2278 c les triangles sont a priori non marques
2283 c les aretes sont marquees non chainees
2284 do 10 noar1=1,mxsoar
2285 nosoar(6,noar1) = -2
2288 c recherche du sommet de la triangulation de plus petite abscisse
2289 c ===============================================================
2293 if( pxyd(1,i) .lt. dmin ) then
2294 c le nouveau minimum
2296 if( noar1 .gt. 0 ) then
2297 c le sommet appartient a une arete de triangle
2298 if( nosoar(4,noar1) .gt. 0 ) then
2299 c le nouveau minimum
2307 c une arete de sommet ntmin
2308 noar1 = noarst( ntmin )
2309 c un triangle d'arete noar1
2310 ntmin = nosoar( 4, noar1 )
2311 if( ntmin .le. 0 ) then
2313 c kerr(1) = 'pas de triangle d''abscisse minimale'
2315 write(imprim,*) 'pas de triangle d''abscisse minimale'
2320 c chainage des 3 aretes du triangle ntmin
2321 c =======================================
2322 c la premiere arete du chainage des aretes traitees
2323 noar1 = abs( noartr(1,ntmin) )
2324 na0 = abs( noartr(2,ntmin) )
2325 c elle est chainee sur la seconde arete du triangle ntmin
2326 nosoar(6,noar1) = na0
2327 c les 2 autres aretes du triangle ntmin sont chainees
2328 na1 = abs( noartr(3,ntmin) )
2329 c la seconde est chainee sur la troisieme arete
2331 c la troisieme n'a pas de suivante
2334 c le triangle ntmin est a l'exterieur du domaine
2335 c tous les triangles externes sont marques -123 456 789
2336 c les triangles de l'autre cote d'une arete sur une ligne
2337 c sont marques: no de la ligne de l'arete * signe oppose
2338 c =======================================================
2340 ligne = -123 456 789
2342 40 if( noar1 .ne. 0 ) then
2344 c l'arete noar1 du tableau nosoar est a traiter
2345 c ---------------------------------------------
2347 c l'arete suivante devient la premiere a traiter ensuite
2348 noar1 = nosoar(6,noar1)
2349 c l'arete noar est traitee
2354 c l'un des 2 triangles de l'arete
2356 if( nt .gt. 0 ) then
2358 c triangle deja traite pour une ligne anterieure?
2359 if( letrsu(nt) .ne. 0 .and.
2360 % abs(letrsu(nt)) .ne. ligne ) goto 60
2362 cccc trace du triangle nt en couleur ligne0
2363 ccc call mttrtr( pxyd, nt, moartr, noartr, mosoar, nosoar,
2364 ccc % ligne0, ncnoir )
2366 c le triangle est marque avec la valeur de ligne
2369 c chainage eventuel des autres aretes de ce triangle
2370 c si ce n'est pas encore fait
2373 c le numero na de l'arete j du triangle nt dans nosoar
2374 na = abs( noartr(j,nt) )
2375 if( nosoar(6,na) .ne. -2 ) goto 50
2377 c le numero de 1 a nblftr dans nulftr de la ligne de l'arete
2380 c si l'arete est sur une ligne fermee differente de celle envelo
2381 c et non marquee alors examen du triangle oppose
2382 if( nl .gt. 0 ) then
2384 if( nl .eq. ligne0 ) goto 50
2386 c arete frontaliere de ligne non traitee
2387 c => passage de l'autre cote de la ligne
2388 c le triangle de l'autre cote de la ligne est recherche
2389 if( nt .eq. abs( nosoar(4,na) ) ) then
2394 nt2 = abs( nosoar(nt2,na) )
2395 if( nt2 .gt. 0 ) then
2397 c le triangle nt2 de l'autre cote est marque avec le
2398 c avec le signe oppose de celui de ligne
2399 if( ligne .ge. 0 ) then
2404 letrsu(nt2) = lsigne * nl
2406 c temoin de ligne a traiter ensuite dans nulftr
2407 nulftr(nl) = -abs( nulftr(nl) )
2409 cccc trace du triangle nt2 en jaune borde de magenta
2410 ccc call mttrtr( pxyd,nt2,
2411 ccc % moartr,noartr,mosoar,nosoar,
2412 ccc % ncjaun, ncmage )
2414 c l'arete est traitee
2419 c l'arete est traitee
2424 c arete non traitee => elle est chainee
2425 nosoar(6,na) = noar1
2435 c les triangles de la ligne fermee ont tous ete marques
2436 c plus d'arete chainee
2438 c recherche d'une nouvelle ligne fermee a traiter
2439 c ===============================================
2440 65 do 70 nl=1,nblftr
2441 if( nulftr(nl) .lt. 0 ) goto 80
2443 c plus de ligne fermee a traiter
2446 c tous les triangles de cette composante connexe
2447 c entre ligne et ligne0 vont etre marques
2448 c ==============================================
2449 c remise en etat du numero de ligne
2450 c nl est le numero de la ligne dans nulftr a traiter
2451 80 nulftr(nl) = -nulftr(nl)
2453 if( abs(letrsu(nt2)) .eq. nl ) goto 92
2456 c recherche de l'arete j du triangle nt2 avec ce numero de ligne nl
2459 c le numero de l'arete j du triangle dans nosoar
2461 na0 = abs( noartr(j,nt2) )
2462 if( nl .eq. nosoar(3,na0) ) then
2464 c na0 est l'arete de ligne nl
2465 c l'arete suivante du triangle nt2
2467 c le numero dans nosoar de l'arete i de nt2
2468 na1 = abs( noartr(i,nt2) )
2469 if( nosoar(6,na1) .eq. -2 ) then
2470 c arete non traitee => elle est la premiere du chainage
2472 c pas de suivante dans ce chainage
2478 c l'eventuelle seconde arete suivante
2480 na = abs( noartr(i,nt2) )
2481 if( nosoar(6,na) .eq. -2 ) then
2482 if( na1 .eq. 0 ) then
2483 c 1 arete non traitee et seule a chainer
2487 c 2 aretes a chainer
2493 if( noar1 .gt. 0 ) then
2495 c il existe au moins une arete a visiter pour ligne
2496 c marquage des triangles internes a la ligne nl
2503 c nt2 est le seul triangle de la ligne fermee
2510 c reperage des sommets internes ou externes dans nslign
2511 c nslign(sommet externe au domaine)=-1
2512 c nslign(sommet interne au domaine)= 0
2513 c =====================================================
2514 110 do 170 ns1=1,nbsomm
2515 c tout sommet non sur la frontiere ou interne impose
2516 c est suppose externe
2517 if( nslign(ns1) .eq. 0 ) nslign(ns1) = -1
2520 c les triangles externes sont marques vides dans le tableau noartr
2521 c ================================================================
2525 if( letrsu(nt) .le. 0 ) then
2527 c triangle nt externe
2528 if( noartr(1,nt) .ne. 0 ) then
2529 c la premiere arete est annulee
2531 c le triangle nt est considere comme etant vide
2532 noartr(2,nt) = n1artr
2538 c triangle nt interne
2542 c marquage des 3 sommets du triangle nt
2544 c le numero nosoar de l'arete i du triangle nt
2545 noar = abs( noartr(i,nt) )
2546 c le numero des 2 sommets
2547 ns1 = nosoar(1,noar)
2548 ns2 = nosoar(2,noar)
2549 c mise a jour du numero d'une arete des 2 sommets de l'arete
2550 noarst( ns1 ) = noar
2551 noarst( ns2 ) = noar
2552 c ns1 et ns2 sont des sommets de la triangulation du domaine
2553 if( nslign(ns1) .lt. 0 ) nslign(ns1)=0
2554 if( nslign(ns2) .lt. 0 ) nslign(ns2)=0
2560 c ici tout sommet externe ns verifie nslign(ns)=-1
2562 c les triangles externes sont mis a zero dans nosoar
2563 c ==================================================
2564 do 300 noar=1,mxsoar
2566 if( nosoar(1,noar) .gt. 0 ) then
2568 c le second triangle de l'arete noar
2570 if( nt .gt. 0 ) then
2571 c si le triangle nt est externe
2572 c alors il est supprime pour l'arete noar
2573 if( letrsu(nt) .le. 0 ) nosoar(5,noar)=0
2576 c le premier triangle de l'arete noar
2578 if( nt .gt. 0 ) then
2579 if( letrsu(nt) .le. 0 ) then
2580 c si le triangle nt est externe
2581 c alors il est supprime pour l'arete noar
2582 c et l'eventuel triangle oppose prend sa place
2583 c en position 4 de nosoar
2584 if( nosoar(5,noar) .gt. 0 ) then
2585 nosoar(4,noar)=nosoar(5,noar)
2596 c remise en etat pour eviter les modifications de ladefi
2597 9990 do 9991 nl=1,nblftr
2598 if( nulftr(nl) .lt. 0 ) nulftr(nl)=-nulftr(nl)
2605 subroutine trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
2606 % mxpile, lhpile, lapile )
2607 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2608 c but : recherche des triangles de noartr partageant le sommet ns
2610 c limite: un camembert de centre ns entame 2 fois
2611 c ne donne que l'une des parties
2615 c ns : numero du sommet
2616 c noarst : noarst(i) numero d'une arete de sommet i
2617 c mosoar : nombre maximal d'entiers par arete et
2618 c indice dans nosoar de l'arete suivante dans le hachage
2619 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
2620 c chainage des aretes frontalieres, chainage du hachage des aretes
2621 c moartr : nombre maximal d'entiers par arete du tableau noartr
2622 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2623 c mxpile : nombre maximal de triangles empilables
2627 c lhpile : >0 nombre de triangles empiles
2628 c =0 si impossible de tourner autour du point
2629 c =-lhpile si apres butee sur la frontiere il y a a nouveau
2630 c butee sur la frontiere . a ce stade on ne peut dire si tous
2631 c les triangles ayant ce sommet ont ete recenses
2632 c ce cas arrive seulement si le sommet est sur la frontiere
2633 c lapile : numero dans noartr des triangles de sommet ns
2634 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2635 c auteur : alain perronnet analyse numerique paris upmc mars 1997
2636 c....................................................................012
2637 common / unites / lecteu, imprim, nunite(30)
2638 integer noartr(moartr,*),
2641 integer lapile(1:mxpile)
2646 c la premiere arete de sommet ns
2648 if( nar .le. 0 ) then
2649 write(imprim,*) 'trp1st: sommet',ns,' sans arete'
2653 c l'arete nar est elle active?
2654 if( nosoar(1,nar) .le. 0 ) then
2655 ccc write(imprim,*) 'trp1st: arete vide',nar,
2656 ccc % ' st1:', nosoar(1,nar),' st2:',nosoar(2,nar)
2660 c le premier triangle de sommet ns
2661 nt0 = abs( nosoar(4,nar) )
2662 if( nt0 .le. 0 ) then
2663 write(imprim,*) 'trp1st: sommet',ns,' dans aucun triangle'
2667 c le triangle est il interne?
2668 if( noartr(1,nt0) .eq. 0 ) goto 9999
2670 c le numero des 3 sommets du triangle nt0 dans le sens direct
2671 call nusotr( nt0, mosoar, nosoar, moartr, noartr, nosotr )
2673 c reperage du sommet ns dans le triangle nt0
2675 if( nosotr(nar) .eq. ns ) goto 10
2680 c ns retrouve : le triangle nt0 est empile
2685 c recherche dans le sens des aiguilles d'une montre
2686 c (sens indirect) du triangle nt1 de l'autre cote de l'arete
2687 c nar du triangle et en tournant autour du sommet ns
2688 c ==========================================================
2689 noar = abs( noartr(nar,nt0) )
2690 c le triangle nt1 oppose du triangle nt0 par l'arete noar
2691 if( nosoar(4,noar) .eq. nt0 ) then
2692 nt1 = nosoar(5,noar)
2694 nt1 = nosoar(4,noar)
2697 c la boucle sur les triangles nt1 de sommet ns dans le sens indirect
2698 c ==================================================================
2699 if( nt1 .gt. 0 ) then
2701 if( noartr(1,nt1) .eq. 0 ) goto 30
2703 c le triangle nt1 n'a pas ete detruit. il est actif
2704 c le triangle oppose par l'arete noar existe
2705 c le numero des 3 sommets du triangle nt1 dans le sens direct
2706 15 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
2708 c reperage du sommet ns dans nt1
2710 if( nosotr(nar) .eq. ns ) goto 25
2716 25 if( lhpile .ge. mxpile ) goto 9990
2718 lapile(lhpile) = nt1
2720 c le triangle nt1 de l'autre cote de l'arete de sommet ns
2721 c sauvegarde du precedent triangle dans nta
2723 noar = abs( noartr(nar,nt1) )
2724 if( nosoar(4,noar) .eq. nt1 ) then
2725 nt1 = nosoar(5,noar)
2727 nt1 = nosoar(4,noar)
2729 if( nt1 .le. 0 ) goto 30
2730 c le triangle suivant est a l'exterieur
2731 if( nt1 .ne. nt0 ) goto 15
2733 c recherche terminee par arrivee sur nt0
2734 c les triangles forment un "cercle" de "centre" ns
2739 c pas de triangle voisin a nt1
2740 c ============================
2741 c le parcours passe par 1 des triangles exterieurs
2742 c le parcours est inverse par l'arete de gauche
2743 c le triangle nta est le premier triangle empile
2745 lapile(lhpile) = nta
2747 c le numero des 3 sommets du triangle nta dans le sens direct
2748 call nusotr( nta, mosoar, nosoar, moartr, noartr, nosotr )
2750 if( nosotr(nar) .eq. ns ) goto 33
2754 c l'arete qui precede (rotation / ns dans le sens direct)
2755 33 if( nar .eq. 1 ) then
2761 c le triangle voisin de nta dans le sens direct
2762 noar = abs( noartr(nar,nta) )
2763 if( nosoar(4,noar) .eq. nta ) then
2764 nt1 = nosoar(5,noar)
2766 nt1 = nosoar(4,noar)
2768 if( nt1 .le. 0 ) then
2769 c un seul triangle contient ns
2773 c boucle sur les triangles de sommet ns dans le sens direct
2774 c ==========================================================
2775 40 if( noartr(1,nt1) .eq. 0 ) goto 70
2777 c le triangle nt1 n'a pas ete detruit. il est actif
2778 c le numero des 3 sommets du triangle nt1 dans le sens direct
2779 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
2781 c reperage du sommet ns dans nt1
2783 if( nosotr(nar) .eq. ns ) goto 60
2789 60 if( lhpile .ge. mxpile ) goto 9990
2791 lapile(lhpile) = nt1
2793 c l'arete qui precede dans le sens direct
2794 if( nar .eq. 1 ) then
2800 c l'arete de sommet ns dans nosoar
2801 noar = abs( noartr(nar,nt1) )
2803 c le triangle voisin de nta dans le sens direct
2805 if( nosoar(4,noar) .eq. nt1 ) then
2806 nt1 = nosoar(5,noar)
2808 nt1 = nosoar(4,noar)
2811 if( nt1 .gt. 0 ) goto 40
2813 c butee sur le trou => fin des triangles de sommet ns
2814 c ----------------------------------------------------
2816 c impossible ici de trouver les autres triangles de sommet ns
2817 c les triangles de sommet ns ne forment pas une boule de centre ns
2820 c saturation de la pile des triangles
2821 c -----------------------------------
2822 9990 write(imprim,*)'trp1st: saturation pile des triangles autour ',
2826 c erreur triangle ne contenant pas le sommet ns
2827 c ----------------------------------------------
2828 9995 write(imprim,*) 'trp1st: triangle ',nta,' st=',
2829 % (nosotr(nar),nar=1,3),' sans le sommet' ,ns
2837 subroutine nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
2838 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2839 c but : calcul du numero des 3 sommets du triangle nt de noartr
2840 c ----- dans le sens direct (aire>0 si non degenere)
2844 c nt : numero du triangle dans le tableau noartr
2845 c mosoar : nombre maximal d'entiers par arete
2846 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
2847 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
2848 c moartr : nombre maximal d'entiers par arete du tableau noartr
2849 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2850 c arete1=0 si triangle vide => arete2=triangle vide suivant
2854 c nosotr : numero (dans le tableau pxyd) des 3 sommets du triangle
2855 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2856 c auteur : alain perronnet analyse numerique paris upmc mars 1997
2857 c2345x7..............................................................012
2858 integer nosoar(mosoar,*), noartr(moartr,*), nosotr(3)
2860 c les 2 sommets de l'arete 1 du triangle nt dans le sens direct
2861 na = noartr( 1, nt )
2862 if( na .gt. 0 ) then
2870 nosotr(1) = nosoar( nosotr(1), na )
2871 nosotr(2) = nosoar( nosotr(2), na )
2874 na = abs( noartr(2,nt) )
2876 c le sommet nosotr(3 du triangle 123
2877 nosotr(3) = nosoar( 1, na )
2878 if( nosotr(3) .eq. nosotr(1) .or. nosotr(3) .eq. nosotr(2) ) then
2879 nosotr(3) = nosoar(2,na)
2884 subroutine tesusp( nbarpi, pxyd, noarst,
2885 % mosoar, mxsoar, n1soar, nosoar,
2886 % moartr, mxartr, n1artr, noartr,
2887 % mxarcf, n1arcf, noarcf, larmin, notrcf, liarcf,
2889 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2890 c but : supprimer de la triangulation les sommets de te trop proches
2891 c ----- soit d'un sommet frontalier ou point interne impose
2892 c soit d'une arete frontaliere
2894 c attention: le chainage lchain de nosoar devient celui des cf
2898 c nbarpi : numero du dernier point interne impose par l'utilisateur
2899 c pxyd : tableau des coordonnees 2d des points
2900 c par point : x y distance_souhaitee
2901 c mosoar : nombre maximal d'entiers par arete et
2902 c indice dans nosoar de l'arete suivante dans le hachage
2903 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
2904 c attention: mxsoar>3*mxsomm obligatoire!
2905 c moartr : nombre maximal d'entiers par arete du tableau noartr
2906 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
2910 c noarst : noarst(i) numero d'une arete de sommet i
2911 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
2912 c chainage des vides suivant en 3 et precedant en 2 de nosoar
2913 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
2914 c chainage des aretes frontalieres, chainage du hachage des aretes
2915 c hachage des aretes = nosoar(1)+nosoar(2)*2
2916 c avec mxsoar>=3*mxsomm
2917 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
2918 c nosoar(2,arete vide)=l'arete vide qui precede
2919 c nosoar(3,arete vide)=l'arete vide qui suit
2920 c n1artr : numero du premier triangle vide dans le tableau noartr
2921 c le chainage des triangles vides se fait sur noartr(2,.)
2922 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2923 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
2928 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
2929 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
2930 c larmin : tableau ( mxarcf ) auxiliaire d'entiers
2931 c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
2932 c liarcf : tableau ( mxarcf ) auxiliaire d'entiers
2936 c ierr : =0 si pas d'erreur
2937 c >0 si une erreur est survenue
2938 c 11 algorithme defaillant
2939 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2940 c auteur : alain perronnet analyse numerique paris upmc mars 1997
2941 c....................................................................012
2942 c parameter ( quamal=0.3 ) => ok
2943 c parameter ( quamal=0.4 ) => pb pour le test ocean
2944 c parameter ( quamal=0.5 ) => pb pour le test ocean
2946 parameter ( quamal=0.333, lchain=6 )
2947 common / unites / lecteu,imprim,intera,nunite(29)
2948 double precision pxyd(3,*), qualit
2949 integer nosoar(mosoar,mxsoar),
2959 equivalence (nosotr(1),ns1), (nosotr(2),ns2),
2962 cccc le nombre de sommets de te supprimes
2965 c initialisation du chainage des aretes des cf => 0 arete de cf
2966 do 10 narete=1,mxsoar
2967 nosoar( lchain, narete ) = -1
2970 c boucle sur l'ensemble des sommets frontaliers ou points internes
2971 c ================================================================
2972 do 100 ns = 1, nbarpi
2974 cccc le nombre de sommets supprimes pour ce sommet ns
2977 c la qualite minimale au dessous de laquelle le point proche
2978 c interne est supprime
2981 c une arete de sommet ns
2982 15 narete = noarst( ns )
2983 if( narete .le. 0 ) then
2984 c erreur: le point appartient a aucune arete
2985 write(imprim,*) 'sommet ',ns,' dans aucune arete'
2990 c recherche des triangles de sommet ns
2991 c ils doivent former un contour ferme de type etoile
2992 call trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
2993 % mxarcf, nbtrcf, notrcf )
2994 if( nbtrcf .eq. 0 ) goto 100
2995 if( nbtrcf .lt. 0 ) then
2996 c erreur: impossible de trouver tous les triangles de sommet ns
2997 c seule une partie est a priori retrouvee
3001 c boucle sur les triangles de l'etoile du sommet ns
3005 c le numero des 3 sommets du triangle nt
3007 call nusotr( nt, mosoar, nosoar, moartr, noartr,
3009 c nosotr(1:3) est en equivalence avec ns1, ns2, ns3
3011 c la qualite du triangle ns1 ns2 ns3
3012 call qutr2d( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), qualit )
3013 if( qualit .lt. quamin ) then
3019 c bilan sur la qualite des triangles de sommet ns
3020 if( quamin .lt. quaopt ) then
3022 c recherche du sommet de ntqmin le plus proche et non frontalier
3023 c ==============================================================
3024 c le numero des 3 sommets du triangle nt
3025 call nusotr( ntqmin, mosoar, nosoar, moartr, noartr,
3030 if( nosotr(j) .ne. ns .and. nosotr(j) .gt. nbarpi ) then
3031 d = (pxyd(1,nosotr(j))-pxyd(1,ns))**2
3032 % + (pxyd(2,nosotr(j))-pxyd(2,ns))**2
3033 if( d .lt. quamin ) then
3040 if( nste .gt. 0 ) then
3042 c nste est le sommet le plus proche de ns de ce
3043 c triangle de mauvaise qualite et sommet non encore traite
3044 nste = nosotr( nste )
3046 c nste est un sommet de triangle equilateral
3047 c => le sommet nste va etre supprime
3048 c ==========================================
3049 call te1stm( nste, pxyd, noarst,
3050 % mosoar, mxsoar, n1soar, nosoar,
3051 % moartr, mxartr, n1artr, noartr,
3052 % mxarcf, n1arcf, noarcf,
3053 % larmin, notrcf, liarcf, ierr )
3054 if( ierr .eq. 0 ) then
3055 cccc un sommet de te supprime de plus
3056 ccc nbstsu = nbstsu + 1
3058 else if( ierr .lt. 0 ) then
3059 c le sommet nste est externe donc non supprime
3060 c ou bien le sommet nste est le centre d'un cf dont toutes
3061 c les aretes simples sont frontalieres
3062 c dans les 2 cas le sommet n'est pas supprime
3066 c erreur motivant un arret de la triangulation
3070 cccc boucle jusqu'a obtenir une qualite suffisante
3071 cccc si triangulation tres irreguliere =>
3072 cccc destruction de beaucoup de points internes
3073 cccc les 2 variables suivantes brident ces destructions massives
3074 ccc nbsuns = nbsuns + 1
3075 ccc quaopt = quaopt * 0.8
3076 ccc if( nbsuns .lt. 5 ) goto 15
3082 c write(imprim,*)'retrait de',nbstsu,
3083 c % ' sommets de te trop proches de la frontiere'
3088 subroutine teamqa( nutysu,
3089 % noarst, mosoar, mxsoar, n1soar, nosoar,
3090 % moartr, mxartr, n1artr, noartr,
3091 % mxtrcf, notrcf, nostbo,
3092 % n1arcf, noarcf, larmin,
3093 % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
3095 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3096 c but: si la taille de l'arete moyenne est >ampli*taille souhaitee
3097 c ---- alors ajout d'un sommet barycentre du plus grand triangle
3099 c si la taille de l'arete moyenne est <ampli/2*taille souhaitee
3100 c alors suppression du sommet ns
3101 c sinon le sommet ns devient le barycentre pondere de ses voisins
3103 c remarque: ampli est defini dans $mefisto/mail/tehote.f
3104 c et doit avoir la meme valeur pour eviter trop de modifications
3108 c nutysu : numero de traitement de areteideale() selon le type de surface
3109 c 0 pas d'emploi de la fonction areteideale() => aretmx active
3110 c 1 il existe une fonction areteideale()
3111 c dont seules les 2 premieres composantes de uv sont actives
3112 c autres options a definir...
3113 c noarst : noarst(i) numero d'une arete de sommet i
3114 c mosoar : nombre maximal d'entiers par arete et
3115 c indice dans nosoar de l'arete suivante dans le hachage
3116 c mxsoar : nombre maximal d'aretes frontalieres declarables
3117 c n1soar : numero de la premiere arete vide dans le tableau nosoar
3118 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
3119 c chainage des aretes frontalieres, chainage du hachage des aretes
3120 c moartr : nombre maximal d'entiers par arete du tableau noartr
3121 c mxartr : nombre maximal de triangles declarables dans noartr
3122 c n1artr : numero du premier triangle vide dans le tableau noartr
3123 c le chainage des triangles vides se fait sur noartr(2,.)
3124 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
3125 c mxtrcf : nombre maximal de triangles empilables
3126 c nbarpi : numero du dernier sommet frontalier ou interne impose
3127 c nslign : tableau du numero de sommet dans sa ligne pour chaque
3129 c numero du point dans le lexique point si interne impose
3130 c 0 si le point est interne non impose par l'utilisateur
3131 c -1 si le sommet est externe au domaine
3132 c comxmi : min et max des coordonneees des sommets du maillage
3136 c nbsomm : nombre actuel de sommets de la triangulation
3137 c (certains sommets internes ont ete desactives ou ajoutes)
3138 c pxyd : tableau des coordonnees 2d des points
3142 c notrcf : tableau ( mxtrcf ) auxiliaire d'entiers
3143 c numero dans noartr des triangles de sommet ns
3144 c nostbo : tableau ( mxtrcf ) auxiliaire d'entiers
3145 c numero dans pxyd des sommets des aretes simples de la boule
3146 c n1arcf : tableau (0:mxtrcf) auxiliaire d'entiers
3147 c noarcf : tableau (3,mxtrcf) auxiliaire d'entiers
3148 c larmin : tableau ( mxtrcf ) auxiliaire d'entiers
3149 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3150 c auteur : alain perronnet analyse numerique paris upmc juin 1997
3151 c....................................................................012
3152 double precision ampli,ampli2
3153 parameter (ampli=1.34d0,ampli2=ampli/2d0)
3154 parameter (lchain=6)
3155 common / unites / lecteu, imprim, nunite(30)
3156 double precision pxyd(3,*)
3157 double precision ponder, ponde1, xbar, ybar, x, y, surtd2
3158 double precision d, dmoy
3159 double precision d2d3(3,3)
3160 real origin(3), xyz(3)
3161 integer noartr(moartr,*),
3170 double precision comxmi(3,2)
3173 c le nombre d'iterations pour ameliorer la qualite
3177 c initialisation du parcours
3182 do 5000 iter=1,nbitaq
3184 c le nombre de sommets supprimes
3188 c coefficient de ponderation croissant avec les iterations
3189 ponder = min( 1d0, ( 50 + (50*iter)/nbitaq ) * 0.01d0 )
3190 ponde1 = 1d0 - ponder
3192 c l'ordre du parcours dans le sens croissant ou decroissant
3196 c alternance du parcours
3199 do 1000 ns = nbs1, nbs2, nbs3
3201 c le sommet est il interne au domaine?
3202 if( nslign(ns) .ne. 0 ) goto 1000
3204 c existe-t-il une arete de sommet ns ?
3205 10 noar = noarst( ns )
3206 if( noar .le. 0 ) goto 1000
3208 c le 1-er triangle de l'arete noar
3209 nt = nosoar( 4, noar )
3210 if( nt .le. 0 ) goto 1000
3212 c recherche des triangles de sommet ns
3213 c ils doivent former un contour ferme de type etoile
3214 call trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
3215 % mxtrcf, nbtrcf, notrcf )
3216 if( nbtrcf .le. 0 ) goto 1000
3218 c mise a jour de la distance souhaitee
3219 if( nutysu .gt. 0 ) then
3220 c la fonction taille_ideale(x,y,z) existe
3221 c calcul de pxyzd(3,ns) dans le repere initial => xyz(1:3)
3222 call tetaid( nutysu, pxyd(1,ns), pxyd(2,ns),
3226 c boucle sur les triangles qui forment une boule autour du sommet ns
3228 c chainage des aretes simples de la boule a rendre delaunay
3232 c le numero de l'arete du triangle nt ne contenant pas le sommet ns
3235 c le numero de l'arete na dans le tableau nosoar
3236 noar = abs( noartr(na,nt) )
3237 if( nosoar(1,noar) .ne. ns .and.
3238 % nosoar(2,noar) .ne. ns ) goto 25
3241 c construction de la liste des sommets des aretes simples
3242 c de la boule des triangles de sommet ns
3243 c -------------------------------------------------------
3245 ns1 = nosoar(na,noar)
3247 if( ns1 .eq. nostbo(j) ) goto 35
3249 c ns1 est un nouveau sommet a ajouter
3251 nostbo(nbstbo) = ns1
3254 c noar est une arete potentielle a rendre delaunay
3255 if( nosoar(3,noar) .eq. 0 ) then
3256 c arete non frontaliere
3257 nosoar(lchain,noar) = noar0
3263 c calcul des 2 coordonnees du barycentre de la boule du sommet ns
3264 c calcul de la longueur moyenne des aretes issues du sommet ns
3265 c ---------------------------------------------------------------
3270 x = pxyd(1,nostbo(i))
3271 y = pxyd(2,nostbo(i))
3274 dmoy = dmoy + sqrt( (x-pxyd(1,ns))**2+(y-pxyd(2,ns))**2 )
3276 dmoy = dmoy / nbstbo
3278 c pas de modification de la topologie lors de la derniere iteration
3279 c =================================================================
3280 if( iter .eq. nbitaq ) goto 200
3282 c si la taille de l'arete moyenne est >ampli*taille souhaitee
3283 c alors ajout d'un sommet barycentre du plus grand triangle
3285 c ===========================================================
3286 if( dmoy .gt. ampli*pxyd(3,ns) ) then
3290 c recherche du plus grand triangle en surface
3291 call nusotr( notrcf(i), mosoar, nosoar,
3292 % moartr, noartr, nosotr )
3293 d = surtd2( pxyd(1,nosotr(1)),
3294 % pxyd(1,nosotr(2)),
3295 % pxyd(1,nosotr(3)) )
3296 if( d .gt. dmoy ) then
3302 c ajout du barycentre du triangle notrcf(imax)
3304 call nusotr( nt, mosoar, nosoar,
3305 % moartr, noartr, nosotr )
3306 if( nbsomm .ge. mxsomm ) then
3307 write(imprim,*) 'saturation du tableau pxyd'
3308 c abandon de l'amelioration du sommet ns
3313 pxyd(i,nbsomm) = ( pxyd(i,nosotr(1))
3314 % + pxyd(i,nosotr(2))
3315 % + pxyd(i,nosotr(3)) ) / 3d0
3318 if( nutysu .gt. 0 ) then
3319 c la fonction taille_ideale(x,y,z) existe
3320 c calcul de pxyzd(3,nbsomm) dans le repere initial => xyz(1:3)
3321 call tetaid( nutysu, pxyd(1,nbsomm), pxyd(2,nbsomm),
3322 % pxyd(3,nbsomm), ier )
3325 c sommet interne a la triangulation
3328 c les 3 aretes du triangle nt sont a rendre delaunay
3330 noar = abs( noartr(i,nt) )
3331 if( nosoar(3,noar) .eq. 0 ) then
3332 c arete non frontaliere
3333 if( nosoar(lchain,noar) .lt. 0 ) then
3334 c arete non encore chainee
3335 nosoar(lchain,noar) = noar0
3341 c triangulation du triangle de barycentre nbsomm
3342 c protection a ne pas modifier sinon erreur!
3343 call tr3str( nbsomm, nt,
3344 % mosoar, mxsoar, n1soar, nosoar,
3345 % moartr, mxartr, n1artr, noartr,
3348 if( ierr .ne. 0 ) goto 9999
3350 c un barycentre ajoute de plus
3353 c les aretes chainees de la boule sont rendues delaunay
3358 c si la taille de l'arete moyenne est <ampli/2*taille souhaitee
3359 c alors suppression du sommet ns
3360 c =============================================================
3361 if( dmoy .lt. ampli2*pxyd(3,ns) ) then
3362 c remise a -1 du chainage des aretes peripheriques de la boule ns
3364 90 if( noar .gt. 0 ) then
3365 c protection du no de l'arete suivante
3366 na = nosoar(lchain,noar)
3367 c l'arete interne est remise a -1
3368 nosoar(lchain,noar) = -1
3373 call te1stm( ns, pxyd, noarst,
3374 % mosoar, mxsoar, n1soar, nosoar,
3375 % moartr, mxartr, n1artr, noartr,
3376 % mxtrcf, n1arcf, noarcf,
3377 % larmin, notrcf, nostbo,
3379 if( ierr .eq. -543 ) then
3382 else if( ierr .lt. 0 ) then
3383 c le sommet ns est externe donc non supprime
3384 c ou bien le sommet ns est le centre d'un cf dont toutes
3385 c les aretes simples sont frontalieres
3386 c dans les 2 cas le sommet ns n'est pas supprime
3389 else if( ierr .gt. 0 ) then
3390 c erreur irrecuperable
3398 c les 2 coordonnees du barycentre des sommets des aretes
3399 c simples de la boule du sommet ns
3400 c ======================================================
3401 200 xbar = xbar / nbstbo
3402 ybar = ybar / nbstbo
3404 c ponderation pour eviter les degenerescenses
3405 pxyd(1,ns) = ponde1 * pxyd(1,ns) + ponder * xbar
3406 pxyd(2,ns) = ponde1 * pxyd(2,ns) + ponder * ybar
3408 if( nutysu .gt. 0 ) then
3409 c la fonction taille_ideale(x,y,z) existe
3410 c calcul de pxyzd(3,ns) dans le repere initial => xyz(1:3)
3411 call tetaid( nutysu, pxyd(1,ns), pxyd(2,ns),
3415 c les aretes chainees de la boule sont rendues delaunay
3416 900 call tedela( pxyd, noarst,
3417 % mosoar, mxsoar, n1soar, nosoar, noar0,
3418 % moartr, mxartr, n1artr, noartr, modifs )
3422 ccc write(imprim,11000) nbstsu, nbbaaj
3423 ccc11000 format( i6,' sommets supprimes ' ,
3424 ccc % i6,' barycentres ajoutes' )
3426 c mise a jour pour ne pas oublier les nouveaux sommets
3427 if( nbs1 .gt. nbs2 ) then
3439 subroutine teamsf( nutysu,
3440 % noarst, mosoar, mxsoar, n1soar, nosoar,
3441 % moartr, mxartr, n1artr, noartr,
3442 % mxtrcf, notrcf, nostbo,
3443 % n1arcf, noarcf, larmin,
3444 % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
3446 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3447 c but : modification de la topologie des triangles autour des
3448 c ----- sommets frontaliers et mise en triangulation delaunay locale
3452 c nutysu : numero de traitement de areteideale() selon le type de surface
3453 c 0 pas d'emploi de la fonction areteideale() => aretmx active
3454 c 1 il existe une fonction areteideale()
3455 c dont seules les 2 premieres composantes de uv sont actives
3456 c autres options a definir...
3457 c noarst : noarst(i) numero d'une arete de sommet i
3458 c mosoar : nombre maximal d'entiers par arete et
3459 c indice dans nosoar de l'arete suivante dans le hachage
3460 c mxsoar : nombre maximal d'aretes frontalieres declarables
3461 c n1soar : numero de la premiere arete vide dans le tableau nosoar
3462 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
3463 c chainage des aretes frontalieres, chainage du hachage des aretes
3464 c moartr : nombre maximal d'entiers par arete du tableau noartr
3465 c mxartr : nombre maximal de triangles declarables dans noartr
3466 c n1artr : numero du premier triangle vide dans le tableau noartr
3467 c le chainage des triangles vides se fait sur noartr(2,.)
3468 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
3469 c mxtrcf : nombre maximal de triangles empilables
3470 c nbarpi : numero du dernier sommet frontalier ou interne impose
3471 c nslign : >0 => ns numero du point dans le lexique point si interne impose
3472 c ou => 1 000 000 * n + ns1
3473 c ou n est le numero (1 a nblftr) de la ligne de ce point
3474 c ns1 est le numero du point dans sa ligne
3475 c = 0 si le point est interne non impose par l'utilisateur
3476 c =-1 si le sommet est externe au domaine
3477 c comxmi : min et max des coordonneees des sommets du maillage
3481 c nbsomm : nombre actuel de sommets de la triangulation
3482 c (certains sommets internes ont ete desactives ou ajoutes)
3483 c pxyd : tableau des coordonnees 2d des points
3487 c notrcf : tableau ( mxtrcf ) auxiliaire d'entiers
3488 c numero dans noartr des triangles de sommet ns
3489 c nostbo : tableau ( mxtrcf ) auxiliaire d'entiers
3490 c numero dans pxyd des sommets des aretes simples de la boule
3491 c n1arcf : tableau (0:mxtrcf) auxiliaire d'entiers
3492 c noarcf : tableau (3,mxtrcf) auxiliaire d'entiers
3493 c larmin : tableau ( mxtrcf ) auxiliaire d'entiers
3494 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3495 c auteur : alain perronnet analyse numerique paris upmc janvier 1998
3496 c....................................................................012
3497 parameter (lchain=6)
3498 common / unites / lecteu, imprim, nunite(30)
3499 double precision pxyd(3,*)
3500 double precision a, angle, angled, pi, deuxpi, pis3
3501 double precision d2d3(3,3)
3502 real origin(3), xyz(3)
3503 integer noartr(moartr,*),
3513 double precision comxmi(3,2)
3515 c le nombre d'iterations pour ameliorer la qualite
3520 pi = atan(1d0) * 4d0
3524 c initialisation du parcours
3528 c => pas de traitement sur les points des lignes de la frontiere
3531 do 5000 iter=1,nbitaq
3533 c le nombre de sommets supprimes
3536 c l'ordre du parcours dans le sens croissant ou decroissant
3540 c alternance du parcours
3543 do 1000 ns = nbs1, nbs2, nbs3
3545 c le sommet est il sur une ligne de la frontiere?
3546 c if( nslign(ns) .lt. 1 000 000 ) goto 1000
3548 c traitement d'un sommet d'une ligne de la frontiere
3549 c ==================================================
3550 c existe-t-il une arete de sommet ns ?
3552 if( noar .le. 0 ) goto 1000
3554 c le 1-er triangle de l'arete noar
3555 nt = nosoar( 4, noar )
3556 if( nt .le. 0 ) goto 1000
3558 c recherche des triangles de sommet ns
3559 c ils doivent former un contour ferme de type camembert
3560 call trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
3561 % mxtrcf, nbtrcf, notrcf )
3562 if( nbtrcf .ge. -1 ) goto 1000
3564 c boucle sur les triangles qui forment un camembert autour du sommet n
3567 c angle interne au camembert autour du sommet ns
3571 c le numero de l'arete du triangle nt ne contenant pas le sommet ns
3574 c le numero de l'arete na dans le tableau nosoar
3575 noar = abs( noartr(na,nt) )
3576 if( nosoar(1,noar) .ne. ns .and.
3577 % nosoar(2,noar) .ne. ns ) goto 525
3580 c calcul de l'angle (ns-st1 arete, ns-st2 arete)
3581 525 ns1 = nosoar(1,noar)
3582 ns2 = nosoar(2,noar)
3583 a = angled( pxyd(1,ns), pxyd(1,ns1), pxyd(1,ns2) )
3584 if( a .gt. pi ) a = deuxpi - a
3589 c nombre ideal de triangles autour du sommet ns
3590 n = nint( angle / pis3 )
3591 if( n .le. 1 ) goto 1000
3593 if( nbtrcf .gt. n ) then
3595 c ajout du barycentre du triangle "milieu"
3596 nt = notrcf( (n+1)/2 )
3597 call nusotr( nt, mosoar, nosoar,
3598 % moartr, noartr, nosotr )
3599 if( nbsomm .ge. mxsomm ) then
3600 write(imprim,*) 'saturation du tableau pxyd'
3601 c abandon de l'amelioration du sommet ns
3606 pxyd(i,nbsomm) = ( pxyd(i,nosotr(1))
3607 % + pxyd(i,nosotr(2))
3608 % + pxyd(i,nosotr(3)) ) / 3d0
3611 if( nutysu .gt. 0 ) then
3612 c la fonction taille_ideale(x,y,z) existe
3613 c calcul de pxyzd(3,nbsomm) dans le repere initial => xyz(1:3)
3614 call tetaid( nutysu, pxyd(1,nbsomm), pxyd(2,nbsomm),
3615 % pxyd(3,nbsomm), ier )
3618 c sommet interne a la triangulation
3621 c les 3 aretes du triangle nt sont a rendre delaunay
3624 noar = abs( noartr(i,nt) )
3625 if( nosoar(3,noar) .eq. 0 ) then
3626 c arete non frontaliere
3627 if( nosoar(lchain,noar) .lt. 0 ) then
3628 c arete non encore chainee
3629 nosoar(lchain,noar) = noar0
3635 c triangulation du triangle de barycentre nbsomm
3636 c protection a ne pas modifier sinon erreur!
3637 call tr3str( nbsomm, nt,
3638 % mosoar, mxsoar, n1soar, nosoar,
3639 % moartr, mxartr, n1artr, noartr,
3642 if( ierr .ne. 0 ) goto 9999
3644 c les aretes chainees de la boule sont rendues delaunay
3645 call tedela( pxyd, noarst,
3646 % mosoar, mxsoar, n1soar, nosoar, noar0,
3647 % moartr, mxartr, n1artr, noartr, modifs )
3658 subroutine teamqs( nutysu,
3659 % noarst, mosoar, mxsoar, n1soar, nosoar,
3660 % moartr, mxartr, n1artr, noartr,
3661 % mxtrcf, notrcf, nostbo,
3662 % n1arcf, noarcf, larmin,
3663 % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
3665 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3666 c but : une iteration de barycentrage des points internes
3667 c ----- modification de la topologie pour avoir 4 ou 5 ou 6 triangles
3668 c pour chaque sommet de la triangulation
3669 c mise en triangulation delaunay
3673 c nutysu : numero de traitement de areteideale() selon le type de surface
3674 c 0 pas d'emploi de la fonction areteideale() => aretmx active
3675 c 1 il existe une fonction areteideale()
3676 c dont seules les 2 premieres composantes de uv sont actives
3677 c autres options a definir...
3678 c noarst : noarst(i) numero d'une arete de sommet i
3679 c mosoar : nombre maximal d'entiers par arete et
3680 c indice dans nosoar de l'arete suivante dans le hachage
3681 c mxsoar : nombre maximal d'aretes frontalieres declarables
3682 c n1soar : numero de la premiere arete vide dans le tableau nosoar
3683 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
3684 c chainage des aretes frontalieres, chainage du hachage des aretes
3685 c moartr : nombre maximal d'entiers par arete du tableau noartr
3686 c mxartr : nombre maximal de triangles declarables dans noartr
3687 c n1artr : numero du premier triangle vide dans le tableau noartr
3688 c le chainage des triangles vides se fait sur noartr(2,.)
3689 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
3690 c mxtrcf : nombre maximal de triangles empilables
3691 c nbarpi : numero du dernier sommet frontalier ou interne impose
3692 c nslign : >0 => ns numero du point dans le lexique point si interne impose
3693 c ou => 1 000 000 * n + ns1
3694 c ou n est le numero (1 a nblftr) de la ligne de ce point
3695 c ns1 est le numero du point dans sa ligne
3696 c = 0 si le point est interne non impose par l'utilisateur
3697 c =-1 si le sommet est externe au domaine
3698 c comxmi : min et max des coordonneees des sommets du maillage
3702 c nbsomm : nombre actuel de sommets de la triangulation
3703 c (certains sommets internes ont ete desactives ou ajoutes)
3704 c pxyd : tableau des coordonnees 2d des points
3708 c notrcf : tableau ( mxtrcf ) auxiliaire d'entiers
3709 c numero dans noartr des triangles de sommet ns
3710 c nostbo : tableau ( mxtrcf ) auxiliaire d'entiers
3711 c numero dans pxyd des sommets des aretes simples de la boule
3712 c n1arcf : tableau (0:mxtrcf) auxiliaire d'entiers
3713 c noarcf : tableau (3,mxtrcf) auxiliaire d'entiers
3714 c larmin : tableau ( mxtrcf ) auxiliaire d'entiers
3715 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3716 c auteur : Alain Perronnet Laboratoire J.-L. LIONS Paris UPMC mars 2006
3717 c....................................................................012
3718 parameter (lchain=6)
3719 common / unites / lecteu, imprim, nunite(30)
3720 double precision pxyd(3,*)
3721 double precision ponder, ponde1, xbar, ybar, x, y, d, dmin, dmax
3722 double precision surtd2
3723 double precision d2d3(3,3)
3724 real origin(3), xyz(3)
3725 integer noartr(moartr,*),
3735 double precision comxmi(3,2)
3737 c le nombre d'iterations pour ameliorer la qualite
3741 c initialisation du parcours
3744 c => pas de traitement sur les points des lignes de la frontiere
3747 do 5000 iter=1,nbitaq
3749 c le nombre de sommets supprimes
3752 c les compteurs de passage sur les differents cas
3757 c coefficient de ponderation croissant avec les iterations
3758 ponder = min( 1d0, 0.1d0 + iter * 0.9d0 / nbitaq )
3759 ccc 9 mars 2006 ponder = min( 1d0, ( 50 + (50*iter)/nbitaq ) * 0.01d0 )
3760 ponde1 = 1d0 - ponder
3762 c l'ordre du parcours dans le sens croissant ou decroissant
3766 c alternance du parcours
3769 do 1000 ns = nbs1, nbs2, nbs3
3771 c le sommet est il interne au domaine?
3772 if( nslign(ns) .ne. 0 ) goto 1000
3774 c traitement d'un sommet interne non impose par l'utilisateur
3775 c ===========================================================
3776 c existe-t-il une arete de sommet ns ?
3777 10 noar = noarst( ns )
3778 if( noar .le. 0 ) goto 1000
3780 c le 1-er triangle de l'arete noar
3781 nt = nosoar( 4, noar )
3782 if( nt .le. 0 ) goto 1000
3784 c recherche des triangles de sommet ns
3785 c ils doivent former un contour ferme de type etoile
3786 call trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
3787 % mxtrcf, nbtrcf, notrcf )
3788 if( nbtrcf .le. 2 ) goto 1000
3790 c boucle sur les triangles qui forment une boule autour du sommet ns
3792 c chainage des aretes simples de la boule a rendre delaunay
3796 c le numero de l'arete du triangle nt ne contenant pas le sommet ns
3799 c le numero de l'arete na dans le tableau nosoar
3800 noar = abs( noartr(na,nt) )
3801 if( nosoar(1,noar) .ne. ns .and.
3802 % nosoar(2,noar) .ne. ns ) goto 25
3805 c construction de la liste des sommets des aretes simples
3806 c de la boule des triangles de sommet ns
3807 c -------------------------------------------------------
3809 ns1 = nosoar(na,noar)
3811 if( ns1 .eq. nostbo(j) ) goto 35
3813 c ns1 est un nouveau sommet a ajouter
3815 nostbo(nbstbo) = ns1
3818 c noar est une arete potentielle a rendre delaunay
3819 if( nosoar(3,noar) .eq. 0 ) then
3820 c arete non frontaliere
3821 nosoar(lchain,noar) = noar0
3827 c calcul des 2 coordonnees du barycentre de la boule du sommet ns
3828 c calcul de l'arete de taille maximale et minimale issue de ns
3829 c ---------------------------------------------------------------
3835 x = pxyd(1,nostbo(i))
3836 y = pxyd(2,nostbo(i))
3839 d = (x-pxyd(1,ns)) ** 2 + (y-pxyd(2,ns)) ** 2
3840 if( d .gt. dmax ) then
3844 if( d .lt. dmin ) then
3850 c pas de modification de la topologie lors de la derniere iteration
3851 c =================================================================
3852 if( iter .ge. nbitaq ) goto 200
3854 c si la boule de ns contient au plus 3 triangles
3855 c => pas de changement de topologie
3856 c ==============================================
3857 if( nbtrcf .le. 3 ) goto 200
3859 c si la boule de ns contient 4 triangles le sommet ns est detruit
3860 c ===============================================================
3861 if( nbtrcf .eq. 4 ) then
3863 c remise a -1 du chainage des aretes peripheriques de la boule ns
3865 60 if( noar .gt. 0 ) then
3866 c protection du no de l'arete suivante
3867 na = nosoar(lchain,noar)
3868 c l'arete interne est remise a -1
3869 nosoar(lchain,noar) = -1
3874 call te1stm( ns, pxyd, noarst,
3875 % mosoar, mxsoar, n1soar, nosoar,
3876 % moartr, mxartr, n1artr, noartr,
3877 % mxtrcf, n1arcf, noarcf,
3878 % larmin, notrcf, nostbo,
3880 if( ierr .eq. -543 ) then
3883 else if( ierr .lt. 0 ) then
3884 c le sommet ns est externe donc non supprime
3885 c ou bien le sommet ns est le centre d'un cf dont toutes
3886 c les aretes simples sont frontalieres
3887 c dans les 2 cas le sommet ns n'est pas supprime
3890 else if( ierr .eq. 0 ) then
3894 c erreur irrecuperable
3896 % 'teamqs: erreur1 irrecuperable en sortie te1stm'
3903 c si la boule de ns contient 5 triangles et a un sommet voisin
3904 c sommet de 5 triangles alors l'arete joignant ces 2 sommets
3905 c est transformee en un seul sommet de 6 triangles
3906 c ============================================================
3907 if( nbtrcf .eq. 5 ) then
3910 c le numero du sommet de l'arete i et different de ns
3912 c la liste des triangles de sommet ns1
3913 call trp1st( ns1, noarst,
3914 % mosoar, nosoar, moartr, noartr,
3915 % mxtrcf-5, nbtrc1, notrcf(6) )
3916 if( nbtrc1 .eq. 5 ) then
3918 c l'arete de sommets ns-ns1 devient un point
3919 c par suppression du sommet ns
3921 c remise a -1 du chainage des aretes peripheriques de la boul
3923 70 if( noar .gt. 0 ) then
3924 c protection du no de l'arete suivante
3925 na = nosoar(lchain,noar)
3926 c l'arete interne est remise a -1
3927 nosoar(lchain,noar) = -1
3933 c le point ns1 devient le milieu de l'arete ns-ns1
3938 pxyd(j,ns1) = (pxyd(j,ns) + pxyd(j,ns1)) * 0.5d0
3941 if( nutysu .gt. 0 ) then
3942 c la fonction taille_ideale(x,y,z) existe
3943 c calcul de pxyzd(3,ns1) dans le repere initial => xyz(1:3
3944 call tetaid( nutysu,pxyd(1,ns1),pxyd(2,ns1),
3945 % pxyd(3,ns1), ier )
3948 c suppression du point ns et mise en delaunay
3949 call te1stm( ns, pxyd, noarst,
3950 % mosoar, mxsoar, n1soar, nosoar,
3951 % moartr, mxartr, n1artr, noartr,
3952 % mxtrcf, n1arcf, noarcf,
3953 % larmin, notrcf, nostbo,
3955 if( ierr .lt. 0 ) then
3956 c le sommet ns est externe donc non supprime
3957 c ou bien le sommet ns est le centre d'un cf dont toutes
3958 c les aretes simples sont frontalieres ou erreur
3959 c dans les 3 cas le sommet ns n'est pas supprime
3960 c restauration du sommet ns1 a son ancienne place
3966 else if( ierr .eq. 0 ) then
3971 c erreur irrecuperable
3973 % 'teamqs: erreur2 irrecuperable en sortie te1stm'
3980 c si la boule de ns contient au moins 8 triangles
3981 c alors un triangle interne est ajoute + 3 triangles (1 par arete)
3982 c ================================================================
3983 if( nbtrcf .ge. 8 ) then
3985 c modification des coordonnees du sommet ns
3986 c il devient le barycentre du triangle notrcf(1)
3987 call nusotr( notrcf(1), mosoar, nosoar,
3988 % moartr, noartr, nosotr )
3990 pxyd(i,ns) = ( pxyd(i,nosotr(1,1))
3991 % + pxyd(i,nosotr(2,1))
3992 % + pxyd(i,nosotr(3,1)) ) / 3d0
3995 if( nutysu .gt. 0 ) then
3996 c la fonction taille_ideale(x,y,z) existe
3997 c calcul de pxyzd(3,nbsomm) dans le repere initial => xyz(1:3)
3998 call tetaid( nutysu, pxyd(1,ns), pxyd(2,ns),
4002 c ajout des 2 autres sommets comme barycentres des triangles
4003 c notrcf(1+nbtrcf/3) et notrcf(1+2*nbtrcf/3)
4004 nbt1 = ( nbtrcf + 1 ) / 3
4007 c le triangle traite
4008 nt = notrcf(1 + n * nbt1 )
4010 c le numero pxyd de ses 3 sommets
4011 call nusotr( nt, mosoar, nosoar,
4012 % moartr, noartr, nosotr )
4014 c ajout du nouveau barycentre
4015 if( nbsomm .ge. mxsomm ) then
4016 write(imprim,*) 'teamqs: saturation du tableau pxyd'
4017 c abandon de l'amelioration
4022 pxyd(i,nbsomm) = ( pxyd(i,nosotr(1,1))
4023 % + pxyd(i,nosotr(2,1))
4024 % + pxyd(i,nosotr(3,1)) ) / 3d0
4027 if( nutysu .gt. 0 ) then
4028 c la fonction taille_ideale(x,y,z) existe
4029 c calcul de pxyzd(3,nbsomm) dans le repere initial => xyz(1:3
4030 call tetaid( nutysu, pxyd(1,nbsomm),pxyd(2,nbsomm),
4031 % pxyd(3,nbsomm), ier )
4034 c sommet interne a la triangulation
4037 c les 3 aretes du triangle nt sont a rendre delaunay
4039 noar = abs( noartr(i,nt) )
4040 if( nosoar(3,noar) .eq. 0 ) then
4041 c arete non frontaliere
4042 if( nosoar(lchain,noar) .lt. 0 ) then
4043 c arete non encore chainee
4044 nosoar(lchain,noar) = noar0
4050 c triangulation du triangle de barycentre nbsomm
4051 c protection a ne pas modifier sinon erreur!
4052 call tr3str( nbsomm, nt,
4053 % mosoar, mxsoar, n1soar, nosoar,
4054 % moartr, mxartr, n1artr, noartr,
4057 if( ierr .ne. 0 ) then
4059 % 'teamqs: erreur irrecuperable en sortie tr3str'
4066 c les aretes chainees de la boule sont rendues delaunay
4071 c nbtrcf est compris entre 5 et 7 => barycentrage simple
4072 c ======================================================
4073 c les 2 coordonnees du barycentre des sommets des aretes
4074 c simples de la boule du sommet ns
4075 200 xbar = xbar / nbstbo
4076 ybar = ybar / nbstbo
4078 C DEBUT AJOUT 21/MAI/2005
4079 C PONDERATION POUR EVITER LES DEGENERESCENSES AVEC PROTECTION
4080 C SI UN TRIANGLE DE SOMMET NS A UNE AIRE NEGATIVE APRES BARYCENTRAGE
4081 C ALORS LE SOMMET NS N'EST PAS BOUGE
4083 c protection des XY du point initial
4087 pxyd(1,ns) = ponde1 * pxyd(1,ns) + ponder * xbar
4088 pxyd(2,ns) = ponde1 * pxyd(2,ns) + ponder * ybar
4090 ccc write(imprim,*)'teamqs 200: ns=',ns,' ancien =',xxx,yyy
4091 ccc write(imprim,*)'teamqs 200: ns=',ns,' nouveau=',pxyd(1,ns),pxyd(2,ns)
4094 c le numero de l'arete du triangle nt ne contenant pas le sommet ns
4097 c le numero de l'arete na dans le tableau nosoar
4098 noar = abs( noartr(na,nt) )
4099 if( nosoar(1,noar) .ne. ns .and.
4100 % nosoar(2,noar) .ne. ns ) then
4101 if( noartr(na,nt) .ge. 0 ) then
4102 ns2 = nosoar(1,noar)
4103 ns3 = nosoar(2,noar)
4105 ns3 = nosoar(1,noar)
4106 ns2 = nosoar(2,noar)
4112 c aire signee du triangle nt
4113 225 d = surtd2( pxyd(1,ns), pxyd(1,ns2), pxyd(1,ns3) )
4114 if( d .le. 0d0 ) then
4115 ccc write(imprim,*),'iter=',iter,
4116 ccc % ' Barycentrage au point ns=',ns,
4117 ccc % ' XB=',pxyd(1,ns),' YB=',pxyd(2,ns),
4118 ccc % ' => triangle avec AIRE<0 => Pt REMIS en X =',xxx,
4126 C FIN AJOUT 21/MAI/2005
4128 c les aretes chainees de la boule sont rendues delaunay
4129 300 call tedela( pxyd, noarst,
4130 % mosoar, mxsoar, n1soar, nosoar, noar0,
4131 % moartr, mxartr, n1artr, noartr, modifs )
4135 ccc write(imprim,11000) iter, nbitaq, nbst4, nbst5, nbst8
4136 ccc11000 format( 'teamqs iter=',i2,' max iter=',i2,':',
4137 ccc % i7,' sommets de 4t',
4138 ccc % i7,' sommets 5t+5t',
4139 ccc % i7,' sommets >7t' )
4141 c mise a jour pour ne pas oublier les nouveaux sommets
4142 if( nbs1 .gt. nbs2 ) then
4156 subroutine teamqt( nutysu,
4157 % noarst, mosoar, mxsoar, n1soar, nosoar,
4158 % moartr, mxartr, n1artr, noartr,
4159 % mxarcf, notrcf, nostbo,
4160 % n1arcf, noarcf, larmin,
4161 % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
4163 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4164 c but : amelioration de la qualite de la triangulation
4169 c nutysu : numero de traitement de areteideale() selon le type de surface
4170 c 0 pas d'emploi de la fonction areteideale() => aretmx active
4171 c 1 il existe une fonction areteideale()
4172 c dont seules les 2 premieres composantes de uv sont actives
4173 c autres options a definir...
4174 c noarst : noarst(i) numero d'une arete de sommet i
4175 c mosoar : nombre maximal d'entiers par arete et
4176 c indice dans nosoar de l'arete suivante dans le hachage
4177 c mxsoar : nombre maximal d'aretes frontalieres declarables
4178 c n1soar : numero de la premiere arete vide dans le tableau nosoar
4179 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4180 c chainage des aretes frontalieres, chainage du hachage des aretes
4181 c moartr : nombre maximal d'entiers par arete du tableau noartr
4182 c mxartr : nombre maximal de triangles declarables dans noartr
4183 c n1artr : numero du premier triangle vide dans le tableau noartr
4184 c le chainage des triangles vides se fait sur noartr(2,.)
4185 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4186 c mxarcf : nombre maximal de triangles empilables
4187 c nbarpi : numero du dernier sommet frontalier ou interne impose
4188 c nslign : tableau du numero de sommet dans sa ligne pour chaque
4190 c numero du point dans le lexique point si interne impose
4191 c 0 si le point est interne non impose par l'utilisateur
4192 c -1 si le sommet est externe au domaine
4193 c comxmi : min et max des coordonneees des sommets du maillage
4197 c nbsomm : nombre actuel de sommets de la triangulation
4198 c (certains sommets internes ont ete desactives ou ajoutes)
4199 c pxyd : tableau des coordonnees 2d des points
4203 c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
4204 c numero dans noartr des triangles de sommet ns
4205 c nostbo : tableau ( mxarcf ) auxiliaire d'entiers
4206 c numero dans pxyd des sommets des aretes simples de la boule
4207 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
4208 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
4209 c larmin : tableau ( mxarcf ) auxiliaire d'entiers
4210 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4211 c auteur : alain perronnet analyse numerique paris upmc juin 1997
4212 c....................................................................012
4213 common / unites / lecteu, imprim, nunite(30)
4214 double precision pxyd(3,*), d2d3(3,3)
4215 integer noartr(moartr,*),
4224 double precision comxmi(3,2)
4226 c suppression des sommets de triangles equilateraux trop proches
4227 c d'un sommet frontalier ou d'un point interne impose par
4228 c triangulation frontale de l'etoile et mise en delaunay
4229 c ==============================================================
4230 call tesusp( nbarpi, pxyd, noarst,
4231 % mosoar, mxsoar, n1soar, nosoar,
4232 % moartr, mxartr, n1artr, noartr,
4233 % mxarcf, n1arcf, noarcf, larmin, notrcf, nostbo,
4235 if( ierr .ne. 0 ) goto 9999
4237 c ajustage des tailles moyennes des aretes avec ampli=1.34d0 entre
4238 c ampli/2 x taille_souhaitee et ampli x taille_souhaitee
4239 c + barycentrage des sommets et mise en triangulation delaunay
4240 c ================================================================
4241 call teamqa( nutysu,
4242 % noarst, mosoar, mxsoar, n1soar, nosoar,
4243 % moartr, mxartr, n1artr, noartr,
4244 % mxarcf, notrcf, nostbo,
4245 % n1arcf, noarcf, larmin,
4246 % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
4248 if( ierr .ne. 0 ) goto 9999
4250 cccc modification de la topologie autour des sommets frontaliers
4251 cccc pour avoir un nombre de triangles egal a l'angle/60 degres
4252 cccc et mise en triangulation delaunay locale
4253 cccc ===========================================================
4254 ccc call teamsf( nutysu,
4255 ccc % noarst, mosoar, mxsoar, n1soar, nosoar,
4256 ccc % moartr, mxartr, n1artr, noartr,
4257 ccc % mxarcf, notrcf, nostbo,
4258 ccc % n1arcf, noarcf, larmin,
4259 ccc % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
4261 ccc if( ierr .ne. 0 ) goto 9999
4263 c quelques iterations de barycentrage des points internes
4264 c modification de la topologie pour avoir 4 ou 5 ou 6 triangles
4265 c pour chaque sommet de la triangulation
4266 c et mise en triangulation delaunay
4267 c =============================================================
4268 call teamqs( nutysu,
4269 % noarst, mosoar, mxsoar, n1soar, nosoar,
4270 % moartr, mxartr, n1artr, noartr,
4271 % mxarcf, notrcf, nostbo,
4272 % n1arcf, noarcf, larmin,
4273 % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
4279 subroutine trfrcf( nscent, mosoar, nosoar, moartr, noartr,
4280 % nbtrcf, notrcf, nbarfr )
4281 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4282 c but : calculer le nombre d'aretes simples du contour ferme des
4283 c ----- nbtrcf triangles de numeros stockes dans le tableau notrcf
4284 c ayant tous le sommet nscent
4288 c nscent : numero du sommet appartenant a tous les triangles notrcf
4289 c mosoar : nombre maximal d'entiers par arete et
4290 c indice dans nosoar de l'arete suivante dans le hachage
4291 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4292 c chainage des aretes frontalieres, chainage du hachage des aretes
4293 c moartr : nombre maximal d'entiers par arete du tableau noartr
4294 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4295 c nbtrcf : >0 nombre de triangles empiles
4296 c =0 si impossible de tourner autour du point
4297 c =-nbtrcf si apres butee sur la frontiere il y a a nouveau
4298 c butee sur la frontiere . a ce stade on ne peut dire si tous
4299 c les triangles ayant ce sommet ont ete recenses
4300 c ce cas arrive seulement si le sommet est sur la frontiere
4301 c notrcf : numero dans noartr des triangles de sommet ns
4305 c nbarfr : nombre d'aretes simples frontalieres
4306 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4307 c auteur : alain perronnet analyse numerique paris upmc juin 1997
4308 c....................................................................012
4309 integer noartr(moartr,*),
4315 c le numero du triangle n dans le tableau noartr
4317 c parcours des 3 aretes du triangle nt
4319 c le numero de l'arete i dans le tableau nosoar
4320 noar = abs( noartr( i, nt ) )
4322 c le numero du sommet j de l'arete noar
4323 ns = nosoar( j, noar )
4324 if( ns .eq. nscent ) goto 40
4326 c l'arete noar (sans sommet nscent) est elle frontaliere?
4327 if( nosoar( 5, noar ) .le. 0 ) then
4328 c l'arete appartient au plus a un triangle
4329 c une arete simple frontaliere de plus
4332 c le triangle a au plus une arete sans sommet nscent
4338 subroutine int2ar( p1, p2, p3, p4, oui )
4339 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4340 c but : les 2 aretes de r**2 p1-p2 p3-p4 s'intersectent elles
4341 c ----- entre leurs sommets?
4345 c p1,p2,p3,p4 : les 2 coordonnees reelles des sommets des 2 aretes
4349 c oui : .true. si intersection, .false. sinon
4350 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4351 c auteur : alain perronnet analyse numerique paris upmc octobre 1991
4352 c2345x7..............................................................012
4353 double precision p1(2),p2(2),p3(2),p4(2)
4354 double precision x21,y21,d21,x43,y43,d43,d,x,y,xx
4357 c longueur des aretes
4360 d21 = x21**2 + y21**2
4364 d43 = x43**2 + y43**2
4366 c les 2 aretes sont-elles jugees paralleles ?
4367 d = x43 * y21 - y43 * x21
4368 if( abs(d) .le. 0.001 * sqrt(d21 * d43) ) then
4369 c aretes paralleles . pas d'intersection
4374 c les 2 coordonnees du point d'intersection
4375 x = ( p1(1)*x43*y21 - p3(1)*x21*y43 - (p1(2)-p3(2))*x21*x43 ) / d
4376 y =-( p1(2)*y43*x21 - p3(2)*y21*x43 - (p1(1)-p3(1))*y21*y43 ) / d
4378 c coordonnees de x,y dans le repere ns1-ns2
4379 xx = ( x - p1(1) ) * x21 + ( y - p1(2) ) * y21
4380 c le point est il entre p1 et p2 ?
4381 oui = -0.00001d0*d21 .le. xx .and. xx .le. 1.00001d0*d21
4383 c coordonnees de x,y dans le repere ns3-ns4
4384 xx = ( x - p3(1) ) * x43 + ( y - p3(2) ) * y43
4385 c le point est il entre p3 et p4 ?
4386 oui = oui .and. -0.00001d0*d43 .le. xx .and. xx .le. 1.00001d0*d43
4390 subroutine trchtd( pxyd, nar00, nar0, noarcf,
4391 % namin0, namin, larmin )
4392 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4393 c but : recherche dans le contour ferme du sommet qui joint a la plus
4394 c ----- courte arete nar00 donne le triangle sans intersection
4395 c avec le contour ferme de meilleure qualite
4399 c pxyd : tableau des coordonnees des sommets et distance_souhaitee
4401 c entrees et sorties:
4402 c -------------------
4403 c nar00 : numero dans noarcf de l'arete avant nar0
4404 c nar0 : numero dans noarcf de la plus petite arete du contour ferme
4405 c a joindre a noarcf(1,namin) pour former le triangle ideal
4406 c noarcf : numero du sommet , numero de l'arete suivante
4407 c numero du triangle exterieur a l'etoile
4411 c namin0 : numero dans noarcf de l'arete avant namin
4412 c namin : numero dans noarcf du sommet choisi
4413 c 0 si contour ferme reduit a moins de 3 aretes
4414 c larmin : tableau auxiliaire pour stocker la liste des numeros des
4415 c aretes de meilleure qualite pour faire le choix final
4416 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4417 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
4418 c2345x7..............................................................012
4419 double precision dmaxim, precision
4420 parameter (dmaxim=1.7d+308, precision=1d-16)
4421 c ATTENTION:variables a ajuster selon la machine!
4422 c ATTENTION:dmaxim : le plus grand reel machine
4423 c ATTENTION:sur dec-alpha la precision est de 10**-14 seulement
4425 common / unites / lecteu,imprim,nunite(30)
4426 double precision pxyd(1:3,1:*)
4427 integer noarcf(1:3,1:*),
4429 double precision q, dd, dmima,
4430 % unpeps, rayon, surtd2
4432 double precision centre(3)
4435 c dmaxim : le plus grand reel machine
4436 unpeps = 1d0 + 100d0 * precision
4438 c recherche de la plus courte arete du contour ferme
4444 2 na0 = noarcf( 2, na00 )
4445 na1 = noarcf( 2, na0 )
4447 c les 2 sommets de l'arete na0 du cf
4448 ns1 = noarcf( 1, na0 )
4449 ns2 = noarcf( 1, na1 )
4450 dd = (pxyd(1,ns2)-pxyd(1,ns1))**2 + (pxyd(2,ns2)-pxyd(2,ns1))**2
4451 if( dd .lt. dmima ) then
4456 if( na00 .ne. nar00 ) then
4457 c derniere arete non atteinte
4461 if( nbar .eq. 3 ) then
4463 c contour ferme reduit a un triangle
4464 c ----------------------------------
4466 nar0 = noarcf( 2, nar00 )
4467 namin0 = noarcf( 2, nar0 )
4470 else if( nbar .le. 2 ) then
4471 write(imprim,*) 'erreur trchtd: cf<3 aretes'
4477 c cf non reduit a un triangle
4478 c la plus petite arete est nar0 dans noarcf
4480 nar0 = noarcf( 2, nar00 )
4481 nar = noarcf( 2, nar0 )
4483 ns1 = noarcf( 1, nar0 )
4484 ns2 = noarcf( 1, nar )
4486 c recherche dans cette etoile du sommet offrant la meilleure qualite
4487 c du triangle ns1-ns2 ns3 sans intersection avec le contour ferme
4488 c ==================================================================
4492 c parcours des sommets possibles ns3
4493 10 nar3 = noarcf( 2, nar3 )
4494 if( nar3 .ne. nar0 ) then
4496 c il existe un sommet ns3 different de ns1 et ns2
4497 ns3 = noarcf( 1, nar3 )
4499 c les aretes ns1-ns3 et ns2-ns3 intersectent-elles une arete
4500 c du contour ferme ?
4501 c ----------------------------------------------------------
4502 c intersection de l'arete ns2-ns3 et des aretes du cf
4503 c jusqu'au sommet ns3
4504 nar1 = noarcf( 2, nar )
4506 15 if( nar1 .ne. nar3 .and. noarcf( 2, nar1 ) .ne. nar3 ) then
4508 nar2 = noarcf( 2, nar1 )
4509 c le numero des 2 sommets de l'arete
4510 np1 = noarcf( 1, nar1 )
4511 np2 = noarcf( 1, nar2 )
4512 call int2ar( pxyd(1,ns2), pxyd(1,ns3),
4513 % pxyd(1,np1), pxyd(1,np2), oui )
4515 c les 2 aretes ne s'intersectent pas entre leurs sommets
4520 c intersection de l'arete ns3-ns1 et des aretes du cf
4521 c jusqu'au sommet de l'arete nar0
4522 nar1 = noarcf( 2, nar3 )
4524 18 if( nar1 .ne. nar0 .and. noarcf( 2, nar1 ) .ne. nar0 ) then
4526 nar2 = noarcf( 2, nar1 )
4527 c le numero des 2 sommets de l'arete
4528 np1 = noarcf( 1, nar1 )
4529 np2 = noarcf( 1, nar2 )
4530 call int2ar( pxyd(1,ns1), pxyd(1,ns3),
4531 % pxyd(1,np1), pxyd(1,np2), oui )
4533 c les 2 aretes ne s'intersectent pas entre leurs sommets
4538 c le triangle ns1-ns2-ns3 n'intersecte pas une arete du contour ferme
4539 c le calcul de la surface du triangle
4540 dd = surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
4541 if( dd .le. 0d0 ) then
4542 c surface negative => triangle a rejeter
4545 c calcul de la qualite du triangle ns1-ns2-ns3
4546 call qutr2d( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), q )
4549 if( q .ge. qmima*1.00001 ) then
4550 c q est un vrai maximum de la qualite
4554 else if( q .ge. qmima*0.999998 ) then
4555 c q est voisin de qmima
4558 larmin( nbmin ) = nar3
4563 c bilan : existe t il plusieurs sommets de meme qualite?
4564 c ======================================================
4565 if( nbmin .gt. 1 ) then
4567 c oui:recherche de ceux de cercle ne contenant pas d'autres sommets
4571 if( nar .le. 0 ) goto 80
4573 c les coordonnees du centre du cercle circonscrit
4576 call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3),
4578 if( ier .ne. 0 ) then
4579 c le sommet ns3 ne convient pas
4583 rayon = centre(3) * unpeps
4588 if( nar1 .le. 0 ) goto 70
4589 ns4 = noarcf(1,nar1)
4590 c appartient t il au cercle ns1 ns2 ns3 ?
4591 dd = (centre(1)-pxyd(1,ns4))**2 +
4592 % (centre(2)-pxyd(2,ns4))**2
4593 if( dd .le. rayon ) then
4594 c ns4 est dans le cercle circonscrit ns1 ns2 ns3
4595 c le sommet ns3 ne convient pas
4603 c existe t il plusieurs sommets ?
4606 if( larmin( i ) .gt. 0 ) then
4607 c compactage des min
4609 larmin(j) = larmin(i)
4614 c oui : choix du plus petit rayon de cercle circonscrit
4617 ns3 = noarcf(1,larmin(i))
4619 c les coordonnees du centre de cercle circonscrit
4620 c au triangle nt et son rayon
4622 call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3),
4624 if( ier .ne. 0 ) then
4625 c le sommet ns3 ne convient pas
4628 rayon = sqrt( centre(3) )
4629 if( rayon .lt. dmima ) then
4631 larmin(1) = larmin(i)
4641 c recherche de l'arete avant namin ( nar0 <> namin )
4642 c ==================================================
4644 200 if( nar1 .ne. namin ) then
4646 nar1 = noarcf( 2, nar1 )
4651 subroutine trcf0a( nbcf, na01, na1, na2, na3,
4652 % noar1, noar2, noar3,
4653 % mosoar, mxsoar, n1soar, nosoar,
4654 % moartr, n1artr, noartr, noarst,
4655 % mxarcf, n1arcf, noarcf, nt )
4656 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4657 c but : modification de la triangulation du contour ferme nbcf
4658 c ----- par ajout d'un triangle ayant 0 arete sur le contour
4659 c creation des 3 aretes dans le tableau nosoar
4660 c modification du contour par ajout de la 3-eme arete
4661 c creation d'un contour ferme a partir de la seconde arete
4665 c nbcf : numero dans n1arcf du cf traite ici
4666 c na01 : numero noarcf de l'arete precedent l'arete na1 de noarcf
4667 c na1 : numero noarcf du 1-er sommet du triangle
4668 c implicitement l'arete na1 n'est pas une arete du triangle
4669 c na2 : numero noarcf du 2-eme sommet du triangle
4670 c implicitement l'arete na1 n'est pas une arete du triangle
4671 c na3 : numero noarcf du 3-eme sommet du triangle
4672 c implicitement l'arete na1 n'est pas une arete du triangle
4674 c mosoar : nombre maximal d'entiers par arete et
4675 c indice dans nosoar de l'arete suivante dans le hachage
4676 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
4677 c attention: mxsoar>3*mxsomm obligatoire!
4678 c moartr : nombre maximal d'entiers par arete du tableau noartr
4680 c entrees et sorties :
4681 c --------------------
4682 c n1soar : numero de la premiere arete vide dans le tableau nosoar
4683 c une arete i de nosoar est vide <=> nosoar(1,i)=0
4684 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4685 c chainage des aretes frontalieres, chainage du hachage des aretes
4686 c hachage des aretes = nosoar(1)+nosoar(2)*2
4687 c n1artr : numero du premier triangle vide dans le tableau noartr
4688 c le chainage des triangles vides se fait sur noartr(2,.)
4689 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4690 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
4692 c noarst : noarst(i) numero d'une arete de sommet i
4693 c n1arcf : numero d'une arete de chaque contour
4694 c noarcf : numero des aretes de la ligne du contour ferme
4695 c attention : chainage circulaire des aretes
4699 c noar1 : numero dans le tableau nosoar de l'arete 1 du triangle
4700 c noar2 : numero dans le tableau nosoar de l'arete 2 du triangle
4701 c noar3 : numero dans le tableau nosoar de l'arete 3 du triangle
4702 c nt : numero du triangle ajoute dans noartr
4703 c 0 si saturation du tableau noartr ou noarcf ou n1arcf
4704 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4705 c auteur : alain perronnet analyse numerique paris upmc mars 1997
4706 c2345x7..............................................................012
4707 common / unites / lecteu, imprim, nunite(30)
4708 integer nosoar(mosoar,*),
4716 c 2 contours fermes peuvent ils etre ajoutes ?
4717 if( nbcf+2 .gt. mxarcf ) goto 9100
4719 c creation des 3 aretes du triangle dans le tableau nosoar
4720 c ========================================================
4721 c la formation de l'arete sommet1-sommet2 dans le tableau nosoar
4722 call fasoar( noarcf(1,na1), noarcf(1,na2), -1, -1, 0,
4723 % mosoar, mxsoar, n1soar, nosoar, noarst,
4725 if( ierr .ne. 0 ) goto 9900
4727 c la formation de l'arete sommet2-sommet3 dans le tableau nosoar
4728 call fasoar( noarcf(1,na2), noarcf(1,na3), -1, -1, 0,
4729 % mosoar, mxsoar, n1soar, nosoar, noarst,
4731 if( ierr .ne. 0 ) goto 9900
4733 c la formation de l'arete sommet3-sommet1 dans le tableau nosoar
4734 call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1, 0,
4735 % mosoar, mxsoar, n1soar, nosoar, noarst,
4737 if( ierr .ne. 0 ) goto 9900
4739 c ajout dans noartr de ce triangle nt
4740 c ===================================
4741 call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
4742 % noar1, noar2, noar3,
4744 % moartr, n1artr, noartr,
4746 if( nt .le. 0 ) return
4748 c modification du contour nbcf existant
4749 c chainage de l'arete na2 vers l'arete na1
4750 c ========================================
4751 c modification du cf en pointant na2 sur na1
4752 na2s = noarcf( 2, na2 )
4753 noarcf( 2, na2 ) = na1
4754 c le numero de l'arete dans le tableau nosoar
4755 noar2s = noarcf( 3, na2 )
4756 c le numero de l'arete dans le tableau nosoar
4757 noarcf( 3, na2 ) = noar1
4759 n1arcf( nbcf ) = na2
4761 c creation d'un nouveau contour ferme na2 - na3
4762 c =============================================
4764 c recherche d'une arete de cf vide
4766 if( nav .le. 0 ) goto 9100
4767 c la 1-ere arete vide est mise a jour
4768 n1arcf(0) = noarcf( 2, nav )
4770 c ajout de l'arete nav pointant sur na2s
4771 c le numero du sommet
4772 noarcf( 1, nav ) = noarcf( 1, na2 )
4774 noarcf( 2, nav ) = na2s
4775 c le numero nosoar de cette arete
4776 noarcf( 3, nav ) = noar2s
4778 c l'arete na3 se referme sur nav
4779 na3s = noarcf( 2, na3 )
4780 noarcf( 2, na3 ) = nav
4781 c le numero de l'arete dans le tableau nosoar
4782 noar3s = noarcf( 3, na3 )
4783 noarcf( 3, na3 ) = noar2
4785 n1arcf( nbcf ) = na3
4787 c creation d'un nouveau contour ferme na3 - na1
4788 c =============================================
4790 c recherche d'une arete de cf vide
4792 if( nav .le. 0 ) goto 9100
4793 c la 1-ere arete vide est mise a jour
4794 n1arcf(0) = noarcf( 2, nav )
4796 c ajout de l'arete nav pointant sur na3s
4797 c le numero du sommet
4798 noarcf( 1, nav ) = noarcf( 1, na3 )
4800 noarcf( 2, nav ) = na3s
4801 c le numero de l'arete dans le tableau nosoar
4802 noarcf( 3, nav ) = noar3s
4804 c recherche d'une arete de cf vide
4806 if( nav1 .le. 0 ) goto 9100
4807 c la 1-ere arete vide est mise a jour
4808 n1arcf(0) = noarcf( 2, nav1 )
4810 c l'arete precedente na01 de na1 pointe sur la nouvelle nav1
4811 noarcf( 2, na01 ) = nav1
4813 c ajout de l'arete nav1 pointant sur nav
4814 c le numero du sommet
4815 noarcf( 1, nav1 ) = noarcf( 1, na1 )
4817 noarcf( 2, nav1 ) = nav
4818 c le numero de l'arete dans le tableau nosoar
4819 noarcf( 3, nav1 ) = noar3
4822 n1arcf( nbcf ) = nav1
4826 9100 write(imprim,*) 'saturation du tableau mxarcf'
4830 c erreur tableau nosoar sature
4831 9900 write(imprim,*) 'saturation du tableau nosoar'
4837 subroutine trcf1a( nbcf, na01, na1, na2, noar1, noar3,
4838 % mosoar, mxsoar, n1soar, nosoar,
4839 % moartr, n1artr, noartr, noarst,
4840 % mxarcf, n1arcf, noarcf, nt )
4841 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4842 c but : modification de la triangulation du contour ferme nbcf
4843 c ----- par ajout d'un triangle ayant 1 arete sur le contour
4844 c modification du contour par ajout de la 3-eme arete
4845 c creation d'un contour ferme a partir de la seconde arete
4849 c nbcf : numero dans n1arcf du cf traite ici
4850 c na01 : numero noarcf de l'arete precedant l'arete na1 de noarcf
4851 c na1 : numero noarcf du 1-er sommet du triangle
4852 c implicitement l'arete na1 n'est pas une arete du triangle
4853 c na2 : numero noarcf du 2-eme sommet du triangle
4854 c cette arete est l'arete 2 du triangle a ajouter
4855 c son arete suivante dans noarcf n'est pas sur le contour
4856 c mosoar : nombre maximal d'entiers par arete et
4857 c indice dans nosoar de l'arete suivante dans le hachage
4858 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
4859 c attention: mxsoar>3*mxsomm obligatoire!
4860 c moartr : nombre maximal d'entiers par arete du tableau noartr
4862 c entrees et sorties :
4863 c --------------------
4864 c n1soar : numero de la premiere arete vide dans le tableau nosoar
4865 c une arete i de nosoar est vide <=> nosoar(1,i)=0
4866 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4867 c chainage des aretes frontalieres, chainage du hachage des aretes
4868 c hachage des aretes = nosoar(1)+nosoar(2)*2
4869 c n1artr : numero du premier triangle vide dans le tableau noartr
4870 c le chainage des triangles vides se fait sur noartr(2,.)
4871 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4872 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
4874 c noarst : noarst(i) numero d'une arete de sommet i
4875 c n1arcf : numero d'une arete de chaque contour
4876 c noarcf : numero des aretes de la ligne du contour ferme
4877 c attention : chainage circulaire des aretes
4881 c noar1 : numero nosoar de l'arete 1 du triangle cree
4882 c noar3 : numero nosoar de l'arete 3 du triangle cree
4883 c nt : numero du triangle ajoute dans notria
4884 c 0 si saturation du tableau notria ou noarcf ou n1arcf
4885 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4886 c auteur : alain perronnet analyse numerique paris upmc mars 1997
4887 c2345x7..............................................................012
4888 common / unites / lecteu, imprim, nunite(30)
4889 integer nosoar(mosoar,mxsoar),
4895 c un cf supplementaire peut il etre ajoute ?
4896 if( nbcf .ge. mxarcf ) then
4897 write(imprim,*) 'saturation du tableau noarcf'
4904 c l' arete suivante du triangle non sur le cf
4905 na3 = noarcf( 2, na2 )
4907 c creation des 2 nouvelles aretes du triangle dans le tableau nosoar
4908 c ==================================================================
4909 c la formation de l'arete sommet1-sommet2 dans le tableau nosoar
4910 call fasoar( noarcf(1,na1), noarcf(1,na2), -1, -1, 0,
4911 % mosoar, mxsoar, n1soar, nosoar, noarst,
4913 if( ierr .ne. 0 ) goto 9900
4915 c la formation de l'arete sommet1-sommet3 dans le tableau nosoar
4916 call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1, 0,
4917 % mosoar, mxsoar, n1soar, nosoar, noarst,
4919 if( ierr .ne. 0 ) goto 9900
4921 c le triangle nt de noartr a l'arete 2 comme arete du contour na2
4922 c ===============================================================
4923 call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
4924 % noar1, noarcf(3,na2), noar3,
4926 % moartr, n1artr, noartr,
4928 if( nt .le. 0 ) return
4930 c modification du contour ferme existant
4931 c suppression de l'arete na2 du cf
4932 c ======================================
4933 c modification du cf en pointant na2 sur na1
4934 noarcf( 2, na2 ) = na1
4935 noarcf( 3, na2 ) = noar1
4937 n1arcf( nbcf ) = na2
4939 c creation d'un nouveau contour ferme na3 - na1
4940 c =============================================
4943 c recherche d'une arete de cf vide
4945 if( nav .le. 0 ) then
4946 write(imprim,*) 'saturation du tableau noarcf'
4951 c la 1-ere arete vide est mise a jour
4952 n1arcf(0) = noarcf( 2, nav )
4954 c ajout de l'arete nav pointant sur na3
4955 c le numero du sommet
4956 noarcf( 1, nav ) = noarcf( 1, na1 )
4958 noarcf( 2, nav ) = na3
4959 c le numero de l'arete dans le tableau nosoar
4960 noarcf( 3, nav ) = noar3
4962 c l'arete precedente na01 de na1 pointe sur la nouvelle nav
4963 noarcf( 2, na01 ) = nav
4966 n1arcf( nbcf ) = nav
4969 c erreur tableau nosoar sature
4970 9900 write(imprim,*) 'saturation du tableau nosoar'
4976 subroutine trcf2a( nbcf, na1, noar3,
4977 % mosoar, mxsoar, n1soar, nosoar,
4978 % moartr, n1artr, noartr, noarst,
4979 % n1arcf, noarcf, nt )
4980 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4981 c but : modification de la triangulation du contour ferme nbcf
4982 c ----- par ajout d'un triangle ayant 2 aretes sur le contour
4983 c creation d'une arete dans nosoar (sommet3-sommet1)
4984 c et modification du contour par ajout de la 3-eme arete
4988 c nbcf : numero dans n1arcf du cf traite ici
4989 c na1 : numero noarcf de la premiere arete sur le contour
4990 c implicitement sa suivante est sur le contour
4991 c la suivante de la suivante n'est pas sur le contour
4992 c mosoar : nombre maximal d'entiers par arete et
4993 c indice dans nosoar de l'arete suivante dans le hachage
4994 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
4995 c attention: mxsoar>3*mxsomm obligatoire!
4996 c moartr : nombre maximal d'entiers par arete du tableau noartr
4998 c entrees et sorties :
4999 c --------------------
5000 c n1soar : numero de la premiere arete vide dans le tableau nosoar
5001 c une arete i de nosoar est vide <=> nosoar(1,i)=0
5002 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
5003 c chainage des aretes frontalieres, chainage du hachage des aretes
5004 c hachage des aretes = nosoar(1)+nosoar(2)*2
5005 c n1artr : numero du premier triangle vide dans le tableau noartr
5006 c le chainage des triangles vides se fait sur noartr(2,.)
5007 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5008 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5010 c noarst : noarst(i) numero d'une arete de sommet i
5011 c n1arcf : numero d'une arete de chaque contour
5012 c noarcf : numero des aretes de la ligne du contour ferme
5013 c attention : chainage circulaire des aretes
5017 c noar3 : numero de l'arete 3 dans le tableau nosoar
5018 c nt : numero du triangle ajoute dans noartr
5019 c 0 si saturation du tableau noartr ou nosoar
5020 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5021 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5022 c2345x7..............................................................012
5023 common / unites / lecteu, imprim, nunite(30)
5024 integer nosoar(mosoar,*),
5027 integer n1arcf(0:*),
5032 c l'arete suivante de l'arete na1 dans noarcf
5033 na2 = noarcf( 2, na1 )
5034 c l'arete suivante de l'arete na2 dans noarcf
5035 na3 = noarcf( 2, na2 )
5037 c la formation de l'arete sommet3-sommet1 dans le tableau nosoar
5038 call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1, 0,
5039 % mosoar, mxsoar, n1soar, nosoar, noarst,
5041 if( ierr .ne. 0 ) then
5042 if( ierr .eq. 1 ) then
5043 write(imprim,*) 'saturation des aretes (tableau nosoar)'
5049 c le triangle a ses 2 aretes na1 na2 sur le contour ferme
5050 c ajout dans noartr de ce triangle nt
5051 call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
5052 % noarcf(3,na1), noarcf(3,na2), noar3,
5054 % moartr, n1artr, noartr,
5056 if( nt .le. 0 ) return
5058 c suppression des 2 aretes (na1 na2) du cf
5059 c ces 2 aretes se suivent dans le chainage du cf
5060 c ajout de la 3-eme arete (noar3) dans le cf
5061 c l'arete suivante de na1 devient la suivante de na2
5063 noarcf(3,na1) = noar3
5065 c l'arete na2 devient vide dans noarcf
5066 noarcf(2,na2) = n1arcf( 0 )
5069 c la premiere pointee dans noarcf est na1
5070 c chainage circulaire => ce peut etre n'importe laquelle
5075 subroutine trcf3a( ns1, ns2, ns3,
5076 % noar1, noar2, noar3,
5078 % moartr, n1artr, noartr,
5080 c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5081 c but : ajouter dans le tableau noartr le triangle
5082 c ----- de sommets ns1 ns2 ns3
5083 c d'aretes noar1 noar2 noar3 deja existantes
5084 c dans le tableau nosoar des aretes
5088 c ns1, ns2, ns3 : le numero dans pxyd des 3 sommets du triangle
5089 c noar1,noar2,noar3 : le numero dans nosoar des 3 aretes du triangle
5090 c mosoar : nombre maximal d'entiers par arete et
5091 c indice dans nosoar de l'arete suivante dans le hachage
5092 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5093 c attention: mxsoar>3*mxsomm obligatoire!
5094 c moartr : nombre maximal d'entiers par arete du tableau noartr
5095 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
5099 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
5100 c chainage des aretes frontalieres, chainage du hachage des aretes
5101 c hachage des aretes = nosoar(1)+nosoar(2)*2
5102 c n1artr : numero du premier triangle vide dans le tableau noartr
5103 c le chainage des triangles vides se fait sur noartr(2,.)
5104 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5105 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5109 c nt : numero dans noartr du triangle ajoute
5110 c =0 si le tableau noartr est sature
5111 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5112 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5113 c....................................................................012
5114 common / unites / lecteu,imprim,nunite(30)
5115 integer nosoar(mosoar,*),
5118 c recherche d'un triangle libre dans le tableau noartr
5119 if( n1artr .le. 0 ) then
5120 write(imprim,*) 'saturation du tableau noartr des aretes'
5125 c le numero dans noartr du nouveau triangle
5128 c le nouveau premier triangle vide dans le tableau noartr
5129 n1artr = noartr(2,n1artr)
5131 c arete 1 du triangle nt
5132 c ======================
5133 c orientation des 3 aretes du triangle pour qu'il soit direct
5134 if( ns1 .eq. nosoar(1,noar1) ) then
5139 c le numero de l'arete 1 du triangle nt
5140 noartr(1,nt) = n * noar1
5142 c le numero du triangle nt pour l'arete
5143 if( nosoar(4,noar1) .le. 0 ) then
5148 nosoar(n,noar1) = nt
5150 c arete 2 du triangle nt
5151 c ======================
5152 c orientation des 3 aretes du triangle pour qu'il soit direct
5153 if( ns2 .eq. nosoar(1,noar2) ) then
5158 c le numero de l'arete 2 du triangle nt
5159 noartr(2,nt) = n * noar2
5161 c le numero du triangle nt pour l'arete
5162 if( nosoar(4,noar2) .le. 0 ) then
5167 nosoar(n,noar2) = nt
5169 c arete 3 du triangle nt
5170 c ======================
5171 c orientation des 3 aretes du triangle pour qu'il soit direct
5172 if( ns3 .eq. nosoar(1,noar3) ) then
5177 c le numero de l'arete 3 du triangle nt
5178 noartr(3,nt) = n * noar3
5180 c le numero du triangle nt pour l'arete
5181 if( nosoar(4,noar3) .le. 0 ) then
5186 nosoar(n,noar3) = nt
5191 subroutine trcf3s( nbcf, na01, na1, na02, na2, na03, na3,
5192 % mosoar, mxsoar, n1soar, nosoar,
5193 % moartr, n1artr, noartr, noarst,
5194 % mxarcf, n1arcf, noarcf, nt )
5195 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5196 c but : ajout d'un triangle d'aretes na1 2 3 du tableau noarcf
5197 c ----- a la triangulation d'un contour ferme (cf)
5201 c nbcf : numero dans n1arcf du cf traite ici
5202 c mais aussi nombre actuel de cf avant ajout du triangle
5203 c na01 : numero noarcf de l'arete precedent l'arete na1 de noarcf
5204 c na1 : numero noarcf du 1-er sommet du triangle
5205 c na02 : numero noarcf de l'arete precedent l'arete na2 de noarcf
5206 c na2 : numero noarcf du 2-eme sommet du triangle
5207 c na03 : numero noarcf de l'arete precedent l'arete na3 de noarcf
5208 c na3 : numero noarcf du 3-eme sommet du triangle
5210 c mosoar : nombre maximal d'entiers par arete et
5211 c indice dans nosoar de l'arete suivante dans le hachage
5212 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5213 c attention: mxsoar>3*mxsomm obligatoire!
5214 c moartr : nombre maximal d'entiers par arete du tableau noartr
5215 c mxarcf : nombre maximal d'aretes declarables dans noarcf, n1arcf
5219 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
5220 c chainage des vides suivant en 3 et precedant en 2 de nosoar
5221 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
5222 c chainage des aretes frontalieres, chainage du hachage des aretes
5223 c hachage des aretes = nosoar(1)+nosoar(2)*2
5224 c avec mxsoar>=3*mxsomm
5225 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
5226 c nosoar(2,arete vide)=l'arete vide qui precede
5227 c nosoar(3,arete vide)=l'arete vide qui suit
5229 c n1artr : numero du premier triangle vide dans le tableau noartr
5230 c le chainage des triangles vides se fait sur noartr(2,.)
5231 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5232 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5233 c noarst : noarst(i) numero d'une arete de sommet i
5235 c n1arcf : numero d'une arete de chaque contour ferme
5236 c noarcf : numero du sommet , numero de l'arete suivante
5237 c numero de l'arete dans le tableau nosoar
5238 c attention : chainage circulaire des aretes
5242 c nbcf : nombre actuel de cf apres ajout du triangle
5243 c nt : numero du triangle ajoute dans noartr
5244 c 0 si saturation du tableau nosoar ou noartr ou noarcf ou n1arcf
5245 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5246 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5247 c2345x7..............................................................012
5248 integer nosoar(mosoar,*),
5254 c combien y a t il d'aretes nbascf sur le cf ?
5255 c ============================================
5256 c la premiere arete est elle sur le cf?
5257 if( noarcf(2,na1) .eq. na2 ) then
5258 c la 1-ere arete est sur le cf
5261 c la 1-ere arete n'est pas sur le cf
5265 c la seconde arete est elle sur le cf?
5266 if( noarcf(2,na2) .eq. na3 ) then
5267 c la 2-eme arete est sur le cf
5273 c la troisieme arete est elle sur le cf?
5274 if( noarcf(2,na3) .eq. na1 ) then
5275 c la 3-eme arete est sur le cf
5281 c le nombre d'aretes sur le cf
5282 nbascf = na1cf + na2cf + na3cf
5284 c traitement selon le nombre d'aretes sur le cf
5285 c =============================================
5286 if( nbascf .eq. 3 ) then
5288 c le contour ferme se reduit a un triangle avec 3 aretes sur le cf
5289 c ----------------------------------------------------------------
5290 c ajout dans noartr de ce nouveau triangle
5291 call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
5292 % noarcf(3,na1), noarcf(3,na2), noarcf(3,na3),
5294 % moartr, n1artr, noartr,
5296 if( nt .le. 0 ) return
5298 c le cf est supprime et chaine vide
5299 noarcf(2,na3) = n1arcf(0)
5302 c ce cf a ete traite => un cf de moins a traiter
5305 else if( nbascf .eq. 2 ) then
5307 c le triangle a 2 aretes sur le contour
5308 c -------------------------------------
5309 c les 2 aretes sont la 1-ere et 2-eme du triangle
5310 if( na1cf .eq. 0 ) then
5311 c l'arete 1 n'est pas sur le cf
5313 else if( na2cf .eq. 0 ) then
5314 c l'arete 2 n'est pas sur le cf
5317 c l'arete 3 n'est pas sur le cf
5320 c le triangle oppose a l'arete 3 est inconnu
5321 c modification du contour apres integration du
5322 c triangle ayant ses 2-eres aretes sur le cf
5323 call trcf2a( nbcf, naa1, naor3,
5324 % mosoar, mxsoar, n1soar, nosoar,
5325 % moartr, n1artr, noartr, noarst,
5326 % n1arcf, noarcf, nt )
5328 else if( nbascf .eq. 1 ) then
5330 c le triangle a 1 arete sur le contour
5331 c ------------------------------------
5332 c cette arete est la seconde du triangle
5333 if( na3cf .ne. 0 ) then
5334 c l'arete 3 est sur le cf
5338 else if( na1cf .ne. 0 ) then
5339 c l'arete 1 est sur le cf
5344 c l'arete 2 est sur le cf
5349 c le triangle oppose a l'arete 1 et 3 est inconnu
5350 c modification du contour apres integration du
5351 c triangle ayant 1 arete sur le cf avec creation
5352 c d'un nouveau contour ferme
5353 call trcf1a( nbcf, naa01, naa1, naa2, naor1, naor3,
5354 % mosoar, mxsoar, n1soar, nosoar,
5355 % moartr, n1artr, noartr, noarst,
5356 % mxarcf, n1arcf, noarcf, nt )
5360 c le triangle a 0 arete sur le contour
5361 c ------------------------------------
5362 c modification du contour apres integration du
5363 c triangle ayant 0 arete sur le cf avec creation
5364 c de 2 nouveaux contours fermes
5365 call trcf0a( nbcf, na01, na1, na2, na3,
5366 % naa1, naa2, naa01,
5367 % mosoar, mxsoar, n1soar, nosoar,
5368 % moartr, n1artr, noartr, noarst,
5369 % mxarcf, n1arcf, noarcf, nt )
5374 subroutine tridcf( nbcf0, pxyd, noarst,
5375 % mosoar, mxsoar, n1soar, nosoar,
5376 % moartr, n1artr, noartr,
5377 % mxarcf, n1arcf, noarcf, larmin,
5378 % nbtrcf, notrcf, ierr )
5379 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5380 c but : triangulation directe de nbcf0 contours fermes (cf)
5381 c ----- definis par la liste circulaire de leurs aretes peripheriques
5385 c nbcf0 : nombre initial de cf a trianguler
5386 c pxyd : tableau des coordonnees 2d des points
5387 c par point : x y distance_souhaitee
5388 c mosoar : nombre maximal d'entiers par arete et
5389 c indice dans nosoar de l'arete suivante dans le hachage
5390 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5391 c attention: mxsoar>3*mxsomm obligatoire!
5392 c moartr : nombre maximal d'entiers par arete du tableau noartr
5393 c mxarcf : nombre maximal d'aretes declarables dans noarcf, n1arcf, larmin, not
5397 c noarst : noarst(i) numero d'une arete de sommet i
5398 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
5399 c chainage des vides suivant en 3 et precedant en 2 de nosoar
5400 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
5401 c chainage des aretes frontalieres, chainage du hachage des aretes
5402 c hachage des aretes = nosoar(1)+nosoar(2)*2
5403 c avec mxsoar>=3*mxsomm
5404 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
5405 c nosoar(2,arete vide)=l'arete vide qui precede
5406 c nosoar(3,arete vide)=l'arete vide qui suit
5408 c n1artr : numero du premier triangle vide dans le tableau noartr
5409 c le chainage des triangles vides se fait sur noartr(2,.)
5410 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5411 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5413 c n1arcf : numero de la premiere arete de chacun des nbcf0 cf
5414 c n1arcf(0) no de la premiere arete vide du tableau noarcf
5415 c noarcf(2,i) no de l'arete suivante
5416 c noarcf : numero du sommet , numero de l'arete suivante du cf
5417 c numero de l'arete dans le tableau nosoar
5421 c larmin : tableau (mxarcf) auxiliaire
5422 c stocker la liste des numeros des meilleures aretes
5423 c lors de la selection du meilleur sommet du cf a trianguler
5428 c nbtrcf : nombre de triangles des nbcf0 cf
5429 c notrcf : numero des triangles des nbcf0 cf dans le tableau noartr
5430 c ierr : 0 si pas d'erreur
5431 c 2 saturation de l'un des des tableaux nosoar, noartr, ...
5432 c 3 si contour ferme reduit a moins de 3 aretes
5433 c 4 saturation du tableau notrcf
5434 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5435 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5436 c....................................................................012
5437 common / unites / lecteu, imprim, nunite(30)
5438 double precision pxyd(3,*)
5439 integer noartr(moartr,*),
5440 % nosoar(mosoar,mxsoar),
5447 ccc integer nosotr(3)
5448 ccc double precision d, surtd2
5450 c depart avec nbcf0 cf a trianguler
5453 c le nombre de triangles formes dans l'ensemble des cf
5456 c tant qu'il existe un cf a trianguler faire
5457 c la triangulation directe du cf
5458 c ==========================================
5459 10 if( nbcf .gt. 0 ) then
5461 c le cf en haut de pile a pour premiere arete
5462 na01 = n1arcf( nbcf )
5463 na1 = noarcf( 2, na01 )
5465 c choix du sommet du cf a relier a l'arete na1
5466 c --------------------------------------------
5467 call trchtd( pxyd, na01, na1, noarcf,
5468 % na03, na3, larmin )
5469 if( na3 .eq. 0 ) then
5474 c l'arete suivante de na1
5476 na2 = noarcf( 2, na1 )
5478 c formation du triangle arete na1 - sommet noarcf(1,na3)
5479 c ------------------------------------------------------
5480 call trcf3s( nbcf, na01, na1, na02, na2, na03, na3,
5481 % mosoar, mxsoar, n1soar, nosoar,
5482 % moartr, n1artr, noartr, noarst,
5483 % mxarcf, n1arcf, noarcf, nt )
5484 if( nt .le. 0 ) then
5485 c saturation du tableau noartr ou noarcf ou n1arcf
5490 c ajout du triangle cree a sa pile
5491 if( nbtrcf .ge. mxarcf ) then
5492 write(imprim,*) 'saturation du tableau notrcf'
5497 notrcf( nbtrcf ) = nt
5501 c mise a jour du chainage des triangles des aretes
5502 c ================================================
5503 do 30 ntp0 = 1, nbtrcf
5505 c le numero du triangle ajoute dans le tableau noartr
5506 nt0 = notrcf( ntp0 )
5508 cccc aire signee du triangle nt0
5509 cccc le numero des 3 sommets du triangle nt
5510 ccc call nusotr( nt0, mosoar, nosoar, moartr, noartr,
5512 ccc d = surtd2( pxyd(1,nosotr(1)), pxyd(1,nosotr(2)),
5513 ccc % pxyd(1,nosotr(3)) )
5514 ccc if( d .le. 0 ) then
5516 cccc un triangle d'aire negative de plus
5517 ccc write(imprim,*) 'triangle ',nt0,' st:',nosotr,
5518 ccc % ' d aire ',d,'<=0'
5522 cccc trace du triangle nt0
5523 ccc call mttrtr( pxyd, nt0, moartr, noartr, mosoar, nosoar,
5524 ccc % ncturq, ncblan )
5526 c boucle sur les 3 aretes du triangle
5529 c le numero de l'arete i du triangle dans le tableau nosoar
5530 noar = abs( noartr(i,nt0) )
5532 c ce triangle est il deja chaine dans cette arete?
5533 nt1 = nosoar(4,noar)
5534 nt2 = nosoar(5,noar)
5535 if( nt1 .eq. nt0 .or. nt2 .eq. nt0 ) goto 20
5537 c ajout de ce triangle nt0 a l'arete noar
5538 if( nt1 .le. 0 ) then
5539 c le triangle est ajoute a l'arete
5540 nosoar( 4, noar ) = nt0
5541 else if( nt2 .le. 0 ) then
5542 c le triangle est ajoute a l'arete
5543 nosoar( 5, noar ) = nt0
5545 c l'arete appartient a 2 triangles differents de nt0
5546 c anomalie. chainage des triangles des aretes defectueux
5548 write(imprim,*) 'pause dans tridcf'
5559 subroutine te1stm( nsasup, pxyd, noarst,
5560 % mosoar, mxsoar, n1soar, nosoar,
5561 % moartr, mxartr, n1artr, noartr,
5562 % mxarcf, n1arcf, noarcf, larmin, notrcf, liarcf,
5564 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5565 c but : supprimer de la triangulation le sommet nsasup qui doit
5566 c ----- etre un sommet interne ("centre" d'une boule de triangles)
5568 c attention: le chainage lchain de nosoar devient celui des cf
5572 c nsasup : numero dans le tableau pxyd du sommet a supprimer
5573 c pxyd : tableau des coordonnees 2d des points
5574 c par point : x y distance_souhaitee
5575 c mosoar : nombre maximal d'entiers par arete et
5576 c indice dans nosoar de l'arete suivante dans le hachage
5577 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5578 c attention: mxsoar>3*mxsomm obligatoire!
5579 c moartr : nombre maximal d'entiers par arete du tableau noartr
5580 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
5584 c noarst : noarst(i) numero d'une arete de sommet i
5585 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
5586 c chainage des vides suivant en 3 et precedant en 2 de nosoar
5587 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
5588 c chainage des aretes frontalieres, chainage du hachage des aretes
5589 c hachage des aretes = nosoar(1)+nosoar(2)*2
5590 c avec mxsoar>=3*mxsomm
5591 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
5592 c nosoar(2,arete vide)=l'arete vide qui precede
5593 c nosoar(3,arete vide)=l'arete vide qui suit
5594 c n1artr : numero du premier triangle vide dans le tableau noartr
5595 c le chainage des triangles vides se fait sur noartr(2,.)
5596 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5597 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5602 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
5603 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
5604 c larmin : tableau ( mxarcf ) auxiliaire d'entiers
5605 c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
5606 c liarcf : tableau ( mxarcf ) auxiliaire d'entiers
5610 c ierr : =0 si pas d'erreur
5611 c -1 le sommet a supprimer n'est pas le centre d'une boule
5612 c de triangles. il est suppose externe
5613 c ou bien le sommet est centre d'un cf dont toutes les
5614 c aretes sont frontalieres
5615 c dans les 2 cas => retour sans modifs
5616 c >0 si une erreur est survenue
5617 c =11 algorithme defaillant
5618 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5619 c auteur : alain perronnet analyse numerique paris upmc mars 2006
5620 c....................................................................012
5621 parameter ( lchain=6, quamal=0.3)
5622 common / unites / lecteu,imprim,intera,nunite(29)
5623 double precision pxyd(3,*)
5624 integer nosoar(mosoar,mxsoar),
5633 c nsasup est il un sommet interne, "centre" d'une boule de triangles?
5634 c => le sommet nsasup peut etre supprime
5635 c ===================================================================
5636 c formation du cf de ''centre'' le sommet nsasup
5637 call trp1st( nsasup, noarst, mosoar, nosoar,
5639 % mxarcf, nbtrcf, notrcf )
5640 if( nbtrcf .le. 0 ) then
5641 c erreur: impossible de trouver tous les triangles de sommet nsasup
5642 c le sommet nsasup n'est pas supprime de la triangulation
5645 else if( nbtrcf .le. 2 ) then
5646 c le sommet nsasup n'est pas supprime
5650 if( nbtrcf*3 .gt. mxarcf ) then
5651 write(imprim,*) 'saturation du tableau noarcf'
5656 ccc trace des triangles de l'etoile du sommet nsasup
5657 ccc call trpltr( nbtrcf, notrcf, pxyd,
5658 ccc % moartr, noartr, mosoar, nosoar,
5659 ccc % ncroug, ncblan )
5661 c si toutes les aretes du cf sont frontalieres, alors il est
5662 c interdit de detruire le sommet "centre" du cf
5663 c calcul du nombre nbarfr des aretes simples des nbtrcf triangles
5664 call trfrcf( nsasup, mosoar, nosoar, moartr, noartr,
5665 % nbtrcf, notrcf, nbarfr )
5666 if( nbarfr .ge. nbtrcf ) then
5667 c toutes les aretes simples sont frontalieres
5668 c le sommet nsasup ("centre" de la cavite) n'est pas supprime
5673 c formation du contour ferme (liste chainee des aretes simples)
5674 c forme a partir des aretes des triangles de l'etoile du sommet nsasup
5675 call focftr( nbtrcf, notrcf, pxyd, noarst,
5676 % mosoar, mxsoar, n1soar, nosoar,
5677 % moartr, n1artr, noartr,
5678 % nbarcf, n1arcf, noarcf,
5680 if( ierr .ne. 0 ) then
5681 c modification de ierr pour continuer le calcul
5686 c ici le sommet nsasup appartient a aucune arete
5687 noarst( nsasup ) = 0
5689 c chainage des aretes vides dans le tableau noarcf
5690 n1arcf(0) = nbarcf+1
5691 mmarcf = min(8*nbarcf,mxarcf)
5692 do 40 i=nbarcf+1,mmarcf
5695 noarcf(2,mmarcf) = 0
5697 c sauvegarde du chainage des aretes peripheriques
5698 c pour la mise en delaunay du maillage
5701 c le numero de l'arete dans le tableau nosoar
5702 liarcf( i ) = noarcf( 3, nbcf )
5703 c l'arete suivante dans le cf
5704 nbcf = noarcf( 2, nbcf )
5707 c triangulation directe du contour ferme sans le sommet nsasup
5708 c ============================================================
5710 call tridcf( nbcf, pxyd, noarst,
5711 % mosoar, mxsoar, n1soar, nosoar,
5712 % moartr, n1artr, noartr,
5713 % mxarcf, n1arcf, noarcf, larmin,
5714 % nbtrcf, notrcf, ierr )
5715 if( ierr .ne. 0 ) return
5717 c transformation des triangles du cf en triangles delaunay
5718 c ========================================================
5719 c construction du chainage lchain dans nosoar
5720 c des aretes peripheriques du cf a partir de la sauvegarde liarcf
5723 c le numero de l'arete peripherique du cf dans nosoar
5725 if( nosoar(3,noar) .le. 0 ) then
5726 c arete interne => elle est chainee a partir de la precedente
5727 nosoar( lchain, noar0 ) = noar
5731 c la derniere arete peripherique n'a pas de suivante
5732 nosoar(lchain,noar0) = 0
5734 c mise en delaunay des aretes chainees
5735 call tedela( pxyd, noarst,
5736 % mosoar, mxsoar, n1soar, nosoar, liarcf(1),
5737 % moartr, mxartr, n1artr, noartr, modifs )
5738 ccc write(imprim,*) 'nombre echanges diagonales =',modifs
5743 subroutine tr3str( np, nt,
5744 % mosoar, mxsoar, n1soar, nosoar,
5745 % moartr, mxartr, n1artr, noartr,
5748 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5749 c but : former les 3 sous-triangles du triangle nt a partir
5750 c ----- du point interne np
5754 c np : numero dans le tableau pxyd du point
5755 c nt : numero dans le tableau noartr du triangle a trianguler
5756 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
5757 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5758 c moartr : nombre maximal d'entiers par arete du tableau noartr
5759 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
5763 c n1soar : numero de la premiere arete vide dans le tableau nosoar
5764 c une arete i de nosoar est vide <=> nosoar(1,i)=0
5765 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages
5766 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
5767 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
5768 c n1artr : numero du premier triangle vide dans le tableau noartr
5769 c le chainage des triangles vides se fait sur noartr(2,.)
5770 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5771 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5772 c noarst : noarst(i) numero d'une arete de sommet i
5776 c nutr : le numero des 3 sous-triangles du triangle nt
5777 c nt : en sortie le triangle initial n'est plus actif dans noartr
5778 c c'est en fait le premier triangle vide de noartr
5779 c ierr : =0 si pas d'erreur
5780 c =1 si le tableau nosoar est sature
5781 c =2 si le tableau noartr est sature
5782 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5783 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5784 c....................................................................012
5785 integer nosoar(mosoar,mxsoar),
5786 % noartr(moartr,mxartr),
5790 integer nosotr(3), nu2sar(2), nuarco(3)
5792 c reservation des 3 nouveaux triangles dans le tableau noartr
5793 c ===========================================================
5795 c le numero du sous-triangle i dans le tableau noartr
5796 if( n1artr .le. 0 ) then
5797 c tableau noartr sature
5802 c le nouveau premier triangle libre dans noartr
5803 n1artr = noartr(2,n1artr)
5806 c les numeros des 3 sommets du triangle nt
5807 call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
5809 c formation des 3 aretes nosotr(i)-np dans le tableau nosoar
5810 c ==========================================================
5814 c le triangle a creer
5817 c les 2 sommets du cote i du triangle nosotr
5818 nu2sar(1) = nosotr(i)
5820 call hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar, noar )
5821 c en sortie: noar>0 => no arete retrouvee
5822 c <0 => no arete ajoutee
5823 c =0 => saturation du tableau nosoar
5825 if( noar .eq. 0 ) then
5826 c saturation du tableau nosoar
5829 else if( noar .lt. 0 ) then
5830 c l'arete a ete ajoutee. initialisation des autres informations
5832 c le numero des 2 sommets a ete initialise par hasoar
5833 c et (nosoar(1,noar)<nosoar(2,noar))
5834 c le numero de la ligne de l'arete: ici arete interne
5837 c l'arete a ete retrouvee
5838 c le numero des 2 sommets a ete retrouve par hasoar
5839 c et (nosoar(1,noar)<nosoar(2,noar))
5840 c le numero de ligne reste inchange
5843 c le triangle 1 de l'arete noar => le triangle nt0
5844 nosoar(4,noar) = nt0
5845 c le triangle 2 de l'arete noar => le triangle nti
5846 nosoar(5,noar) = nti
5848 c le sommet nosotr(i) appartient a l'arete noar
5849 noarst( nosotr(i) ) = noar
5851 c le numero d'arete nosotr(i)-np
5854 c le triangle qui precede le suivant
5858 c le numero d'une arete du point np
5861 c les 3 sous-triangles du triangle nt sont formes dans le tableau noartr
5862 c ======================================================================
5865 c le numero suivant i => i mod 3 + 1
5872 c le numero dans noartr du sous-triangle a ajouter
5875 c le numero de l'arete i du triangle initial nt
5876 c est l'arete 1 du sous-triangle i
5878 noartr( 1, nti ) = noar
5880 c mise a jour du numero de triangle de cette arete
5882 if( nosoar(4,noar) .eq. nt ) then
5883 c le sous-triangle nti remplace le triangle nt
5884 nosoar(4,noar) = nti
5886 c le sous-triangle nti remplace le triangle nt
5887 nosoar(5,noar) = nti
5890 c l'arete 2 du sous-triangle i est l'arete i1 ajoutee
5891 if( nosotr(i1) .eq. nosoar(1,nuarco(i1)) ) then
5892 c l'arete ns i1-np dans nosoar est dans le sens direct
5893 noartr( 2, nti ) = nuarco(i1)
5895 c l'arete ns i1-np dans nosoar est dans le sens indirect
5896 noartr( 2, nti ) = -nuarco(i1)
5899 c l'arete 3 du sous-triangle i est l'arete i ajoutee
5900 if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
5901 c l'arete ns i1-np dans nosoar est dans le sens indirect
5902 noartr( 3, nti ) = -nuarco(i)
5904 c l'arete ns i1-np dans nosoar est dans le sens direct
5905 noartr( 3, nti ) = nuarco(i)
5909 c le triangle nt est rendu libre
5910 c ==============================
5911 c il devient n1artr le premier triangle libre
5913 noartr( 2, nt ) = n1artr
5918 subroutine mt4sqa( na, moartr, noartr, mosoar, nosoar,
5919 % ns1, ns2, ns3, ns4)
5920 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5921 c but : calcul du numero des 4 sommets de l'arete na de nosoar
5922 c ----- formant un quadrangle
5926 c na : numero de l'arete dans nosoar a traiter
5927 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5928 c arete1=0 si triangle vide => arete2=triangle vide suivant
5929 c mosoar : nombre maximal d'entiers par arete
5930 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
5931 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
5935 c ns1,ns2,ns3 : les 3 numeros des sommets du triangle t1 en sens direct
5936 c ns1,ns4,ns2 : les 3 numeros des sommets du triangle t2 en sens direct
5938 c si erreur rencontree => ns4 = 0
5939 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5940 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5941 c2345x7..............................................................012
5942 common / unites / lecteu, imprim, nunite(30)
5943 integer noartr(moartr,*), nosoar(mosoar,*)
5945 c le numero de triangle est il correct ?
5946 c a supprimer apres mise au point
5947 if( na .le. 0 ) then
5949 c write(kerr(mxlger)(1:6),'(i6)') na
5950 c kerr(1) = kerr(mxlger)(1:6) //
5951 c % ' no incorrect arete dans nosoar'
5953 write(imprim,*) na, ' no incorrect arete dans nosoar'
5958 if( nosoar(1,na) .le. 0 ) then
5960 c write(kerr(mxlger)(1:6),'(i6)') na
5961 c kerr(1) = kerr(mxlger)(1:6) //
5962 c % ' arete non active dans nosoar'
5964 write(imprim,*) na, ' arete non active dans nosoar'
5969 c recherche de l'arete na dans le premier triangle
5971 if( nt .le. 0 ) then
5973 c write(kerr(mxlger)(1:6),'(i6)') na
5974 c kerr(1) = 'triangle 1 incorrect pour l''arete ' //
5975 c % kerr(mxlger)(1:6)
5977 write(imprim,*) 'triangle 1 incorrect pour l''arete ', na
5983 if( abs( noartr(i,nt) ) .eq. na ) goto 8
5985 c si arrivee ici => bogue avant
5986 write(imprim,*) 'mt4sqa: arete',na,' non dans le triangle',nt
5990 c les 2 sommets de l'arete na
5991 8 if( noartr(i,nt) .gt. 0 ) then
5998 ns1 = nosoar(ns1,na)
5999 ns2 = nosoar(ns2,na)
6007 naa = abs( noartr(i,nt) )
6009 c le sommet ns3 du triangle 123
6011 if( ns3 .eq. ns1 .or. ns3 .eq. ns2 ) then
6015 c le triangle de l'autre cote de l'arete na
6016 c =========================================
6018 if( nt .le. 0 ) then
6020 c write(kerr(mxlger)(1:6),'(i6)') na
6021 c kerr(1) = 'triangle 2 incorrect pour l''arete ' //
6022 c % kerr(mxlger)(1:6)
6024 write(imprim,*) 'triangle 2 incorrect pour l''arete ',na
6029 c le numero de l'arete naa du triangle nt
6030 naa = abs( noartr(1,nt) )
6031 if( naa .eq. na ) naa = abs( noartr(2,nt) )
6033 if( ns4 .eq. ns1 .or. ns4 .eq. ns2 ) then
6039 subroutine te2t2t( noaret, mosoar, n1soar, nosoar, noarst,
6040 % moartr, noartr, noar34 )
6041 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6042 c but : echanger la diagonale des 2 triangles ayant en commun
6043 c ----- l'arete noaret du tableau nosoar si c'est possible
6047 c noaret : numero de l'arete a echanger entre les 2 triangles
6048 c mosoar : nombre maximal d'entiers par arete
6049 c moartr : nombre maximal d'entiers par triangle
6053 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6054 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
6055 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6056 c noarst : noarst(i) numero d'une arete de sommet i
6057 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6058 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
6062 c noar34 : numero nosoar de la nouvelle arete diagonale
6063 c 0 si pas d'echange des aretes diagonales
6064 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6065 c auteur : alain perronnet analyse numerique paris upmc avril 1997
6066 c....................................................................012
6067 integer nosoar(mosoar,*),
6071 c une arete frontaliere ne peut etre echangee
6073 if( nosoar(3,noaret) .gt. 0 ) return
6075 c les 4 sommets des 2 triangles ayant l'arete noaret en commun
6076 call mt4sqa( noaret, moartr, noartr, mosoar, nosoar,
6077 % ns1, ns2, ns3, ns4)
6078 c ns1,ns2,ns3 : les 3 numeros des sommets du triangle nt1 en sens direct
6079 c ns1,ns4,ns2 : les 3 numeros des sommets du triangle nt2 en sens direct
6081 c recherche du numero de l'arete noaret dans le triangle nt1
6082 nt1 = nosoar(4,noaret)
6084 if( abs(noartr(n1,nt1)) .eq. noaret ) goto 15
6086 c impossible d'arriver ici sans bogue!
6087 write(imprim,*) 'pause dans te2t2t 1'
6089 c l'arete de sommets 2 et 3
6090 15 if( n1 .lt. 3 ) then
6095 na23 = noartr(n2,nt1)
6097 c l'arete de sommets 3 et 1
6098 if( n2 .lt. 3 ) then
6103 na31 = noartr(n3,nt1)
6105 c recherche du numero de l'arete noaret dans le triangle nt2
6106 nt2 = nosoar(5,noaret)
6108 if( abs(noartr(n1,nt2)) .eq. noaret ) goto 25
6110 c impossible d'arriver ici sans bogue!
6111 write(imprim,*) 'pause dans te2t2t 2'
6113 c l'arete de sommets 1 et 4
6114 25 if( n1 .lt. 3 ) then
6119 na14 = noartr(n2,nt2)
6121 c l'arete de sommets 4 et 2
6122 if( n2 .lt. 3 ) then
6127 na42 = noartr(n3,nt2)
6129 c les triangles 123 142 deviennent 143 234
6130 c ========================================
6131 c ajout de l'arete ns3-ns4
6132 c on evite l'affichage de l'erreur
6134 call fasoar( ns3, ns4, nt1, nt2, 0,
6135 % mosoar, mxsoar, n1soar, nosoar, noarst,
6137 if( ierr .gt. 0 ) then
6138 c ierr=1 si le tableau nosoar est sature
6139 c =2 si arete a creer et appartenant a 2 triangles distincts
6140 c des triangles nt1 et nt2
6141 c =3 si arete appartenant a 2 triangles distincts
6142 c differents des triangles nt1 et nt2
6143 c =4 si arete appartenant a 2 triangles distincts
6144 c dont le second n'est pas le triangle nt2
6150 c suppression de l'arete noaret
6151 call sasoar( noaret, mosoar, mxsoar, n1soar, nosoar )
6153 c nt1 = triangle 143
6154 noartr(1,nt1) = na14
6155 c sens de stockage de l'arete ns3-ns4 dans nosoar?
6156 if( nosoar(1,noar34) .eq. ns3 ) then
6161 noartr(2,nt1) = noar34 * n1
6162 noartr(3,nt1) = na31
6164 c nt2 = triangle 234
6165 noartr(1,nt2) = na23
6166 noartr(2,nt2) = -noar34 * n1
6167 noartr(3,nt2) = na42
6169 c echange nt1 -> nt2 pour l'arete na23
6171 if( nosoar(4,na23) .eq. nt1 ) then
6176 nosoar(n1,na23) = nt2
6178 c echange nt2 -> nt1 pour l'arete na14
6180 if( nosoar(4,na14) .eq. nt2 ) then
6185 nosoar(n1,na14) = nt1
6187 c numero d'une arete de chacun des 4 sommets
6190 noarst(ns3) = noar34
6191 noarst(ns4) = noar34
6196 subroutine f0trte( letree, pxyd,
6197 % mosoar, mxsoar, n1soar, nosoar,
6198 % moartr, mxartr, n1artr, noartr,
6200 % nbtr, nutr, ierr )
6201 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6202 c but : former le ou les triangles du triangle equilateral letree
6203 c ----- les points internes au te deviennent des sommets des
6204 c sous-triangles du te
6208 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
6209 c si letree(0)>0 alors
6210 c letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
6212 c letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
6214 c ( le te est une feuille de l'arbre )
6215 c letree(4) : no letree du sur-triangle du triangle j
6216 c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
6217 c letree(6:8) : no pxyd des 3 sommets du triangle j
6218 c pxyd : tableau des x y distance_souhaitee de chaque sommet
6219 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
6220 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6221 c moartr : nombre maximal d'entiers par arete du tableau noartr
6222 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
6226 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6227 c une arete i de nosoar est vide <=> nosoar(1,i)=0
6228 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6229 c chainage des aretes frontalieres, chainage du hachage des aretes
6230 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
6231 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6232 c n1artr : numero du premier triangle vide dans le tableau noartr
6233 c le chainage des triangles vides se fait sur noartr(2,.)
6234 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6235 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
6236 c noarst : noarst(i) numero d'une arete de sommet i
6240 c nbtr : nombre de sous-triangles du te, triangulation du te
6241 c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
6242 c ierr : =0 si pas d'erreur
6243 c =1 si le tableau nosoar est sature
6244 c =2 si le tableau noartr est sature
6245 c =3 si aucun des triangles ne contient l'un des points internes au te
6246 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6247 c auteur : alain perronnet analyse numerique paris upmc mars 1997
6248 c....................................................................012
6249 common / unites / lecteu, imprim, nunite(30)
6250 double precision pxyd(3,*)
6251 integer letree(0:8),
6252 % nosoar(mosoar,mxsoar),
6253 % noartr(moartr,mxartr),
6258 c le numero nt du triangle dans le tableau noartr
6259 if( n1artr .le. 0 ) then
6260 c tableau noartr sature
6261 write(imprim,*) 'f0trte: tableau noartr sature'
6266 c le numero du nouveau premier triangle libre dans noartr
6267 n1artr = noartr( 2, n1artr )
6269 c formation du triangle = le triangle equilateral letree
6276 c ajout eventuel de l'arete si si+1 dans le tableau nosoar
6277 call fasoar( letree(5+i), letree(5+i1), nt, -1, 0,
6278 % mosoar, mxsoar, n1soar, nosoar, noarst,
6280 if( ierr .ne. 0 ) return
6283 c le triangle nt est forme dans le tableau noartr
6285 c letree(5+i) est le numero du sommet 1 de l'arete i du te
6286 if( letree(5+i) .eq. nosoar(1,nuarco(i)) ) then
6291 c l'arete ns1-ns2 dans nosoar est celle du cote du te
6292 noartr( i, nt ) = lesign * nuarco(i)
6295 c triangulation du te=triangle nt par ajout des points internes du te
6298 call trpite( letree, pxyd,
6299 % mosoar, mxsoar, n1soar, nosoar,
6300 % moartr, mxartr, n1artr, noartr, noarst,
6301 % nbtr, nutr, ierr )
6305 subroutine f1trte( letree, pxyd, milieu,
6306 % mosoar, mxsoar, n1soar, nosoar,
6307 % moartr, mxartr, n1artr, noartr,
6309 % nbtr, nutr, ierr )
6310 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6311 c but : former les triangles du triangle equilateral letree
6312 c ----- a partir de l'un des 3 milieux des cotes du te
6313 c et des points internes au te
6314 c ils deviennent tous des sommets des sous-triangles du te
6318 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
6319 c si letree(0)>0 alors
6320 c letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
6322 c letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
6324 c ( le te est une feuille de l'arbre )
6325 c letree(4) : no letree du sur-triangle du triangle j
6326 c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
6327 c letree(6:8) : no pxyd des 3 sommets du triangle j
6328 c pxyd : tableau des x y distance_souhaitee de chaque sommet
6329 c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
6330 c 0 si pas de milieu du cote i a ajouter
6331 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
6332 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6333 c moartr : nombre maximal d'entiers par arete du tableau noartr
6334 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
6338 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6339 c une arete i de nosoar est vide <=> nosoar(1,i)=0
6340 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6341 c chainage des aretes frontalieres, chainage du hachage des aretes
6342 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
6343 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6344 c n1artr : numero du premier triangle vide dans le tableau noartr
6345 c le chainage des triangles vides se fait sur noartr(2,.)
6346 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6347 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
6348 c noarst : noarst(np) numero d'une arete du sommet np
6352 c nbtr : nombre de sous-triangles du te, triangulation du te
6353 c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
6354 c ierr : =0 si pas d'erreur
6355 c =1 si le tableau nosoar est sature
6356 c =2 si le tableau noartr est sature
6357 c =3 si aucun des triangles ne contient l'un des points internes au te
6358 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6359 c auteur : alain perronnet analyse numerique paris upmc mars 1997
6360 c....................................................................012
6361 double precision pxyd(3,*)
6362 integer letree(0:8),
6364 % nosoar(mosoar,mxsoar),
6365 % noartr(moartr,mxartr),
6369 integer nosotr(3), nuarco(5)
6371 c le numero des 2 triangles (=2 demi te) a creer dans le tableau noartr
6373 if( n1artr .le. 0 ) then
6374 c tableau noartr sature
6379 c le nouveau premier triangle libre dans noartr
6380 n1artr = noartr(2,n1artr)
6384 c recherche du milieu a creer
6386 if( milieu(i) .ne. 0 ) goto 9
6388 c le numero pxyd du point milieu du cote i
6391 c on se ramene au seul cas i=3 c-a-d le milieu est sur le cote 3
6393 c milieu sur le cote 1
6394 nosotr(1) = letree(7)
6395 nosotr(2) = letree(8)
6396 nosotr(3) = letree(6)
6397 else if( i .eq. 2 ) then
6398 c milieu sur le cote 2
6399 nosotr(1) = letree(8)
6400 nosotr(2) = letree(6)
6401 nosotr(3) = letree(7)
6403 c milieu sur le cote 3
6404 nosotr(1) = letree(6)
6405 nosotr(2) = letree(7)
6406 nosotr(3) = letree(8)
6409 c formation des 2 aretes s1 s2 et s2 s3
6416 c ajout eventuel de l'arete dans nosoar
6417 call fasoar( nosotr(i), nosotr(i1), nutr(i), -1, 0,
6418 % mosoar, mxsoar, n1soar, nosoar, noarst,
6420 if( ierr .ne. 0 ) return
6423 c ajout eventuel de l'arete s3 milieu dans nosoar
6424 call fasoar( nosotr(3), nm, nutr(2), -1, 0,
6425 % mosoar, mxsoar, n1soar, nosoar, noarst,
6427 if( ierr .ne. 0 ) return
6429 c ajout eventuel de l'arete milieu s1 dans nosoar
6430 call fasoar( nosotr(1), nm, nutr(1), -1, 0,
6431 % mosoar, mxsoar, n1soar, nosoar, noarst,
6433 if( ierr .ne. 0 ) return
6435 c ajout eventuel de l'arete milieu s2 dans nosoar
6436 call fasoar( nosotr(2), nm, nutr(1), nutr(2), 0,
6437 % mosoar, mxsoar, n1soar, nosoar, noarst,
6439 if( ierr .ne. 0 ) return
6441 c les aretes s1 s2 et s2 s3 dans le tableau noartr
6443 c nosotr(i) est le numero du sommet 1 de l'arete i du te
6444 if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
6449 c l'arete ns1-ns2 dans nosoar est celle du cote du te
6450 noartr( 1, nutr(i) ) = lesign * nuarco(i)
6453 c l'arete mediane s2 milieu
6454 if( nm .eq. nosoar(1,nuarco(5)) ) then
6459 noartr( 2, nutr(1) ) = lesign * nuarco(5)
6460 noartr( 3, nutr(2) ) = -lesign * nuarco(5)
6463 if( nm .eq. nosoar(1,nuarco(4)) ) then
6468 noartr( 3, nutr(1) ) = lesign * nuarco(4)
6471 if( nm .eq. nosoar(1,nuarco(3)) ) then
6476 noartr( 2, nutr(2) ) = lesign * nuarco(3)
6478 c triangulation des 2 demi te par ajout des points internes du te
6479 call trpite( letree, pxyd,
6480 % mosoar, mxsoar, n1soar, nosoar,
6481 % moartr, mxartr, n1artr, noartr, noarst,
6482 % nbtr, nutr, ierr )
6486 subroutine f2trte( letree, pxyd, milieu,
6487 % mosoar, mxsoar, n1soar, nosoar,
6488 % moartr, mxartr, n1artr, noartr,
6490 % nbtr, nutr, ierr )
6491 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6492 c but : former les triangles du triangle equilateral letree
6493 c ----- a partir de 2 milieux des cotes du te
6494 c et des points internes au te
6495 c ils deviennent tous des sommets des sous-triangles du te
6499 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
6500 c si letree(0)>0 alors
6501 c letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
6503 c letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
6505 c ( le te est une feuille de l'arbre )
6506 c letree(4) : no letree du sur-triangle du triangle j
6507 c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
6508 c letree(6:8) : no pxyd des 3 sommets du triangle j
6509 c pxyd : tableau des x y distance_souhaitee de chaque sommet
6510 c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
6511 c 0 si pas de milieu du cote i a ajouter
6512 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
6513 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6514 c moartr : nombre maximal d'entiers par arete du tableau noartr
6515 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
6519 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6520 c une arete i de nosoar est vide <=> nosoar(1,i)=0
6521 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6522 c chainage des aretes frontalieres, chainage du hachage des aretes
6523 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
6524 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6525 c n1artr : numero du premier triangle vide dans le tableau noartr
6526 c le chainage des triangles vides se fait sur noartr(2,.)
6527 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6528 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
6529 c noarst : noarst(np) numero d'une arete du sommet np
6533 c nbtr : nombre de sous-triangles du te, triangulation du te
6534 c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
6535 c ierr : =0 si pas d'erreur
6536 c =1 si le tableau nosoar est sature
6537 c =2 si le tableau noartr est sature
6538 c =3 si aucun des triangles ne contient l'un des points internes au te
6539 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6540 c auteur : alain perronnet analyse numerique paris upmc mars 1997
6541 c....................................................................012
6542 common / unites / lecteu, imprim, nunite(30)
6543 double precision pxyd(3,*)
6544 integer letree(0:8),
6546 % nosoar(mosoar,mxsoar),
6547 % noartr(moartr,mxartr),
6551 integer nosotr(3), nuarco(7)
6553 c le numero des 3 triangles a creer dans le tableau noartr
6555 if( n1artr .le. 0 ) then
6556 c tableau noartr sature
6561 c le nouveau premier triangle libre dans noartr
6562 n1artr = noartr(2,n1artr)
6566 c recherche du premier milieu a creer
6568 if( milieu(i) .ne. 0 ) goto 9
6571 c on se ramene au seul cas i=2 c-a-d le cote 1 n'a pas de milieu
6572 9 if( i .eq. 2 ) then
6573 c pas de milieu sur le cote 1
6574 nosotr(1) = letree(6)
6575 nosotr(2) = letree(7)
6576 nosotr(3) = letree(8)
6577 c le numero pxyd du milieu du cote 2
6579 c le numero pxyd du milieu du cote 3
6581 else if( milieu(2) .ne. 0 ) then
6582 c pas de milieu sur le cote 3
6583 nosotr(1) = letree(8)
6584 nosotr(2) = letree(6)
6585 nosotr(3) = letree(7)
6586 c le numero pxyd du milieu du cote 2
6588 c le numero pxyd du milieu du cote 3
6591 c pas de milieu sur le cote 2
6592 nosotr(1) = letree(7)
6593 nosotr(2) = letree(8)
6594 nosotr(3) = letree(6)
6595 c le numero pxyd du milieu du cote 2
6597 c le numero pxyd du milieu du cote 3
6601 c ici seul le cote 1 n'a pas de milieu
6602 c nm2 est le milieu du cote 2
6603 c nm3 est le milieu du cote 3
6605 c ajout eventuel de l'arete s1 s2 dans nosoar
6606 call fasoar( nosotr(1), nosotr(2), nutr(1), -1, 0,
6607 % mosoar, mxsoar, n1soar, nosoar, noarst,
6609 if( ierr .ne. 0 ) return
6611 c ajout eventuel de l'arete s1 s2 dans nosoar
6612 call fasoar( nosotr(2), nm2, nutr(1), -1, 0,
6613 % mosoar, mxsoar, n1soar, nosoar, noarst,
6615 if( ierr .ne. 0 ) return
6617 c ajout eventuel de l'arete s1 nm2 dans nosoar
6618 call fasoar( nosotr(1), nm2, nutr(1), nutr(2), 0,
6619 % mosoar, mxsoar, n1soar, nosoar, noarst,
6621 if( ierr .ne. 0 ) return
6623 c ajout eventuel de l'arete nm2 nm3 dans nosoar
6624 call fasoar( nm3, nm2, nutr(2), nutr(3), 0,
6625 % mosoar, mxsoar, n1soar, nosoar, noarst,
6627 if( ierr .ne. 0 ) return
6629 c ajout eventuel de l'arete s1 nm3 dans nosoar
6630 call fasoar( nosotr(1), nm3, nutr(2), -1, 0,
6631 % mosoar, mxsoar, n1soar, nosoar, noarst,
6633 if( ierr .ne. 0 ) return
6635 c ajout eventuel de l'arete nm2 s3 dans nosoar
6636 call fasoar( nm2, nosotr(3), nutr(3), -1, 0,
6637 % mosoar, mxsoar, n1soar, nosoar, noarst,
6640 c ajout eventuel de l'arete nm3 s3 dans nosoar
6641 call fasoar( nosotr(3), nm3, nutr(3), -1, 0,
6642 % mosoar, mxsoar, n1soar, nosoar, noarst,
6644 if( ierr .ne. 0 ) return
6646 c le triangle s1 s2 nm2 ou arete1 arete2 arete3
6648 c nosotr(i) est le numero du sommet 1 de l'arete i du te
6649 if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
6654 c l'arete ns1-ns2 dans nosoar est celle du cote du te
6655 noartr( i, nutr(1) ) = lesign * nuarco(i)
6657 if( nm2 .eq. nosoar(1,nuarco(3)) ) then
6662 noartr( 3, nutr(1) ) = lesign * nuarco(3)
6664 c le triangle s1 nm2 nm3
6665 noartr( 1, nutr(2) ) = -lesign * nuarco(3)
6666 if( nm2 .eq. nosoar(1,nuarco(4)) ) then
6671 noartr( 2, nutr(2) ) = lesign * nuarco(4)
6672 noartr( 1, nutr(3) ) = -lesign * nuarco(4)
6673 if( nm3 .eq. nosoar(1,nuarco(5)) ) then
6678 noartr( 3, nutr(2) ) = lesign * nuarco(5)
6680 c le triangle nm2 nm3 s3
6681 if( nm2 .eq. nosoar(1,nuarco(6)) ) then
6686 noartr( 2, nutr(3) ) = lesign * nuarco(6)
6687 if( nm3 .eq. nosoar(1,nuarco(7)) ) then
6692 noartr( 3, nutr(3) ) = lesign * nuarco(7)
6694 c triangulation des 3 sous-te par ajout des points internes du te
6695 call trpite( letree, pxyd,
6696 % mosoar, mxsoar, n1soar, nosoar,
6697 % moartr, mxartr, n1artr, noartr, noarst,
6698 % nbtr, nutr, ierr )
6702 subroutine f3trte( letree, pxyd, milieu,
6703 % mosoar, mxsoar, n1soar, nosoar,
6704 % moartr, mxartr, n1artr, noartr,
6706 % nbtr, nutr, ierr )
6707 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6708 c but : former les triangles du triangle equilateral letree
6709 c ----- a partir de 3 milieux des cotes du te
6710 c et des points internes au te
6711 c ils deviennent tous des sommets des sous-triangles du te
6715 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
6716 c si letree(0)>0 alors
6717 c letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
6719 c letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
6721 c ( le te est une feuille de l'arbre )
6722 c letree(4) : no letree du sur-triangle du triangle j
6723 c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
6724 c letree(6:8) : no pxyd des 3 sommets du triangle j
6725 c pxyd : tableau des x y distance_souhaitee de chaque sommet
6726 c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
6727 c 0 si pas de milieu du cote i a ajouter
6728 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
6729 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6730 c moartr : nombre maximal d'entiers par arete du tableau noartr
6731 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
6735 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6736 c une arete i de nosoar est vide <=> nosoar(1,i)=0
6737 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6738 c chainage des aretes frontalieres, chainage du hachage des aretes
6739 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
6740 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6741 c n1artr : numero du premier triangle vide dans le tableau noartr
6742 c le chainage des triangles vides se fait sur noartr(2,.)
6743 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6744 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
6745 c noarst : noarst(np) numero d'une arete du sommet np
6749 c nbtr : nombre de sous-triangles du te, triangulation du te
6750 c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
6751 c ierr : =0 si pas d'erreur
6752 c =1 si le tableau nosoar est sature
6753 c =2 si le tableau noartr est sature
6754 c =3 si aucun des triangles ne contient l'un des points internes au te
6755 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6756 c auteur : alain perronnet analyse numerique paris upmc mars 1997
6757 c....................................................................012
6758 common / unites / lecteu, imprim, nunite(30)
6759 double precision pxyd(3,*)
6760 integer letree(0:8),
6762 % nosoar(mosoar,mxsoar),
6763 % noartr(moartr,mxartr),
6769 c le numero des 4 triangles a creer dans le tableau noartr
6771 if( n1artr .le. 0 ) then
6772 c tableau noartr sature
6777 c le nouveau premier triangle libre dans noartr
6778 n1artr = noartr(2,n1artr)
6789 c le sommet precedant
6797 c ajout eventuel de l'arete si mi dans nosoar
6798 call fasoar( letree(5+i), milieu(i), nutr(i), -1, 0,
6799 % mosoar, mxsoar, n1soar, nosoar, noarst,
6800 % nuarco(i3-2), ierr )
6801 if( ierr .ne. 0 ) return
6803 c ajout eventuel de l'arete mi mi-1 dans nosoar
6804 call fasoar( milieu(i), milieu(i0), nutr(i), nutr(4), 0,
6805 % mosoar, mxsoar, n1soar, nosoar, noarst,
6806 % nuarco(i3-1), ierr )
6807 if( ierr .ne. 0 ) return
6809 c ajout eventuel de l'arete m i-1 si dans nosoar
6810 call fasoar( milieu(i0), letree(5+i), nutr(i), -1, 0,
6811 % mosoar, mxsoar, n1soar, nosoar, noarst,
6812 % nuarco(i3), ierr )
6813 if( ierr .ne. 0 ) return
6817 c les 3 sous-triangles pres des sommets
6825 c le sommet precedant
6833 c ajout du triangle arete3i-2 arete3i-1 arete3i
6834 if( letree(5+i) .eq. nosoar(1,nuarco(i3-2)) ) then
6839 noartr( 1, nutr(i) ) = lesign * nuarco(i3-2)
6841 if( milieu(i) .eq. nosoar(1,nuarco(i3-1)) ) then
6846 noartr( 2, nutr(i) ) = lesign * nuarco(i3-1)
6848 if( milieu(i0) .eq. nosoar(1,nuarco(i3)) ) then
6853 noartr( 3, nutr(i) ) = lesign * nuarco(i3)
6857 c le sous triangle central
6861 if( milieu(i) .eq. nosoar(1,nuarco(i3)) ) then
6866 noartr( i, nutr(4) ) = lesign * nuarco(i3)
6869 c triangulation des 3 sous-te par ajout des points internes du te
6870 call trpite( letree, pxyd,
6871 % mosoar, mxsoar, n1soar, nosoar,
6872 % moartr, mxartr, n1artr, noartr, noarst,
6873 % nbtr, nutr, ierr )
6878 subroutine hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar,
6880 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6881 c but : rechercher le numero des 2 sommets d'une arete parmi
6882 c ----- les numeros des 2 sommets des aretes du tableau nosoar
6883 c s ils n y sont pas stockes les y ajouter
6884 c dans tous les cas retourner le numero de l'arete dans nosoar
6886 c la methode employee ici est celle du hachage
6887 c avec pour fonction d'adressage h(ns1,ns2)=min(ns1,ns2)
6889 c remarque: h(ns1,ns2)=ns1 + 2*ns2
6890 c ne marche pas si des aretes sont detruites
6891 c et ajoutees aux aretes vides
6892 c le chainage est commun a plusieurs hachages!
6893 c d'ou ce choix du minimum pour le hachage
6897 c mosoar : nombre maximal d'entiers par arete et
6898 c indice dans nosoar de l'arete suivante dans le hachage
6899 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6900 c attention: mxsoar>3*mxsomm obligatoire!
6904 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6905 c une arete i de nosoar est vide <=> nosoar(1,i)=0
6906 c chainage des aretes vides amont et aval
6907 c l'arete vide qui precede=nosoar(4,i)
6908 c l'arete vide qui suit =nosoar(5,i)
6909 c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
6910 c chainage momentan'e d'aretes, chainage du hachage des aretes
6911 c hachage des aretes = min( nosoar(1), nosoar(2) )
6912 c nu2sar : en entree les 2 numeros des sommets de l'arete
6913 c en sortie nu2sar(1)<nu2sar(2) numeros des 2 sommets de l'arete
6917 c noar : numero dans nosoar de l'arete apres hachage
6918 c =0 si saturation du tableau nosoar
6919 c >0 si le tableau nu2sar est l'arete noar retrouvee
6920 c dans le tableau nosoar
6921 c <0 si le tableau nu2sar a ete ajoute et forme l'arete
6922 c -noar du tableau nosoar avec nosoar(1,noar)<nosoar(2,noar)
6923 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6924 c auteur : alain perronnet analyse numerique upmc paris mars 1997
6925 c ...................................................................012
6926 integer nu2sar(2), nosoar(mosoar,mxsoar)
6928 if( nu2sar(1) .gt. nu2sar(2) ) then
6930 c permutation des numeros des 2 sommets pour
6931 c amener le plus petit dans nu2sar(1)
6933 nu2sar(1) = nu2sar(2)
6937 c la fonction d'adressage du hachage des aretes : h(ns1,ns2)=min(ns1,ns2)
6938 c ===============================================
6941 c la recherche de l'arete dans le chainage du hachage
6942 c ---------------------------------------------------
6943 10 if( nu2sar(1) .eq. nosoar(1,noar) ) then
6944 if( nu2sar(2) .eq. nosoar(2,noar) ) then
6946 c l'arete est retrouvee
6947 c .....................
6952 c l'arete suivante parmi celles ayant meme fonction d'adressage
6953 i = nosoar( mosoar, noar )
6959 c noar est ici la derniere arete (sans suivante) du chainage
6960 c a partir de l'adressage du hachage
6962 c l'arete non retrouvee doit etre ajoutee
6963 c .......................................
6964 if( nosoar( 1, nu2sar(1) ) .eq. 0 ) then
6966 c l'adresse de hachage est libre => elle devient la nouvelle arete
6967 c retouche des chainages de cette arete noar qui ne sera plus vide
6969 c l'eventuel chainage du hachage n'est pas modifie
6973 c la premiere arete dans l'adressage du hachage n'est pas libre
6974 c => choix quelconque d'une arete vide pour ajouter cette arete
6975 if( n1soar .le. 0 ) then
6977 c le tableau nosoar est sature avec pour temoin d'erreur
6983 c l'arete n1soar est vide => c'est la nouvelle arete
6984 c mise a jour du chainage de la derniere arete noar du chainage
6985 c sa suivante est la nouvelle arete n1soar
6986 nosoar( mosoar, noar ) = n1soar
6988 c l'arete ajoutee est n1soar
6991 c la nouvelle premiere arete vide
6992 n1soar = nosoar( 5, n1soar )
6994 c la premiere arete vide n1soar n'a pas d'arete vide precedente
6995 nosoar( 4, n1soar ) = 0
6997 c noar la nouvelle arete est la derniere du chainage du hachage
6998 nosoar( mosoar, noar ) = 0
7004 c les 2 sommets de la nouvelle arete noar
7005 nosoar( 1, noar ) = nu2sar(1)
7006 nosoar( 2, noar ) = nu2sar(2)
7008 c le tableau nu2sar a ete ajoute avec l'indice -noar
7013 subroutine mt3str( nt, moartr, noartr, mosoar, nosoar,
7015 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7016 c but : calcul du numero des 3 sommets du triangle nt du tableau noartr
7021 c nt : numero du triangle de noartr a traiter
7022 c moartr : nombre maximal d'entiers par triangle
7023 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
7024 c arete1=0 si triangle vide => arete2=triangle vide suivant
7025 c mosoar : nombre maximal d'entiers par arete
7026 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
7027 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
7031 c ns1,ns2,ns3 : les 3 numeros des sommets du triangle en sens direct
7033 c si erreur rencontree => ns1 = 0
7034 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7035 c auteur : alain perronnet analyse numerique paris upmc juillet 1995
7036 c2345x7..............................................................012
7037 integer noartr(moartr,*), nosoar(mosoar,*)
7039 c le numero de triangle est il correct ?
7040 c a supprimer apres mise au point
7041 if( nt .le. 0 ) then
7043 c write(kerr(mxlger)(1:6),'(i6)') nt
7044 c kerr(1) = kerr(mxlger)(1:6) //
7045 c % ' no triangle dans noartr incorrect'
7047 write(imprim,*) nt,' no triangle dans noartr incorrect'
7053 if( na .gt. 0 ) then
7054 c arete dans le sens direct
7058 c arete dans le sens indirect
7064 if( na .gt. 0 ) then
7065 c arete dans le sens direct => ns3 est le second sommet de l'arete
7068 c arete dans le sens indirect => ns3 est le premier sommet de l'arete
7072 subroutine trpite( letree, pxyd,
7073 % mosoar, mxsoar, n1soar, nosoar,
7074 % moartr, mxartr, n1artr, noartr,
7076 % nbtr, nutr, ierr )
7077 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7078 c but : former le ou les sous-triangles des nbtr triangles nutr
7079 c ----- qui forment le triangle equilateral letree par ajout
7080 c des points internes au te qui deviennent des sommets des
7081 c sous-triangles des nbtr triangles
7085 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
7086 c letree(0:3):-no pxyd des 1 a 4 points internes au triangle j
7088 c ( le te est ici une feuille de l'arbre )
7089 c letree(4) : no letree du sur-triangle du triangle j
7090 c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
7091 c letree(6:8) : no pxyd des 3 sommets du triangle j
7092 c pxyd : tableau des x y distance_souhaitee de chaque sommet
7093 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
7094 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
7095 c moartr : nombre maximal d'entiers par arete du tableau noartr
7096 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
7100 c n1soar : numero de la premiere arete vide dans le tableau nosoar
7101 c une arete i de nosoar est vide <=> nosoar(1,i)=0
7102 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
7103 c chainage des aretes frontalieres, chainage du hachage des aretes
7104 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
7105 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
7106 c n1artr : numero du premier triangle vide dans le tableau noartr
7107 c le chainage des triangles vides se fait sur noartr(2,.)
7108 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
7109 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
7110 c noarst : noarst(i) numero d'une arete de sommet i
7114 c nbtr : nombre de sous-triangles du te
7115 c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
7116 c ierr : =0 si pas d'erreur
7117 c =1 si le tableau nosoar est sature
7118 c =2 si le tableau noartr est sature
7119 c =3 si aucun des triangles ne contient l'un des points internes au te
7120 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7121 c auteur : alain perronnet analyse numerique paris upmc mars 1997
7122 c....................................................................012
7124 common / dv2dco / tratri
7125 c trace ou non des triangles generes dans la triangulation
7126 common / unites / lecteu, imprim, nunite(30)
7127 double precision pxyd(3,*)
7128 integer letree(0:8),
7129 % nosoar(mosoar,mxsoar),
7130 % noartr(moartr,mxartr),
7136 c si pas de point interne alors trace eventuel puis retour
7137 if( letree(0) .eq. 0 ) goto 150
7139 c il existe au moins un point interne a trianguler
7140 c dans les nbtr triangles
7143 c le numero du point
7145 if( np .eq. 0 ) goto 150
7147 c le point np dans pxyd est a traiter
7150 c les numeros des 3 sommets du triangle nt=nutr(n)
7152 call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
7154 c le triangle nt contient il le point np?
7155 call ptdatr( pxyd(1,np), pxyd, nosotr, nsigne )
7156 c nsigne>0 si le point est dans le triangle ou sur une des 3 aretes
7157 c =0 si triangle degenere ou indirect ou ne contient pas le poin
7159 if( nsigne .gt. 0 ) then
7161 c le triangle nt est triangule en 3 sous-triangles
7162 call tr3str( np, nt,
7163 % mosoar, mxsoar, n1soar, nosoar,
7164 % moartr, mxartr, n1artr, noartr,
7166 % nutr(nbtr+1), ierr )
7167 if( ierr .ne. 0 ) return
7169 c reamenagement des 3 triangles crees dans nutr
7170 c en supprimant le triangle nt
7171 nutr( n ) = nutr( nbtr + 3 )
7173 c le point np est triangule
7179 c erreur: le point np n'est pas dans l'un des nbtr triangles
7180 write(imprim,10010) np
7185 10010 format(' erreur trpite: pas de triangle contenant le point',i7)
7189 ccc 150 if( tratri ) then
7190 cccc les traces sont demandes
7192 cccc le cadre objet global en unites utilisateur
7193 ccc xx1 = min(pxyd(1,nosotr(1)),pxyd(1,nosotr(2)),pxyd(1,nosotr(3)))
7194 ccc xx2 = max(pxyd(1,nosotr(1)),pxyd(1,nosotr(2)),pxyd(1,nosotr(3)))
7195 ccc yy1 = min(pxyd(2,nosotr(1)),pxyd(2,nosotr(2)),pxyd(2,nosotr(3)))
7196 ccc yy2 = max(pxyd(2,nosotr(1)),pxyd(2,nosotr(2)),pxyd(2,nosotr(3)))
7197 ccc if( xx1 .ge. xx2 ) xx2 = xx1 + (yy2-yy1)
7198 ccc if( yy1 .ge. yy2 ) yy2 = yy1 + (xx2-xx1)*0.5
7199 ccc call isofenetre( xx1-(xx2-xx1), xx2+(xx2-xx1),
7200 ccc % yy1-(yy2-yy1), yy2+(yy2-yy1) )
7202 cccc trace du triangle nutr(i)
7203 ccc call mttrtr( pxyd, nutr(i), moartr, noartr, mosoar, nosoar,
7211 subroutine sasoar( noar, mosoar, mxsoar, n1soar, nosoar )
7212 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7213 c but : supprimer l'arete noar du tableau nosoar
7214 c ----- si celle ci n'est pas une arete des lignes de la frontiere
7216 c la methode employee ici est celle du hachage
7217 c avec pour fonction d'adressage h = min( nu2sar(1), nu2sar(2) )
7219 c attention: il faut mettre a jour le no d'arete des 2 sommets
7220 c de l'arete supprimee dans le tableau noarst!
7224 c noar : numero de l'arete de nosoar a supprimer
7225 c mosoar : nombre maximal d'entiers par arete et
7226 c indice dans nosoar de l'arete suivante dans le hachage h
7227 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
7228 c attention: mxsoar>3*mxsomm obligatoire!
7232 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
7233 c chainage des vides suivant en 3 et precedant en 2 de nosoar
7234 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
7235 c chainage des aretes frontalieres, chainage du hachage des aretes
7236 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
7237 c nosoar(4,arete vide)=l'arete vide qui precede
7238 c nosoar(5,arete vide)=l'arete vide qui suit
7239 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7240 c auteur : alain perronnet analyse numerique upmc paris mars 1997
7241 c ...................................................................012
7242 common / unites / lecteu, imprim, nunite(30)
7243 integer nosoar(mosoar,mxsoar)
7245 if( nosoar(3,noar) .le. 0 ) then
7247 c l'arete n'est pas frontaliere => elle devient une arete vide
7249 c recherche de l'arete qui precede dans le chainage du hachage
7250 noar1 = nosoar(1,noar)
7252 c parcours du chainage du hachage jusqu'a retrouver l'arete noar
7253 10 if( noar1 .ne. noar ) then
7255 c l'arete suivante parmi celles ayant meme fonction d'adressage
7257 noar1 = nosoar( mosoar, noar1 )
7258 if( noar1 .gt. 0 ) goto 10
7260 c l'arete noar n'a pas ete retrouvee dans le chainage => erreur
7261 write(imprim,*) 'erreur sasoar:arete non dans le chainage '
7263 write(imprim,*) 'arete de st1=',nosoar(1,noar),
7264 % ' st2=',nosoar(2,noar),' ligne=',nosoar(3,noar),
7265 % ' tr1=',nosoar(4,noar),' tr2=',nosoar(5,noar)
7266 write(imprim,*) 'chainages=',(nosoar(i,noar),i=6,mosoar)
7267 c l'arete n'est pas detruite
7272 if( noar .ne. nosoar(1,noar) ) then
7274 c saut de l'arete noar dans le chainage du hachage
7275 c noar0 initialisee est ici l'arete qui precede noar dans ce chainage
7276 nosoar( mosoar, noar0 ) = nosoar( mosoar, noar )
7278 c le chainage du hachage n'existe plus pour noar
7279 c pas utile car mise a zero faite dans le sp hasoar
7280 ccc nosoar( mosoar, noar ) = 0
7282 c noar devient la nouvelle premiere arete du chainage des vides
7283 nosoar( 4, noar ) = 0
7284 nosoar( 5, noar ) = n1soar
7285 c la nouvelle precede l'ancienne premiere
7286 nosoar( 4, n1soar ) = noar
7291 c noar est la premiere arete du chainage du hachage h
7292 c cette arete ne peut etre consideree dans le chainage des vides
7293 c car le chainage du hachage doit etre conserve (sinon perte...)
7297 c le temoin d'arete vide
7298 nosoar( 1, noar ) = 0
7303 subroutine caetoi( noar, mosoar, mxsoar, n1soar, nosoar,
7305 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7306 c but : ajouter (ou retirer) l'arete noar de nosoar de l'etoile
7307 c ----- des aretes simples chainees en position lchain de nosoar
7308 c detruire du tableau nosoar les aretes doubles
7310 c attention: le chainage lchain de nosoar devient celui des cf
7314 c noar : numero dans le tableau nosoar de l'arete a traiter
7315 c mosoar : nombre maximal d'entiers par arete et
7316 c indice dans nosoar de l'arete suivante dans le hachage
7317 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
7318 c attention: mxsoar>3*mxsomm obligatoire!
7320 c entrees et sorties:
7321 c -------------------
7322 c n1soar : numero de la premiere arete vide dans le tableau nosoar
7323 c une arete i de nosoar est vide <=> nosoar(1,i)=0
7324 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
7325 c chainage des aretes frontalieres, chainage du hachage des aretes
7326 c n1aeoc : numero dans nosoar de la premiere arete simple de l'etoile
7330 c nbtrar : 1 si arete ajoutee, 2 si arete double supprimee, 0 si erreur
7331 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7332 c auteur : alain perronnet analyse numerique paris upmc mars 1997
7333 c2345x7..............................................................012
7334 parameter (lchain=6)
7335 common / unites / lecteu, imprim, nunite(30)
7336 integer nosoar(mosoar,mxsoar)
7338 c si l'arete n'appartient pas aux aretes de l'etoile naetoi
7339 c alors elle est ajoutee a l'etoile dans naetoi
7340 c sinon elle est empilee dans npile pour etre detruite ensuite
7341 c elle est supprimee de l'etoile naetoi
7343 if( nosoar( lchain, noar ) .lt. 0 ) then
7345 c arete de l'etoile vue pour la premiere fois
7346 c elle est ajoutee au chainage
7347 nosoar( lchain, noar ) = n1aeoc
7348 c elle devient la premiere du chainage
7355 c arete double de l'etoile. elle est supprimee du chainage
7359 c parcours des aretes chainees jusqu'a trouver l'arete noar
7360 10 if( na .ne. noar ) then
7361 c passage a la suivante
7363 na = nosoar( lchain, na )
7364 if( na .le. 0 ) then
7369 if( nbpass .gt. 128 ) then
7370 write(imprim,*)'Pb dans caetoi: boucle infinie evitee'
7377 c suppression de noar du chainage des aretes simples de l'etoile
7378 if( na0 .gt. 0 ) then
7379 c il existe une arete qui precede
7380 nosoar( lchain, na0 ) = nosoar( lchain, noar )
7382 c noar est en fait n1aeoc la premiere du chainage
7383 n1aeoc = nosoar( lchain, noar )
7385 c noar n'est plus une arete simple de l'etoile
7386 nosoar( lchain, noar ) = -1
7388 c destruction du tableau nosoar de l'arete double noar
7389 call sasoar( noar, mosoar, mxsoar, n1soar, nosoar )
7397 subroutine focftr( nbtrcf, notrcf, pxyd, noarst,
7398 % mosoar, mxsoar, n1soar, nosoar,
7399 % moartr, n1artr, noartr,
7400 % nbarcf, n1arcf, noarcf,
7402 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7403 c but : former un contour ferme (cf) avec les aretes simples des
7404 c ----- nbtrcf triangles du tableau notrcf
7405 c destruction des nbtrcf triangles du tableau noartr
7406 c destruction des aretes doubles du tableau nosoar
7408 c attention: le chainage lchain de nosoar devient celui des cf
7412 c nbtrcf : nombre de triangles du cf a former
7413 c notrcf : numero des triangles dans le tableau noartr
7414 c pxyd : tableau des coordonnees 2d des points
7415 c par point : x y distance_souhaitee
7417 c mosoar : nombre maximal d'entiers par arete et
7418 c indice dans nosoar de l'arete suivante dans le hachage
7419 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
7420 c attention: mxsoar>3*mxsomm obligatoire!
7421 c moartr : nombre maximal d'entiers par arete du tableau noartr
7423 c entrees et sorties :
7424 c --------------------
7425 c noarst : noarst(i) numero d'une arete de sommet i
7426 c n1soar : numero de la premiere arete vide dans le tableau nosoar
7427 c une arete i de nosoar est vide <=> nosoar(1,i)=0
7428 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
7429 c chainage des aretes frontalieres, chainage du hachage des aretes
7430 c hachage des aretes = nosoar(1)+nosoar(2)*2
7431 c n1artr : numero du premier triangle vide dans le tableau noartr
7432 c le chainage des triangles vides se fait sur noartr(2,.)
7433 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
7434 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
7438 c nbarcf : nombre d'aretes du cf
7439 c n1arcf : numero d'une arete de chaque contour
7440 c noarcf : numero des aretes de la ligne du contour ferme
7441 c attention: chainage circulaire des aretes
7442 c les aretes vides pointes par n1arcf(0) ne sont pas chainees
7443 c ierr : 0 si pas d'erreur
7444 c 14 si les lignes fermees se coupent => donnees a revoir
7445 c 15 si une seule arete simple frontaliere
7446 c 16 si boucle infinie car toutes les aretes simples
7447 c de la boule sont frontalieres!
7448 c 17 si boucle infinie dans caetoi
7449 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7450 c auteur : alain perronnet analyse numerique paris upmc mars 1997
7451 c....................................................................012
7452 parameter (lchain=6)
7453 common / unites / lecteu, imprim, nunite(30)
7454 double precision pxyd(3,*)
7455 integer notrcf(1:nbtrcf)
7456 integer nosoar(mosoar,mxsoar),
7462 c formation des aretes simples du cf autour de l'arete ns1-ns2
7463 c attention: le chainage lchain du tableau nosoar devient actif
7464 c ============================================================
7465 c ici toutes les aretes du tableau nosoar verifient nosoar(lchain,i) = -1
7466 c ce qui equivaut a dire que l'etoile des aretes simples est vide
7467 c (initialisation dans le sp insoar puis remise a -1 dans la suite!)
7470 c ajout a l'etoile des aretes simples des 3 aretes des triangles a supprimer
7471 c suppression des triangles de l'etoile pour les aretes simples de l'etoile
7473 c ajout ou retrait des 3 aretes du triangle notrcf(i) de l'etoile
7476 c l'arete de nosoar a traiter
7477 noar = abs( noartr(j,nt) )
7478 call caetoi( noar, mosoar, mxsoar, n1soar, nosoar,
7480 if( nbtrar .le. 0 ) then
7484 c si arete simple alors suppression du numero de triangle
7486 if( nbtrar .eq. 1 ) then
7487 if( nosoar(4,noar) .eq. nt ) then
7488 nosoar(4,noar) = nosoar(5,noar)
7492 c l'arete appartient a aucun triangle => elle est vide
7493 c les positions 4 et 5 servent maintenant aux chainages des vides
7498 c les aretes simples de l'etoile sont reordonnees pour former une
7499 c ligne fermee = un contour ferme peripherique de l'etoile encore dit 1 cf
7500 c ========================================================================
7503 c la premiere arete du contour ferme
7507 c l'arete est-elle dans le sens direct?
7508 c recherche de l'arete du triangle exterieur nt d'arete na1
7510 if( nt .le. 0 ) nt = nosoar(5,na1)
7512 c attention au cas de l'arete initiale frontaliere de no de triangles 0 et -
7513 if( nt .le. 0 ) then
7514 c permutation circulaire des aretes simples chainees
7515 c la premiere arete doit devenir la derniere du chainage,
7516 c la 2=>1, la 3=>2, ... , la derniere=>l'avant derniere, 1=>derniere
7517 n1aeoc = nosoar( lchain, n1aeoc )
7518 if( n1aeoc .eq. n1ae00 ) then
7519 c attention: boucle infinie si toutes les aretes simples
7520 c de la boule sont frontalieres!... arretee par ce test
7526 14 if( noar .gt. 0 ) then
7527 c la sauvegarde de l'arete et l'arete suivante
7529 noar = nosoar(lchain,noar)
7532 if( na0 .le. 0 ) then
7533 c une seule arete simple frontaliere
7537 c le suivant de l'ancien dernier est l'ancien premier
7538 nosoar(lchain,na0) = na1
7539 c le nouveau dernier est l'ancien premier
7540 nosoar(lchain,na1) = 0
7544 c ici l'arete na1 est l'une des aretes du triangle nt
7546 if( abs(noartr(i,nt)) .eq. na1 ) then
7548 if( noartr(i,nt) .gt. 0 ) then
7549 c elle est parcourue dans le sens indirect de l'etoile
7550 c (car c'est en fait le triangle exterieur a la boule)
7558 c le 1-er sommet ou arete du contour ferme
7560 c le nombre de sommets du contour ferme de l'etoile
7562 c le premier sommet de l'etoile
7563 noarcf( 1, nbarcf ) = ns0
7564 c l'arete suivante du cf
7565 noarcf( 2, nbarcf ) = nbarcf + 1
7566 c le numero de cette arete dans le tableau nosoar
7567 noarcf( 3, nbarcf ) = na1
7568 c mise a jour du numero d'arete du sommet ns0
7571 cccc trace de l'arete
7572 ccc call dvtrar( pxyd, ns0, ns1, ncvert, ncblan )
7574 c l'arete suivante a chainer
7575 n1aeoc = nosoar( lchain, na1 )
7576 c l'arete na1 n'est plus dans l'etoile
7577 nosoar( lchain, na1 ) = -1
7579 c boucle sur les aretes simples de l'etoile
7580 20 if( n1aeoc .gt. 0 ) then
7582 c recherche de l'arete de 1-er sommet ns1
7585 25 if( na1 .gt. 0 ) then
7587 c le numero du dernier sommet de l'arete precedente
7588 c est il l'un des 2 sommets de l'arete na1?
7589 if ( ns1 .eq. nosoar(1,na1) ) then
7590 c l'autre sommet de l'arete na1
7592 else if( ns1 .eq. nosoar(2,na1) ) then
7593 c l'autre sommet de l'arete na1
7596 c non: passage a l'arete suivante
7598 na1 = nosoar( lchain, na1 )
7602 c oui: na1 est l'arete peripherique suivante
7603 c na0 est sa precedente dans le chainage
7604 c une arete de plus dans le contour ferme (cf)
7606 c le premier sommet de l'arete nbarcf peripherique
7607 noarcf( 1, nbarcf ) = ns1
7608 c l'arete suivante du cf
7609 noarcf( 2, nbarcf ) = nbarcf + 1
7610 c le numero de cette arete dans le tableau nosoar
7611 noarcf( 3, nbarcf ) = na1
7612 c mise a jour du numero d'arete du sommet ns1
7615 cccc trace de l'arete
7616 ccc call dvtrar( pxyd, ns1, ns2, ncvert, ncblan )
7618 c suppression de l'arete des aretes simples de l'etoile
7619 if( n1aeoc .eq. na1 ) then
7620 n1aeoc = nosoar( lchain, na1 )
7622 nosoar( lchain, na0 ) = nosoar( lchain, na1 )
7624 c l'arete n'est plus une arete simple de l'etoile
7625 nosoar( lchain, na1 ) = -1
7627 c le sommet final de l'arete a rechercher ensuite
7634 if( ns1 .ne. ns0 ) then
7635 c arete non retrouvee : l'etoile ne se referme pas
7637 c kerr(1) = 'focftr: revoyez vos donnees'
7638 c kerr(2) = 'les lignes fermees doivent etre disjointes'
7639 c kerr(3) = 'verifiez si elles ne se coupent pas'
7641 write(imprim,*) 'focftr: revoyez vos donnees'
7642 write(imprim,*)'les lignes fermees doivent etre disjointes'
7643 write(imprim,*)'verifiez si elles ne se coupent pas'
7648 c l'arete suivant la derniere arete du cf est la premiere du cf
7649 c => realisation d'un chainage circulaire des aretes du cf
7650 noarcf( 2, nbarcf ) = 1
7652 c destruction des triangles de l'etoile du tableau noartr
7653 c -------------------------------------------------------
7655 c le numero du triangle dans noartr
7657 c l'arete 1 de nt0 devient nulle
7658 noartr( 1, nt0 ) = 0
7659 c chainage de nt0 en tete du chainage des triangles vides de noartr
7660 noartr( 2, nt0 ) = n1artr
7666 subroutine int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x0, y0 )
7667 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7668 c but : existence ou non d'une intersection a l'interieur
7669 c ----- des 2 aretes ns1-ns2 et ns3-ns4
7670 c attention les intersections au sommet sont comptees
7674 c ns1,...ns4 : numero pxyd des 4 sommets
7675 c pxyd : les coordonnees des sommets
7679 c linter : -1 si ns3-ns4 parallele a ns1 ns2
7680 c 0 si ns3-ns4 n'intersecte pas ns1-ns2 entre les aretes
7681 c 1 si ns3-ns4 intersecte ns1-ns2 entre les aretes
7682 c 2 si le point d'intersection est ns1 entre ns3-ns4
7683 c 3 si le point d'intersection est ns3 entre ns1-ns2
7684 c 4 si le point d'intersection est ns4 entre ns1-ns2
7685 c x0,y0 : 2 coordonnees du point d'intersection s'il existe(linter>=1)
7686 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7687 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
7688 c2345x7..............................................................012
7689 parameter ( epsmoi=-0.000001d0, eps=0.001d0,
7690 % unmeps= 0.999d0, unpeps=1.000001d0 )
7691 double precision pxyd(3,*), x0, y0
7692 double precision x1,y1,x21,y21,d21,x43,y43,d43,d,x,y,p21,p43
7696 x21 = pxyd(1,ns2) - x1
7697 y21 = pxyd(2,ns2) - y1
7698 d21 = x21**2 + y21**2
7700 x43 = pxyd(1,ns4) - pxyd(1,ns3)
7701 y43 = pxyd(2,ns4) - pxyd(2,ns3)
7702 d43 = x43**2 + y43**2
7704 c les 2 aretes sont-elles jugees paralleles ?
7705 d = x43 * y21 - y43 * x21
7706 if( d*d .le. 0.000001d0 * d21 * d43 ) then
7707 c cote i parallele a ns1-ns2
7712 c les 2 coordonnees du point d'intersection
7713 x =( x1*x43*y21-pxyd(1,ns3)*x21*y43-(y1-pxyd(2,ns3))*x21*x43)/d
7714 y =(-y1*y43*x21+pxyd(2,ns3)*y21*x43+(x1-pxyd(1,ns3))*y21*y43)/d
7716 c coordonnee barycentrique de x,y dans le repere ns1-ns2
7717 p21 = ( ( x - x1 ) * x21 + ( y - y1 ) * y21 ) / d21
7718 c coordonnee barycentrique de x,y dans le repere ns3-ns4
7719 p43 = ( (x - pxyd(1,ns3))* x43 + (y - pxyd(2,ns3)) * y43 ) / d43
7722 if( epsmoi .le. p21 .and. p21 .le. unpeps ) then
7723 c x,y est entre ns1-ns2
7724 if( (p21 .le. eps) .and.
7725 % (epsmoi .le. p43 .and. p43 .le. unpeps) ) then
7726 c le point x,y est proche de ns1 et interne a ns3-ns4
7731 else if( epsmoi .le. p43 .and. p43 .le. eps ) then
7732 c le point x,y est proche de ns3 et entre ns1-ns2
7737 else if( unmeps .le. p43 .and. p43 .le. unpeps ) then
7738 c le point x,y est proche de ns4 et entre ns1-ns2
7743 else if( eps .le. p43 .and. p43 .le. unmeps ) then
7744 c le point x,y est entre ns3-ns4
7752 c pas d'intersection a l'interieur des aretes
7757 subroutine tefoar( narete, nbarpi, pxyd,
7758 % mosoar, mxsoar, n1soar, nosoar,
7759 % moartr, n1artr, noartr, noarst,
7760 % mxarcf, n1arcf, noarcf, larmin, notrcf,
7762 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7763 c but : forcer l'arete narete de nosoar dans la triangulation actuelle
7764 c ----- triangulation frontale pour la reobtenir
7766 c attention: le chainage lchain(=6) de nosoar devient actif
7767 c durant la formation des contours fermes (cf)
7771 c narete : numero nosoar de l'arete frontaliere a forcer
7772 c nbarpi : numero du dernier point interne impose par l'utilisateur
7773 c pxyd : tableau des coordonnees 2d des points
7774 c par point : x y distance_souhaitee
7776 c mosoar : nombre maximal d'entiers par arete et
7777 c indice dans nosoar de l'arete suivante dans le hachage
7778 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
7779 c attention: mxsoar>3*mxsomm obligatoire!
7780 c moartr : nombre maximal d'entiers par arete du tableau noartr
7784 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
7785 c chainage des vides suivant en 3 et precedant en 2 de nosoar
7786 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
7787 c chainage des aretes frontalieres, chainage du hachage des aretes
7788 c hachage des aretes = nosoar(1)+nosoar(2)*2
7789 c avec mxsoar>=3*mxsomm
7790 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
7791 c nosoar(2,arete vide)=l'arete vide qui precede
7792 c nosoar(3,arete vide)=l'arete vide qui suit
7793 c n1artr : numero du premier triangle vide dans le tableau noartr
7794 c le chainage des triangles vides se fait sur noartr(2,.)
7795 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
7796 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
7797 c noarst : noarst(i) numero d'une arete de sommet i
7799 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
7801 c tableaux auxiliaires :
7802 c ----------------------
7803 c n1arcf : tableau (0:mxarcf) auxiliaire
7804 c noarcf : tableau (3,mxarcf) auxiliaire
7805 c larmin : tableau (mxarcf) auxiliaire
7806 c notrcf : tableau (1:mxarcf) auxiliaire
7810 c ierr : 0 si pas d'erreur
7811 c 1 saturation des sommets
7812 c 2 ns1 dans aucun triangle
7813 c 9 tableau nosoar de taille insuffisante car trop d'aretes
7815 c 10 un des tableaux n1arcf, noarcf notrcf est sature
7816 c augmenter a l'appel mxarcf
7817 c 11 algorithme defaillant
7818 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7819 c auteur : alain perronnet analyse numerique paris upmc mars 1997
7820 c....................................................................012
7821 parameter (mxpitr=32)
7822 common / unites / lecteu,imprim,intera,nunite(29)
7824 common / dv2dco / tratri
7825 double precision pxyd(3,*)
7826 integer noartr(moartr,*),
7827 % nosoar(mosoar,mxsoar),
7834 integer lapitr(mxpitr)
7835 double precision x1,y1,x2,y2,d12,d3,d4,x,y,d,dmin
7836 integer nosotr(3), ns(2)
7837 integer nacf(1:2), nacf1, nacf2
7838 equivalence (nacf(1),nacf1), (nacf(2),nacf2)
7840 c traitement de cette arete perdue
7841 ns1 = nosoar( 1, narete )
7842 ns2 = nosoar( 2, narete )
7845 c les traces sont demandes
7847 c le cadre objet global en unites utilisateur
7848 xx1 = min( pxyd(1,ns1), pxyd(1,ns2) )
7849 xx2 = max( pxyd(1,ns1), pxyd(1,ns2) )
7850 yy1 = min( pxyd(2,ns1), pxyd(2,ns2) )
7851 yy2 = max( pxyd(2,ns1), pxyd(2,ns2) )
7852 if( xx1 .ge. xx2 ) xx2 = xx1 + (yy2-yy1)
7853 if( yy1 .ge. yy2 ) yy2 = yy1 + (xx2-xx1)*0.5
7854 c call isofenetre( xx1-(xx2-xx1), xx2+(xx2-xx1),
7855 c % yy1-(yy2-yy1), yy2+(yy2-yy1) )
7858 cccc trace de l'arete perdue
7859 ccc call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
7861 c le sommet ns2 est il correct?
7863 if( na .le. 0 ) then
7864 write(imprim,*) 'tefoar: erreur sommet ',ns2,' sans arete'
7868 if( nosoar(4,na) .le. 0 ) then
7869 write(imprim,*) 'tefoar: erreur sommet ',ns2,
7870 % ' dans aucun triangle'
7875 c recherche du triangle voisin dans le sens indirect de rotation
7877 c le premier passage: recherche dans le sens ns1->ns2
7880 c recherche des triangles intersectes par le segment ns1-ns2
7881 c ==========================================================
7886 d12 = (x2-x1)**2 + (y2-y1)**2
7888 c recherche du no local du sommet ns1 dans l'un de ses triangles
7889 na01 = noarst( ns1 )
7890 if( na01 .le. 0 ) then
7891 write(imprim,*) 'tefoar: sommet ',ns1,' sans arete'
7895 nt0 = nosoar(4,na01)
7896 if( nt0 .le. 0 ) then
7897 write(imprim,*) 'tefoar: sommet ',ns1,' dans aucun triangle'
7902 c le numero des 3 sommets du triangle nt0 dans le sens direct
7903 20 call nusotr( nt0, mosoar, nosoar, moartr, noartr, nosotr )
7905 if( nosotr(na00) .eq. ns1 ) goto 26
7908 25 if( ipas .eq. 0 ) then
7909 c le second passage: recherche dans le sens ns2->ns1
7910 c tentative d'inversion des 2 sommets extremites de l'arete a forcer
7917 c les sens ns1->ns2 et ns2->ns1 ne donne pas de solution!
7918 write(imprim,*)'tefoar:arete ',ns1,' - ',ns2,' a imposer'
7919 write(imprim,*)'tefoar:anomalie sommet ',ns1,
7920 % 'non dans le triangle de sommets ',(nosotr(i),i=1,3)
7925 c le numero des aretes suivante et precedente
7926 26 na0 = nosui3( na00 )
7927 na1 = nopre3( na00 )
7931 cccc trace du triangle nt0 et de l'arete perdue
7932 ccc call mttrtr( pxyd, nt0, moartr, noartr, mosoar, nosoar,
7933 ccc % ncblan, ncjaun )
7934 ccc call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
7935 ccc call dvtrar( pxyd, ns3, ns4, ncbleu, nccyan )
7937 c point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
7938 c ------------------------------------------------------------
7939 call int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x1, y1 )
7940 if( linter .le. 0 ) then
7942 c pas d'intersection: rotation autour du point ns1
7943 c pour trouver le triangle de l'autre cote de l'arete na01
7944 if( nsens .lt. 0 ) then
7945 c sens indirect de rotation: l'arete de sommet ns1
7946 na01 = abs( noartr(na00,nt0) )
7948 c sens direct de rotation: l'arete de sommet ns1 qui precede
7949 na01 = abs( noartr(na1,nt0) )
7951 c le triangle de l'autre cote de l'arete na01
7952 if( nosoar(4,na01) .eq. nt0 ) then
7953 nt0 = nosoar(5,na01)
7955 nt0 = nosoar(4,na01)
7957 if( nt0 .gt. 0 ) goto 20
7959 c le parcours sort du domaine
7960 c il faut tourner dans l'autre sens autour de ns1
7961 if( nsens .lt. 0 ) then
7967 c dans les 2 sens, pas d'intersection => impossible
7968 c essai avec l'arete inversee ns1 <-> ns2
7969 if( ipas .eq. 0 ) goto 25
7970 write(imprim,*) 'tefoar: arete ',ns1,' ',ns2,
7971 % ' sans intersection avec les triangles actuels'
7972 write(imprim,*) 'revoyez les lignes du contour'
7977 c il existe une intersection avec l'arete opposee au sommet ns1
7978 c =============================================================
7979 c nbtrcf : nombre de triangles du cf
7983 c le triangle oppose a l'arete na0 de nt0
7984 30 noar = abs( noartr(na0,nt0) )
7985 if( nosoar(4,noar) .eq. nt0 ) then
7986 nt1 = nosoar(5,noar)
7988 nt1 = nosoar(4,noar)
7991 cccc trace du triangle nt1 et de l'arete perdue
7992 ccc call mttrtr( pxyd, nt1, moartr, noartr, mosoar, nosoar,
7993 ccc % ncjaun, ncmage )
7994 ccc call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
7996 c le numero des 3 sommets du triangle nt1 dans le sens direct
7997 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
7999 c le triangle nt1 contient il ns2 ?
8001 if( nosotr(j) .eq. ns2 ) goto 70
8004 c recherche de l'arete noar, na1 dans nt1 qui est l'arete na0 de nt0
8006 if( abs( noartr(na1,nt1) ) .eq. noar ) goto 35
8009 c trace du triangle nt1 et de l'arete perdue
8011 ccc 35 call mttrtr( pxyd, nt1, moartr, noartr, mosoar, nosoar,
8012 ccc % ncjaun, ncmage )
8013 ccc call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
8015 c recherche de l'intersection de ns1-ns2 avec les 2 autres aretes de nt1
8016 c ======================================================================
8022 c les 2 sommets de l'arete na2 de nt1
8023 noar = abs( noartr(na2,nt1) )
8024 ns3 = nosoar( 1, noar )
8025 ns4 = nosoar( 2, noar )
8026 ccc call dvtrar( pxyd, ns3, ns4, ncbleu, nccyan )
8028 c point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
8029 c ------------------------------------------------------------
8030 call int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x , y )
8031 if( linter .gt. 0 ) then
8033 c les 2 aretes s'intersectent en (x,y)
8034 c distance de (x,y) a ns3 et ns4
8035 d3 = (pxyd(1,ns3)-x)**2 + (pxyd(2,ns3)-y)**2
8036 d4 = (pxyd(1,ns4)-x)**2 + (pxyd(2,ns4)-y)**2
8037 c nsp est le point le plus proche de (x,y)
8038 if( d3 .lt. d4 ) then
8045 if( d .gt. 1d-5*d12 ) goto 60
8047 c ici le sommet nsp est trop proche de l'arete perdue ns1-ns2
8048 if( nsp .le. nbarpi ) then
8049 c point utilisateur ou frontalier non supprimable
8051 write(imprim,*) 'pause dans tefoar 1', d, d3, d4, d12
8055 c le sommet interne nsp est supprime en mettant tous les triangles
8056 c l'ayant comme sommet dans la pile notrcf des triangles a supprimer
8057 c ------------------------------------------------------------------
8058 ccc write(imprim,*) 'tefoar: le sommet ',nsp,' est supprime'
8059 c construction de la liste des triangles de sommet nsp
8060 call trp1st( nsp, noarst, mosoar, nosoar, moartr, noartr,
8061 % mxpitr, nbt, lapitr )
8062 if( nbt .le. 0 ) then
8063 c les triangles de sommet nsp ne forme pas une "boule"
8064 c avec ce sommet nsp pour "centre"
8066 % 'tefoar: pas d''etoile de triangles autour du sommet',nsp
8067 cccc trace des triangles de l'etoile du sommet nsp
8069 ccc call trpltr( nbt, lapitr, pxyd,
8070 ccc % moartr, noartr, mosoar, nosoar,
8071 ccc % ncroug, ncblan )
8072 ccc tratri = .false.
8074 write(imprim,*) 'pause dans tefoar 2'
8078 c ajout des triangles de sommet ns1 a notrcf
8083 if( nt .eq. notrcf(k) ) goto 38
8087 notrcf( nbtrcf ) = nt
8088 ccc call mttrtr( pxyd, nt, moartr, noartr, mosoar, nosoar,
8089 ccc % ncjaun, ncmage )
8090 ccc call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
8093 c ce sommet supprime n'appartient plus a aucun triangle
8096 c ns2 est-il un sommet des triangles empiles?
8097 c -------------------------------------------
8098 do 40 nt=nbtrc0+1,nbtrcf
8099 c le triangle a supprimer nt
8101 c le numero des 3 sommets du triangle nt1 dans le sens direct
8102 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr)
8104 c le sommet k de nt1
8105 if( nosotr( k ) .eq. ns2 ) then
8112 c recherche du plus proche point d'intersection de ns1-ns2
8113 c par rapport a ns2 avec les aretes des triangles ajoutes
8116 do 48 nt=nbtrc0+1,nbtrcf
8118 c le numero des 3 sommets du triangle nt1 dans le sens direct
8119 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr)
8121 c les 2 sommets de l'arete k de nt
8123 ns4 = nosotr( nosui3(k) )
8125 c point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
8126 c ------------------------------------------------------------
8127 call int1sd( ns1, ns2, ns3, ns4, pxyd,
8129 if( linter .gt. 0 ) then
8130 c les 2 aretes s'intersectent en (x,y)
8131 d = (x-x2)**2+(y-y2)**2
8132 if( d .lt. dmin ) then
8141 c redemarrage avec le triangle nt0 et l'arete na0
8142 if( nt0 .gt. 0 ) goto 30
8144 write(imprim,*) 'tefoar: algorithme defaillant'
8150 c pas d'intersection differente de l'initiale => sommet sur ns1-ns2
8151 c rotation autour du sommet par l'arete suivant na1
8153 write(imprim,*) 'tefoar 50: revoyez vos donnees'
8154 write(imprim,*) 'les lignes fermees doivent etre disjointes'
8155 write(imprim,*) 'verifiez si elles ne se coupent pas'
8159 c cas sans probleme : intersection differente de celle initiale
8160 c ================= =========================================
8161 60 nbtrcf = nbtrcf + 1
8162 notrcf( nbtrcf ) = nt1
8163 c passage au triangle suivant
8168 c ----------------------------------------------------------
8169 c ici toutes les intersections de ns1-ns2 ont ete parcourues
8170 c tous les triangles intersectes ou etendus forment les
8171 c nbtrcf triangles du tableau notrcf
8172 c ----------------------------------------------------------
8173 70 nbtrcf = nbtrcf + 1
8174 notrcf( nbtrcf ) = nt1
8176 c formation du cf des aretes simples des triangles de notrcf
8177 c et destruction des nbtrcf triangles du tableau noartr
8178 c attention: le chainage lchain du tableau nosoar devient actif
8179 c =============================================================
8180 80 if( nbtrcf*3 .gt. mxarcf ) then
8181 write(imprim,*) 'saturation du tableau noarcf'
8186 call focftr( nbtrcf, notrcf, pxyd, noarst,
8187 % mosoar, mxsoar, n1soar, nosoar,
8188 % moartr, n1artr, noartr,
8189 % nbarcf, n1arcf, noarcf,
8191 if( ierr .ne. 0 ) return
8193 c chainage des aretes vides dans le tableau noarcf
8194 c ------------------------------------------------
8195 c decalage de 2 aretes car 2 aretes sont necessaires ensuite pour
8196 c integrer 2 fois l'arete perdue et former ainsi 2 cf
8197 c comme nbtrcf*3 minore mxarcf il existe au moins 2 places vides
8198 c derriere => pas de test de debordement
8199 n1arcf(0) = nbarcf+3
8200 mmarcf = min(8*nbarcf,mxarcf)
8201 do 90 i=nbarcf+3,mmarcf
8204 noarcf(2,mmarcf) = 0
8206 c reperage des sommets ns1 ns2 de l'arete perdue dans le cf
8207 c ---------------------------------------------------------
8208 ns1 = nosoar( 1, narete )
8209 ns2 = nosoar( 2, narete )
8213 c la premiere arete dans noarcf du cf
8215 110 if( noarcf(1,na0) .ne. ns(i) ) then
8216 c passage a l'arete suivante
8217 na0 = noarcf( 2, na0 )
8220 c position dans noarcf du sommet i de l'arete perdue
8224 c formation des 2 cf chacun contenant l'arete ns1-ns2
8225 c ---------------------------------------------------
8226 c sauvegarde de l'arete suivante de celle de sommet ns1
8227 na0 = noarcf( 2, nacf1 )
8228 nt1 = noarcf( 3, nacf1 )
8232 c l'arete suivante dans le premier cf
8233 noarcf( 2, nacf1 ) = nacf2
8234 c cette arete est celle perdue
8235 noarcf( 3, nacf1 ) = narete
8241 c le premier sommet de la premiere arete du second cf
8242 noarcf( 1, n1 ) = ns2
8243 c l'arete suivante dans le second cf
8244 noarcf( 2, n1 ) = n2
8245 c cette arete est celle perdue
8246 noarcf( 3, n1 ) = narete
8247 c la seconde arete du second cf
8248 noarcf( 1, n2 ) = ns1
8249 noarcf( 2, n2 ) = na0
8250 noarcf( 3, n2 ) = nt1
8253 c recherche du precedent de nacf2
8254 130 na1 = noarcf( 2, na0 )
8255 if( na1 .ne. nacf2 ) then
8256 c passage a l'arete suivante
8260 c na0 precede nacf2 => il precede n1
8261 noarcf( 2, na0 ) = n1
8266 c triangulation directe des 2 contours fermes
8267 c l'arete ns1-ns2 devient une arete de la triangulation des 2 cf
8268 c ==============================================================
8269 call tridcf( nbcf, pxyd, noarst,
8270 % mosoar, mxsoar, n1soar, nosoar,
8271 % moartr, n1artr, noartr,
8272 % mxarcf, n1arcf, noarcf, larmin,
8273 % nbtrcf, notrcf, ierr )
8277 subroutine te4ste( nbsomm, mxsomm, pxyd, ntrp, letree,
8279 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8280 c but : decouper un te ntrp de letree en 4 sous-triangles
8281 c ----- eliminer les sommets de te trop proches des points
8285 c mxsomm : nombre maximal de points declarables dans pxyd
8286 c ntrp : numero letree du triangle a decouper en 4 sous-triangles
8290 c nbsomm : nombre actuel de points dans pxyd
8291 c pxyd : tableau des coordonnees des points
8292 c par point : x y distance_souhaitee
8293 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
8294 c letree(0,0) : no du 1-er te vide dans letree
8295 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
8296 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
8297 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
8298 c si letree(0,.)>0 alors
8299 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
8301 c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
8303 c ( j est alors une feuille de l'arbre )
8304 c letree(4,j) : no letree du sur-triangle du triangle j
8305 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
8306 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
8310 c ierr : 0 si pas d'erreur, 51 saturation letree, 52 saturation pxyd
8311 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8312 c auteur : alain perronnet analyse numerique paris upmc juillet 1994
8313 c2345x7..............................................................012
8314 common / unites / lecteu,imprim,nunite(30)
8315 integer letree(0:8,0:*)
8316 double precision pxyd(3,mxsomm)
8317 integer np(0:3),milieu(3)
8319 c debut par l'arete 2 du triangle ntrp
8324 c le milieu de l'arete i1 existe t il deja ?
8325 call n1trva( ntrp, i1, letree, noteva, niveau )
8326 if( noteva .gt. 0 ) then
8327 c il existe un te voisin
8328 c s'il existe 4 sous-triangles le milieu existe deja
8329 if( letree(0,noteva) .gt. 0 ) then
8331 nsot = letree(0,noteva)
8332 milieu(i) = letree( 5+nopre3(i1), nsot )
8337 c le milieu n'existe pas. il est cree
8339 if( nbsomm .gt. mxsomm ) then
8340 c plus assez de place dans pxyd
8341 write(imprim,*) 'te4ste: saturation pxyd'
8346 c le milieu de l'arete i
8349 c ntrp est le triangle de milieux d'arete ces 3 sommets
8350 ns1 = letree( 5+i1, ntrp )
8351 ns2 = letree( 5+i2, ntrp )
8352 pxyd(1,nbsomm) = ( pxyd(1,ns1) + pxyd(1,ns2) ) * 0.5
8353 pxyd(2,nbsomm) = ( pxyd(2,ns1) + pxyd(2,ns2) ) * 0.5
8355 c l'arete et milieu suivant
8362 c le premier triangle vide
8364 if( nsot .le. 0 ) then
8365 c manque de place. saturation letree
8367 write(imprim,*) 'te4ste: saturation letree'
8372 c mise a jour du premier te libre
8373 letree(0,0) = letree(0,nsot)
8375 c nsot est le i-eme sous triangle
8381 c le numero des points et sous triangles dans ntrp
8382 np(i) = -letree(i,ntrp)
8383 letree(i,ntrp) = nsot
8385 c le sommet commun avec le triangle ntrp
8386 letree(5+i,nsot) = letree(5+i,ntrp)
8388 c le sur-triangle et numero de sous-triangle de nsot
8389 c a laisser ici car incorrect sinon pour i=0
8390 letree(4,nsot) = ntrp
8393 c le sous-triangle du triangle
8394 letree(i,ntrp) = nsot
8397 c le numero des nouveaux sommets milieux
8398 nsot = letree(0,ntrp)
8399 letree(6,nsot) = milieu(1)
8400 letree(7,nsot) = milieu(2)
8401 letree(8,nsot) = milieu(3)
8403 nsot = letree(1,ntrp)
8404 letree(7,nsot) = milieu(3)
8405 letree(8,nsot) = milieu(2)
8407 nsot = letree(2,ntrp)
8408 letree(6,nsot) = milieu(3)
8409 letree(8,nsot) = milieu(1)
8411 nsot = letree(3,ntrp)
8412 letree(6,nsot) = milieu(2)
8413 letree(7,nsot) = milieu(1)
8415 c repartition des eventuels 4 points np dans ces 4 sous-triangles
8416 c il y a obligatoirement suffisamment de place
8418 if( np(i) .gt. 0 ) then
8419 nsot = notrpt( pxyd(1,np(i)), pxyd, ntrp, letree )
8422 if( letree(i1,nsot) .eq. 0 ) then
8423 c place libre a occuper
8424 letree(i1,nsot) = -np(i)