1 subroutine qutr2d( p1, p2, p3, qualite )
2 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3 c but : calculer la qualite d'un triangle de r**2
4 c ----- 2 coordonnees des 3 sommets en double precision
8 c p1,p2,p3 : les 3 coordonnees des 3 sommets du triangle
9 c sens direct pour une surface et qualite >0
12 c qualite: valeur de la qualite du triangle entre 0 et 1 (equilateral)
13 c 1 etant la qualite optimale
14 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
15 c auteur : alain perronnet analyse numerique upmc paris janvier 1995
16 c2345x7..............................................................012
17 parameter ( d2uxr3 = 3.4641016151377544d0 )
18 c d2uxr3 = 2 * sqrt(3)
19 double precision p1(2), p2(2), p3(2), qualite, a, b, c, p
21 c la longueur des 3 cotes
22 a = sqrt( (p2(1)-p1(1))**2 + (p2(2)-p1(2))**2 )
23 b = sqrt( (p3(1)-p2(1))**2 + (p3(2)-p2(2))**2 )
24 c = sqrt( (p1(1)-p3(1))**2 + (p1(2)-p3(2))**2 )
29 if ( (a*b*c) .ne. 0d0 ) then
30 c critere : 2 racine(3) * rayon_inscrit / plus longue arete
31 qualite = d2uxr3 * sqrt( abs( (p-a) / p * (p-b) * (p-c) ) )
38 c autres criteres possibles:
39 c critere : 2 * rayon_inscrit / rayon_circonscrit
40 c qualite = 8d0 * (p-a) * (p-b) * (p-c) / (a * b * c)
42 c critere : 3*sqrt(3.) * ray_inscrit / demi perimetre
43 c qualite = 3*sqrt(3.) * sqrt ((p-a)*(p-b)*(p-c) / p**3)
45 c critere : 2*sqrt(3.) * ray_inscrit / max( des aretes )
46 c qualite = 2*sqrt(3.) * sqrt( (p-a)*(p-b)*(p-c) / p ) / max(a,b,c)
50 double precision function surtd2( p1 , p2 , p3 )
51 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
52 c but : calcul de la surface d'un triangle defini par 3 points de R**2
54 c parametres d entree :
55 c ---------------------
56 c p1 p2 p3 : les 3 fois 2 coordonnees des sommets du triangle
58 c parametre resultat :
59 c --------------------
60 c surtd2 : surface du triangle
61 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
62 c auteur : alain perronnet analyse numerique upmc paris fevrier 1992
63 c2345x7..............................................................012
64 double precision p1(2), p2(2), p3(2)
66 c la surface du triangle
67 surtd2 = ( ( p2(1)-p1(1) ) * ( p3(2)-p1(2) )
68 % - ( p2(2)-p1(2) ) * ( p3(1)-p1(1) ) ) * 0.5d0
71 integer function nopre3( i )
72 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
73 c but : numero precedent i dans le sens circulaire 1 2 3 1 ...
75 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
76 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
77 c2345x7..............................................................012
85 integer function nosui3( i )
86 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
87 c but : numero suivant i dans le sens circulaire 1 2 3 1 ...
89 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
90 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
91 c2345x7..............................................................012
99 subroutine provec( v1 , v2 , v3 )
100 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
101 c but : v3 vecteur = produit vectoriel de 2 vecteurs de r ** 3
105 c v1, v2 : les 2 vecteurs de 3 composantes
109 c v3 : vecteur = v1 produit vectoriel v2
110 cc++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
111 c auteur : perronnet alain upmc analyse numerique paris mars 1987
112 c2345x7..............................................................012
113 double precision v1(3), v2(3), v3(3)
115 v3( 1 ) = v1( 2 ) * v2( 3 ) - v1( 3 ) * v2( 2 )
116 v3( 2 ) = v1( 3 ) * v2( 1 ) - v1( 1 ) * v2( 3 )
117 v3( 3 ) = v1( 1 ) * v2( 2 ) - v1( 2 ) * v2( 1 )
122 subroutine norme1( n, v, ierr )
123 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
124 c but : normalisation euclidienne a 1 d un vecteur v de n composantes
128 c n : nombre de composantes du vecteur
132 c v : le vecteur a normaliser a 1
136 c ierr : 1 si la norme de v est egale a 0
138 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
139 c auteur : alain perronnet analyse numerique paris mars 1987
140 c ......................................................................
141 double precision v( n ), s, sqrt
145 s = s + v( i ) * v( i )
148 c test de nullite de la norme du vecteur
149 c --------------------------------------
150 if( s .le. 0.0d0 ) then
151 c norme nulle du vecteur non normalisable a 1
156 s = 1.0d0 / sqrt( s )
165 subroutine insoar( mxsomm, mosoar, mxsoar, n1soar, nosoar )
166 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
167 c but : initialiser le tableau nosoar pour le hachage des aretes
172 c mxsomm : plus grand numero de sommet d'une arete au cours du calcul
173 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
174 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
175 c avec mxsoar>=3*mxsomm
179 c n1soar : numero de la premiere arete vide dans le tableau nosoar
180 c une arete i de nosoar est vide <=> nosoar(1,i)=0
181 c chainage des aretes vides amont et aval
182 c l'arete vide qui precede=nosoar(4,i)
183 c l'arete vide qui suit =nosoar(5,i)
184 c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
185 c chainage momentan'e d'aretes, chainage du hachage des aretes
186 c hachage des aretes = min( nosoar(1), nosoar(2) )
187 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
188 c auteur : alain perronnet analyse numerique paris upmc mars 1997
189 c2345x7..............................................................012
190 integer nosoar(mosoar,mxsoar)
192 c initialisation des aretes 1 a mxsomm
195 c sommet 1 = 0 <=> temoin d'arete vide pour le hachage
198 c arete sur aucune ligne
201 c la position de l'arete interne ou frontaliere est inconnue
204 c fin de chainage du hachage pas d'arete suivante
205 nosoar( mosoar, i ) = 0
209 c la premiere arete vide chainee est la mxsomm+1 du tableau
210 c car ces aretes ne sont pas atteignables par le hachage direct
213 c initialisation des aretes vides et des chainages
214 do 20 i = n1soar, mxsoar
216 c sommet 1 = 0 <=> temoin d'arete vide pour le hachage
219 c arete sur aucune ligne
222 c chainage sur l'arete vide qui precede
223 c (si arete occupee cela deviendra le no du triangle 1 de l'arete)
226 c chainage sur l'arete vide qui suit
227 c (si arete occupee cela deviendra le no du triangle 2 de l'arete)
230 c chainages des aretes frontalieres ou internes ou ...
233 c fin de chainage du hachage
234 nosoar( mosoar, i ) = 0
238 c la premiere arete vide n'a pas de precedent
239 nosoar( 4, n1soar ) = 0
241 c la derniere arete vide est mxsoar sans arete vide suivante
242 nosoar( 5, mxsoar ) = 0
246 subroutine azeroi ( l , ntab )
247 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
248 c but : initialisation a zero d un tableau ntab de l variables entieres
250 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
251 c auteur : alain perronnet analyse numerique upmc paris septembre 1988
252 c23456---------------------------------------------------------------012
260 subroutine fasoar( ns1, ns2, nt1, nt2, nolign,
261 % mosoar, mxsoar, n1soar, nosoar, noarst,
263 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
264 c but : former l'arete de sommet ns1-ns2 dans le hachage du tableau
265 c ----- nosoar des aretes de la triangulation
269 c ns1 ns2: numero pxyd des 2 sommets de l'arete
270 c nt1 : numero du triangle auquel appartient l'arete
271 c nt1=-1 si numero inconnu
272 c nt2 : numero de l'eventuel second triangle de l'arete si connu
273 c nt2=-1 si numero inconnu
274 c nolign : numero de la ligne de l'arete dans ladefi(wulftr-1+nolign)
275 c =0 si l'arete n'est une arete de ligne
276 c ce numero est ajoute seulement si l'arete est creee
277 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
278 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
282 c n1soar : numero de la premiere arete vide dans le tableau nosoar
283 c une arete i de nosoar est vide <=> nosoar(1,i)=0
284 c chainage des aretes vides amont et aval
285 c l'arete vide qui precede=nosoar(4,i)
286 c l'arete vide qui suit =nosoar(5,i)
287 c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
288 c chainage momentan'e d'aretes, chainage du hachage des aretes
289 c hachage des aretes = min( nosoar(1), nosoar(2) )
290 c noarst : noarst(np) numero d'une arete du sommet np
292 c ierr : si < 0 en entree pas d'affichage en cas d'erreur du type
293 c "arete appartenant a plus de 2 triangles et a creer!"
294 c si >=0 en entree affichage de ce type d'erreur
298 c noar : >0 numero de l'arete retrouvee ou ajoutee
299 c ierr : =0 si pas d'erreur
300 c =1 si le tableau nosoar est sature
301 c =2 si arete a creer et appartenant a 2 triangles distincts
302 c des triangles nt1 et nt2
303 c =3 si arete appartenant a 2 triangles distincts
304 c differents des triangles nt1 et nt2
305 c =4 si arete appartenant a 2 triangles distincts
306 c dont le second n'est pas le triangle nt2
307 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
308 c auteur : alain perronnet analyse numerique paris upmc mars 1997
309 c2345x7..............................................................012
310 common / unites / lecteu, imprim, nunite(30)
311 integer nosoar(mosoar,mxsoar), noarst(*)
314 c ajout eventuel de l'arete s1 s2 dans nosoar
318 c hachage de l'arete de sommets nu2sar
319 call hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar, noar )
320 c en sortie: noar>0 => no arete retrouvee
321 c <0 => no arete ajoutee
322 c =0 => saturation du tableau nosoar
324 if( noar .eq. 0 ) then
326 c saturation du tableau nosoar
327 write(imprim,*) 'fasoar: tableau nosoar sature'
331 else if( noar .lt. 0 ) then
333 c l'arete a ete ajoutee. initialisation des autres informations
335 c le numero de la ligne de l'arete
336 nosoar(3,noar) = nolign
337 c le triangle 1 de l'arete => le triangle nt1
339 c le triangle 2 de l'arete => le triangle nt2
342 c le sommet appartient a l'arete noar
343 noarst( nu2sar(1) ) = noar
344 noarst( nu2sar(2) ) = noar
348 c l'arete a ete retrouvee.
349 c si elle appartient a 2 triangles differents de nt1 et nt2
350 c alors il y a une erreur
351 if( nosoar(4,noar) .gt. 0 .and.
352 % nosoar(5,noar) .gt. 0 ) then
353 if( nosoar(4,noar) .ne. nt1 .and.
354 % nosoar(4,noar) .ne. nt2 .or.
355 % nosoar(5,noar) .ne. nt1 .and.
356 % nosoar(5,noar) .ne. nt2 ) then
357 c arete appartenant a plus de 2 triangles => erreur
358 if( ierr .ge. 0 ) then
359 write(imprim,*) 'erreur fasoar: arete ',noar,
360 % ' dans 2 triangles et a creer!'
367 c mise a jour du numero des triangles de l'arete noar
368 c le triangle 2 de l'arete => le triangle nt1
369 if( nosoar(4,noar) .lt. 0 ) then
370 c pas de triangle connu pour cette arete
373 c deja un triangle connu. ce nouveau est le second
374 if( nosoar(5,noar) .gt. 0 .and. nt1 .gt. 0 .and.
375 % nosoar(5,noar) .ne. nt1 ) then
376 c arete appartenant a plus de 2 triangles => erreur
377 write(imprim,*) 'erreur fasoar: arete ',noar,
378 % ' dans plus de 2 triangles'
386 c cas de l'arete frontaliere retrouvee comme diagonale d'un quadrangle
387 if( nt2 .gt. 0 ) then
388 c l'arete appartient a 2 triangles
389 if( nosoar(5,noar) .gt. 0 .and.
390 % nosoar(5,noar) .ne. nt2 ) then
391 c arete appartenant a plus de 2 triangles => erreur
392 write(imprim,*) 'erreur fasoar: arete ',noar,
393 % ' dans plus de 2 triangles'
406 subroutine fq1inv( x, y, s, xc, yc, ierr )
407 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
408 c but : calcul des 2 coordonnees (xc,yc) dans le carre (0,1)
409 c ----- image par f:carre unite-->quadrangle appartenant a q1**2
410 c par une resolution directe due a nicolas thenault
414 c x,y : coordonnees du point image dans le quadrangle de sommets s
415 c s : les 2 coordonnees des 4 sommets du quadrangle
419 c xc,yc : coordonnees dans le carre dont l'image par f vaut (x,y)
420 c ierr : 0 si calcul sans erreur, 1 si quadrangle degenere
421 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
422 c auteurs: thenault tulenew analyse numerique paris janvier 1998
423 c modifs : perronnet alain analyse numerique paris janvier 1998
424 c234567..............................................................012
425 real s(1:2,1:4), dist(2)
426 double precision a,b,c,d,alpha,beta,gamma,delta,x0,y0,t(2),u,v,w
431 d = s(1,1) - s(1,2) + s(1,3) - s(1,4)
434 beta = s(2,2) - s(2,1)
435 gamma = s(2,4) - s(2,1)
436 delta = s(2,1) - s(2,2) + s(2,3) - s(2,4)
438 u = beta * c - b * gamma
440 c quadrangle degenere
444 v = delta * c - d * gamma
445 w = b * delta - beta * d
447 x0 = c * (y-alpha) - gamma * (x-a)
448 y0 = b * (y-alpha) - beta * (x-a)
451 b = u * u - w * x0 - v * y0
456 delta = sqrt( b*b-4*a*c )
457 if( b .ge. 0.0 ) then
462 c la racine de plus grande valeur absolue
463 c (elle donne le plus souvent le point exterieur au carre unite
464 c donc a tester en second pour reduire les calculs)
465 t(2) = t(2) / ( 2 * a )
466 c calcul de la seconde racine a partir de la somme => plus stable
471 c la solution i donne t elle un point interne au carre unite?
472 xc = ( x0 - v * t(i) ) / u
473 yc = ( w * t(i) - y0 ) / u
474 if( 0.0 .le. xc .and. xc .le. 1.0 ) then
475 if( 0.0 .le. yc .and. yc .le. 1.0 ) goto 9000
478 c le point (xc,yc) n'est pas dans le carre unite
479 c cela peut etre du aux erreurs d'arrondi
480 c => choix par le minimum de la distance aux bords du carre
481 dist(i) = max( 0.0, -xc, xc-1.0, -yc, yc-1.0 )
485 if( dist(1) .gt. dist(2) ) then
486 c f(xc,yc) pour la racine 2 est plus proche de x,y
487 c xc yc sont deja calcules
491 else if ( b .ne. 0 ) then
497 c les 2 coordonnees du point dans le carre unite
498 xc = ( x0 - v * t(1) ) / u
499 yc = ( w * t(1) - y0 ) / u
506 subroutine ptdatr( point, pxyd, nosotr, nsigne )
507 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
508 c but : le point est il dans le triangle de sommets nosotr
513 c point : les 2 coordonnees du point
514 c pxyd : les 2 coordonnees et distance souhaitee des points du maillage
515 c nosotr : le numero des 3 sommets du triangle
519 c nsigne : >0 si le point est dans le triangle ou sur une des 3 aretes
520 c =0 si le triangle est degenere ou indirect ou ne contient pas le poin
521 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
522 c auteur : alain perronnet analyse numerique paris upmc mars 1997
523 c....................................................................012
525 double precision point(2), pxyd(3,*)
526 double precision xp,yp, x1,x2,x3, y1,y2,y3, d,dd, cb1,cb2,cb3
543 c 2 fois la surface du triangle = determinant de la matrice
544 c de calcul des coordonnees barycentriques du point p
545 d = ( x2 - x1 ) * ( y3 - y1 ) - ( x3 - x1 ) * ( y2 - y1 )
549 c triangle non degenere
550 c =====================
551 c calcul des 3 coordonnees barycentriques du
552 c point xp yp dans le triangle
553 cb1 = ( ( x2-xp ) * ( y3-yp ) - ( x3-xp ) * ( y2-yp ) ) / d
554 cb2 = ( ( x3-xp ) * ( y1-yp ) - ( x1-xp ) * ( y3-yp ) ) / d
556 ccc cb3 = ( ( x1-xp ) * ( y2-yp ) - ( x2-xp ) * ( y1-yp ) ) / d
558 ccc if( cb1 .ge. -0.00005d0 .and. cb1 .le. 1.00005d0 .and.
559 if( cb1 .ge. 0d0 .and. cb1 .le. 1d0 .and.
560 % cb2 .ge. 0d0 .and. cb2 .le. 1d0 .and.
561 % cb3 .ge. 0d0 .and. cb3 .le. 1d0 ) then
563 c le triangle nosotr contient le point
573 c le point est il du meme cote que le sommet oppose de chaque arete?
576 c le sinus de l'angle p1 p2-p1 point
579 d = ( pxyd(1,n2) - x1 ) * ( point(2) - y1 )
580 % - ( pxyd(2,n2) - y1 ) * ( point(1) - x1 )
581 dd = ( pxyd(1,n2) - x1 ) * ( pxyd(2,n3) - y1 )
582 % - ( pxyd(2,n2) - y1 ) * ( pxyd(1,n3) - x1 )
583 cb1 = ( pxyd(1,n2) - x1 ) ** 2
584 % + ( pxyd(2,n2) - y1 ) ** 2
585 cb2 = ( point(1) - x1 ) ** 2
586 % + ( point(2) - y1 ) ** 2
587 cb3 = ( pxyd(1,n3) - x1 ) ** 2
588 % + ( pxyd(2,n3) - y1 ) ** 2
589 if( abs( dd ) .le. 1e-4 * sqrt( cb1 * cb3 ) ) then
590 c le point 3 est sur l'arete 1-2
591 c le point doit y etre aussi
592 if( abs( d ) .le. 1e-4 * sqrt( cb1 * cb2 ) ) then
597 c le point 3 n'est pas sur l'arete . test des signes
598 if( d * dd .ge. 0 ) then
602 c permutation circulaire des 3 sommets et aretes
608 if( nsigne .ne. 3 ) nsigne = 0
612 integer function nosstr( p, pxyd, nt, letree )
613 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
614 c but : calculer le numero 0 a 3 du sous-triangle te contenant
619 c p : point de r**2 contenu dans le te nt de letree
620 c pxyd : x y distance des points
621 c nt : numero letree du te de te voisin a calculer
622 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
623 c letree(0,0) no du 1-er te vide dans letree
624 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
625 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
626 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
627 c si letree(0,.)>0 alors
628 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
630 c letree(0:3,j) :-no pxyd des 1
\85a 4 points internes au triangle j
632 c ( j est alors une feuille de l'arbre )
633 c letree(4,j) : no letree du sur-triangle du triangle j
634 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
635 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
639 c nosstr : 0 si le sous-triangle central contient p
640 c i =1,2,3 numero du sous-triangle contenant p
641 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
642 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
643 c2345x7..............................................................012
644 integer letree(0:8,0:*)
645 double precision pxyd(3,*), p(2),
646 % x1, y1, x21, y21, x31, y31, d, xe, ye
648 c le numero des 3 sommets du triangle
649 ns1 = letree( 6, nt )
650 ns2 = letree( 7, nt )
651 ns3 = letree( 8, nt )
653 c les coordonnees entre 0 et 1 du point p
657 x21 = pxyd(1,ns2) - x1
658 y21 = pxyd(2,ns2) - y1
660 x31 = pxyd(1,ns3) - x1
661 y31 = pxyd(2,ns3) - y1
663 d = 1.0 / ( x21 * y31 - x31 * y21 )
665 xe = ( ( p(1) - x1 ) * y31 - ( p(2) - y1 ) * x31 ) * d
666 ye = ( ( p(2) - y1 ) * x21 - ( p(1) - x1 ) * y21 ) * d
668 if( xe .gt. 0.5d0 ) then
669 c sous-triangle droit
671 else if( ye .gt. 0.5d0 ) then
674 else if( xe+ye .lt. 0.5d0 ) then
675 c sous-triangle gauche
678 c sous-triangle central
684 integer function notrpt( p, pxyd, notrde, letree )
685 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
686 c but : calculer le numero letree du sous-triangle feuille contenant
687 c ----- le point p a partir du te notrde de letree
691 c p : point de r**2 contenu dans le te nt de letree
692 c pxyd : x y distance des points
693 c notrde : numero letree du triangle depart de recherche (1=>racine)
694 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
695 c letree(0,0) no du 1-er te vide dans letree
696 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
697 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
698 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
699 c si letree(0,.)>0 alors
700 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
702 c letree(0:3,j) :-no pxyd des 1
\85 4 points internes au triangle j
704 c ( j est alors une feuille de l'arbre )
705 c letree(4,j) : no letree du sur-triangle du triangle j
706 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
707 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
711 c notrpt : numero letree du triangle contenant le point p
712 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
713 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
714 c2345x7..............................................................012
715 integer letree(0:8,0:*)
716 double precision pxyd(1:3,*), p(2)
718 c la racine depart de la recherche
721 c tant que la feuille n'est pas atteinte descendre l'arbre
722 10 if( letree(0,notrpt) .gt. 0 ) then
724 c recherche du sous-triangle contenant p
725 nsot = nosstr( p, pxyd, notrpt, letree )
727 c le numero letree du sous-triangle
728 notrpt = letree( nsot, notrpt )
735 subroutine teajpt( ns, nbsomm, mxsomm, pxyd, letree,
737 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
738 c but : ajout du point ns de pxyd dans letree
743 c ns : numero du point a ajouter dans letree
744 c mxsomm : nombre maximal de points declarables dans pxyd
745 c pxyd : tableau des coordonnees des points
746 c par point : x y distance_souhaitee
750 c nbsomm : nombre actuel de points dans pxyd
752 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
753 c letree(0,0) : no du 1-er te vide dans letree
754 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
755 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
756 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
757 c si letree(0,.)>0 alors
758 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
760 c letree(0:3,j) :-no pxyd des 1
\85a 4 points internes au triangle j
762 c ( j est alors une feuille de l'arbre )
763 c letree(4,j) : no letree du sur-triangle du triangle j
764 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
765 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
769 c ntrp : numero letree du triangle te ou a ete ajoute le point
770 c ierr : 0 si pas d'erreur, 51 saturation letree, 52 saturation pxyd
771 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
772 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
773 c2345x7..............................................................012
774 integer letree(0:8,0:*)
775 double precision pxyd(3,mxsomm)
777 c depart de la racine
780 c recherche du triangle contenant le point pxyd(ns)
781 1 ntrp = notrpt( pxyd(1,ns), pxyd, ntrp, letree )
783 c existe t il un point libre
785 if( letree(i,ntrp) .eq. 0 ) then
786 c la place i est libre
792 c pas de place libre => 4 sous-triangles sont crees
793 c a partir des 3 milieux des aretes
794 call te4ste( nbsomm, mxsomm, pxyd, ntrp, letree, ierr )
795 if( ierr .ne. 0 ) return
801 subroutine n1trva( nt, lar, letree, notrva, lhpile )
802 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
803 c but : calculer le numero letree du triangle voisin du te nt
804 c ----- par l'arete lar (1 a 3 ) de nt
805 c attention : notrva n'est pas forcement minimal
809 c nt : numero letree du te de te voisin a calculer
810 c lar : numero 1 a 3 de l'arete du triangle nt
811 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
812 c letree(0,0) no du 1-er te vide dans letree
813 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
814 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
815 c letree(0:8,1) : racine de l'arbre (triangle sans sur-triangle)
816 c si letree(0,.)>0 alors
817 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
819 c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
821 c ( j est alors une feuille de l'arbre )
822 c letree(4,j) : no letree du sur-triangle du triangle j
823 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
824 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
828 c notrva : >0 numero letree du te voisin par l'arete lar
829 c =0 si pas de te voisin (racine , ... )
830 c lhpile : =0 si nt et notrva ont meme taille
831 c >0 nt est 4**lhpile fois plus petit que notrva
832 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
833 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
834 c2345x7..............................................................012
835 integer letree(0:8,0:*)
838 c initialisation de la pile
839 c le triangle est empile
843 c tant qu'il existe un sur-triangle
844 10 ntr = lapile( lhpile )
845 if( ntr .eq. 1 ) then
846 c racine atteinte => pas de triangle voisin
852 c le type du triangle ntr
853 nty = letree( 5, ntr )
854 c l'eventuel sur-triangle
855 nsut = letree( 4, ntr )
857 if( nty .eq. 0 ) then
859 c triangle de type 0 => triangle voisin de type precedent(lar)
860 c dans le sur-triangle de ntr
861 c ce triangle remplace ntr dans lapile
862 lapile( lhpile ) = letree( nopre3(lar), nsut )
866 c triangle ntr de type nty>0
867 if( nosui3(nty) .eq. lar ) then
869 c le triangle voisin par lar est le triangle 0
870 lapile( lhpile ) = letree( 0, nsut )
874 c triangle sans voisin direct => passage par le sur-triangle
875 if( nsut .eq. 0 ) then
877 c ntr est la racine => pas de triangle voisin par cette arete
882 c le sur-triangle est empile
884 lapile(lhpile) = nsut
888 c descente aux sous-triangles selon la meme arete
889 20 notrva = lapile( lhpile )
891 30 lhpile = lhpile - 1
892 if( letree(0,notrva) .le. 0 ) then
893 c le triangle est une feuille de l'arbre 0 sous-triangle
894 c lhpile = nombre de differences de niveaux dans l'arbre
897 c le triangle a 4 sous-triangles
898 if( lhpile .gt. 0 ) then
900 c bas de pile non atteint
901 nty = letree( 5, lapile(lhpile) )
902 if( nty .eq. lar ) then
903 c l'oppose est suivant(nty) de notrva
904 notrva = letree( nosui3(nty) , notrva )
906 c l'oppose est precedent(nty) de notrva
907 notrva = letree( nopre3(nty) , notrva )
913 c meme niveau dans l'arbre lhpile = 0
917 subroutine cenced( xy1, xy2, xy3, cetria, ierr )
918 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
919 c but : calcul des coordonnees du centre du cercle circonscrit
920 c ----- du triangle defini par ses 3 sommets de coordonnees
921 c xy1 xy2 xy3 ainsi que le carre du rayon de ce cercle
925 c xy1 xy2 xy3 : les 2 coordonnees des 3 sommets du triangle
926 c ierr : <0 => pas d'affichage si triangle degenere
927 c >=0 => affichage si triangle degenere
931 c cetria : cetria(1)=abcisse du centre
932 c cetria(2)=ordonnee du centre
933 c cetria(3)=carre du rayon 1d28 si triangle degenere
934 c ierr : 0 si triangle non degenere
935 c 1 si triangle degenere
936 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
937 c auteur : perronnet alain upmc analyse numerique paris juin 1995
938 c2345x7..............................................................012
939 parameter (epsurf=1d-7)
940 common / unites / lecteu,imprim,nunite(30)
941 double precision x1,y1,x21,y21,x31,y31,
943 % xy1(2),xy2(2),xy3(2),cetria(3)
945 c le calcul de 2 fois l'aire du triangle
946 c attention l'ordre des 3 sommets est direct ou non
955 aire2 = x21 * y31 - x31 * y21
957 c recherche d'un test relatif peu couteux
958 c pour reperer la degenerescence du triangle
960 % epsurf*(abs(x21)+abs(x31))*(abs(y21)+abs(y31)) ) then
961 c triangle de qualite trop faible
962 if( ierr .ge. 0 ) then
964 c kerr(1) = 'erreur cenced: triangle degenere'
966 write(imprim,*) 'erreur cenced: triangle degenere'
967 write(imprim,10000) xy1,xy2,xy3,aire2
969 10000 format( 3(' x=',g24.16,' y=',g24.16/),' aire*2=',g24.16)
977 c les 2 coordonnees du centre intersection des 2 mediatrices
978 c x = (x1+x2)/2 + lambda * (y2-y1)
979 c y = (y1+y2)/2 - lambda * (x2-x1)
980 c x = (x1+x3)/2 + rot * (y3-y1)
981 c y = (y1+y3)/2 - rot * (x3-x1)
982 c ==========================================================
983 rot = ((xy2(1)-xy3(1))*x21 + (xy2(2)-xy3(2))*y21) / (2 * aire2)
985 xc = ( x1 + xy3(1) ) * 0.5d0 + rot * y31
986 yc = ( y1 + xy3(2) ) * 0.5d0 - rot * x31
992 cetria(3) = (x1-xc) ** 2 + (y1-yc) ** 2
994 c pas d'erreur rencontree
999 double precision function angled( p1, p2, p3 )
1000 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1001 c but : calculer l'angle (p1p2,p1p3) en radians
1006 c p1,p2,p3 : les 2 coordonnees des 3 sommets de l'angle
1007 c sens direct pour une surface >0
1010 c angled : angle (p1p2,p1p3) en radians entre [0 et 2pi]
1011 c 0 si p1=p2 ou p1=p3
1012 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1013 c auteur : alain perronnet analyse numerique upmc paris fevrier 1992
1014 c2345x7..............................................................012
1015 double precision p1(2),p2(2),p3(2),x21,y21,x31,y31,a1,a2,d,c
1023 c longueur des cotes
1024 a1 = x21 * x21 + y21 * y21
1025 a2 = x31 * x31 + y31 * y31
1032 c cosinus de l'angle
1033 c = ( x21 * x31 + y21 * y31 ) / d
1034 if( c .le. -1.d0 ) then
1035 c tilt sur apollo si acos( -1 -eps )
1036 angled = atan( 1.d0 ) * 4.d0
1038 else if( c .ge. 1.d0 ) then
1039 c tilt sur apollo si acos( 1 + eps )
1045 if( x21 * y31 - x31 * y21 .lt. 0 ) then
1046 c demi plan inferieur
1047 angled = 8.d0 * atan( 1.d0 ) - angled
1052 subroutine teajte( mxsomm, nbsomm, pxyd, comxmi,
1053 % aretmx, mxtree, letree,
1055 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1056 c but : initialisation des tableaux letree
1057 c ----- ajout des sommets 1 a nbsomm (valeur en entree) dans letree
1061 c mxsomm : nombre maximal de sommets permis pour la triangulation
1062 c mxtree : nombre maximal de triangles equilateraux (te) declarables
1063 c aretmx : longueur maximale des aretes des triangles equilateraux
1065 c entrees et sorties :
1066 c --------------------
1067 c nbsomm : nombre de sommets apres identification
1068 c pxyd : tableau des coordonnees 2d des points
1069 c par point : x y distance_souhaitee
1070 c tableau reel(3,mxsomm)
1074 c comxmi : coordonnees minimales et maximales des points frontaliers
1075 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
1076 c letree(0,0) : no du 1-er te vide dans letree
1077 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
1078 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
1079 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
1080 c si letree(0,.)>0 alors
1081 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
1083 c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
1085 c ( j est alors une feuille de l'arbre )
1086 c letree(4,j) : no letree du sur-triangle du triangle j
1087 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
1088 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
1090 c ierr : 0 si pas d'erreur
1091 c 51 saturation letree
1092 c 52 saturation pxyd
1093 c 7 tous les points sont alignes
1094 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1095 c auteur : alain perronnet analyse numerique paris upmc juillet 1994
1096 c....................................................................012
1097 integer letree(0:8,0:mxtree)
1098 double precision pxyd(3,mxsomm)
1099 double precision comxmi(3,2)
1100 double precision a(2),s,aretmx,rac3
1102 c protection du nombre de sommets avant d'ajouter ceux de tetree
1105 comxmi(1,1) = min( comxmi(1,1), pxyd(1,i) )
1106 comxmi(1,2) = max( comxmi(1,2), pxyd(1,i) )
1107 comxmi(2,1) = min( comxmi(2,1), pxyd(2,i) )
1108 comxmi(2,2) = max( comxmi(2,2), pxyd(2,i) )
1111 c creation de l'arbre tee
1112 c =======================
1113 c la premiere colonne vide de letree
1115 c chainage des te vides
1119 letree(0,mxtree) = 0
1120 c les maxima des 2 indices de letree
1122 letree(2,0) = mxtree
1125 c aucun point interne au triangle equilateral (te) 1
1130 c pas de sur-triangle
1133 c le numero pxyd des 3 sommets du te 1
1134 letree(6,1) = nbsomm + 1
1135 letree(7,1) = nbsomm + 2
1136 letree(8,1) = nbsomm + 3
1138 c calcul de la largeur et hauteur du rectangle englobant
1139 c ======================================================
1140 a(1) = comxmi(1,2) - comxmi(1,1)
1141 a(2) = comxmi(2,2) - comxmi(2,1)
1142 c la longueur de la diagonale
1143 s = sqrt( a(1)**2 + a(2)**2 )
1145 if( a(k) .lt. 1e-4 * s ) then
1147 write(imprim,*) 'tous les points sont alignes'
1154 c le maximum des ecarts
1157 c le triangle equilateral englobant
1158 c =================================
1159 c ecart du rectangle au triangle equilateral
1160 rac3 = sqrt( 3.0d0 )
1161 arete = a(1) + 2 * aretmx + 2 * ( a(2) + aretmx ) / rac3
1163 c le point nbsomm + 1 en bas a gauche
1165 pxyd(1,nbsomm) = (comxmi(1,1)+comxmi(1,2))*0.5d0 - arete*0.5d0
1166 pxyd(2,nbsomm) = comxmi(2,1) - aretmx
1169 c le point nbsomm + 2 en bas a droite
1171 pxyd(1,nbsomm) = pxyd(1,nbsomm-1) + arete
1172 pxyd(2,nbsomm) = pxyd(2,nbsomm-1)
1175 c le point nbsomm + 3 sommet au dessus
1177 pxyd(1,nbsomm) = pxyd(1,nbsomm-2) + arete * 0.5d0
1178 pxyd(2,nbsomm) = pxyd(2,nbsomm-2) + arete * 0.5d0 * rac3
1181 c ajout des sommets des lignes pour former letree
1182 c ===============================================
1184 c ajout du point i de pxyd a letree
1185 call teajpt( i, nbsomm, mxsomm, pxyd, letree,
1187 if( ierr .ne. 0 ) return
1194 subroutine tetaid( nutysu, dx, dy, longai, ierr )
1195 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1196 c but : calculer la longueur de l'arete ideale en dx,dy
1201 c nutysu : numero de traitement de areteideale() selon le type de surface
1202 c 0 pas d'emploi de la fonction areteideale() => aretmx active
1203 c 1 il existe une fonction areteideale(xyz,xyzdir)
1204 c ... autres options a definir ...
1205 c dx, dy : abscisse et ordonnee dans le plan du point (reel2!)
1209 c longai : longueur de l'areteideale(xyz,xyzdir) autour du point xyz
1210 c ierr : 0 si pas d'erreur, <>0 sinon
1211 c 1 calcul incorrect de areteideale(xyz,xyzdir)
1212 c 2 longueur calculee nulle
1213 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1214 c auteur : alain perronnet analyse numerique paris upmc mars 1997
1215 c2345x7..............................................................012
1216 common / unites / lecteu, imprim, nunite(30)
1218 double precision areteideale
1219 double precision dx, dy, longai
1220 double precision xyz(3), xyzd(3), d0
1223 if( nutysu .gt. 0 ) then
1225 c le point ou se calcule la longueur
1228 c z pour le calcul de la longueur (inactif ici!)
1230 c la direction pour le calcul de la longueur (inactif ici!)
1235 longai = areteideale(xyz,xyzd)
1236 if( longai .lt. 0d0 ) then
1237 write(imprim,10000) xyz
1238 10000 format('attention: longueur de areteideale(',
1239 % g14.6,',',g14.6,',',g14.6,')<=0! => rendue >0' )
1242 if( longai .eq. 0d0 ) then
1243 write(imprim,10001) xyz
1244 10001 format('erreur: longueur de areteideale(',
1245 % g14.6,',',g14.6,',',g14.6,')=0!' )
1253 subroutine tehote( nutysu,
1254 % nbarpi, mxsomm, nbsomm, pxyd,
1256 % letree, mxqueu, laqueu,
1258 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1259 c but : homogeneisation de l'arbre des te a un saut de taille au plus
1260 c ----- prise en compte des distances souhaitees autour des sommets initiaux
1264 c nutysu : numero de traitement de areteideale() selon le type de surface
1265 c 0 pas d'emploi de la fonction areteideale() => aretmx active
1266 c 1 il existe une fonction areteideale()
1267 c dont seules les 2 premieres composantes de uv sont actives
1268 c autres options a definir...
1269 c nbarpi : nombre de sommets de la frontiere + nombre de points internes
1270 c imposes par l'utilisateur
1271 c mxsomm : nombre maximal de sommets permis pour la triangulation et te
1272 c mxqueu : nombre d'entiers utilisables dans laqueu
1273 c comxmi : minimum et maximum des coordonnees de l'objet
1274 c aretmx : longueur maximale des aretes des triangles equilateraux
1275 c permtr : perimetre de la ligne enveloppe dans le plan
1276 c avant mise a l'echelle a 2**20
1280 c nbsomm : nombre de sommets apres identification
1281 c pxyd : tableau des coordonnees 2d des points
1282 c par point : x y distance_souhaitee
1283 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
1284 c letree(0,0) : no du 1-er te vide dans letree
1285 c letree(1,0) : maximum du 1-er indice de letree (ici 8)
1286 c letree(2,0) : maximum declare du 2-eme indice de letree (ici mxtree)
1287 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
1288 c si letree(0,.)>0 alors
1289 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
1291 c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
1293 c ( j est alors une feuille de l'arbre )
1294 c letree(4,j) : no letree du sur-triangle du triangle j
1295 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
1296 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
1300 c laqueu : mxqueu entiers servant de queue pour le parcours de letree
1304 c ierr : 0 si pas d'erreur
1305 c 51 si saturation letree dans te4ste
1306 c 52 si saturation pxyd dans te4ste
1307 c >0 si autre erreur
1308 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1309 c auteur : alain perronnet analyse numerique paris upmc avril 1997
1310 c2345x7..............................................................012
1311 double precision ampli
1312 parameter (ampli=1.34d0)
1313 common / unites / lecteu, imprim, intera, nunite(29)
1315 double precision pxyd(3,mxsomm), d2, aretm2
1316 double precision comxmi(3,2),aretmx,a,s,xrmin,xrmax,yrmin,yrmax
1317 double precision dmin, dmax
1318 integer letree(0:8,0:*)
1320 integer laqueu(1:mxqueu),lequeu
1321 c lequeu : entree dans la queue
1322 c lhqueu : longueur de la queue
1323 c gestion circulaire
1326 equivalence (nuste(1),ns1),(nuste(2),ns2),(nuste(3),ns3)
1328 c existence ou non de la fonction 'taille_ideale' des aretes
1329 c autour du point. ici la carte est supposee isotrope
1330 c ==========================================================
1331 c attention: si la fonction taille_ideale existe
1332 c alors pxyd(3,*) est la taille_ideale dans l'espace initial
1333 c sinon pxyd(3,*) est la distance calculee dans le plan par
1334 c propagation a partir des tailles des aretes de la frontiere
1336 if( nutysu .gt. 0 ) then
1338 c la fonction taille_ideale(x,y,z) existe
1339 c ---------------------------------------
1340 c initialisation de la distance souhaitee autour des points 1 a nbsomm
1342 c calcul de pxyzd(3,i)
1343 call tetaid( nutysu, pxyd(1,i), pxyd(2,i),
1345 if( ierr .ne. 0 ) goto 9999
1350 c la fonction taille_ideale(x,y,z) n'existe pas
1351 c ---------------------------------------------
1352 c prise en compte des distances souhaitees dans le plan
1353 c autour des points frontaliers et des points internes imposes
1354 c toutes les autres distances souhaitees ont ete mis a aretmx
1355 c lors de l'execution du sp teqini
1357 c le sommet i n'est pas un sommet de letree => sommet frontalier
1358 c recherche du sous-triangle minimal feuille contenant le point i
1360 2 nte = notrpt( pxyd(1,i), pxyd, nte, letree )
1361 c la distance au sommet le plus eloigne est elle inferieure
1362 c a la distance souhaitee?
1366 d2 = max( ( pxyd(1,i)-pxyd(1,ns1) )**2 +
1367 % ( pxyd(2,i)-pxyd(2,ns1) )**2
1368 % , ( pxyd(1,i)-pxyd(1,ns2) )**2 +
1369 % ( pxyd(2,i)-pxyd(2,ns2) )**2
1370 % , ( pxyd(1,i)-pxyd(1,ns3) )**2 +
1371 % ( pxyd(2,i)-pxyd(2,ns3) )**2 )
1372 if( d2 .gt. pxyd(3,i)**2 ) then
1373 c le triangle nte trop grand doit etre subdivise en 4 sous-triangle
1374 call te4ste( nbsomm, mxsomm, pxyd, nte, letree,
1376 if( ierr .ne. 0 ) return
1382 c le sous-triangle central de la racine est decoupe systematiquement
1383 c ==================================================================
1385 if( letree(0,2) .le. 0 ) then
1386 c le sous-triangle central de la racine n'est pas subdivise
1387 c il est donc decoupe en 4 soustriangles
1389 call te4ste( nbsomm, mxsomm, pxyd, nte, letree,
1391 if( ierr .ne. 0 ) return
1392 do 4 i=nbsom0+1,nbsomm
1393 c mise a jour de taille_ideale des nouveaux sommets de te
1394 call tetaid( nutysu, pxyd(1,i), pxyd(2,i), pxyd(3,i), ierr )
1395 if( ierr .ne. 0 ) goto 9999
1399 c le carre de la longueur de l'arete de triangles equilateraux
1400 c souhaitee pour le fond de la triangulation
1401 aretm2 = (aretmx*ampli) ** 2
1403 c tout te contenu dans le rectangle englobant doit avoir un
1404 c cote < aretmx et etre de meme taille que les te voisins
1405 c s'il contient un point; sinon un seul saut de taille est permis
1406 c ===============================================================
1407 c le rectangle englobant pour selectionner les te "internes"
1408 c le numero des 3 sommets du te englobant racine de l'arbre des te
1413 c abscisse du milieu de l'arete gauche du te 1
1414 s = ( pxyd(1,ns1) + pxyd(1,ns3) ) / 2
1415 xrmin = min( s, comxmi(1,1) - aretmx ) - a
1416 c abscisse du milieu de l'arete droite du te 1
1417 s = ( pxyd(1,ns2) + pxyd(1,ns3) ) / 2
1418 xrmax = max( s, comxmi(1,2) + aretmx ) + a
1419 yrmin = comxmi(2,1) - aretmx
1420 c ordonnee de la droite passant par les milieus des 2 aretes
1421 c droite gauche du te 1
1422 s = ( pxyd(2,ns1) + pxyd(2,ns3) ) / 2
1423 yrmax = max( s, comxmi(2,2) + aretmx ) + a
1425 c cas particulier de 3 ou 4 ou peu d'aretes frontalieres
1426 if( nbarpi .le. 8 ) then
1427 c tout le triangle englobant (racine) est a prendre en compte
1428 xrmin = pxyd(1,ns1) - a
1429 xrmax = pxyd(1,ns2) + a
1430 yrmin = pxyd(2,ns1) - a
1431 yrmax = pxyd(2,ns3) + a
1437 c initialisation de la queue
1438 5 nbiter = nbiter + 1
1441 c la racine de letree initialise la queue
1444 c tant que la longueur de la queue est >=0 traiter le debut de queue
1445 10 if( lhqueu .ge. 0 ) then
1447 c le triangle te a traiter
1449 if( i .le. 0 ) i = mxqueu + i
1451 c la longueur de la queue est reduite
1454 c nte est il un sous-triangle feuille minimal ?
1455 15 if( letree(0,nte) .gt. 0 ) then
1457 c non les 4 sous-triangles sont mis dans la queue
1458 if( lhqueu + 4 .ge. mxqueu ) then
1459 write(imprim,*) 'tehote: saturation de la queue'
1464 c ajout du sous-triangle i
1467 if( lequeu .gt. mxqueu ) lequeu = lequeu - mxqueu
1468 laqueu( lequeu ) = letree( i, nte )
1474 c ici nte est un triangle minimal non subdivise
1475 c ---------------------------------------------
1476 c le te est il dans le cadre englobant de l'objet ?
1480 if( pxyd(1,ns1) .gt. pxyd(1,ns2) ) then
1487 if( (xrmin .le. dmin .and. dmin .le. xrmax) .or.
1488 % (xrmin .le. dmax .and. dmax .le. xrmax) ) then
1489 if( pxyd(2,ns1) .gt. pxyd(2,ns3) ) then
1496 if( (yrmin .le. dmin .and. dmin .le. yrmax) .or.
1497 % (yrmin .le. dmax .and. dmax .le. yrmax) ) then
1499 c nte est un te feuille et interne au rectangle englobant
1500 c =======================================================
1501 c le carre de la longueur de l'arete du te de numero nte
1502 d2 = (pxyd(1,ns1)-pxyd(1,ns2)) ** 2 +
1503 % (pxyd(2,ns1)-pxyd(2,ns2)) ** 2
1505 if( nutysu .eq. 0 ) then
1507 c il n'existe pas de fonction 'taille_ideale'
1508 c -------------------------------------------
1509 c si la taille effective de l'arete du te est superieure a aretmx
1510 c alors le te est decoupe
1511 if( d2 .gt. aretm2 ) then
1512 c le triangle nte trop grand doit etre subdivise
1513 c en 4 sous-triangles
1514 call te4ste( nbsomm,mxsomm, pxyd,
1515 % nte, letree, ierr )
1516 if( ierr .ne. 0 ) return
1522 c il existe ici une fonction 'taille_ideale'
1523 c ------------------------------------------
1524 c si la taille effective de l'arete du te est superieure au mini
1525 c des 3 tailles_ideales aux sommets alors le te est decoupe
1527 if( d2 .gt. (pxyd(3,nuste(i))*ampli)**2 ) then
1528 c le triangle nte trop grand doit etre subdivise
1529 c en 4 sous-triangles
1531 call te4ste( nbsomm, mxsomm, pxyd,
1532 & nte, letree, ierr )
1533 if( ierr .ne. 0 ) return
1534 do 27 j=nbsom0+1,nbsomm
1535 c mise a jour de taille_ideale des nouveaux sommets de
1536 call tetaid( nutysu, pxyd(1,j), pxyd(2,j),
1538 if( ierr .ne. 0 ) goto 9999
1545 c recherche du nombre de niveaux entre nte et les te voisins par se
1546 c si la difference de subdivisions excede 1 alors le plus grand des
1547 c =================================================================
1550 c noteva triangle voisin de nte par l'arete i
1551 call n1trva( nte, i, letree, noteva, niveau )
1552 if( noteva .le. 0 ) goto 30
1553 c il existe un te voisin
1554 if( niveau .gt. 0 ) goto 30
1555 c nte a un te voisin plus petit ou egal
1556 if( letree(0,noteva) .le. 0 ) goto 30
1557 c nte a un te voisin noteva subdivise au moins une fois
1559 if( nbiter .gt. 0 ) then
1560 c les 2 sous triangles voisins sont-ils subdivises?
1561 ns2 = letree(i,noteva)
1562 if( letree(0,ns2) .le. 0 ) then
1563 c ns2 n'est pas subdivise
1564 ns2 = letree(nosui3(i),noteva)
1565 if( letree(0,ns2) .le. 0 ) then
1566 c les 2 sous-triangles ne sont pas subdivises
1572 c saut>1 => le triangle nte doit etre subdivise en 4 sous-triang
1573 c --------------------------------------------------------------
1575 call te4ste( nbsomm,mxsomm, pxyd, nte, letree,
1577 if( ierr .ne. 0 ) return
1578 if( nutysu .gt. 0 ) then
1579 do 32 j=nbsom0+1,nbsomm
1580 c mise a jour de taille_ideale des nouveaux sommets de te
1581 call tetaid( nutysu, pxyd(1,j), pxyd(2,j),
1583 if( ierr .ne. 0 ) goto 9999
1593 if( nbs0 .lt. nbsomm ) then
1599 c pb dans le calcul de la fonction taille_ideale
1601 9999 write(imprim,*) 'pb dans le calcul de taille_ideale'
1603 c kerr(1) = 'pb dans le calcul de taille_ideale'
1609 subroutine tetrte( comxmi, aretmx, nbarpi, mxsomm, pxyd,
1610 % mxqueu, laqueu, letree,
1611 % mosoar, mxsoar, n1soar, nosoar,
1612 % moartr, mxartr, n1artr, noartr, noarst,
1614 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1615 c but : trianguler les triangles equilateraux feuilles et
1616 c ----- les points de la frontiere et les points internes imposes
1618 c attention: la triangulation finale n'est pas de type delaunay!
1622 c comxmi : minimum et maximum des coordonnees de l'objet
1623 c aretmx : longueur maximale des aretes des triangles equilateraux
1624 c nbarpi : nombre de sommets de la frontiere + nombre de points internes
1625 c imposes par l'utilisateur
1626 c mxsomm : nombre maximal de sommets declarables dans pxyd
1627 c pxyd : tableau des coordonnees 2d des points
1628 c par point : x y distance_souhaitee
1630 c mxqueu : nombre d'entiers utilisables dans laqueu
1631 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
1632 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
1633 c moartr : nombre maximal d'entiers par arete du tableau noartr
1634 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
1635 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
1636 c letree(0,0) : no du 1-er te vide dans letree
1637 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
1638 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
1639 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
1640 c si letree(0,.)>0 alors
1641 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
1643 c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
1645 c ( j est alors une feuille de l'arbre )
1646 c letree(4,j) : no letree du sur-triangle du triangle j
1647 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
1648 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
1652 c n1soar : numero de la premiere arete vide dans le tableau nosoar
1653 c une arete i de nosoar est vide <=> nosoar(1,i)=0
1654 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
1655 c chainage des aretes frontalieres, chainage du hachage des aretes
1656 c hachage des aretes = nosoar(1)+nosoar(2)*2
1657 c noarst : noarst(i) numero d'une arete de sommet i
1661 c laqueu : mxqueu entiers servant de queue pour le parcours de letree
1665 c n1artr : numero du premier triangle vide dans le tableau noartr
1666 c le chainage des triangles vides se fait sur noartr(2,.)
1667 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
1668 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
1669 c ierr : =0 si pas d'erreur
1670 c =1 si le tableau nosoar est sature
1671 c =2 si le tableau noartr est sature
1672 c =3 si aucun des triangles ne contient l'un des points internes d'un t
1673 c =5 si saturation de la queue de parcours de l'arbre des te
1674 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1675 c auteur : alain perronnet analyse numerique paris upmc mars 1997
1676 c2345x7..............................................................012
1677 common / unites / lecteu, imprim, intera, nunite(29)
1679 double precision pxyd(3,mxsomm)
1680 double precision comxmi(3,2),aretmx,a,s,xrmin,xrmax,yrmin,yrmax
1681 double precision dmin, dmax
1683 integer nosoar(mosoar,mxsoar),
1684 % noartr(moartr,mxartr),
1687 integer letree(0:8,0:*)
1688 integer laqueu(1:mxqueu)
1689 c lequeu:entree dans la queue en gestion circulaire
1690 c lhqueu:longueur de la queue en gestion circulaire
1692 integer milieu(3), nutr(1:13)
1694 c le rectangle englobant pour selectionner les te "internes"
1695 c le numero des 3 sommets du te englobant racine de l'arbre des te
1700 c abscisse du milieu de l'arete gauche du te 1
1701 s = ( pxyd(1,ns1) + pxyd(1,ns3) ) / 2
1702 xrmin = min( s, comxmi(1,1) - aretmx ) - a
1703 c abscisse du milieu de l'arete droite du te 1
1704 s = ( pxyd(1,ns2) + pxyd(1,ns3) ) / 2
1705 xrmax = max( s, comxmi(1,2) + aretmx ) + a
1706 yrmin = comxmi(2,1) - aretmx
1707 c ordonnee de la droite passant par les milieus des 2 aretes
1708 c droite gauche du te 1
1709 s = ( pxyd(2,ns1) + pxyd(2,ns3) ) / 2
1710 yrmax = max( s, comxmi(2,2) + aretmx ) + a
1712 c cas particulier de 3 ou 4 ou peu d'aretes frontalieres
1713 if( nbarpi .le. 8 ) then
1714 c tout le triangle englobant (racine) est a prendre en compte
1715 xrmin = pxyd(1,ns1) - a
1716 xrmax = pxyd(1,ns2) + a
1717 yrmin = pxyd(2,ns1) - a
1718 yrmax = pxyd(2,ns3) + a
1721 c initialisation du tableau noartr
1723 c le numero de l'arete est inconnu
1725 c le chainage sur le triangle vide suivant
1728 noartr(2,mxartr) = 0
1731 c parcours des te jusqu'a trianguler toutes les feuilles (triangles eq)
1732 c =====================================================================
1733 c initialisation de la queue sur les te
1737 c la racine de letree initialise la queue
1740 c tant que la longueur de la queue est >=0 traiter le debut de queue
1741 10 if( lhqueu .ge. 0 ) then
1743 c le triangle te a traiter
1745 if( i .le. 0 ) i = mxqueu + i
1747 c la longueur est reduite
1750 c nte est il un sous-triangle feuille (minimal) ?
1751 15 if( letree(0,nte) .gt. 0 ) then
1752 c non les 4 sous-triangles sont mis dans la queue
1753 if( lhqueu + 4 .ge. mxqueu ) then
1754 write(imprim,*) 'tetrte: saturation de la queue'
1759 c ajout du sous-triangle i
1762 if( lequeu .gt. mxqueu ) lequeu = lequeu - mxqueu
1763 laqueu( lequeu ) = letree( i, nte )
1768 c ici nte est un triangle minimal non subdivise
1769 c ---------------------------------------------
1770 c le te est il dans le cadre englobant de l'objet ?
1774 if( pxyd(1,ns1) .gt. pxyd(1,ns2) ) then
1781 if( (xrmin .le. dmin .and. dmin .le. xrmax) .or.
1782 % (xrmin .le. dmax .and. dmax .le. xrmax) ) then
1783 if( pxyd(2,ns1) .gt. pxyd(2,ns3) ) then
1790 if( (yrmin .le. dmin .and. dmin .le. yrmax) .or.
1791 % (yrmin .le. dmax .and. dmax .le. yrmax) ) then
1793 c te minimal et interne au rectangle englobant
1794 c --------------------------------------------
1795 c recherche du nombre de niveaux entre nte et les te voisins
1800 c a priori pas de milieu de l'arete i du te nte
1803 c recherche de noteva te voisin de nte par l'arete i
1804 call n1trva( nte, i, letree, noteva, niveau )
1805 c noteva : >0 numero letree du te voisin par l'arete i
1806 c =0 si pas de te voisin (racine , ... )
1807 c niveau : =0 si nte et noteva ont meme taille
1808 c >0 nte est 4**niveau fois plus petit que noteva
1809 if( noteva .gt. 0 ) then
1810 c il existe un te voisin
1811 if( letree(0,noteva) .gt. 0 ) then
1812 c noteva est plus petit que nte
1813 c => recherche du numero du milieu du cote=sommet du te no
1814 c le sous-te 0 du te noteva
1815 nsot = letree(0,noteva)
1816 c le numero dans pxyd du milieu de l'arete i de nte
1817 milieu( i ) = letree( 5+nopre3(i), nsot )
1824 c triangulation du te nte en fonction du nombre de ses milieux
1825 goto( 50, 100, 200, 300 ) , nbmili + 1
1827 c 0 milieu => 1 triangle = le te nte
1828 c ----------------------------------
1829 50 call f0trte( letree(0,nte), pxyd,
1830 % mosoar, mxsoar, n1soar, nosoar,
1831 % moartr, mxartr, n1artr, noartr,
1833 % nbtr, nutr, ierr )
1834 if( ierr .ne. 0 ) return
1837 c 1 milieu => 2 triangles = 2 demi te
1838 c -----------------------------------
1839 100 call f1trte( letree(0,nte), pxyd, milieu,
1840 % mosoar, mxsoar, n1soar, nosoar,
1841 % moartr, mxartr, n1artr, noartr,
1843 % nbtr, nutr, ierr )
1844 if( ierr .ne. 0 ) return
1847 c 2 milieux => 3 triangles
1848 c -----------------------------------
1849 200 call f2trte( letree(0,nte), pxyd, milieu,
1850 % mosoar, mxsoar, n1soar, nosoar,
1851 % moartr, mxartr, n1artr, noartr,
1853 % nbtr, nutr, ierr )
1854 if( ierr .ne. 0 ) return
1857 c 3 milieux => 4 triangles = 4 quart te
1858 c -------------------------------------
1859 300 call f3trte( letree(0,nte), pxyd, milieu,
1860 % mosoar, mxsoar, n1soar, nosoar,
1861 % moartr, mxartr, n1artr, noartr,
1863 % nbtr, nutr, ierr )
1864 if( ierr .ne. 0 ) return
1873 subroutine aisoar( mosoar, mxsoar, nosoar, na1 )
1874 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1875 c but : chainer en colonne lchain les aretes non vides et
1876 c ----- non frontalieres du tableau nosoar
1880 c mosoar : nombre maximal d'entiers par arete dans le tableau nosoar
1881 c mxsoar : nombre maximal d'aretes frontalieres declarables
1885 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
1886 c nosoar(lchain,i)=arete interne suivante
1890 c na1 : numero dans nosoar de la premiere arete interne
1891 c les suivantes sont nosoar(lchain,na1), ...
1892 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1893 c auteur : alain perronnet analyse numerique paris upmc mars 1997
1894 c....................................................................012
1895 parameter (lchain=6)
1896 integer nosoar(mosoar,mxsoar)
1898 c formation du chainage des aretes internes a echanger eventuellement
1899 c recherche de la premiere arete non vide et non frontaliere
1901 if( nosoar(1,na1) .gt. 0 .and. nosoar(3,na1) .le. 0 ) goto 15
1904 c protection de la premiere arete non vide et non frontaliere
1906 do 20 na=na1+1,mxsoar
1907 if( nosoar(1,na) .gt. 0 .and. nosoar(3,na) .le. 0 ) then
1908 c arete interne => elle est chainee a partir de la precedente
1909 nosoar(lchain,na0) = na
1914 c la derniere arete interne n'a pas de suivante
1915 nosoar(lchain,na0) = 0
1919 subroutine tedela( pxyd, noarst,
1920 % mosoar, mxsoar, n1soar, nosoar, n1ardv,
1921 % moartr, mxartr, n1artr, noartr, modifs )
1922 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1923 c but : pour toutes les aretes chainees dans nosoar(lchain,*)
1924 c ----- du tableau nosoar
1925 c echanger la diagonale des 2 triangles si le sommet oppose
1926 c a un triangle ayant en commun une arete appartient au cercle
1927 c circonscrit de l'autre (violation boule vide delaunay)
1931 c pxyd : tableau des x y distance_souhaitee de chaque sommet
1935 c noarst : noarst(i) numero d'une arete de sommet i
1936 c mosoar : nombre maximal d'entiers par arete dans le tableau nosoar
1937 c mxsoar : nombre maximal d'aretes frontalieres declarables
1938 c n1soar : numero de la premiere arete vide dans le tableau nosoar
1939 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
1940 c n1ardv : numero dans nosoar de la premiere arete du chainage
1941 c des aretes a rendre delaunay
1943 c moartr : nombre d'entiers par triangle dans le tableau noartr
1944 c mxartr : nombre maximal de triangles declarables dans noartr
1945 c n1artr : numero du premier triangle vide dans le tableau noartr
1946 c le chainage des triangles vides se fait sur noartr(2,.)
1947 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
1948 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
1949 c modifs : nombre d'echanges de diagonales pour maximiser la qualite
1950 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1951 c auteur : alain perronnet analyse numerique paris upmc mars 1997
1952 c....................................................................012
1953 parameter (lchain=6)
1954 common / unites / lecteu, imprim, nunite(30)
1955 double precision pxyd(3,*), surtd2, s123, s142, s143, s234,
1956 % s12, s34, a12, cetria(3), r0
1957 integer nosoar(mosoar,mxsoar),
1958 % noartr(moartr,mxartr),
1961 c le nombre d'echanges de diagonales pour minimiser l'aire
1965 c la premiere arete du chainage des aretes a rendre delaunay
1968 c tant que la pile des aretes a echanger eventuellement est non vide
1969 c ==================================================================
1970 20 if( na0 .gt. 0 ) then
1974 c la prochaine arete a traiter
1975 na0 = nosoar(lchain,na0)
1977 c l'arete est marquee traitee avec le numero -1
1978 nosoar(lchain,na) = -1
1980 c l'arete est elle active?
1981 if( nosoar(1,na) .eq. 0 ) goto 20
1983 c si arete frontaliere pas d'echange possible
1984 if( nosoar(3,na) .gt. 0 ) goto 20
1986 c existe-t-il 2 triangles ayant cette arete commune?
1987 if( nosoar(4,na) .le. 0 .or. nosoar(5,na) .le. 0 ) goto 20
1989 c aucun des 2 triangles est-il desactive?
1990 if( noartr(1,nosoar(4,na)) .eq. 0 .or.
1991 % noartr(1,nosoar(5,na)) .eq. 0 ) goto 20
1993 c l'arete appartient a deux triangles actifs
1994 c le numero des 4 sommets du quadrangle des 2 triangles
1995 call mt4sqa( na, moartr, noartr, mosoar, nosoar,
1996 % ns1, ns2, ns3, ns4 )
1997 if( ns4 .eq. 0 ) goto 20
1999 c carre de la longueur de l'arete ns1 ns2
2000 a12 = (pxyd(1,ns2)-pxyd(1,ns1))**2+(pxyd(2,ns2)-pxyd(2,ns1))**2
2002 c comparaison de la somme des aires des 2 triangles
2003 c -------------------------------------------------
2004 c calcul des surfaces des triangles 123 et 142 de cette arete
2005 s123=surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
2006 s142=surtd2( pxyd(1,ns1), pxyd(1,ns4), pxyd(1,ns2) )
2007 s12 = abs( s123 ) + abs( s142 )
2008 if( s12 .le. 0.001*a12 ) goto 20
2010 c calcul des surfaces des triangles 143 et 234 de cette arete
2011 s143=surtd2( pxyd(1,ns1), pxyd(1,ns4), pxyd(1,ns3) )
2012 s234=surtd2( pxyd(1,ns2), pxyd(1,ns3), pxyd(1,ns4) )
2013 s34 = abs( s234 ) + abs( s143 )
2015 if( abs(s34-s12) .gt. 1d-15*s34 ) goto 20
2017 c quadrangle convexe : le critere de delaunay intervient
2018 c ------------------ ---------------------------------
2019 c calcul du centre et rayon de la boule circonscrite a 123
2020 c pas d'affichage si le triangle est degenere
2022 call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), cetria,
2024 if( ierr .gt. 0 ) then
2025 c ierr=1 si triangle degenere => abandon
2029 if( (cetria(1)-pxyd(1,ns4))**2+(cetria(2)-pxyd(2,ns4))**2
2030 % .lt. cetria(3) ) then
2032 c protection contre une boucle infinie sur le meme cercle
2033 if( r0 .eq. cetria(3) ) goto 20
2035 c oui: ns4 est dans le cercle circonscrit a ns1 ns2 ns3
2036 c => ns3 est aussi dans le cercle circonscrit de ns1 ns2 ns4
2038 cccc les 2 triangles d'arete na sont effaces
2040 ccc nt = nosoar(j,na)
2041 cccc trace du triangle nt
2042 ccc call mttrtr( pxyd, nt, moartr, noartr, mosoar, nosoar,
2043 ccc % ncnoir, ncjaun )
2046 c echange de la diagonale 12 par 34 des 2 triangles
2047 call te2t2t( na, mosoar, n1soar, nosoar, noarst,
2048 % moartr, noartr, na34 )
2049 if( na34 .eq. 0 ) goto 20
2052 c l'arete na34 est marquee traitee
2053 nosoar(lchain,na34) = -1
2056 c les aretes internes peripheriques des 2 triangles sont enchainees
2059 cccc trace du triangle nt
2060 ccc call mttrtr( pxyd, nt, moartr, noartr, mosoar, nosoar,
2061 ccc % ncoran, ncgric )
2063 n = abs( noartr(i,nt) )
2064 if( n .ne. na34 ) then
2065 if( nosoar(3,n) .eq. 0 .and.
2066 % nosoar(lchain,n) .eq. -1 ) then
2067 c cette arete marquee est chainee pour etre traitee
2068 nosoar(lchain,n) = na0
2077 c retour en haut de la pile des aretes a traiter
2083 subroutine terefr( nbarpi, pxyd,
2084 % mosoar, mxsoar, n1soar, nosoar,
2085 % moartr, n1artr, noartr, noarst,
2086 % mxarcf, n1arcf, noarcf, larmin, notrcf,
2088 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2089 c but : recherche des aretes de la frontiere non dans la triangulation
2090 c ----- triangulation frontale pour les reobtenir
2092 c attention: le chainage lchain de nosoar devient celui des cf
2097 c nbarpi : numero du dernier point interne impose par l'utilisateur
2098 c pxyd : tableau des coordonnees 2d des points
2099 c par point : x y distance_souhaitee
2100 c mosoar : nombre maximal d'entiers par arete et
2101 c indice dans nosoar de l'arete suivante dans le hachage
2102 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
2103 c attention: mxsoar>3*mxsomm obligatoire!
2104 c moartr : nombre maximal d'entiers par arete du tableau noartr
2105 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
2109 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
2110 c chainage des vides suivant en 3 et precedant en 2 de nosoar
2111 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
2112 c chainage des aretes frontalieres, chainage du hachage des aretes
2113 c hachage des aretes = nosoar(1)+nosoar(2)*2
2114 c avec mxsoar>=3*mxsomm
2115 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
2116 c nosoar(2,arete vide)=l'arete vide qui precede
2117 c nosoar(3,arete vide)=l'arete vide qui suit
2118 c n1artr : numero du premier triangle vide dans le tableau noartr
2119 c le chainage des triangles vides se fait sur noartr(2,.)
2120 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2121 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
2122 c noarst : noarst(i) numero d'une arete de sommet i
2127 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
2128 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
2129 c larmin : tableau (mxarcf) auxiliaire d'entiers
2130 c notrcf : tableau (mxarcf) auxiliaire d'entiers
2134 c nbarpe : nombre d'aretes perdues puis retrouvees
2135 c ierr : =0 si pas d'erreur
2136 c >0 si une erreur est survenue
2137 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2138 c auteur : alain perronnet analyse numerique paris upmc mars 1997
2139 c....................................................................012
2140 parameter (lchain=6)
2141 common / unites / lecteu,imprim,intera,nunite(29)
2142 double precision pxyd(3,*)
2143 integer nosoar(mosoar,mxsoar),
2151 c le nombre d'aretes de la frontiere non arete de la triangulation
2154 c initialisation du chainage des aretes des cf => 0 arete de cf
2155 do 10 narete=1,mxsoar
2156 nosoar( lchain, narete) = -1
2159 c boucle sur l'ensemble des aretes actuelles
2160 c ==========================================
2161 do 30 narete=1,mxsoar
2163 if( nosoar(3,narete) .gt. 0 ) then
2164 c arete appartenant a une ligne => frontaliere
2166 if(nosoar(4,narete) .le. 0 .or. nosoar(5,narete) .le. 0)then
2167 c l'arete narete frontaliere n'appartient pas a 2 triangles
2168 c => elle est perdue
2171 c le numero des 2 sommets de l'arete frontaliere perdue
2172 ns1 = nosoar( 1, narete )
2173 ns2 = nosoar( 2, narete )
2174 c write(imprim,10000) ns1,(pxyd(j,ns1),j=1,2),
2175 c % ns2,(pxyd(j,ns2),j=1,2)
2176 10000 format(' arete perdue a forcer',
2177 % (t24,'sommet=',i6,' x=',g13.5,' y=',g13.5))
2179 c traitement de cette arete perdue ns1-ns2
2180 call tefoar( narete, nbarpi, pxyd,
2181 % mosoar, mxsoar, n1soar, nosoar,
2182 % moartr, n1artr, noartr, noarst,
2183 % mxarcf, n1arcf, noarcf, larmin, notrcf,
2185 if( ierr .ne. 0 ) return
2187 c fin du traitement de cette arete perdue et retrouvee
2195 subroutine tesuex( nblftr, nulftr,
2196 % ndtri0, nbsomm, pxyd, nslign,
2197 % mosoar, mxsoar, nosoar,
2198 % moartr, mxartr, n1artr, noartr, noarst,
2199 % nbtria, letrsu, ierr )
2200 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2201 c but : supprimer du tableau noartr les triangles externes au domaine
2202 c ----- en annulant le numero de leur 1-ere arete dans noartr
2203 c et en les chainant comme triangles vides
2207 c nblftr : nombre de lignes fermees definissant la surface
2208 c nulftr : numero des lignes fermees definissant la surface
2209 c ndtri0 : plus grand numero dans noartr d'un triangle
2210 c pxyd : tableau des coordonnees 2d des points
2211 c par point : x y distance_souhaitee
2212 c nslign : tableau du numero de sommet dans sa ligne pour chaque
2214 c numero du point dans le lexique point si interne impose
2215 c 0 si le point est interne non impose par l'utilisateur
2216 c -1 si le sommet est externe au domaine
2217 c mosoar : nombre maximal d'entiers par arete et
2218 c indice dans nosoar de l'arete suivante dans le hachage
2219 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
2220 c attention: mxsoar>3*mxsomm obligatoire!
2221 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
2222 c chainage des aretes frontalieres, chainage du hachage des aretes
2223 c hachage des aretes = nosoar(1)+nosoar(2)*2
2224 c avec mxsoar>=3*mxsomm
2225 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
2226 c nosoar(2,arete vide)=l'arete vide qui precede
2227 c nosoar(3,arete vide)=l'arete vide qui suit
2228 c moartr : nombre maximal d'entiers par arete du tableau noartr
2229 c mxartr : nombre maximal de triangles declarables
2230 c n1artr : numero du premier triangle vide dans le tableau noartr
2231 c le chainage des triangles vides se fait sur noartr(2,.)
2232 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2233 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
2234 c noarst : noarst(i) numero nosoar d'une arete de sommet i
2238 c nbtria : nombre de triangles internes au domaine
2239 c letrsu : letrsu(nt)=numero du triangle interne, 0 sinon
2240 c noarst : noarst(i) numero nosoar d'une arete du sommet i (modifi'e)
2241 c ierr : 0 si pas d'erreur, >0 sinon
2242 cc++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2243 c auteur : alain perronnet analyse numerique paris upmc mai 1999
2244 c2345x7..............................................................012
2245 double precision pxyd(3,*)
2246 integer nulftr(nblftr),nslign(nbsomm),
2247 % nosoar(mosoar,mxsoar),
2248 % noartr(moartr,mxartr),
2250 integer letrsu(1:ndtri0)
2251 double precision dmin
2253 c les triangles sont a priori non marques
2258 c les aretes sont marquees non chainees
2259 do 10 noar1=1,mxsoar
2260 nosoar(6,noar1) = -2
2263 c recherche du sommet de la triangulation de plus petite abscisse
2264 c ===============================================================
2268 if( pxyd(1,i) .lt. dmin ) then
2269 c le nouveau minimum
2271 if( noar1 .gt. 0 ) then
2272 c le sommet appartient a une arete de triangle
2273 if( nosoar(4,noar1) .gt. 0 ) then
2274 c le nouveau minimum
2282 c une arete de sommet ntmin
2283 noar1 = noarst( ntmin )
2284 c un triangle d'arete noar1
2285 ntmin = nosoar( 4, noar1 )
2286 if( ntmin .le. 0 ) then
2288 c kerr(1) = 'pas de triangle d''abscisse minimale'
2290 write(imprim,*) 'pas de triangle d''abscisse minimale'
2295 c chainage des 3 aretes du triangle ntmin
2296 c =======================================
2297 c la premiere arete du chainage des aretes traitees
2298 noar1 = abs( noartr(1,ntmin) )
2299 na0 = abs( noartr(2,ntmin) )
2300 c elle est chainee sur la seconde arete du triangle ntmin
2301 nosoar(6,noar1) = na0
2302 c les 2 autres aretes du triangle ntmin sont chainees
2303 na1 = abs( noartr(3,ntmin) )
2304 c la seconde est chainee sur la troisieme arete
2306 c la troisieme n'a pas de suivante
2309 c le triangle ntmin est a l'exterieur du domaine
2310 c tous les triangles externes sont marques -123 456 789
2311 c les triangles de l'autre cote d'une arete sur une ligne
2312 c sont marques: no de la ligne de l'arete * signe oppose
2313 c =======================================================
2315 ligne = -123 456 789
2317 40 if( noar1 .ne. 0 ) then
2319 c l'arete noar1 du tableau nosoar est a traiter
2320 c ---------------------------------------------
2322 c l'arete suivante devient la premiere a traiter ensuite
2323 noar1 = nosoar(6,noar1)
2324 c l'arete noar est traitee
2329 c l'un des 2 triangles de l'arete
2331 if( nt .gt. 0 ) then
2333 c triangle deja traite pour une ligne anterieure?
2334 if( letrsu(nt) .ne. 0 .and.
2335 % abs(letrsu(nt)) .ne. ligne ) goto 60
2337 cccc trace du triangle nt en couleur ligne0
2338 ccc call mttrtr( pxyd, nt, moartr, noartr, mosoar, nosoar,
2339 ccc % ligne0, ncnoir )
2341 c le triangle est marque avec la valeur de ligne
2344 c chainage eventuel des autres aretes de ce triangle
2345 c si ce n'est pas encore fait
2348 c le numero na de l'arete j du triangle nt dans nosoar
2349 na = abs( noartr(j,nt) )
2350 if( nosoar(6,na) .ne. -2 ) goto 50
2352 c le numero de 1 a nblftr dans nulftr de la ligne de l'arete
2355 c si l'arete est sur une ligne fermee differente de celle envelo
2356 c et non marquee alors examen du triangle oppose
2357 if( nl .gt. 0 ) then
2359 if( nl .eq. ligne0 ) goto 50
2361 c arete frontaliere de ligne non traitee
2362 c => passage de l'autre cote de la ligne
2363 c le triangle de l'autre cote de la ligne est recherche
2364 if( nt .eq. abs( nosoar(4,na) ) ) then
2369 nt2 = abs( nosoar(nt2,na) )
2370 if( nt2 .gt. 0 ) then
2372 c le triangle nt2 de l'autre cote est marque avec le
2373 c avec le signe oppose de celui de ligne
2374 if( ligne .ge. 0 ) then
2379 letrsu(nt2) = lsigne * nl
2381 c temoin de ligne a traiter ensuite dans nulftr
2382 nulftr(nl) = -abs( nulftr(nl) )
2384 cccc trace du triangle nt2 en jaune borde de magenta
2385 ccc call mttrtr( pxyd,nt2,
2386 ccc % moartr,noartr,mosoar,nosoar,
2387 ccc % ncjaun, ncmage )
2389 c l'arete est traitee
2394 c l'arete est traitee
2399 c arete non traitee => elle est chainee
2400 nosoar(6,na) = noar1
2410 c les triangles de la ligne fermee ont tous ete marques
2411 c plus d'arete chainee
2413 c recherche d'une nouvelle ligne fermee a traiter
2414 c ===============================================
2415 65 do 70 nl=1,nblftr
2416 if( nulftr(nl) .lt. 0 ) goto 80
2418 c plus de ligne fermee a traiter
2421 c tous les triangles de cette composante connexe
2422 c entre ligne et ligne0 vont etre marques
2423 c ==============================================
2424 c remise en etat du numero de ligne
2425 c nl est le numero de la ligne dans nulftr a traiter
2426 80 nulftr(nl) = -nulftr(nl)
2428 if( abs(letrsu(nt2)) .eq. nl ) goto 92
2431 c recherche de l'arete j du triangle nt2 avec ce numero de ligne nl
2434 c le numero de l'arete j du triangle dans nosoar
2436 na0 = abs( noartr(j,nt2) )
2437 if( nl .eq. nosoar(3,na0) ) then
2439 c na0 est l'arete de ligne nl
2440 c l'arete suivante du triangle nt2
2442 c le numero dans nosoar de l'arete i de nt2
2443 na1 = abs( noartr(i,nt2) )
2444 if( nosoar(6,na1) .eq. -2 ) then
2445 c arete non traitee => elle est la premiere du chainage
2447 c pas de suivante dans ce chainage
2453 c l'eventuelle seconde arete suivante
2455 na = abs( noartr(i,nt2) )
2456 if( nosoar(6,na) .eq. -2 ) then
2457 if( na1 .eq. 0 ) then
2458 c 1 arete non traitee et seule a chainer
2462 c 2 aretes a chainer
2468 if( noar1 .gt. 0 ) then
2470 c il existe au moins une arete a visiter pour ligne
2471 c marquage des triangles internes a la ligne nl
2478 c nt2 est le seul triangle de la ligne fermee
2485 c reperage des sommets internes ou externes dans nslign
2486 c nslign(sommet externe au domaine)=-1
2487 c nslign(sommet interne au domaine)= 0
2488 c =====================================================
2489 110 do 170 ns1=1,nbsomm
2490 c tout sommet non sur la frontiere ou interne impose
2491 c est suppose externe
2492 if( nslign(ns1) .eq. 0 ) nslign(ns1) = -1
2495 c les triangles externes sont marques vides dans le tableau noartr
2496 c ================================================================
2500 if( letrsu(nt) .le. 0 ) then
2502 c triangle nt externe
2503 if( noartr(1,nt) .ne. 0 ) then
2504 c la premiere arete est annulee
2506 c le triangle nt est considere comme etant vide
2507 noartr(2,nt) = n1artr
2513 c triangle nt interne
2517 c marquage des 3 sommets du triangle nt
2519 c le numero nosoar de l'arete i du triangle nt
2520 noar = abs( noartr(i,nt) )
2521 c le numero des 2 sommets
2522 ns1 = nosoar(1,noar)
2523 ns2 = nosoar(2,noar)
2524 c mise a jour du numero d'une arete des 2 sommets de l'arete
2525 noarst( ns1 ) = noar
2526 noarst( ns2 ) = noar
2527 c ns1 et ns2 sont des sommets de la triangulation du domaine
2528 if( nslign(ns1) .lt. 0 ) nslign(ns1)=0
2529 if( nslign(ns2) .lt. 0 ) nslign(ns2)=0
2535 c ici tout sommet externe ns verifie nslign(ns)=-1
2537 c les triangles externes sont mis a zero dans nosoar
2538 c ==================================================
2539 do 300 noar=1,mxsoar
2541 if( nosoar(1,noar) .gt. 0 ) then
2543 c le second triangle de l'arete noar
2545 if( nt .gt. 0 ) then
2546 c si le triangle nt est externe
2547 c alors il est supprime pour l'arete noar
2548 if( letrsu(nt) .le. 0 ) nosoar(5,noar)=0
2551 c le premier triangle de l'arete noar
2553 if( nt .gt. 0 ) then
2554 if( letrsu(nt) .le. 0 ) then
2555 c si le triangle nt est externe
2556 c alors il est supprime pour l'arete noar
2557 c et l'eventuel triangle oppose prend sa place
2558 c en position 4 de nosoar
2559 if( nosoar(5,noar) .gt. 0 ) then
2560 nosoar(4,noar)=nosoar(5,noar)
2571 c remise en etat pour eviter les modifications de ladefi
2572 9990 do 9991 nl=1,nblftr
2573 if( nulftr(nl) .lt. 0 ) nulftr(nl)=-nulftr(nl)
2580 subroutine trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
2581 % mxpile, lhpile, lapile )
2582 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2583 c but : recherche des triangles de noartr partageant le sommet ns
2585 c limite: un camembert de centre ns entame 2 fois
2586 c ne donne que l'une des parties
2590 c ns : numero du sommet
2591 c noarst : noarst(i) numero d'une arete de sommet i
2592 c mosoar : nombre maximal d'entiers par arete et
2593 c indice dans nosoar de l'arete suivante dans le hachage
2594 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
2595 c chainage des aretes frontalieres, chainage du hachage des aretes
2596 c moartr : nombre maximal d'entiers par arete du tableau noartr
2597 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2598 c mxpile : nombre maximal de triangles empilables
2602 c lhpile : >0 nombre de triangles empiles
2603 c =0 si impossible de tourner autour du point
2604 c =-lhpile si apres butee sur la frontiere il y a a nouveau
2605 c butee sur la frontiere . a ce stade on ne peut dire si tous
2606 c les triangles ayant ce sommet ont ete recenses
2607 c ce cas arrive seulement si le sommet est sur la frontiere
2608 c lapile : numero dans noartr des triangles de sommet ns
2609 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2610 c auteur : alain perronnet analyse numerique paris upmc mars 1997
2611 c....................................................................012
2612 common / unites / lecteu, imprim, nunite(30)
2613 integer noartr(moartr,*),
2616 integer lapile(1:mxpile)
2619 c la premiere arete de sommet ns
2621 if( nar .le. 0 ) then
2622 write(imprim,*) 'trp1st: sommet',ns,' sans arete'
2626 c l'arete nar est elle active?
2627 if( nosoar(1,nar) .le. 0 ) then
2628 ccc write(imprim,*) 'trp1st: arete vide',nar,
2629 ccc % ' st1:', nosoar(1,nar),' st2:',nosoar(2,nar)
2633 c le premier triangle de sommet ns
2634 nt0 = abs( nosoar(4,nar) )
2635 if( nt0 .le. 0 ) then
2636 write(imprim,*) 'trp1st: sommet',ns,' dans aucun triangle'
2640 c le triangle est il interne?
2641 if( noartr(1,nt0) .eq. 0 ) goto 9999
2643 c le numero des 3 sommets du triangle nt0 dans le sens direct
2644 call nusotr( nt0, mosoar, nosoar, moartr, noartr, nosotr )
2646 c reperage du sommet ns dans le triangle nt0
2648 if( nosotr(nar) .eq. ns ) goto 10
2653 c ns retrouve : le triangle nt0 est empile
2658 c recherche dans le sens des aiguilles d'une montre
2659 c (sens indirect) du triangle nt1 de l'autre cote de l'arete
2660 c nar du triangle et en tournant autour du sommet ns
2661 c ==========================================================
2662 noar = abs( noartr(nar,nt0) )
2663 c le triangle nt1 oppose du triangle nt0 par l'arete noar
2664 if( nosoar(4,noar) .eq. nt0 ) then
2665 nt1 = nosoar(5,noar)
2667 nt1 = nosoar(4,noar)
2670 c la boucle sur les triangles nt1 de sommet ns dans le sens indirect
2671 c ==================================================================
2672 if( nt1 .gt. 0 ) then
2674 if( noartr(1,nt1) .eq. 0 ) goto 30
2676 c le triangle nt1 n'a pas ete detruit. il est actif
2677 c le triangle oppose par l'arete noar existe
2678 c le numero des 3 sommets du triangle nt1 dans le sens direct
2679 15 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
2681 c reperage du sommet ns dans nt1
2683 if( nosotr(nar) .eq. ns ) goto 25
2689 25 if( lhpile .ge. mxpile ) goto 9990
2691 lapile(lhpile) = nt1
2693 c le triangle nt1 de l'autre cote de l'arete de sommet ns
2694 c sauvegarde du precedent triangle dans nta
2696 noar = abs( noartr(nar,nt1) )
2697 if( nosoar(4,noar) .eq. nt1 ) then
2698 nt1 = nosoar(5,noar)
2700 nt1 = nosoar(4,noar)
2702 if( nt1 .le. 0 ) goto 30
2703 c le triangle suivant est a l'exterieur
2704 if( nt1 .ne. nt0 ) goto 15
2706 c recherche terminee par arrivee sur nt0
2707 c les triangles forment un "cercle" de "centre" ns
2712 c pas de triangle voisin a nt1
2713 c ============================
2714 c le parcours passe par 1 des triangles exterieurs
2715 c le parcours est inverse par l'arete de gauche
2716 c le triangle nta est le premier triangle empile
2718 lapile(lhpile) = nta
2720 c le numero des 3 sommets du triangle nta dans le sens direct
2721 call nusotr( nta, mosoar, nosoar, moartr, noartr, nosotr )
2723 if( nosotr(nar) .eq. ns ) goto 33
2727 c l'arete qui precede (rotation / ns dans le sens direct)
2728 33 if( nar .eq. 1 ) then
2734 c le triangle voisin de nta dans le sens direct
2735 noar = abs( noartr(nar,nta) )
2736 if( nosoar(4,noar) .eq. nta ) then
2737 nt1 = nosoar(5,noar)
2739 nt1 = nosoar(4,noar)
2741 if( nt1 .le. 0 ) then
2742 c un seul triangle contient ns
2746 c boucle sur les triangles de sommet ns dans le sens direct
2747 c ==========================================================
2748 40 if( noartr(1,nt1) .eq. 0 ) goto 70
2750 c le triangle nt1 n'a pas ete detruit. il est actif
2751 c le numero des 3 sommets du triangle nt1 dans le sens direct
2752 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
2754 c reperage du sommet ns dans nt1
2756 if( nosotr(nar) .eq. ns ) goto 60
2762 60 if( lhpile .ge. mxpile ) goto 9990
2764 lapile(lhpile) = nt1
2766 c l'arete qui precede dans le sens direct
2767 if( nar .eq. 1 ) then
2773 c l'arete de sommet ns dans nosoar
2774 noar = abs( noartr(nar,nt1) )
2776 c le triangle voisin de nta dans le sens direct
2778 if( nosoar(4,noar) .eq. nt1 ) then
2779 nt1 = nosoar(5,noar)
2781 nt1 = nosoar(4,noar)
2784 if( nt1 .gt. 0 ) goto 40
2786 c butee sur le trou => fin des triangles de sommet ns
2787 c ----------------------------------------------------
2789 c impossible ici de trouver les autres triangles de sommet ns
2790 c les triangles de sommet ns ne forment pas une boule de centre ns
2793 c saturation de la pile des triangles
2794 c -----------------------------------
2795 9990 write(imprim,*) 'trp1st:saturation pile des triangles autour ',
2799 c erreur triangle ne contenant pas le sommet ns
2800 c ----------------------------------------------
2801 9995 write(imprim,*) 'trp1st:triangle ',nta,' st=',
2802 % (nosotr(nar),nar=1,3),' sans le sommet' ,ns
2810 subroutine nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
2811 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2812 c but : calcul du numero des 3 sommets du triangle nt de noartr
2813 c ----- dans le sens direct (aire>0 si non degenere)
2817 c nt : numero du triangle dans le tableau noartr
2818 c mosoar : nombre maximal d'entiers par arete
2819 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
2820 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
2821 c moartr : nombre maximal d'entiers par arete du tableau noartr
2822 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2823 c arete1=0 si triangle vide => arete2=triangle vide suivant
2827 c nosotr : numero (dans le tableau pxyd) des 3 sommets du triangle
2828 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2829 c auteur : alain perronnet analyse numerique paris upmc mars 1997
2830 c2345x7..............................................................012
2831 integer nosoar(mosoar,*), noartr(moartr,*), nosotr(3)
2833 c les 2 sommets de l'arete 1 du triangle nt dans le sens direct
2834 na = noartr( 1, nt )
2835 if( na .gt. 0 ) then
2843 nosotr(1) = nosoar( nosotr(1), na )
2844 nosotr(2) = nosoar( nosotr(2), na )
2847 na = abs( noartr(2,nt) )
2849 c le sommet nosotr(3 du triangle 123
2850 nosotr(3) = nosoar( 1, na )
2851 if( nosotr(3) .eq. nosotr(1) .or. nosotr(3) .eq. nosotr(2) ) then
2852 nosotr(3) = nosoar(2,na)
2857 subroutine tesusp( nbarpi, pxyd, noarst,
2858 % mosoar, mxsoar, n1soar, nosoar,
2859 % moartr, mxartr, n1artr, noartr,
2860 % mxarcf, n1arcf, noarcf, larmin, notrcf, liarcf,
2862 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2863 c but : supprimer de la triangulation les sommets de te trop proches
2864 c ----- soit d'un sommet frontalier ou point interne impose
2865 c soit d'une arete frontaliere
2867 c attention: le chainage lchain de nosoar devient celui des cf
2871 c nbarpi : numero du dernier point interne impose par l'utilisateur
2872 c pxyd : tableau des coordonnees 2d des points
2873 c par point : x y distance_souhaitee
2874 c mosoar : nombre maximal d'entiers par arete et
2875 c indice dans nosoar de l'arete suivante dans le hachage
2876 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
2877 c attention: mxsoar>3*mxsomm obligatoire!
2878 c moartr : nombre maximal d'entiers par arete du tableau noartr
2879 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
2883 c noarst : noarst(i) numero d'une arete de sommet i
2884 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
2885 c chainage des vides suivant en 3 et precedant en 2 de nosoar
2886 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
2887 c chainage des aretes frontalieres, chainage du hachage des aretes
2888 c hachage des aretes = nosoar(1)+nosoar(2)*2
2889 c avec mxsoar>=3*mxsomm
2890 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
2891 c nosoar(2,arete vide)=l'arete vide qui precede
2892 c nosoar(3,arete vide)=l'arete vide qui suit
2893 c n1artr : numero du premier triangle vide dans le tableau noartr
2894 c le chainage des triangles vides se fait sur noartr(2,.)
2895 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2896 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
2901 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
2902 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
2903 c larmin : tableau ( mxarcf ) auxiliaire d'entiers
2904 c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
2905 c liarcf : tableau ( mxarcf ) auxiliaire d'entiers
2909 c nbstsu : nombre de sommets de te supprimes
2910 c ierr : =0 si pas d'erreur
2911 c >0 si une erreur est survenue
2912 c 11 algorithme defaillant
2913 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2914 c auteur : alain perronnet analyse numerique paris upmc mars 1997
2915 c....................................................................012
2916 c parameter ( quamal=0.3 ) => ok
2917 c parameter ( quamal=0.4 ) => pb pour le test ocean
2918 c parameter ( quamal=0.5 ) => pb pour le test ocean
2920 parameter ( quamal=0.333, lchain=6 )
2921 common / unites / lecteu,imprim,intera,nunite(29)
2922 double precision pxyd(3,*), qualit
2923 integer nosoar(mosoar,mxsoar),
2933 equivalence (nosotr(1),ns1), (nosotr(2),ns2),
2936 c le nombre de sommets de te supprimes
2939 c initialisation du chainage des aretes des cf => 0 arete de cf
2940 do 10 narete=1,mxsoar
2941 nosoar( lchain, narete ) = -1
2944 c boucle sur l'ensemble des sommets frontaliers ou points internes
2945 c ================================================================
2946 do 100 ns = 1, nbarpi
2948 cccc le nombre de sommets supprimes pour ce sommet ns
2951 c la qualite minimale au dessous de laquelle le point proche
2952 c interne est supprime
2955 c une arete de sommet ns
2956 15 narete = noarst( ns )
2957 if( narete .le. 0 ) then
2958 c erreur: le point appartient a aucune arete
2959 write(imprim,*) 'sommet ',ns,' dans aucune arete'
2965 c recherche des triangles de sommet ns
2966 c ils doivent former un contour ferme de type etoile
2967 call trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
2968 % mxarcf, nbtrcf, notrcf )
2969 if( nbtrcf .le. 0 ) then
2970 c erreur: impossible de trouver tous les triangles de sommet ns
2971 c seule une partie est a priori retrouvee
2975 c boucle sur les triangles de l'etoile du sommet ns
2979 c le numero des 3 sommets du triangle nt
2981 call nusotr( nt, mosoar, nosoar, moartr, noartr,
2983 c nosotr(1:3) est en equivalence avec ns1, ns2, ns3
2985 c la qualite du triangle ns1 ns2 ns3
2986 call qutr2d( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), qualit )
2987 if( qualit .lt. quamin ) then
2993 c bilan sur la qualite des triangles de sommet ns
2994 if( quamin .lt. quaopt ) then
2996 c recherche du sommet de ntqmin le plus proche et non frontalier
2997 c ==============================================================
2998 c le numero des 3 sommets du triangle nt
2999 call nusotr( ntqmin, mosoar, nosoar, moartr, noartr,
3004 if( nosotr(j) .ne. ns .and. nosotr(j) .gt. nbarpi ) then
3005 d = (pxyd(1,nosotr(j))-pxyd(1,ns))**2
3006 % + (pxyd(2,nosotr(j))-pxyd(2,ns))**2
3007 if( d .lt. quamin ) then
3014 if( nste .gt. 0 ) then
3016 c nste est le sommet le plus proche de ns de ce
3017 c triangle de mauvaise qualite et sommet non encore traite
3018 nste = nosotr( nste )
3020 c nste est un sommet de triangle equilateral
3021 c => le sommet nste va etre supprime
3022 c ==========================================
3023 call te1stm( nste, pxyd, noarst,
3024 % mosoar, mxsoar, n1soar, nosoar,
3025 % moartr, mxartr, n1artr, noartr,
3026 % mxarcf, n1arcf, noarcf,
3027 % larmin, notrcf, liarcf, ierr )
3028 if( ierr .eq. 0 ) then
3029 c un sommet de te supprime de plus
3031 else if( ierr .lt. 0 ) then
3032 c le sommet nste est externe donc non supprime
3033 c ou bien le sommet nste est le centre d'un cf dont toutes
3034 c les aretes simples sont frontalieres
3035 c dans les 2 cas le sommet n'est pas supprime
3039 c erreur motivant un arret de la triangulation
3043 c boucle jusqu'a obtenir une qualite suffisante
3044 c si triangulation tres irreguliere =>
3045 c destruction de beaucoup de points internes
3046 c les 2 variables suivantes brident ces destructions massives
3047 ccc nbsuns = nbsuns + 1
3048 quaopt = quaopt * 0.8
3049 ccc if( nbsuns .le. 5 ) goto 15
3058 subroutine teamqa( nutysu,
3059 % noarst, mosoar, mxsoar, n1soar, nosoar,
3060 % moartr, mxartr, n1artr, noartr,
3061 % mxtrcf, notrcf, nostbo,
3062 % n1arcf, noarcf, larmin,
3063 % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
3065 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3066 c but: si la taille de l'arete moyenne est >ampli*taille souhaitee
3067 c ---- alors ajout d'un sommet barycentre du plus grand triangle
3069 c si la taille de l'arete moyenne est <ampli/2*taille souhaitee
3070 c alors suppression du sommet ns
3071 c sinon le sommet ns devient le barycentre pondere de ses voisins
3073 c remarque: ampli est defini dans $mefisto/mail/tehote.f
3074 c et doit avoir la meme valeur pour eviter trop de modifications
3078 c nutysu : numero de traitement de areteideale() selon le type de surface
3079 c 0 pas d'emploi de la fonction areteideale() => aretmx active
3080 c 1 il existe une fonction areteideale()
3081 c dont seules les 2 premieres composantes de uv sont actives
3082 c autres options a definir...
3083 c noarst : noarst(i) numero d'une arete de sommet i
3084 c mosoar : nombre maximal d'entiers par arete et
3085 c indice dans nosoar de l'arete suivante dans le hachage
3086 c mxsoar : nombre maximal d'aretes frontalieres declarables
3087 c n1soar : numero de la premiere arete vide dans le tableau nosoar
3088 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
3089 c chainage des aretes frontalieres, chainage du hachage des aretes
3090 c moartr : nombre maximal d'entiers par arete du tableau noartr
3091 c mxartr : nombre maximal de triangles declarables dans noartr
3092 c n1artr : numero du premier triangle vide dans le tableau noartr
3093 c le chainage des triangles vides se fait sur noartr(2,.)
3094 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
3095 c mxtrcf : nombre maximal de triangles empilables
3096 c nbarpi : numero du dernier sommet frontalier ou interne impose
3097 c nslign : tableau du numero de sommet dans sa ligne pour chaque
3099 c numero du point dans le lexique point si interne impose
3100 c 0 si le point est interne non impose par l'utilisateur
3101 c -1 si le sommet est externe au domaine
3102 c comxmi : min et max des coordonneees des sommets du maillage
3106 c nbsomm : nombre actuel de sommets de la triangulation
3107 c (certains sommets internes ont ete desactives ou ajoutes)
3108 c pxyd : tableau des coordonnees 2d des points
3112 c notrcf : tableau ( mxtrcf ) auxiliaire d'entiers
3113 c numero dans noartr des triangles de sommet ns
3114 c nostbo : tableau ( mxtrcf ) auxiliaire d'entiers
3115 c numero dans pxyd des sommets des aretes simples de la boule
3116 c n1arcf : tableau (0:mxtrcf) auxiliaire d'entiers
3117 c noarcf : tableau (3,mxtrcf) auxiliaire d'entiers
3118 c larmin : tableau ( mxtrcf ) auxiliaire d'entiers
3119 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3120 c auteur : alain perronnet analyse numerique paris upmc juin 1997
3121 c....................................................................012
3122 double precision ampli,ampli2
3123 parameter (ampli=1.34d0,ampli2=ampli/2d0)
3124 parameter (lchain=6)
3125 common / unites / lecteu, imprim, nunite(30)
3126 double precision pxyd(3,*)
3127 double precision ponder, ponde1, xbar, ybar, x, y, surtd2
3128 double precision d, dmoy
3129 double precision d2d3(3,3)
3130 real origin(3), xyz(3)
3131 integer noartr(moartr,*),
3140 double precision comxmi(3,2)
3143 c le nombre d'iterations pour ameliorer la qualite
3147 c initialisation du parcours
3152 do 5000 iter=1,nbitaq
3154 c le nombre de sommets supprimes
3158 c coefficient de ponderation croissant avec les iterations
3159 ponder = min( 1d0, ( 50 + (50*iter)/nbitaq ) * 0.01d0 )
3160 ponde1 = 1d0 - ponder
3162 c l'ordre du parcours dans le sens croissant ou decroissant
3166 c alternance du parcours
3169 do 1000 ns = nbs1, nbs2, nbs3
3171 c le sommet est il interne au domaine?
3172 if( nslign(ns) .ne. 0 ) goto 1000
3174 c existe-t-il une arete de sommet ns ?
3175 10 noar = noarst( ns )
3176 if( noar .le. 0 ) goto 1000
3178 c le 1-er triangle de l'arete noar
3179 nt = nosoar( 4, noar )
3180 if( nt .le. 0 ) goto 1000
3182 c recherche des triangles de sommet ns
3183 c ils doivent former un contour ferme de type etoile
3184 call trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
3185 % mxtrcf, nbtrcf, notrcf )
3186 if( nbtrcf .le. 0 ) goto 1000
3188 c mise a jour de la distance souhaitee
3189 if( nutysu .gt. 0 ) then
3190 c la fonction taille_ideale(x,y,z) existe
3191 c calcul de pxyzd(3,ns) dans le repere initial => xyz(1:3)
3192 call tetaid( nutysu, pxyd(1,ns), pxyd(2,ns),
3196 c boucle sur les triangles qui forment une boule autour du sommet ns
3198 c chainage des aretes simples de la boule a rendre delaunay
3202 c le numero de l'arete du triangle nt ne contenant pas le sommet ns
3205 c le numero de l'arete na dans le tableau nosoar
3206 noar = abs( noartr(na,nt) )
3207 if( nosoar(1,noar) .ne. ns .and.
3208 % nosoar(2,noar) .ne. ns ) goto 25
3211 c construction de la liste des sommets des aretes simples
3212 c de la boule des triangles de sommet ns
3213 c -------------------------------------------------------
3215 ns1 = nosoar(na,noar)
3217 if( ns1 .eq. nostbo(j) ) goto 35
3219 c ns1 est un nouveau sommet a ajouter
3221 nostbo(nbstbo) = ns1
3224 c noar est une arete potentielle a rendre delaunay
3225 if( nosoar(3,noar) .eq. 0 ) then
3226 c arete non frontaliere
3227 nosoar(lchain,noar) = noar0
3233 c calcul des 2 coordonnees du barycentre de la boule du sommet ns
3234 c calcul de la longueur moyenne des aretes issues du sommet ns
3235 c ---------------------------------------------------------------
3240 x = pxyd(1,nostbo(i))
3241 y = pxyd(2,nostbo(i))
3244 dmoy = dmoy + sqrt( (x-pxyd(1,ns))**2+(y-pxyd(2,ns))**2 )
3246 dmoy = dmoy / nbstbo
3248 c pas de modification de la topologie lors de la derniere iteration
3249 c =================================================================
3250 if( iter .eq. nbitaq ) goto 200
3252 c si la taille de l'arete moyenne est >ampli*taille souhaitee
3253 c alors ajout d'un sommet barycentre du plus grand triangle
3255 c ===========================================================
3256 if( dmoy .gt. ampli*pxyd(3,ns) ) then
3260 c recherche du plus grand triangle en surface
3261 call nusotr( notrcf(i), mosoar, nosoar,
3262 % moartr, noartr, nosotr )
3263 d = surtd2( pxyd(1,nosotr(1)),
3264 % pxyd(1,nosotr(2)),
3265 % pxyd(1,nosotr(3)) )
3266 if( d .gt. dmoy ) then
3272 c ajout du barycentre du triangle notrcf(imax)
3274 call nusotr( nt, mosoar, nosoar,
3275 % moartr, noartr, nosotr )
3276 if( nbsomm .ge. mxsomm ) then
3277 write(imprim,*) 'saturation du tableau pxyd'
3278 c abandon de l'amelioration du sommet ns
3283 pxyd(i,nbsomm) = ( pxyd(i,nosotr(1))
3284 % + pxyd(i,nosotr(2))
3285 % + pxyd(i,nosotr(3)) ) / 3d0
3288 if( nutysu .gt. 0 ) then
3289 c la fonction taille_ideale(x,y,z) existe
3290 c calcul de pxyzd(3,nbsomm) dans le repere initial => xyz(1:3)
3291 call tetaid( nutysu, pxyd(1,nbsomm), pxyd(2,nbsomm),
3292 % pxyd(3,nbsomm), ier )
3295 c sommet interne a la triangulation
3298 c les 3 aretes du triangle nt sont a rendre delaunay
3300 noar = abs( noartr(i,nt) )
3301 if( nosoar(3,noar) .eq. 0 ) then
3302 c arete non frontaliere
3303 if( nosoar(lchain,noar) .lt. 0 ) then
3304 c arete non encore chainee
3305 nosoar(lchain,noar) = noar0
3311 c triangulation du triangle de barycentre nbsomm
3312 c protection a ne pas modifier sinon erreur!
3313 call tr3str( nbsomm, nt,
3314 % mosoar, mxsoar, n1soar, nosoar,
3315 % moartr, mxartr, n1artr, noartr,
3318 if( ierr .ne. 0 ) goto 9999
3320 c un barycentre ajoute de plus
3323 c les aretes chainees de la boule sont rendues delaunay
3328 c si la taille de l'arete moyenne est <ampli/2*taille souhaitee
3329 c alors suppression du sommet ns
3330 c =============================================================
3331 if( dmoy .lt. ampli2*pxyd(3,ns) ) then
3332 c remise a -1 du chainage des aretes peripheriques de la boule ns
3334 90 if( noar .gt. 0 ) then
3335 c protection du no de l'arete suivante
3336 na = nosoar(lchain,noar)
3337 c l'arete interne est remise a -1
3338 nosoar(lchain,noar) = -1
3343 call te1stm( ns, pxyd, noarst,
3344 % mosoar, mxsoar, n1soar, nosoar,
3345 % moartr, mxartr, n1artr, noartr,
3346 % mxtrcf, n1arcf, noarcf,
3347 % larmin, notrcf, nostbo,
3349 if( ierr .lt. 0 ) then
3350 c le sommet ns est externe donc non supprime
3351 c ou bien le sommet ns est le centre d'un cf dont toutes
3352 c les aretes simples sont frontalieres
3353 c dans les 2 cas le sommet ns n'est pas supprime
3356 else if( ierr .gt. 0 ) then
3357 c erreur irrecuperable
3365 c les 2 coordonnees du barycentre des sommets des aretes
3366 c simples de la boule du sommet ns
3367 c ======================================================
3368 200 xbar = xbar / nbstbo
3369 ybar = ybar / nbstbo
3371 c ponderation pour eviter les degenerescenses
3372 pxyd(1,ns) = ponde1 * pxyd(1,ns) + ponder * xbar
3373 pxyd(2,ns) = ponde1 * pxyd(2,ns) + ponder * ybar
3375 if( nutysu .gt. 0 ) then
3376 c la fonction taille_ideale(x,y,z) existe
3377 c calcul de pxyzd(3,ns) dans le repere initial => xyz(1:3)
3378 call tetaid( nutysu, pxyd(1,ns), pxyd(2,ns),
3382 c les aretes chainees de la boule sont rendues delaunay
3383 900 call tedela( pxyd, noarst,
3384 % mosoar, mxsoar, n1soar, nosoar, noar0,
3385 % moartr, mxartr, n1artr, noartr, modifs )
3389 ccc write(imprim,11000) nbstsu, nbbaaj
3390 ccc11000 format( i6,' sommets supprimes ' ,
3391 ccc % i6,' barycentres ajoutes' )
3393 c mise a jour pour ne pas oublier les nouveaux sommets
3394 if( nbs1 .gt. nbs2 ) then
3406 subroutine teamsf( nutysu,
3407 % noarst, mosoar, mxsoar, n1soar, nosoar,
3408 % moartr, mxartr, n1artr, noartr,
3409 % mxtrcf, notrcf, nostbo,
3410 % n1arcf, noarcf, larmin,
3411 % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
3413 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3414 c but : modification de la topologie des triangles autour des
3415 c ----- sommets frontaliers et mise en triangulation delaunay locale
3419 c nutysu : numero de traitement de areteideale() selon le type de surface
3420 c 0 pas d'emploi de la fonction areteideale() => aretmx active
3421 c 1 il existe une fonction areteideale()
3422 c dont seules les 2 premieres composantes de uv sont actives
3423 c autres options a definir...
3424 c noarst : noarst(i) numero d'une arete de sommet i
3425 c mosoar : nombre maximal d'entiers par arete et
3426 c indice dans nosoar de l'arete suivante dans le hachage
3427 c mxsoar : nombre maximal d'aretes frontalieres declarables
3428 c n1soar : numero de la premiere arete vide dans le tableau nosoar
3429 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
3430 c chainage des aretes frontalieres, chainage du hachage des aretes
3431 c moartr : nombre maximal d'entiers par arete du tableau noartr
3432 c mxartr : nombre maximal de triangles declarables dans noartr
3433 c n1artr : numero du premier triangle vide dans le tableau noartr
3434 c le chainage des triangles vides se fait sur noartr(2,.)
3435 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
3436 c mxtrcf : nombre maximal de triangles empilables
3437 c nbarpi : numero du dernier sommet frontalier ou interne impose
3438 c nslign : >0 => ns numero du point dans le lexique point si interne impose
3439 c ou => 1 000 000 * n + ns1
3440 c ou n est le numero (1 a nblftr) de la ligne de ce point
3441 c ns1 est le numero du point dans sa ligne
3442 c = 0 si le point est interne non impose par l'utilisateur
3443 c =-1 si le sommet est externe au domaine
3444 c comxmi : min et max des coordonneees des sommets du maillage
3448 c nbsomm : nombre actuel de sommets de la triangulation
3449 c (certains sommets internes ont ete desactives ou ajoutes)
3450 c pxyd : tableau des coordonnees 2d des points
3454 c notrcf : tableau ( mxtrcf ) auxiliaire d'entiers
3455 c numero dans noartr des triangles de sommet ns
3456 c nostbo : tableau ( mxtrcf ) auxiliaire d'entiers
3457 c numero dans pxyd des sommets des aretes simples de la boule
3458 c n1arcf : tableau (0:mxtrcf) auxiliaire d'entiers
3459 c noarcf : tableau (3,mxtrcf) auxiliaire d'entiers
3460 c larmin : tableau ( mxtrcf ) auxiliaire d'entiers
3461 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3462 c auteur : alain perronnet analyse numerique paris upmc janvier 1998
3463 c....................................................................012
3464 parameter (lchain=6)
3465 common / unites / lecteu, imprim, nunite(30)
3466 double precision pxyd(3,*)
3467 double precision a, angle, angled, pi, deuxpi, pis3
3468 double precision d2d3(3,3)
3469 real origin(3), xyz(3)
3470 integer noartr(moartr,*),
3480 double precision comxmi(3,2)
3482 c le nombre d'iterations pour ameliorer la qualite
3487 pi = atan(1d0) * 4d0
3491 c initialisation du parcours
3495 c => pas de traitement sur les points des lignes de la frontiere
3498 do 5000 iter=1,nbitaq
3500 c le nombre de sommets supprimes
3503 c l'ordre du parcours dans le sens croissant ou decroissant
3507 c alternance du parcours
3510 do 1000 ns = nbs1, nbs2, nbs3
3512 c le sommet est il sur une ligne de la frontiere?
3513 c if( nslign(ns) .lt. 1 000 000 ) goto 1000
3515 c traitement d'un sommet d'une ligne de la frontiere
3516 c ==================================================
3517 c existe-t-il une arete de sommet ns ?
3519 if( noar .le. 0 ) goto 1000
3521 c le 1-er triangle de l'arete noar
3522 nt = nosoar( 4, noar )
3523 if( nt .le. 0 ) goto 1000
3525 c recherche des triangles de sommet ns
3526 c ils doivent former un contour ferme de type camembert
3527 call trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
3528 % mxtrcf, nbtrcf, notrcf )
3529 if( nbtrcf .ge. -1 ) goto 1000
3531 c boucle sur les triangles qui forment un camembert autour du sommet n
3534 c angle interne au camembert autour du sommet ns
3538 c le numero de l'arete du triangle nt ne contenant pas le sommet ns
3541 c le numero de l'arete na dans le tableau nosoar
3542 noar = abs( noartr(na,nt) )
3543 if( nosoar(1,noar) .ne. ns .and.
3544 % nosoar(2,noar) .ne. ns ) goto 525
3547 c calcul de l'angle (ns-st1 arete, ns-st2 arete)
3548 525 ns1 = nosoar(1,noar)
3549 ns2 = nosoar(2,noar)
3550 a = angled( pxyd(1,ns), pxyd(1,ns1), pxyd(1,ns2) )
3551 if( a .gt. pi ) a = deuxpi - a
3556 c nombre ideal de triangles autour du sommet ns
3557 n = nint( angle / pis3 )
3558 if( n .le. 1 ) goto 1000
3560 if( nbtrcf .gt. n ) then
3562 c ajout du barycentre du triangle "milieu"
3563 nt = notrcf( (n+1)/2 )
3564 call nusotr( nt, mosoar, nosoar,
3565 % moartr, noartr, nosotr )
3566 if( nbsomm .ge. mxsomm ) then
3567 write(imprim,*) 'saturation du tableau pxyd'
3568 c abandon de l'amelioration du sommet ns
3573 pxyd(i,nbsomm) = ( pxyd(i,nosotr(1))
3574 % + pxyd(i,nosotr(2))
3575 % + pxyd(i,nosotr(3)) ) / 3d0
3578 if( nutysu .gt. 0 ) then
3579 c la fonction taille_ideale(x,y,z) existe
3580 c calcul de pxyzd(3,nbsomm) dans le repere initial => xyz(1:3)
3581 call tetaid( nutysu, pxyd(1,nbsomm), pxyd(2,nbsomm),
3582 % pxyd(3,nbsomm), ier )
3585 c sommet interne a la triangulation
3588 c les 3 aretes du triangle nt sont a rendre delaunay
3591 noar = abs( noartr(i,nt) )
3592 if( nosoar(3,noar) .eq. 0 ) then
3593 c arete non frontaliere
3594 if( nosoar(lchain,noar) .lt. 0 ) then
3595 c arete non encore chainee
3596 nosoar(lchain,noar) = noar0
3602 c triangulation du triangle de barycentre nbsomm
3603 c protection a ne pas modifier sinon erreur!
3604 call tr3str( nbsomm, nt,
3605 % mosoar, mxsoar, n1soar, nosoar,
3606 % moartr, mxartr, n1artr, noartr,
3609 if( ierr .ne. 0 ) goto 9999
3611 c les aretes chainees de la boule sont rendues delaunay
3612 call tedela( pxyd, noarst,
3613 % mosoar, mxsoar, n1soar, nosoar, noar0,
3614 % moartr, mxartr, n1artr, noartr, modifs )
3625 subroutine teamqs( nutysu,
3626 % noarst, mosoar, mxsoar, n1soar, nosoar,
3627 % moartr, mxartr, n1artr, noartr,
3628 % mxtrcf, notrcf, nostbo,
3629 % n1arcf, noarcf, larmin,
3630 % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
3632 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3633 c but : une iteration de barycentrage des points internes
3634 c ----- modification de la topologie pour avoir 4 ou 5 ou 6 triangles
3635 c pour chaque sommet de la triangulation
3636 c mise en triangulation delaunay
3640 c nutysu : numero de traitement de areteideale() selon le type de surface
3641 c 0 pas d'emploi de la fonction areteideale() => aretmx active
3642 c 1 il existe une fonction areteideale()
3643 c dont seules les 2 premieres composantes de uv sont actives
3644 c autres options a definir...
3645 c noarst : noarst(i) numero d'une arete de sommet i
3646 c mosoar : nombre maximal d'entiers par arete et
3647 c indice dans nosoar de l'arete suivante dans le hachage
3648 c mxsoar : nombre maximal d'aretes frontalieres declarables
3649 c n1soar : numero de la premiere arete vide dans le tableau nosoar
3650 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
3651 c chainage des aretes frontalieres, chainage du hachage des aretes
3652 c moartr : nombre maximal d'entiers par arete du tableau noartr
3653 c mxartr : nombre maximal de triangles declarables dans noartr
3654 c n1artr : numero du premier triangle vide dans le tableau noartr
3655 c le chainage des triangles vides se fait sur noartr(2,.)
3656 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
3657 c mxtrcf : nombre maximal de triangles empilables
3658 c nbarpi : numero du dernier sommet frontalier ou interne impose
3659 c nslign : >0 => ns numero du point dans le lexique point si interne impose
3660 c ou => 1 000 000 * n + ns1
3661 c ou n est le numero (1 a nblftr) de la ligne de ce point
3662 c ns1 est le numero du point dans sa ligne
3663 c = 0 si le point est interne non impose par l'utilisateur
3664 c =-1 si le sommet est externe au domaine
3665 c comxmi : min et max des coordonneees des sommets du maillage
3669 c nbsomm : nombre actuel de sommets de la triangulation
3670 c (certains sommets internes ont ete desactives ou ajoutes)
3671 c pxyd : tableau des coordonnees 2d des points
3675 c notrcf : tableau ( mxtrcf ) auxiliaire d'entiers
3676 c numero dans noartr des triangles de sommet ns
3677 c nostbo : tableau ( mxtrcf ) auxiliaire d'entiers
3678 c numero dans pxyd des sommets des aretes simples de la boule
3679 c n1arcf : tableau (0:mxtrcf) auxiliaire d'entiers
3680 c noarcf : tableau (3,mxtrcf) auxiliaire d'entiers
3681 c larmin : tableau ( mxtrcf ) auxiliaire d'entiers
3682 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3683 c auteur : alain perronnet analyse numerique paris upmc mai 1997
3684 c....................................................................012
3685 parameter (lchain=6)
3686 common / unites / lecteu, imprim, nunite(30)
3687 double precision pxyd(3,*)
3688 double precision ponder, ponde1, xbar, ybar, x, y, d, dmin, dmax
3689 double precision d2d3(3,3)
3690 real origin(3), xyz(3)
3691 integer noartr(moartr,*),
3701 double precision comxmi(3,2)
3703 c le nombre d'iterations pour ameliorer la qualite
3707 c initialisation du parcours
3710 c => pas de traitement sur les points des lignes de la frontiere
3713 do 5000 iter=1,nbitaq
3715 c le nombre de sommets supprimes
3718 c les compteurs de passage sur les differents cas
3723 c coefficient de ponderation croissant avec les iterations
3724 ponder = min( 1d0, ( 50 + (50*iter)/nbitaq ) * 0.01d0 )
3725 ponde1 = 1d0 - ponder
3727 c l'ordre du parcours dans le sens croissant ou decroissant
3731 c alternance du parcours
3734 do 1000 ns = nbs1, nbs2, nbs3
3736 c le sommet est il interne au domaine?
3737 if( nslign(ns) .ne. 0 ) goto 1000
3739 c traitement d'un sommet interne non impose par l'utilisateur
3740 c ===========================================================
3741 c existe-t-il une arete de sommet ns ?
3742 10 noar = noarst( ns )
3743 if( noar .le. 0 ) goto 1000
3745 c le 1-er triangle de l'arete noar
3746 nt = nosoar( 4, noar )
3747 if( nt .le. 0 ) goto 1000
3749 c recherche des triangles de sommet ns
3750 c ils doivent former un contour ferme de type etoile
3751 call trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
3752 % mxtrcf, nbtrcf, notrcf )
3753 if( nbtrcf .le. 0 ) goto 1000
3755 c boucle sur les triangles qui forment une boule autour du sommet ns
3757 c chainage des aretes simples de la boule a rendre delaunay
3761 c le numero de l'arete du triangle nt ne contenant pas le sommet ns
3764 c le numero de l'arete na dans le tableau nosoar
3765 noar = abs( noartr(na,nt) )
3766 if( nosoar(1,noar) .ne. ns .and.
3767 % nosoar(2,noar) .ne. ns ) goto 25
3770 c construction de la liste des sommets des aretes simples
3771 c de la boule des triangles de sommet ns
3772 c -------------------------------------------------------
3774 ns1 = nosoar(na,noar)
3776 if( ns1 .eq. nostbo(j) ) goto 35
3778 c ns1 est un nouveau sommet a ajouter
3780 nostbo(nbstbo) = ns1
3783 c noar est une arete potentielle a rendre delaunay
3784 if( nosoar(3,noar) .eq. 0 ) then
3785 c arete non frontaliere
3786 nosoar(lchain,noar) = noar0
3792 c calcul des 2 coordonnees du barycentre de la boule du sommet ns
3793 c calcul de l'arete de taille maximale et minimale issue de ns
3794 c ---------------------------------------------------------------
3800 x = pxyd(1,nostbo(i))
3801 y = pxyd(2,nostbo(i))
3804 d = (x-pxyd(1,ns)) ** 2 + (y-pxyd(2,ns)) ** 2
3805 if( d .gt. dmax ) then
3809 if( d .lt. dmin ) then
3815 c pas de modification de la topologie lors de la derniere iteration
3816 c =================================================================
3817 if( iter .ge. nbitaq ) goto 200
3819 c si la boule de ns contient 3 ou 4 triangles le sommet ns est detruit
3820 c ====================================================================
3821 if( nbtrcf .le. 4 ) then
3823 c remise a -1 du chainage des aretes peripheriques de la boule ns
3825 60 if( noar .gt. 0 ) then
3826 c protection du no de l'arete suivante
3827 na = nosoar(lchain,noar)
3828 c l'arete interne est remise a -1
3829 nosoar(lchain,noar) = -1
3834 call te1stm( ns, pxyd, noarst,
3835 % mosoar, mxsoar, n1soar, nosoar,
3836 % moartr, mxartr, n1artr, noartr,
3837 % mxtrcf, n1arcf, noarcf,
3838 % larmin, notrcf, nostbo,
3840 if( ierr .lt. 0 ) then
3841 c le sommet ns est externe donc non supprime
3842 c ou bien le sommet ns est le centre d'un cf dont toutes
3843 c les aretes simples sont frontalieres
3844 c dans les 2 cas le sommet ns n'est pas supprime
3847 else if( ierr .eq. 0 ) then
3851 c erreur irrecuperable
3858 c si la boule de ns contient 5 triangles et a un sommet voisin
3859 c sommet de 5 triangles alors l'arete joignant ces 2 sommets
3860 c est transformee en un seul sommet de 6 triangles
3861 c ============================================================
3862 if( nbtrcf .eq. 5 ) then
3865 c le numero du sommet de l'arete i et different de ns
3867 c la liste des triangles de sommet ns1
3868 call trp1st( ns1, noarst,
3869 % mosoar, nosoar, moartr, noartr,
3870 % mxtrcf-5, nbtrc1, notrcf(6) )
3871 if( nbtrc1 .eq. 5 ) then
3873 c l'arete de sommets ns-ns1 devient un point
3874 c par suppression du sommet ns
3876 c remise a -1 du chainage des aretes peripheriques de la boul
3878 70 if( noar .gt. 0 ) then
3879 c protection du no de l'arete suivante
3880 na = nosoar(lchain,noar)
3881 c l'arete interne est remise a -1
3882 nosoar(lchain,noar) = -1
3888 c le point ns1 devient le milieu de l'arete ns-ns1
3890 pxyd(j,ns1) = (pxyd(j,ns) + pxyd(j,ns1)) * 0.5d0
3893 if( nutysu .gt. 0 ) then
3894 c la fonction taille_ideale(x,y,z) existe
3895 c calcul de pxyzd(3,ns1) dans le repere initial => xyz(1:3
3896 call tetaid( nutysu,pxyd(1,ns1),pxyd(2,ns1),
3897 % pxyd(3,ns1), ier )
3900 c suppression du point ns et mise en delaunay
3901 call te1stm( ns, pxyd, noarst,
3902 % mosoar, mxsoar, n1soar, nosoar,
3903 % moartr, mxartr, n1artr, noartr,
3904 % mxtrcf, n1arcf, noarcf,
3905 % larmin, notrcf, nostbo,
3907 if( ierr .lt. 0 ) then
3908 c le sommet ns est externe donc non supprime
3909 c ou bien le sommet ns est le centre d'un cf dont toutes
3910 c les aretes simples sont frontalieres
3911 c dans les 2 cas le sommet ns n'est pas supprime
3914 else if( ierr .eq. 0 ) then
3919 c erreur irrecuperable
3926 c si la boule de ns contient au moins 8 triangles
3927 c alors un triangle interne est ajoute + 3 triangles (1 par arete)
3928 c ================================================================
3929 if( nbtrcf .ge. 8 ) then
3931 c modification des coordonnees du sommet ns
3932 c il devient le barycentre du triangle notrcf(1)
3933 call nusotr( notrcf(1), mosoar, nosoar,
3934 % moartr, noartr, nosotr )
3936 pxyd(i,ns) = ( pxyd(i,nosotr(1,1))
3937 % + pxyd(i,nosotr(2,1))
3938 % + pxyd(i,nosotr(3,1)) ) / 3d0
3941 if( nutysu .gt. 0 ) then
3942 c la fonction taille_ideale(x,y,z) existe
3943 c calcul de pxyzd(3,nbsomm) dans le repere initial => xyz(1:3)
3944 call tetaid( nutysu, pxyd(1,ns), pxyd(2,ns),
3948 c ajout des 2 autres sommets comme barycentres des triangles
3949 c notrcf(1+nbtrcf/3) et notrcf(1+2*nbtrcf/3)
3950 nbt1 = ( nbtrcf + 1 ) / 3
3953 c le triangle traite
3954 nt = notrcf(1 + n * nbt1 )
3956 c le numero pxyd de ses 3 sommets
3957 call nusotr( nt, mosoar, nosoar,
3958 % moartr, noartr, nosotr )
3960 c ajout du nouveau barycentre
3961 if( nbsomm .ge. mxsomm ) then
3962 write(imprim,*) 'saturation du tableau pxyd'
3963 c abandon de l'amelioration
3968 pxyd(i,nbsomm) = ( pxyd(i,nosotr(1,1))
3969 % + pxyd(i,nosotr(2,1))
3970 % + pxyd(i,nosotr(3,1)) ) / 3d0
3973 if( nutysu .gt. 0 ) then
3974 c la fonction taille_ideale(x,y,z) existe
3975 c calcul de pxyzd(3,nbsomm) dans le repere initial => xyz(1:3
3976 call tetaid( nutysu, pxyd(1,nbsomm),pxyd(2,nbsomm),
3977 % pxyd(3,nbsomm), ier )
3980 c sommet interne a la triangulation
3983 c les 3 aretes du triangle nt sont a rendre delaunay
3985 noar = abs( noartr(i,nt) )
3986 if( nosoar(3,noar) .eq. 0 ) then
3987 c arete non frontaliere
3988 if( nosoar(lchain,noar) .lt. 0 ) then
3989 c arete non encore chainee
3990 nosoar(lchain,noar) = noar0
3996 c triangulation du triangle de barycentre nbsomm
3997 c protection a ne pas modifier sinon erreur!
3998 call tr3str( nbsomm, nt,
3999 % mosoar, mxsoar, n1soar, nosoar,
4000 % moartr, mxartr, n1artr, noartr,
4003 if( ierr .ne. 0 ) goto 9999
4008 c les aretes chainees de la boule sont rendues delaunay
4013 c nbtrcf est compris entre 5 et 7 => barycentrage simple
4014 c ======================================================
4015 c les 2 coordonnees du barycentre des sommets des aretes
4016 c simples de la boule du sommet ns
4017 200 xbar = xbar / nbstbo
4018 ybar = ybar / nbstbo
4020 c ponderation pour eviter les degenerescenses
4021 pxyd(1,ns) = ponde1 * pxyd(1,ns) + ponder * xbar
4022 pxyd(2,ns) = ponde1 * pxyd(2,ns) + ponder * ybar
4024 c les aretes chainees de la boule sont rendues delaunay
4025 300 call tedela( pxyd, noarst,
4026 % mosoar, mxsoar, n1soar, nosoar, noar0,
4027 % moartr, mxartr, n1artr, noartr, modifs )
4031 c trace de la triangulation actuelle et calcul de la qualite
4034 ccc write(imprim,11000) nbst4, nbst5, nbst8
4035 ccc11000 format( i7,' sommets de 4t',
4036 ccc % i7,' sommets 5t+5t',
4037 ccc % i7,' sommets >7t' )
4039 c mise a jour pour ne pas oublier les nouveaux sommets
4040 if( nbs1 .gt. nbs2 ) then
4054 subroutine teamqt( nutysu,
4055 % noarst, mosoar, mxsoar, n1soar, nosoar,
4056 % moartr, mxartr, n1artr, noartr,
4057 % mxarcf, notrcf, nostbo,
4058 % n1arcf, noarcf, larmin,
4059 % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
4061 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4062 c but : amelioration de la qualite de la triangulation issue de teabr4
4067 c nutysu : numero de traitement de areteideale() selon le type de surface
4068 c 0 pas d'emploi de la fonction areteideale() => aretmx active
4069 c 1 il existe une fonction areteideale()
4070 c dont seules les 2 premieres composantes de uv sont actives
4071 c autres options a definir...
4072 c noarst : noarst(i) numero d'une arete de sommet i
4073 c mosoar : nombre maximal d'entiers par arete et
4074 c indice dans nosoar de l'arete suivante dans le hachage
4075 c mxsoar : nombre maximal d'aretes frontalieres declarables
4076 c n1soar : numero de la premiere arete vide dans le tableau nosoar
4077 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4078 c chainage des aretes frontalieres, chainage du hachage des aretes
4079 c moartr : nombre maximal d'entiers par arete du tableau noartr
4080 c mxartr : nombre maximal de triangles declarables dans noartr
4081 c n1artr : numero du premier triangle vide dans le tableau noartr
4082 c le chainage des triangles vides se fait sur noartr(2,.)
4083 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4084 c mxarcf : nombre maximal de triangles empilables
4085 c nbarpi : numero du dernier sommet frontalier ou interne impose
4086 c nslign : tableau du numero de sommet dans sa ligne pour chaque
4088 c numero du point dans le lexique point si interne impose
4089 c 0 si le point est interne non impose par l'utilisateur
4090 c -1 si le sommet est externe au domaine
4091 c comxmi : min et max des coordonneees des sommets du maillage
4095 c nbsomm : nombre actuel de sommets de la triangulation
4096 c (certains sommets internes ont ete desactives ou ajoutes)
4097 c pxyd : tableau des coordonnees 2d des points
4101 c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
4102 c numero dans noartr des triangles de sommet ns
4103 c nostbo : tableau ( mxarcf ) auxiliaire d'entiers
4104 c numero dans pxyd des sommets des aretes simples de la boule
4105 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
4106 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
4107 c larmin : tableau ( mxarcf ) auxiliaire d'entiers
4108 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4109 c auteur : alain perronnet analyse numerique paris upmc juin 1997
4110 c....................................................................012
4111 common / unites / lecteu, imprim, nunite(30)
4112 double precision pxyd(3,*), d2d3(3,3)
4113 integer noartr(moartr,*),
4122 double precision comxmi(3,2)
4124 c suppression des sommets de triangles equilateraux trop proches
4125 c d'un sommet frontalier ou d'un point interne impose par
4126 c triangulation frontale de l'etoile et mise en delaunay
4127 c ==============================================================
4128 call tesusp( nbarpi, pxyd, noarst,
4129 % mosoar, mxsoar, n1soar, nosoar,
4130 % moartr, mxartr, n1artr, noartr,
4131 % mxarcf, n1arcf, noarcf, larmin, notrcf, nostbo,
4133 if( ierr .ne. 0 ) goto 9999
4134 c write(imprim,*) 'retrait de',nbstsu,
4135 c % ' sommets de te trop proches de la frontiere'
4137 c ajustage des tailles moyennes des aretes avec ampli=1.34d0 entre
4138 c ampli/2 x taille_souhaitee et ampli x taille_souhaitee
4139 c + barycentrage des sommets et mise en triangulation delaunay
4140 c ================================================================
4141 call teamqa( nutysu,
4142 % noarst, mosoar, mxsoar, n1soar, nosoar,
4143 % moartr, mxartr, n1artr, noartr,
4144 % mxarcf, notrcf, nostbo,
4145 % n1arcf, noarcf, larmin,
4146 % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
4148 if( ierr .ne. 0 ) goto 9999
4150 c modification de la topologie autour des sommets frontaliers
4151 c pour avoir un nombre de triangles egal a l'angle/60 degres
4152 c et mise en triangulation delaunay locale
4153 c ===========================================================
4154 call teamsf( nutysu,
4155 % noarst, mosoar, mxsoar, n1soar, nosoar,
4156 % moartr, mxartr, n1artr, noartr,
4157 % mxarcf, notrcf, nostbo,
4158 % n1arcf, noarcf, larmin,
4159 % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
4161 if( ierr .ne. 0 ) goto 9999
4163 c quelques iterations de barycentrage des points internes
4164 c modification de la topologie pour avoir 4 ou 5 ou 6 triangles
4165 c pour chaque sommet de la triangulation
4166 c et mise en triangulation delaunay
4167 c =============================================================
4168 call teamqs( nutysu,
4169 % noarst, mosoar, mxsoar, n1soar, nosoar,
4170 % moartr, mxartr, n1artr, noartr,
4171 % mxarcf, notrcf, nostbo,
4172 % n1arcf, noarcf, larmin,
4173 % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
4179 subroutine trfrcf( nscent, mosoar, nosoar, moartr, noartr,
4180 % nbtrcf, notrcf, nbarfr )
4181 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4182 c but : calculer le nombre d'aretes simples du contour ferme des
4183 c ----- nbtrcf triangles de numeros stockes dans le tableau notrcf
4184 c ayant tous le sommet nscent
4188 c nscent : numero du sommet appartenant a tous les triangles notrcf
4189 c mosoar : nombre maximal d'entiers par arete et
4190 c indice dans nosoar de l'arete suivante dans le hachage
4191 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4192 c chainage des aretes frontalieres, chainage du hachage des aretes
4193 c moartr : nombre maximal d'entiers par arete du tableau noartr
4194 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4195 c nbtrcf : >0 nombre de triangles empiles
4196 c =0 si impossible de tourner autour du point
4197 c =-nbtrcf si apres butee sur la frontiere il y a a nouveau
4198 c butee sur la frontiere . a ce stade on ne peut dire si tous
4199 c les triangles ayant ce sommet ont ete recenses
4200 c ce cas arrive seulement si le sommet est sur la frontiere
4201 c notrcf : numero dans noartr des triangles de sommet ns
4205 c nbarfr : nombre d'aretes simples frontalieres
4206 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4207 c auteur : alain perronnet analyse numerique paris upmc juin 1997
4208 c....................................................................012
4209 integer noartr(moartr,*),
4215 c le numero du triangle n dans le tableau noartr
4217 c parcours des 3 aretes du triangle nt
4219 c le numero de l'arete i dans le tableau nosoar
4220 noar = abs( noartr( i, nt ) )
4222 c le numero du sommet j de l'arete noar
4223 ns = nosoar( j, noar )
4224 if( ns .eq. nscent ) goto 40
4226 c l'arete noar (sans sommet nscent) est elle frontaliere?
4227 if( nosoar( 5, noar ) .le. 0 ) then
4228 c l'arete appartient au plus a un triangle
4229 c une arete simple frontaliere de plus
4232 c le triangle a au plus une arete sans sommet nscent
4238 subroutine int2ar( p1, p2, p3, p4, oui )
4239 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4240 c but : les 2 aretes de r**2 p1-p2 p3-p4 s'intersectent elles
4241 c ----- entre leurs sommets?
4245 c p1,p2,p3,p4 : les 2 coordonnees reelles des sommets des 2 aretes
4249 c oui : .true. si intersection, .false. sinon
4250 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4251 c auteur : alain perronnet analyse numerique paris upmc octobre 1991
4252 c2345x7..............................................................012
4253 double precision p1(2),p2(2),p3(2),p4(2)
4254 double precision x21,y21,d21,x43,y43,d43,d,x,y,xx
4257 c longueur des aretes
4260 d21 = x21**2 + y21**2
4264 d43 = x43**2 + y43**2
4266 c les 2 aretes sont-elles jugees paralleles ?
4267 d = x43 * y21 - y43 * x21
4268 if( abs(d) .le. 0.001 * sqrt(d21 * d43) ) then
4269 c aretes paralleles . pas d'intersection
4274 c les 2 coordonnees du point d'intersection
4275 x = ( p1(1)*x43*y21 - p3(1)*x21*y43 - (p1(2)-p3(2))*x21*x43 ) / d
4276 y =-( p1(2)*y43*x21 - p3(2)*y21*x43 - (p1(1)-p3(1))*y21*y43 ) / d
4278 c coordonnees de x,y dans le repere ns1-ns2
4279 xx = ( x - p1(1) ) * x21 + ( y - p1(2) ) * y21
4280 c le point est il entre p1 et p2 ?
4281 oui = -0.00001d0*d21 .le. xx .and. xx .le. 1.00001d0*d21
4283 c coordonnees de x,y dans le repere ns3-ns4
4284 xx = ( x - p3(1) ) * x43 + ( y - p3(2) ) * y43
4285 c le point est il entre p3 et p4 ?
4286 oui = oui .and. -0.00001d0*d43 .le. xx .and. xx .le. 1.00001d0*d43
4290 subroutine trchtd( pxyd, nar00, nar0, noarcf,
4291 % namin0, namin, larmin )
4292 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4293 c but : recherche dans le contour ferme du sommet qui joint a la plus
4294 c ----- courte arete nar00 donne le triangle sans intersection
4295 c avec le contour ferme de meilleure qualite
4299 c pxyd : tableau des coordonnees des sommets et distance_souhaitee
4301 c entrees et sorties:
4302 c -------------------
4303 c nar00 : numero dans noarcf de l'arete avant nar0
4304 c nar0 : numero dans noarcf de la plus petite arete du contour ferme
4305 c a joindre a noarcf(1,namin) pour former le triangle ideal
4306 c noarcf : numero du sommet , numero de l'arete suivante
4307 c numero du triangle exterieur a l'etoile
4311 c namin0 : numero dans noarcf de l'arete avant namin
4312 c namin : numero dans noarcf du sommet choisi
4313 c 0 si contour ferme reduit a moins de 3 aretes
4314 c larmin : tableau auxiliaire pour stocker la liste des numeros des
4315 c aretes de meilleure qualite pour faire le choix final
4316 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4317 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
4318 c2345x7..............................................................012
4319 double precision dmaxim, precision
4320 parameter (dmaxim=1.7d+308, precision=1d-16)
4321 c ATTENTION:variables a ajuster selon la machine!
4322 c ATTENTION:dmaxim : le plus grand reel machine
4323 c ATTENTION:sur dec-alpha la precision est de 10**-14 seulement
4325 common / unites / lecteu,imprim,nunite(30)
4326 double precision pxyd(1:3,1:*)
4327 integer noarcf(1:3,1:*),
4329 double precision q, dd, dmima,
4330 % unpeps, rayon, surtd2
4332 double precision centre(3)
4335 c dmaxim : le plus grand reel machine
4336 unpeps = 1d0 + 100d0 * precision
4338 c recherche de la plus courte arete du contour ferme
4344 2 na0 = noarcf( 2, na00 )
4345 na1 = noarcf( 2, na0 )
4347 c les 2 sommets de l'arete na0 du cf
4348 ns1 = noarcf( 1, na0 )
4349 ns2 = noarcf( 1, na1 )
4350 dd = (pxyd(1,ns2)-pxyd(1,ns1))**2 + (pxyd(2,ns2)-pxyd(2,ns1))**2
4351 if( dd .lt. dmima ) then
4356 if( na00 .ne. nar00 ) then
4357 c derniere arete non atteinte
4361 if( nbar .eq. 3 ) then
4363 c contour ferme reduit a un triangle
4364 c ----------------------------------
4366 nar0 = noarcf( 2, nar00 )
4367 namin0 = noarcf( 2, nar0 )
4370 else if( nbar .le. 2 ) then
4371 write(imprim,*) 'erreur trchtd: cf<3 aretes'
4378 c cf non reduit a un triangle
4379 c la plus petite arete est nar0 dans noarcf
4381 nar0 = noarcf( 2, nar00 )
4382 nar = noarcf( 2, nar0 )
4384 ns1 = noarcf( 1, nar0 )
4385 ns2 = noarcf( 1, nar )
4387 c recherche dans cette etoile du sommet offrant la meilleure qualite
4388 c du triangle ns1-ns2 ns3 sans intersection avec le contour ferme
4389 c ==================================================================
4393 c parcours des sommets possibles ns3
4394 10 nar3 = noarcf( 2, nar3 )
4395 if( nar3 .ne. nar0 ) then
4397 c il existe un sommet ns3 different de ns1 et ns2
4398 ns3 = noarcf( 1, nar3 )
4400 c les aretes ns1-ns3 et ns2-ns3 intersectent-elles une arete
4401 c du contour ferme ?
4402 c ----------------------------------------------------------
4403 c intersection de l'arete ns2-ns3 et des aretes du cf
4404 c jusqu'au sommet ns3
4405 nar1 = noarcf( 2, nar )
4407 15 if( nar1 .ne. nar3 .and. noarcf( 2, nar1 ) .ne. nar3 ) then
4409 nar2 = noarcf( 2, nar1 )
4410 c le numero des 2 sommets de l'arete
4411 np1 = noarcf( 1, nar1 )
4412 np2 = noarcf( 1, nar2 )
4413 call int2ar( pxyd(1,ns2), pxyd(1,ns3),
4414 % pxyd(1,np1), pxyd(1,np2), oui )
4416 c les 2 aretes ne s'intersectent pas entre leurs sommets
4421 c intersection de l'arete ns3-ns1 et des aretes du cf
4422 c jusqu'au sommet de l'arete nar0
4423 nar1 = noarcf( 2, nar3 )
4425 18 if( nar1 .ne. nar0 .and. noarcf( 2, nar1 ) .ne. nar0 ) then
4427 nar2 = noarcf( 2, nar1 )
4428 c le numero des 2 sommets de l'arete
4429 np1 = noarcf( 1, nar1 )
4430 np2 = noarcf( 1, nar2 )
4431 call int2ar( pxyd(1,ns1), pxyd(1,ns3),
4432 % pxyd(1,np1), pxyd(1,np2), oui )
4434 c les 2 aretes ne s'intersectent pas entre leurs sommets
4439 c le triangle ns1-ns2-ns3 n'intersecte pas une arete du contour ferme
4440 c le calcul de la surface du triangle
4441 dd = surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
4442 if( dd .le. 0d0 ) then
4443 c surface negative => triangle a rejeter
4446 c calcul de la qualite du triangle ns1-ns2-ns3
4447 call qutr2d( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), q )
4450 if( q .ge. qmima*1.00001 ) then
4451 c q est un vrai maximum de la qualite
4455 else if( q .ge. qmima*0.999998 ) then
4456 c q est voisin de qmima
4459 larmin( nbmin ) = nar3
4464 c bilan : existe t il plusieurs sommets de meme qualite?
4465 c ======================================================
4466 if( nbmin .gt. 1 ) then
4468 c oui:recherche de ceux de cercle ne contenant pas d'autres sommets
4472 if( nar .le. 0 ) goto 80
4474 c les coordonnees du centre du cercle circonscrit
4477 call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3),
4479 if( ier .ne. 0 ) then
4480 c le sommet ns3 ne convient pas
4484 rayon = centre(3) * unpeps
4489 if( nar1 .le. 0 ) goto 70
4490 ns4 = noarcf(1,nar1)
4491 c appartient t il au cercle ns1 ns2 ns3 ?
4492 dd = (centre(1)-pxyd(1,ns4))**2 +
4493 % (centre(2)-pxyd(2,ns4))**2
4494 if( dd .le. rayon ) then
4495 c ns4 est dans le cercle circonscrit ns1 ns2 ns3
4496 c le sommet ns3 ne convient pas
4504 c existe t il plusieurs sommets ?
4507 if( larmin( i ) .gt. 0 ) then
4508 c compactage des min
4510 larmin(j) = larmin(i)
4515 c oui : choix du plus petit rayon de cercle circonscrit
4518 ns3 = noarcf(1,larmin(i))
4520 c les coordonnees du centre de cercle circonscrit
4521 c au triangle nt et son rayon
4523 call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3),
4525 if( ier .ne. 0 ) then
4526 c le sommet ns3 ne convient pas
4529 rayon = sqrt( centre(3) )
4530 if( rayon .lt. dmima ) then
4532 larmin(1) = larmin(i)
4542 c recherche de l'arete avant namin ( nar0 <> namin )
4543 c ==================================================
4545 200 if( nar1 .ne. namin ) then
4547 nar1 = noarcf( 2, nar1 )
4552 subroutine trcf0a( nbcf, na01, na1, na2, na3,
4553 % noar1, noar2, noar3,
4554 % mosoar, mxsoar, n1soar, nosoar,
4555 % moartr, n1artr, noartr, noarst,
4556 % mxarcf, n1arcf, noarcf, nt )
4557 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4558 c but : modification de la triangulation du contour ferme nbcf
4559 c ----- par ajout d'un triangle ayant 0 arete sur le contour
4560 c creation des 3 aretes dans le tableau nosoar
4561 c modification du contour par ajout de la 3-eme arete
4562 c creation d'un contour ferme a partir de la seconde arete
4566 c nbcf : numero dans n1arcf du cf traite ici
4567 c na01 : numero noarcf de l'arete precedent l'arete na1 de noarcf
4568 c na1 : numero noarcf du 1-er sommet du triangle
4569 c implicitement l'arete na1 n'est pas une arete du triangle
4570 c na2 : numero noarcf du 2-eme sommet du triangle
4571 c implicitement l'arete na1 n'est pas une arete du triangle
4572 c na3 : numero noarcf du 3-eme sommet du triangle
4573 c implicitement l'arete na1 n'est pas une arete du triangle
4575 c mosoar : nombre maximal d'entiers par arete et
4576 c indice dans nosoar de l'arete suivante dans le hachage
4577 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
4578 c attention: mxsoar>3*mxsomm obligatoire!
4579 c moartr : nombre maximal d'entiers par arete du tableau noartr
4581 c entrees et sorties :
4582 c --------------------
4583 c n1soar : numero de la premiere arete vide dans le tableau nosoar
4584 c une arete i de nosoar est vide <=> nosoar(1,i)=0
4585 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4586 c chainage des aretes frontalieres, chainage du hachage des aretes
4587 c hachage des aretes = nosoar(1)+nosoar(2)*2
4588 c n1artr : numero du premier triangle vide dans le tableau noartr
4589 c le chainage des triangles vides se fait sur noartr(2,.)
4590 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4591 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
4593 c noarst : noarst(i) numero d'une arete de sommet i
4594 c n1arcf : numero d'une arete de chaque contour
4595 c noarcf : numero des aretes de la ligne du contour ferme
4596 c attention : chainage circulaire des aretes
4600 c noar1 : numero dans le tableau nosoar de l'arete 1 du triangle
4601 c noar2 : numero dans le tableau nosoar de l'arete 2 du triangle
4602 c noar3 : numero dans le tableau nosoar de l'arete 3 du triangle
4603 c nt : numero du triangle ajoute dans noartr
4604 c 0 si saturation du tableau noartr ou noarcf ou n1arcf
4605 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4606 c auteur : alain perronnet analyse numerique paris upmc mars 1997
4607 c2345x7..............................................................012
4608 common / unites / lecteu, imprim, nunite(30)
4609 integer nosoar(mosoar,*),
4617 c 2 contours fermes peuvent ils etre ajoutes ?
4618 if( nbcf+2 .gt. mxarcf ) goto 9100
4620 c creation des 3 aretes du triangle dans le tableau nosoar
4621 c ========================================================
4622 c la formation de l'arete sommet1-sommet2 dans le tableau nosoar
4623 call fasoar( noarcf(1,na1), noarcf(1,na2), -1, -1, 0,
4624 % mosoar, mxsoar, n1soar, nosoar, noarst,
4626 if( ierr .ne. 0 ) goto 9900
4628 c la formation de l'arete sommet2-sommet3 dans le tableau nosoar
4629 call fasoar( noarcf(1,na2), noarcf(1,na3), -1, -1, 0,
4630 % mosoar, mxsoar, n1soar, nosoar, noarst,
4632 if( ierr .ne. 0 ) goto 9900
4634 c la formation de l'arete sommet3-sommet1 dans le tableau nosoar
4635 call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1, 0,
4636 % mosoar, mxsoar, n1soar, nosoar, noarst,
4638 if( ierr .ne. 0 ) goto 9900
4640 c ajout dans noartr de ce triangle nt
4641 c ===================================
4642 call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
4643 % noar1, noar2, noar3,
4645 % moartr, n1artr, noartr,
4647 if( nt .le. 0 ) return
4649 c modification du contour nbcf existant
4650 c chainage de l'arete na2 vers l'arete na1
4651 c ========================================
4652 c modification du cf en pointant na2 sur na1
4653 na2s = noarcf( 2, na2 )
4654 noarcf( 2, na2 ) = na1
4655 c le numero de l'arete dans le tableau nosoar
4656 noar2s = noarcf( 3, na2 )
4657 c le numero de l'arete dans le tableau nosoar
4658 noarcf( 3, na2 ) = noar1
4660 n1arcf( nbcf ) = na2
4662 c creation d'un nouveau contour ferme na2 - na3
4663 c =============================================
4665 c recherche d'une arete de cf vide
4667 if( nav .le. 0 ) goto 9100
4668 c la 1-ere arete vide est mise a jour
4669 n1arcf(0) = noarcf( 2, nav )
4671 c ajout de l'arete nav pointant sur na2s
4672 c le numero du sommet
4673 noarcf( 1, nav ) = noarcf( 1, na2 )
4675 noarcf( 2, nav ) = na2s
4676 c le numero nosoar de cette arete
4677 noarcf( 3, nav ) = noar2s
4679 c l'arete na3 se referme sur nav
4680 na3s = noarcf( 2, na3 )
4681 noarcf( 2, na3 ) = nav
4682 c le numero de l'arete dans le tableau nosoar
4683 noar3s = noarcf( 3, na3 )
4684 noarcf( 3, na3 ) = noar2
4686 n1arcf( nbcf ) = na3
4688 c creation d'un nouveau contour ferme na3 - na1
4689 c =============================================
4691 c recherche d'une arete de cf vide
4693 if( nav .le. 0 ) goto 9100
4694 c la 1-ere arete vide est mise a jour
4695 n1arcf(0) = noarcf( 2, nav )
4697 c ajout de l'arete nav pointant sur na3s
4698 c le numero du sommet
4699 noarcf( 1, nav ) = noarcf( 1, na3 )
4701 noarcf( 2, nav ) = na3s
4702 c le numero de l'arete dans le tableau nosoar
4703 noarcf( 3, nav ) = noar3s
4705 c recherche d'une arete de cf vide
4707 if( nav1 .le. 0 ) goto 9100
4708 c la 1-ere arete vide est mise a jour
4709 n1arcf(0) = noarcf( 2, nav1 )
4711 c l'arete precedente na01 de na1 pointe sur la nouvelle nav1
4712 noarcf( 2, na01 ) = nav1
4714 c ajout de l'arete nav1 pointant sur nav
4715 c le numero du sommet
4716 noarcf( 1, nav1 ) = noarcf( 1, na1 )
4718 noarcf( 2, nav1 ) = nav
4719 c le numero de l'arete dans le tableau nosoar
4720 noarcf( 3, nav1 ) = noar3
4723 n1arcf( nbcf ) = nav1
4727 9100 write(imprim,*) 'saturation du tableau mxarcf'
4731 c erreur tableau nosoar sature
4732 9900 write(imprim,*) 'saturation du tableau nosoar'
4738 subroutine trcf1a( nbcf, na01, na1, na2, noar1, noar3,
4739 % mosoar, mxsoar, n1soar, nosoar,
4740 % moartr, n1artr, noartr, noarst,
4741 % mxarcf, n1arcf, noarcf, nt )
4742 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4743 c but : modification de la triangulation du contour ferme nbcf
4744 c ----- par ajout d'un triangle ayant 1 arete sur le contour
4745 c modification du contour par ajout de la 3-eme arete
4746 c creation d'un contour ferme a partir de la seconde arete
4750 c nbcf : numero dans n1arcf du cf traite ici
4751 c na01 : numero noarcf de l'arete precedant l'arete na1 de noarcf
4752 c na1 : numero noarcf du 1-er sommet du triangle
4753 c implicitement l'arete na1 n'est pas une arete du triangle
4754 c na2 : numero noarcf du 2-eme sommet du triangle
4755 c cette arete est l'arete 2 du triangle a ajouter
4756 c son arete suivante dans noarcf n'est pas sur le contour
4757 c mosoar : nombre maximal d'entiers par arete et
4758 c indice dans nosoar de l'arete suivante dans le hachage
4759 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
4760 c attention: mxsoar>3*mxsomm obligatoire!
4761 c moartr : nombre maximal d'entiers par arete du tableau noartr
4763 c entrees et sorties :
4764 c --------------------
4765 c n1soar : numero de la premiere arete vide dans le tableau nosoar
4766 c une arete i de nosoar est vide <=> nosoar(1,i)=0
4767 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4768 c chainage des aretes frontalieres, chainage du hachage des aretes
4769 c hachage des aretes = nosoar(1)+nosoar(2)*2
4770 c n1artr : numero du premier triangle vide dans le tableau noartr
4771 c le chainage des triangles vides se fait sur noartr(2,.)
4772 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4773 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
4775 c noarst : noarst(i) numero d'une arete de sommet i
4776 c n1arcf : numero d'une arete de chaque contour
4777 c noarcf : numero des aretes de la ligne du contour ferme
4778 c attention : chainage circulaire des aretes
4782 c noar1 : numero nosoar de l'arete 1 du triangle cree
4783 c noar3 : numero nosoar de l'arete 3 du triangle cree
4784 c nt : numero du triangle ajoute dans notria
4785 c 0 si saturation du tableau notria ou noarcf ou n1arcf
4786 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4787 c auteur : alain perronnet analyse numerique paris upmc mars 1997
4788 c2345x7..............................................................012
4789 common / unites / lecteu, imprim, nunite(30)
4790 integer nosoar(mosoar,mxsoar),
4796 c un cf supplementaire peut il etre ajoute ?
4797 if( nbcf .ge. mxarcf ) then
4798 write(imprim,*) 'saturation du tableau noarcf'
4805 c l' arete suivante du triangle non sur le cf
4806 na3 = noarcf( 2, na2 )
4808 c creation des 2 nouvelles aretes du triangle dans le tableau nosoar
4809 c ==================================================================
4810 c la formation de l'arete sommet1-sommet2 dans le tableau nosoar
4811 call fasoar( noarcf(1,na1), noarcf(1,na2), -1, -1, 0,
4812 % mosoar, mxsoar, n1soar, nosoar, noarst,
4814 if( ierr .ne. 0 ) goto 9900
4816 c la formation de l'arete sommet1-sommet3 dans le tableau nosoar
4817 call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1, 0,
4818 % mosoar, mxsoar, n1soar, nosoar, noarst,
4820 if( ierr .ne. 0 ) goto 9900
4822 c le triangle nt de noartr a l'arete 2 comme arete du contour na2
4823 c ===============================================================
4824 call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
4825 % noar1, noarcf(3,na2), noar3,
4827 % moartr, n1artr, noartr,
4829 if( nt .le. 0 ) return
4831 c modification du contour ferme existant
4832 c suppression de l'arete na2 du cf
4833 c ======================================
4834 c modification du cf en pointant na2 sur na1
4835 noarcf( 2, na2 ) = na1
4836 noarcf( 3, na2 ) = noar1
4838 n1arcf( nbcf ) = na2
4840 c creation d'un nouveau contour ferme na3 - na1
4841 c =============================================
4844 c recherche d'une arete de cf vide
4846 if( nav .le. 0 ) then
4847 write(imprim,*) 'saturation du tableau noarcf'
4852 c la 1-ere arete vide est mise a jour
4853 n1arcf(0) = noarcf( 2, nav )
4855 c ajout de l'arete nav pointant sur na3
4856 c le numero du sommet
4857 noarcf( 1, nav ) = noarcf( 1, na1 )
4859 noarcf( 2, nav ) = na3
4860 c le numero de l'arete dans le tableau nosoar
4861 noarcf( 3, nav ) = noar3
4863 c l'arete precedente na01 de na1 pointe sur la nouvelle nav
4864 noarcf( 2, na01 ) = nav
4867 n1arcf( nbcf ) = nav
4870 c erreur tableau nosoar sature
4871 9900 write(imprim,*) 'saturation du tableau nosoar'
4877 subroutine trcf2a( nbcf, na1, noar3,
4878 % mosoar, mxsoar, n1soar, nosoar,
4879 % moartr, n1artr, noartr, noarst,
4880 % n1arcf, noarcf, nt )
4881 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4882 c but : modification de la triangulation du contour ferme nbcf
4883 c ----- par ajout d'un triangle ayant 2 aretes sur le contour
4884 c creation d'une arete dans nosoar (sommet3-sommet1)
4885 c et modification du contour par ajout de la 3-eme arete
4889 c nbcf : numero dans n1arcf du cf traite ici
4890 c na1 : numero noarcf de la premiere arete sur le contour
4891 c implicitement sa suivante est sur le contour
4892 c la suivante de la suivante n'est pas sur le contour
4893 c mosoar : nombre maximal d'entiers par arete et
4894 c indice dans nosoar de l'arete suivante dans le hachage
4895 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
4896 c attention: mxsoar>3*mxsomm obligatoire!
4897 c moartr : nombre maximal d'entiers par arete du tableau noartr
4899 c entrees et sorties :
4900 c --------------------
4901 c n1soar : numero de la premiere arete vide dans le tableau nosoar
4902 c une arete i de nosoar est vide <=> nosoar(1,i)=0
4903 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4904 c chainage des aretes frontalieres, chainage du hachage des aretes
4905 c hachage des aretes = nosoar(1)+nosoar(2)*2
4906 c n1artr : numero du premier triangle vide dans le tableau noartr
4907 c le chainage des triangles vides se fait sur noartr(2,.)
4908 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4909 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
4911 c noarst : noarst(i) numero d'une arete de sommet i
4912 c n1arcf : numero d'une arete de chaque contour
4913 c noarcf : numero des aretes de la ligne du contour ferme
4914 c attention : chainage circulaire des aretes
4918 c noar3 : numero de l'arete 3 dans le tableau nosoar
4919 c nt : numero du triangle ajoute dans noartr
4920 c 0 si saturation du tableau noartr ou nosoar
4921 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4922 c auteur : alain perronnet analyse numerique paris upmc mars 1997
4923 c2345x7..............................................................012
4924 common / unites / lecteu, imprim, nunite(30)
4925 integer nosoar(mosoar,*),
4928 integer n1arcf(0:*),
4933 c l'arete suivante de l'arete na1 dans noarcf
4934 na2 = noarcf( 2, na1 )
4935 c l'arete suivante de l'arete na2 dans noarcf
4936 na3 = noarcf( 2, na2 )
4938 c la formation de l'arete sommet3-sommet1 dans le tableau nosoar
4939 call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1, 0,
4940 % mosoar, mxsoar, n1soar, nosoar, noarst,
4942 if( ierr .ne. 0 ) then
4943 if( ierr .eq. 1 ) then
4944 write(imprim,*) 'saturation des aretes (tableau nosoar)'
4950 c le triangle a ses 2 aretes na1 na2 sur le contour ferme
4951 c ajout dans noartr de ce triangle nt
4952 call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
4953 % noarcf(3,na1), noarcf(3,na2), noar3,
4955 % moartr, n1artr, noartr,
4957 if( nt .le. 0 ) return
4959 c suppression des 2 aretes (na1 na2) du cf
4960 c ces 2 aretes se suivent dans le chainage du cf
4961 c ajout de la 3-eme arete (noar3) dans le cf
4962 c l'arete suivante de na1 devient la suivante de na2
4964 noarcf(3,na1) = noar3
4966 c l'arete na2 devient vide dans noarcf
4967 noarcf(2,na2) = n1arcf( 0 )
4970 c la premiere pointee dans noarcf est na1
4971 c chainage circulaire => ce peut etre n'importe laquelle
4976 subroutine trcf3a( ns1, ns2, ns3,
4977 % noar1, noar2, noar3,
4979 % moartr, n1artr, noartr,
4981 c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4982 c but : ajouter dans le tableau noartr le triangle
4983 c ----- de sommets ns1 ns2 ns3
4984 c d'aretes noar1 noar2 noar3 deja existantes
4985 c dans le tableau nosoar des aretes
4989 c ns1, ns2, ns3 : le numero dans pxyd des 3 sommets du triangle
4990 c noar1,noar2,noar3 : le numero dans nosoar des 3 aretes du triangle
4991 c mosoar : nombre maximal d'entiers par arete et
4992 c indice dans nosoar de l'arete suivante dans le hachage
4993 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
4994 c attention: mxsoar>3*mxsomm obligatoire!
4995 c moartr : nombre maximal d'entiers par arete du tableau noartr
4996 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
5000 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
5001 c chainage des aretes frontalieres, chainage du hachage des aretes
5002 c hachage des aretes = nosoar(1)+nosoar(2)*2
5003 c n1artr : numero du premier triangle vide dans le tableau noartr
5004 c le chainage des triangles vides se fait sur noartr(2,.)
5005 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5006 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5010 c nt : numero dans noartr du triangle ajoute
5011 c =0 si le tableau noartr est sature
5012 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5013 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5014 c....................................................................012
5015 common / unites / lecteu,imprim,nunite(30)
5016 integer nosoar(mosoar,*),
5019 c recherche d'un triangle libre dans le tableau noartr
5020 if( n1artr .le. 0 ) then
5021 write(imprim,*) 'saturation du tableau noartr des aretes'
5026 c le numero dans noartr du nouveau triangle
5029 c le nouveau premier triangle vide dans le tableau noartr
5030 n1artr = noartr(2,n1artr)
5032 c arete 1 du triangle nt
5033 c ======================
5034 c orientation des 3 aretes du triangle pour qu'il soit direct
5035 if( ns1 .eq. nosoar(1,noar1) ) then
5040 c le numero de l'arete 1 du triangle nt
5041 noartr(1,nt) = n * noar1
5043 c le numero du triangle nt pour l'arete
5044 if( nosoar(4,noar1) .le. 0 ) then
5049 nosoar(n,noar1) = nt
5051 c arete 2 du triangle nt
5052 c ======================
5053 c orientation des 3 aretes du triangle pour qu'il soit direct
5054 if( ns2 .eq. nosoar(1,noar2) ) then
5059 c le numero de l'arete 2 du triangle nt
5060 noartr(2,nt) = n * noar2
5062 c le numero du triangle nt pour l'arete
5063 if( nosoar(4,noar2) .le. 0 ) then
5068 nosoar(n,noar2) = nt
5070 c arete 3 du triangle nt
5071 c ======================
5072 c orientation des 3 aretes du triangle pour qu'il soit direct
5073 if( ns3 .eq. nosoar(1,noar3) ) then
5078 c le numero de l'arete 3 du triangle nt
5079 noartr(3,nt) = n * noar3
5081 c le numero du triangle nt pour l'arete
5082 if( nosoar(4,noar3) .le. 0 ) then
5087 nosoar(n,noar3) = nt
5092 subroutine trcf3s( nbcf, na01, na1, na02, na2, na03, na3,
5093 % mosoar, mxsoar, n1soar, nosoar,
5094 % moartr, n1artr, noartr, noarst,
5095 % mxarcf, n1arcf, noarcf, nt )
5096 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5097 c but : ajout d'un triangle d'aretes na1 2 3 du tableau noarcf
5098 c ----- a la triangulation d'un contour ferme (cf)
5102 c nbcf : numero dans n1arcf du cf traite ici
5103 c mais aussi nombre actuel de cf avant ajout du triangle
5104 c na01 : numero noarcf de l'arete precedent l'arete na1 de noarcf
5105 c na1 : numero noarcf du 1-er sommet du triangle
5106 c na02 : numero noarcf de l'arete precedent l'arete na2 de noarcf
5107 c na2 : numero noarcf du 2-eme sommet du triangle
5108 c na03 : numero noarcf de l'arete precedent l'arete na3 de noarcf
5109 c na3 : numero noarcf du 3-eme sommet du triangle
5111 c mosoar : nombre maximal d'entiers par arete et
5112 c indice dans nosoar de l'arete suivante dans le hachage
5113 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5114 c attention: mxsoar>3*mxsomm obligatoire!
5115 c moartr : nombre maximal d'entiers par arete du tableau noartr
5116 c mxarcf : nombre maximal d'aretes declarables dans noarcf, n1arcf
5120 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
5121 c chainage des vides suivant en 3 et precedant en 2 de nosoar
5122 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
5123 c chainage des aretes frontalieres, chainage du hachage des aretes
5124 c hachage des aretes = nosoar(1)+nosoar(2)*2
5125 c avec mxsoar>=3*mxsomm
5126 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
5127 c nosoar(2,arete vide)=l'arete vide qui precede
5128 c nosoar(3,arete vide)=l'arete vide qui suit
5130 c n1artr : numero du premier triangle vide dans le tableau noartr
5131 c le chainage des triangles vides se fait sur noartr(2,.)
5132 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5133 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5134 c noarst : noarst(i) numero d'une arete de sommet i
5136 c n1arcf : numero d'une arete de chaque contour ferme
5137 c noarcf : numero du sommet , numero de l'arete suivante
5138 c numero de l'arete dans le tableau nosoar
5139 c attention : chainage circulaire des aretes
5143 c nbcf : nombre actuel de cf apres ajout du triangle
5144 c nt : numero du triangle ajoute dans noartr
5145 c 0 si saturation du tableau nosoar ou noartr ou noarcf ou n1arcf
5146 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5147 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5148 c2345x7..............................................................012
5149 integer nosoar(mosoar,*),
5155 c combien y a t il d'aretes nbascf sur le cf ?
5156 c ============================================
5157 c la premiere arete est elle sur le cf?
5158 if( noarcf(2,na1) .eq. na2 ) then
5159 c la 1-ere arete est sur le cf
5162 c la 1-ere arete n'est pas sur le cf
5166 c la seconde arete est elle sur le cf?
5167 if( noarcf(2,na2) .eq. na3 ) then
5168 c la 2-eme arete est sur le cf
5174 c la troisieme arete est elle sur le cf?
5175 if( noarcf(2,na3) .eq. na1 ) then
5176 c la 3-eme arete est sur le cf
5182 c le nombre d'aretes sur le cf
5183 nbascf = na1cf + na2cf + na3cf
5185 c traitement selon le nombre d'aretes sur le cf
5186 c =============================================
5187 if( nbascf .eq. 3 ) then
5189 c le contour ferme se reduit a un triangle avec 3 aretes sur le cf
5190 c ----------------------------------------------------------------
5191 c ajout dans noartr de ce nouveau triangle
5192 call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
5193 % noarcf(3,na1), noarcf(3,na2), noarcf(3,na3),
5195 % moartr, n1artr, noartr,
5197 if( nt .le. 0 ) return
5199 c le cf est supprime et chaine vide
5200 noarcf(2,na3) = n1arcf(0)
5203 c ce cf a ete traite => un cf de moins a traiter
5206 else if( nbascf .eq. 2 ) then
5208 c le triangle a 2 aretes sur le contour
5209 c -------------------------------------
5210 c les 2 aretes sont la 1-ere et 2-eme du triangle
5211 if( na1cf .eq. 0 ) then
5212 c l'arete 1 n'est pas sur le cf
5214 else if( na2cf .eq. 0 ) then
5215 c l'arete 2 n'est pas sur le cf
5218 c l'arete 3 n'est pas sur le cf
5221 c le triangle oppose a l'arete 3 est inconnu
5222 c modification du contour apres integration du
5223 c triangle ayant ses 2-eres aretes sur le cf
5224 call trcf2a( nbcf, naa1, naor3,
5225 % mosoar, mxsoar, n1soar, nosoar,
5226 % moartr, n1artr, noartr, noarst,
5227 % n1arcf, noarcf, nt )
5229 else if( nbascf .eq. 1 ) then
5231 c le triangle a 1 arete sur le contour
5232 c ------------------------------------
5233 c cette arete est la seconde du triangle
5234 if( na3cf .ne. 0 ) then
5235 c l'arete 3 est sur le cf
5239 else if( na1cf .ne. 0 ) then
5240 c l'arete 1 est sur le cf
5245 c l'arete 2 est sur le cf
5250 c le triangle oppose a l'arete 1 et 3 est inconnu
5251 c modification du contour apres integration du
5252 c triangle ayant 1 arete sur le cf avec creation
5253 c d'un nouveau contour ferme
5254 call trcf1a( nbcf, naa01, naa1, naa2, naor1, naor3,
5255 % mosoar, mxsoar, n1soar, nosoar,
5256 % moartr, n1artr, noartr, noarst,
5257 % mxarcf, n1arcf, noarcf, nt )
5261 c le triangle a 0 arete sur le contour
5262 c ------------------------------------
5263 c modification du contour apres integration du
5264 c triangle ayant 0 arete sur le cf avec creation
5265 c de 2 nouveaux contours fermes
5266 call trcf0a( nbcf, na01, na1, na2, na3,
5267 % naa1, naa2, naa01,
5268 % mosoar, mxsoar, n1soar, nosoar,
5269 % moartr, n1artr, noartr, noarst,
5270 % mxarcf, n1arcf, noarcf, nt )
5275 subroutine tridcf( nbcf0, pxyd, noarst,
5276 % mosoar, mxsoar, n1soar, nosoar,
5277 % moartr, n1artr, noartr,
5278 % mxarcf, n1arcf, noarcf, larmin,
5279 % nbtrcf, notrcf, ierr )
5280 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5281 c but : triangulation directe de nbcf0 contours fermes (cf)
5282 c ----- definis par la liste circulaire de leurs aretes peripheriques
5286 c nbcf0 : nombre initial de cf a trianguler
5287 c pxyd : tableau des coordonnees 2d des points
5288 c par point : x y distance_souhaitee
5289 c mosoar : nombre maximal d'entiers par arete et
5290 c indice dans nosoar de l'arete suivante dans le hachage
5291 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5292 c attention: mxsoar>3*mxsomm obligatoire!
5293 c moartr : nombre maximal d'entiers par arete du tableau noartr
5294 c mxarcf : nombre maximal d'aretes declarables dans noarcf, n1arcf, larmin, not
5298 c noarst : noarst(i) numero d'une arete de sommet i
5299 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
5300 c chainage des vides suivant en 3 et precedant en 2 de nosoar
5301 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
5302 c chainage des aretes frontalieres, chainage du hachage des aretes
5303 c hachage des aretes = nosoar(1)+nosoar(2)*2
5304 c avec mxsoar>=3*mxsomm
5305 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
5306 c nosoar(2,arete vide)=l'arete vide qui precede
5307 c nosoar(3,arete vide)=l'arete vide qui suit
5309 c n1artr : numero du premier triangle vide dans le tableau noartr
5310 c le chainage des triangles vides se fait sur noartr(2,.)
5311 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5312 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5314 c n1arcf : numero de la premiere arete de chacun des nbcf0 cf
5315 c n1arcf(0) no de la premiere arete vide du tableau noarcf
5316 c noarcf(2,i) no de l'arete suivante
5317 c noarcf : numero du sommet , numero de l'arete suivante du cf
5318 c numero de l'arete dans le tableau nosoar
5322 c larmin : tableau (mxarcf) auxiliaire
5323 c stocker la liste des numeros des meilleures aretes
5324 c lors de la selection du meilleur sommet du cf a trianguler
5329 c nbtrcf : nombre de triangles des nbcf0 cf
5330 c notrcf : numero des triangles des nbcf0 cf dans le tableau noartr
5331 c ierr : 0 si pas d'erreur
5332 c 2 saturation de l'un des des tableaux nosoar, noartr, ...
5333 c 3 si contour ferme reduit a moins de 3 aretes
5334 c 4 saturation du tableau notrcf
5335 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5336 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5337 c....................................................................012
5338 common / unites / lecteu, imprim, nunite(30)
5339 double precision pxyd(3,*)
5340 integer noartr(moartr,*),
5341 % nosoar(mosoar,mxsoar),
5348 ccc integer nosotr(3)
5349 ccc double precision d, surtd2
5351 c depart avec nbcf0 cf a trianguler
5354 c le nombre de triangles formes dans l'ensemble des cf
5357 c tant qu'il existe un cf a trianguler faire
5358 c la triangulation directe du cf
5359 c ==========================================
5360 10 if( nbcf .gt. 0 ) then
5362 c le cf en haut de pile a pour premiere arete
5363 na01 = n1arcf( nbcf )
5364 na1 = noarcf( 2, na01 )
5366 c choix du sommet du cf a relier a l'arete na1
5367 c --------------------------------------------
5368 call trchtd( pxyd, na01, na1, noarcf,
5369 % na03, na3, larmin )
5370 if( na3 .eq. 0 ) then
5375 c l'arete suivante de na1
5377 na2 = noarcf( 2, na1 )
5379 c formation du triangle arete na1 - sommet noarcf(1,na3)
5380 c ------------------------------------------------------
5381 call trcf3s( nbcf, na01, na1, na02, na2, na03, na3,
5382 % mosoar, mxsoar, n1soar, nosoar,
5383 % moartr, n1artr, noartr, noarst,
5384 % mxarcf, n1arcf, noarcf, nt )
5385 if( nt .le. 0 ) then
5386 c saturation du tableau noartr ou noarcf ou n1arcf
5391 c ajout du triangle cree a sa pile
5392 if( nbtrcf .ge. mxarcf ) then
5393 write(imprim,*) 'saturation du tableau notrcf'
5398 notrcf( nbtrcf ) = nt
5402 c mise a jour du chainage des triangles des aretes
5403 c ================================================
5404 do 30 ntp0 = 1, nbtrcf
5406 c le numero du triangle ajoute dans le tableau noartr
5407 nt0 = notrcf( ntp0 )
5409 cccc aire signee du triangle nt0
5410 cccc le numero des 3 sommets du triangle nt
5411 ccc call nusotr( nt0, mosoar, nosoar, moartr, noartr,
5413 ccc d = surtd2( pxyd(1,nosotr(1)), pxyd(1,nosotr(2)),
5414 ccc % pxyd(1,nosotr(3)) )
5415 ccc if( d .le. 0 ) then
5417 cccc un triangle d'aire negative de plus
5418 ccc write(imprim,*) 'triangle ',nt0,' st:',nosotr,
5419 ccc % ' d aire ',d,'<=0'
5423 cccc trace du triangle nt0
5424 ccc call mttrtr( pxyd, nt0, moartr, noartr, mosoar, nosoar,
5425 ccc % ncturq, ncblan )
5427 c boucle sur les 3 aretes du triangle
5430 c le numero de l'arete i du triangle dans le tableau nosoar
5431 noar = abs( noartr(i,nt0) )
5433 c ce triangle est il deja chaine dans cette arete?
5434 nt1 = nosoar(4,noar)
5435 nt2 = nosoar(5,noar)
5436 if( nt1 .eq. nt0 .or. nt2 .eq. nt0 ) goto 20
5438 c ajout de ce triangle nt0 a l'arete noar
5439 if( nt1 .le. 0 ) then
5440 c le triangle est ajoute a l'arete
5441 nosoar( 4, noar ) = nt0
5442 else if( nt2 .le. 0 ) then
5443 c le triangle est ajoute a l'arete
5444 nosoar( 5, noar ) = nt0
5446 c l'arete appartient a 2 triangles differents de nt0
5447 c anomalie. chainage des triangles des aretes defectueux
5449 write(imprim,*) 'pause dans tridcf'
5461 subroutine te1stm( nsasup, pxyd, noarst,
5462 % mosoar, mxsoar, n1soar, nosoar,
5463 % moartr, mxartr, n1artr, noartr,
5464 % mxarcf, n1arcf, noarcf, larmin, notrcf, liarcf,
5466 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5467 c but : supprimer de la triangulation le sommet nsasup qui doit
5468 c ----- etre un sommet interne ("centre" d'une boule de triangles)
5470 c attention: le chainage lchain de nosoar devient celui des cf
5474 c nsasup : numero dans le tableau pxyd du sommet a supprimer
5475 c pxyd : tableau des coordonnees 2d des points
5476 c par point : x y distance_souhaitee
5477 c mosoar : nombre maximal d'entiers par arete et
5478 c indice dans nosoar de l'arete suivante dans le hachage
5479 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5480 c attention: mxsoar>3*mxsomm obligatoire!
5481 c moartr : nombre maximal d'entiers par arete du tableau noartr
5482 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
5486 c noarst : noarst(i) numero d'une arete de sommet i
5487 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
5488 c chainage des vides suivant en 3 et precedant en 2 de nosoar
5489 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
5490 c chainage des aretes frontalieres, chainage du hachage des aretes
5491 c hachage des aretes = nosoar(1)+nosoar(2)*2
5492 c avec mxsoar>=3*mxsomm
5493 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
5494 c nosoar(2,arete vide)=l'arete vide qui precede
5495 c nosoar(3,arete vide)=l'arete vide qui suit
5496 c n1artr : numero du premier triangle vide dans le tableau noartr
5497 c le chainage des triangles vides se fait sur noartr(2,.)
5498 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5499 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5504 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
5505 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
5506 c larmin : tableau ( mxarcf ) auxiliaire d'entiers
5507 c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
5508 c liarcf : tableau ( mxarcf ) auxiliaire d'entiers
5512 c ierr : =0 si pas d'erreur
5513 c -1 le sommet a supprimer n'est pas le centre d'une boule
5514 c de triangles. il est suppose externe
5515 c ou bien le sommet est centre d'un cf dont toutes les
5516 c aretes sont frontalieres
5517 c dans les 2 cas => retour sans modifs
5518 c >0 si une erreur est survenue
5519 c =11 algorithme defaillant
5520 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5521 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5522 c....................................................................012
5523 parameter ( lchain=6, quamal=0.3)
5524 common / unites / lecteu,imprim,intera,nunite(29)
5525 double precision pxyd(3,*)
5526 integer nosoar(mosoar,mxsoar),
5535 c nsasup est il un sommet interne, "centre" d'une boule de triangles?
5536 c => le sommet nsasup peut etre supprime
5537 c ===================================================================
5538 c formation du cf de ''centre'' le sommet nsasup
5539 call trp1st( nsasup, noarst, mosoar, nosoar,
5541 % mxarcf, nbtrcf, notrcf )
5542 if( nbtrcf .le. 0 ) then
5543 c erreur: impossible de trouver tous les triangles de sommet nsasup
5544 c le sommet nsasup n'est pas supprime de la triangulation
5547 else if( nbtrcf .le. 2 ) then
5548 c le sommet nsasup n'est pas supprime
5552 if( nbtrcf*3 .gt. mxarcf ) then
5553 write(imprim,*) 'saturation du tableau noarcf'
5558 ccc trace des triangles de l'etoile du sommet nsasup
5559 ccc call trpltr( nbtrcf, notrcf, pxyd,
5560 ccc % moartr, noartr, mosoar, nosoar,
5561 ccc % ncroug, ncblan )
5563 c si toutes les aretes du cf sont frontalieres, alors il est
5564 c interdit de detruire le sommet "centre" du cf
5565 c calcul du nombre nbarfr des aretes simples des nbtrcf triangles
5566 call trfrcf( nsasup, mosoar, nosoar, moartr, noartr,
5567 % nbtrcf, notrcf, nbarfr )
5568 if( nbarfr .ge. nbtrcf ) then
5569 c toutes les aretes simples sont frontalieres
5570 c le sommet nsasup ("centre" de la cavite) n'est pas supprime
5575 c formation du contour ferme (liste chainee des aretes simples)
5576 c forme a partir des aretes des triangles de l'etoile du sommet nsasup
5577 call focftr( nbtrcf, notrcf, pxyd, noarst,
5578 % mosoar, mxsoar, n1soar, nosoar,
5579 % moartr, n1artr, noartr,
5580 % nbarcf, n1arcf, noarcf,
5582 if( ierr .ne. 0 ) return
5584 c ici le sommet nsasup appartient a aucune arete
5585 noarst( nsasup ) = 0
5587 c chainage des aretes vides dans le tableau noarcf
5588 n1arcf(0) = nbarcf+1
5589 mmarcf = min(8*nbarcf,mxarcf)
5590 do 40 i=nbarcf+1,mmarcf
5593 noarcf(2,mmarcf) = 0
5595 c sauvegarde du chainage des aretes peripheriques
5596 c pour la mise en delaunay du maillage
5599 c le numero de l'arete dans le tableau nosoar
5600 liarcf( i ) = noarcf( 3, nbcf )
5601 c l'arete suivante dans le cf
5602 nbcf = noarcf( 2, nbcf )
5605 c triangulation directe du contour ferme sans le sommet nsasup
5606 c ============================================================
5608 call tridcf( nbcf, pxyd, noarst,
5609 % mosoar, mxsoar, n1soar, nosoar,
5610 % moartr, n1artr, noartr,
5611 % mxarcf, n1arcf, noarcf, larmin,
5612 % nbtrcf, notrcf, ierr )
5613 if( ierr .ne. 0 ) return
5615 c transformation des triangles du cf en triangles delaunay
5616 c ========================================================
5617 c construction du chainage lchain dans nosoar
5618 c des aretes peripheriques du cf a partir de la sauvegarde liarcf
5621 c le numero de l'arete peripherique du cf dans nosoar
5623 if( nosoar(3,noar) .le. 0 ) then
5624 c arete interne => elle est chainee a partir de la precedente
5625 nosoar( lchain, noar0 ) = noar
5629 c la derniere arete peripherique n'a pas de suivante
5630 nosoar(lchain,noar0) = 0
5632 c mise en delaunay des aretes chainees
5633 call tedela( pxyd, noarst,
5634 % mosoar, mxsoar, n1soar, nosoar, liarcf(1),
5635 % moartr, mxartr, n1artr, noartr, modifs )
5636 ccc write(imprim,*) 'nombre echanges diagonales =',modifs
5641 subroutine tr3str( np, nt,
5642 % mosoar, mxsoar, n1soar, nosoar,
5643 % moartr, mxartr, n1artr, noartr,
5646 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5647 c but : former les 3 sous-triangles du triangle nt a partir
5648 c ----- du point interne np
5652 c np : numero dans le tableau pxyd du point
5653 c nt : numero dans le tableau noartr du triangle a trianguler
5654 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
5655 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5656 c moartr : nombre maximal d'entiers par arete du tableau noartr
5657 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
5661 c n1soar : numero de la premiere arete vide dans le tableau nosoar
5662 c une arete i de nosoar est vide <=> nosoar(1,i)=0
5663 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages
5664 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
5665 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
5666 c n1artr : numero du premier triangle vide dans le tableau noartr
5667 c le chainage des triangles vides se fait sur noartr(2,.)
5668 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5669 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5670 c noarst : noarst(i) numero d'une arete de sommet i
5674 c nutr : le numero des 3 sous-triangles du triangle nt
5675 c nt : en sortie le triangle initial n'est plus actif dans noartr
5676 c c'est en fait le premier triangle vide de noartr
5677 c ierr : =0 si pas d'erreur
5678 c =1 si le tableau nosoar est sature
5679 c =2 si le tableau noartr est sature
5680 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5681 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5682 c....................................................................012
5683 integer nosoar(mosoar,mxsoar),
5684 % noartr(moartr,mxartr),
5688 integer nosotr(3), nu2sar(2), nuarco(3)
5690 c reservation des 3 nouveaux triangles dans le tableau noartr
5691 c ===========================================================
5693 c le numero du sous-triangle i dans le tableau noartr
5694 if( n1artr .le. 0 ) then
5695 c tableau noartr sature
5700 c le nouveau premier triangle libre dans noartr
5701 n1artr = noartr(2,n1artr)
5704 c les numeros des 3 sommets du triangle nt
5705 call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
5707 c formation des 3 aretes nosotr(i)-np dans le tableau nosoar
5708 c ==========================================================
5712 c le triangle a creer
5715 c les 2 sommets du cote i du triangle nosotr
5716 nu2sar(1) = nosotr(i)
5718 call hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar, noar )
5719 c en sortie: noar>0 => no arete retrouvee
5720 c <0 => no arete ajoutee
5721 c =0 => saturation du tableau nosoar
5723 if( noar .eq. 0 ) then
5724 c saturation du tableau nosoar
5727 else if( noar .lt. 0 ) then
5728 c l'arete a ete ajoutee. initialisation des autres informations
5730 c le numero des 2 sommets a ete initialise par hasoar
5731 c et (nosoar(1,noar)<nosoar(2,noar))
5732 c le numero de la ligne de l'arete: ici arete interne
5735 c l'arete a ete retrouvee
5736 c le numero des 2 sommets a ete retrouve par hasoar
5737 c et (nosoar(1,noar)<nosoar(2,noar))
5738 c le numero de ligne reste inchange
5741 c le triangle 1 de l'arete noar => le triangle nt0
5742 nosoar(4,noar) = nt0
5743 c le triangle 2 de l'arete noar => le triangle nti
5744 nosoar(5,noar) = nti
5746 c le sommet nosotr(i) appartient a l'arete noar
5747 noarst( nosotr(i) ) = noar
5749 c le numero d'arete nosotr(i)-np
5752 c le triangle qui precede le suivant
5756 c le numero d'une arete du point np
5759 c les 3 sous-triangles du triangle nt sont formes dans le tableau noartr
5760 c ======================================================================
5763 c le numero suivant i => i mod 3 + 1
5770 c le numero dans noartr du sous-triangle a ajouter
5773 c le numero de l'arete i du triangle initial nt
5774 c est l'arete 1 du sous-triangle i
5776 noartr( 1, nti ) = noar
5778 c mise a jour du numero de triangle de cette arete
5780 if( nosoar(4,noar) .eq. nt ) then
5781 c le sous-triangle nti remplace le triangle nt
5782 nosoar(4,noar) = nti
5784 c le sous-triangle nti remplace le triangle nt
5785 nosoar(5,noar) = nti
5788 c l'arete 2 du sous-triangle i est l'arete i1 ajoutee
5789 if( nosotr(i1) .eq. nosoar(1,nuarco(i1)) ) then
5790 c l'arete ns i1-np dans nosoar est dans le sens direct
5791 noartr( 2, nti ) = nuarco(i1)
5793 c l'arete ns i1-np dans nosoar est dans le sens indirect
5794 noartr( 2, nti ) = -nuarco(i1)
5797 c l'arete 3 du sous-triangle i est l'arete i ajoutee
5798 if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
5799 c l'arete ns i1-np dans nosoar est dans le sens indirect
5800 noartr( 3, nti ) = -nuarco(i)
5802 c l'arete ns i1-np dans nosoar est dans le sens direct
5803 noartr( 3, nti ) = nuarco(i)
5807 c le triangle nt est rendu libre
5808 c ==============================
5809 c il devient n1artr le premier triangle libre
5811 noartr( 2, nt ) = n1artr
5816 subroutine mt4sqa( na, moartr, noartr, mosoar, nosoar,
5817 % ns1, ns2, ns3, ns4)
5818 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5819 c but : calcul du numero des 4 sommets de l'arete na de nosoar
5820 c ----- formant un quadrangle
5824 c na : numero de l'arete dans nosoar a traiter
5825 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5826 c arete1=0 si triangle vide => arete2=triangle vide suivant
5827 c mosoar : nombre maximal d'entiers par arete
5828 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
5829 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
5833 c ns1,ns2,ns3 : les 3 numeros des sommets du triangle t1 en sens direct
5834 c ns1,ns4,ns2 : les 3 numeros des sommets du triangle t2 en sens direct
5836 c si erreur rencontree => ns4 = 0
5837 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5838 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5839 c2345x7..............................................................012
5840 common / unites / lecteu, imprim, nunite(30)
5841 integer noartr(moartr,*), nosoar(mosoar,*)
5843 c le numero de triangle est il correct ?
5844 c a supprimer apres mise au point
5845 if( na .le. 0 ) then
5847 c write(kerr(mxlger)(1:6),'(i6)') na
5848 c kerr(1) = kerr(mxlger)(1:6) //
5849 c % ' no incorrect arete dans nosoar'
5851 write(imprim,*) na, ' no incorrect arete dans nosoar'
5856 if( nosoar(1,na) .le. 0 ) then
5858 c write(kerr(mxlger)(1:6),'(i6)') na
5859 c kerr(1) = kerr(mxlger)(1:6) //
5860 c % ' arete non active dans nosoar'
5862 write(imprim,*) na, ' arete non active dans nosoar'
5867 c recherche de l'arete na dans le premier triangle
5869 if( nt .le. 0 ) then
5871 c write(kerr(mxlger)(1:6),'(i6)') na
5872 c kerr(1) = 'triangle 1 incorrect pour l''arete ' //
5873 c % kerr(mxlger)(1:6)
5875 write(imprim,*) 'triangle 1 incorrect pour l''arete ', na
5881 if( abs( noartr(i,nt) ) .eq. na ) goto 8
5883 c si arrivee ici => bogue avant
5884 write(imprim,*) 'mt4sqa: arete',na,' non dans le triangle',nt
5888 c les 2 sommets de l'arete na
5889 8 if( noartr(i,nt) .gt. 0 ) then
5896 ns1 = nosoar(ns1,na)
5897 ns2 = nosoar(ns2,na)
5905 naa = abs( noartr(i,nt) )
5907 c le sommet ns3 du triangle 123
5909 if( ns3 .eq. ns1 .or. ns3 .eq. ns2 ) then
5913 c le triangle de l'autre cote de l'arete na
5914 c =========================================
5916 if( nt .le. 0 ) then
5918 c write(kerr(mxlger)(1:6),'(i6)') na
5919 c kerr(1) = 'triangle 2 incorrect pour l''arete ' //
5920 c % kerr(mxlger)(1:6)
5922 write(imprim,*) 'triangle 2 incorrect pour l''arete ',na
5927 c le numero de l'arete naa du triangle nt
5928 naa = abs( noartr(1,nt) )
5929 if( naa .eq. na ) naa = abs( noartr(2,nt) )
5931 if( ns4 .eq. ns1 .or. ns4 .eq. ns2 ) then
5937 subroutine te2t2t( noaret, mosoar, n1soar, nosoar, noarst,
5938 % moartr, noartr, noar34 )
5939 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5940 c but : echanger la diagonale des 2 triangles ayant en commun
5941 c ----- l'arete noaret du tableau nosoar si c'est possible
5945 c noaret : numero de l'arete a echanger entre les 2 triangles
5946 c mosoar : nombre maximal d'entiers par arete
5947 c moartr : nombre maximal d'entiers par triangle
5951 c n1soar : numero de la premiere arete vide dans le tableau nosoar
5952 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
5953 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
5954 c noarst : noarst(i) numero d'une arete de sommet i
5955 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5956 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5960 c noar34 : numero nosoar de la nouvelle arete diagonale
5961 c 0 si pas d'echange des aretes diagonales
5962 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5963 c auteur : alain perronnet analyse numerique paris upmc avril 1997
5964 c....................................................................012
5965 integer nosoar(mosoar,*),
5969 c une arete frontaliere ne peut etre echangee
5971 if( nosoar(3,noaret) .gt. 0 ) return
5973 c les 4 sommets des 2 triangles ayant l'arete noaret en commun
5974 call mt4sqa( noaret, moartr, noartr, mosoar, nosoar,
5975 % ns1, ns2, ns3, ns4)
5976 c ns1,ns2,ns3 : les 3 numeros des sommets du triangle nt1 en sens direct
5977 c ns1,ns4,ns2 : les 3 numeros des sommets du triangle nt2 en sens direct
5979 c recherche du numero de l'arete noaret dans le triangle nt1
5980 nt1 = nosoar(4,noaret)
5982 if( abs(noartr(n1,nt1)) .eq. noaret ) goto 15
5984 c impossible d'arriver ici sans bogue!
5985 write(imprim,*) 'pause dans te2t2t 1'
5988 c l'arete de sommets 2 et 3
5989 15 if( n1 .lt. 3 ) then
5994 na23 = noartr(n2,nt1)
5996 c l'arete de sommets 3 et 1
5997 if( n2 .lt. 3 ) then
6002 na31 = noartr(n3,nt1)
6004 c recherche du numero de l'arete noaret dans le triangle nt2
6005 nt2 = nosoar(5,noaret)
6007 if( abs(noartr(n1,nt2)) .eq. noaret ) goto 25
6009 c impossible d'arriver ici sans bogue!
6010 write(imprim,*) 'pause dans te2t2t 2'
6013 c l'arete de sommets 1 et 4
6014 25 if( n1 .lt. 3 ) then
6019 na14 = noartr(n2,nt2)
6021 c l'arete de sommets 4 et 2
6022 if( n2 .lt. 3 ) then
6027 na42 = noartr(n3,nt2)
6029 c les triangles 123 142 deviennent 143 234
6030 c ========================================
6031 c ajout de l'arete ns3-ns4
6032 c on evite l'affichage de l'erreur
6034 call fasoar( ns3, ns4, nt1, nt2, 0,
6035 % mosoar, mxsoar, n1soar, nosoar, noarst,
6037 if( ierr .gt. 0 ) then
6038 c ierr=1 si le tableau nosoar est sature
6039 c =2 si arete a creer et appartenant a 2 triangles distincts
6040 c des triangles nt1 et nt2
6041 c =3 si arete appartenant a 2 triangles distincts
6042 c differents des triangles nt1 et nt2
6043 c =4 si arete appartenant a 2 triangles distincts
6044 c dont le second n'est pas le triangle nt2
6050 c suppression de l'arete noaret
6051 call sasoar( noaret, mosoar, mxsoar, n1soar, nosoar )
6053 c nt1 = triangle 143
6054 noartr(1,nt1) = na14
6055 c sens de stockage de l'arete ns3-ns4 dans nosoar?
6056 if( nosoar(1,noar34) .eq. ns3 ) then
6061 noartr(2,nt1) = noar34 * n1
6062 noartr(3,nt1) = na31
6064 c nt2 = triangle 234
6065 noartr(1,nt2) = na23
6066 noartr(2,nt2) = -noar34 * n1
6067 noartr(3,nt2) = na42
6069 c echange nt1 -> nt2 pour l'arete na23
6071 if( nosoar(4,na23) .eq. nt1 ) then
6076 nosoar(n1,na23) = nt2
6078 c echange nt2 -> nt1 pour l'arete na14
6080 if( nosoar(4,na14) .eq. nt2 ) then
6085 nosoar(n1,na14) = nt1
6087 c numero d'une arete de chacun des 4 sommets
6090 noarst(ns3) = noar34
6091 noarst(ns4) = noar34
6096 subroutine f0trte( letree, pxyd,
6097 % mosoar, mxsoar, n1soar, nosoar,
6098 % moartr, mxartr, n1artr, noartr,
6100 % nbtr, nutr, ierr )
6101 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6102 c but : former le ou les triangles du triangle equilateral letree
6103 c ----- les points internes au te deviennent des sommets des
6104 c sous-triangles du te
6108 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
6109 c si letree(0)>0 alors
6110 c letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
6112 c letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
6114 c ( le te est une feuille de l'arbre )
6115 c letree(4) : no letree du sur-triangle du triangle j
6116 c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
6117 c letree(6:8) : no pxyd des 3 sommets du triangle j
6118 c pxyd : tableau des x y distance_souhaitee de chaque sommet
6119 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
6120 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6121 c moartr : nombre maximal d'entiers par arete du tableau noartr
6122 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
6126 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6127 c une arete i de nosoar est vide <=> nosoar(1,i)=0
6128 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6129 c chainage des aretes frontalieres, chainage du hachage des aretes
6130 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
6131 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6132 c n1artr : numero du premier triangle vide dans le tableau noartr
6133 c le chainage des triangles vides se fait sur noartr(2,.)
6134 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6135 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
6136 c noarst : noarst(i) numero d'une arete de sommet i
6140 c nbtr : nombre de sous-triangles du te, triangulation du te
6141 c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
6142 c ierr : =0 si pas d'erreur
6143 c =1 si le tableau nosoar est sature
6144 c =2 si le tableau noartr est sature
6145 c =3 si aucun des triangles ne contient l'un des points internes au te
6146 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6147 c auteur : alain perronnet analyse numerique paris upmc mars 1997
6148 c....................................................................012
6149 common / unites / lecteu, imprim, nunite(30)
6150 double precision pxyd(3,*)
6151 integer letree(0:8),
6152 % nosoar(mosoar,mxsoar),
6153 % noartr(moartr,mxartr),
6158 c le numero nt du triangle dans le tableau noartr
6159 if( n1artr .le. 0 ) then
6160 c tableau noartr sature
6161 write(imprim,*) 'f0trte: tableau noartr sature'
6166 c le numero du nouveau premier triangle libre dans noartr
6167 n1artr = noartr( 2, n1artr )
6169 c formation du triangle = le triangle equilateral letree
6176 c ajout eventuel de l'arete si si+1 dans le tableau nosoar
6177 call fasoar( letree(5+i), letree(5+i1), nt, -1, 0,
6178 % mosoar, mxsoar, n1soar, nosoar, noarst,
6180 if( ierr .ne. 0 ) return
6183 c le triangle nt est forme dans le tableau noartr
6185 c letree(5+i) est le numero du sommet 1 de l'arete i du te
6186 if( letree(5+i) .eq. nosoar(1,nuarco(i)) ) then
6191 c l'arete ns1-ns2 dans nosoar est celle du cote du te
6192 noartr( i, nt ) = lesign * nuarco(i)
6195 c triangulation du te=triangle nt par ajout des points internes du te
6198 call trpite( letree, pxyd,
6199 % mosoar, mxsoar, n1soar, nosoar,
6200 % moartr, mxartr, n1artr, noartr, noarst,
6201 % nbtr, nutr, ierr )
6205 subroutine f1trte( letree, pxyd, milieu,
6206 % mosoar, mxsoar, n1soar, nosoar,
6207 % moartr, mxartr, n1artr, noartr,
6209 % nbtr, nutr, ierr )
6210 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6211 c but : former les triangles du triangle equilateral letree
6212 c ----- a partir de l'un des 3 milieux des cotes du te
6213 c et des points internes au te
6214 c ils deviennent tous des sommets des sous-triangles du te
6218 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
6219 c si letree(0)>0 alors
6220 c letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
6222 c letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
6224 c ( le te est une feuille de l'arbre )
6225 c letree(4) : no letree du sur-triangle du triangle j
6226 c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
6227 c letree(6:8) : no pxyd des 3 sommets du triangle j
6228 c pxyd : tableau des x y distance_souhaitee de chaque sommet
6229 c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
6230 c 0 si pas de milieu du cote i a ajouter
6231 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
6232 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6233 c moartr : nombre maximal d'entiers par arete du tableau noartr
6234 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
6238 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6239 c une arete i de nosoar est vide <=> nosoar(1,i)=0
6240 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6241 c chainage des aretes frontalieres, chainage du hachage des aretes
6242 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
6243 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6244 c n1artr : numero du premier triangle vide dans le tableau noartr
6245 c le chainage des triangles vides se fait sur noartr(2,.)
6246 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6247 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
6248 c noarst : noarst(np) numero d'une arete du sommet np
6252 c nbtr : nombre de sous-triangles du te, triangulation du te
6253 c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
6254 c ierr : =0 si pas d'erreur
6255 c =1 si le tableau nosoar est sature
6256 c =2 si le tableau noartr est sature
6257 c =3 si aucun des triangles ne contient l'un des points internes au te
6258 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6259 c auteur : alain perronnet analyse numerique paris upmc mars 1997
6260 c....................................................................012
6261 double precision pxyd(3,*)
6262 integer letree(0:8),
6264 % nosoar(mosoar,mxsoar),
6265 % noartr(moartr,mxartr),
6269 integer nosotr(3), nuarco(5)
6271 c le numero des 2 triangles (=2 demi te) a creer dans le tableau noartr
6273 if( n1artr .le. 0 ) then
6274 c tableau noartr sature
6279 c le nouveau premier triangle libre dans noartr
6280 n1artr = noartr(2,n1artr)
6284 c recherche du milieu a creer
6286 if( milieu(i) .ne. 0 ) goto 9
6288 c le numero pxyd du point milieu du cote i
6291 c on se ramene au seul cas i=3 c-a-d le milieu est sur le cote 3
6293 c milieu sur le cote 1
6294 nosotr(1) = letree(7)
6295 nosotr(2) = letree(8)
6296 nosotr(3) = letree(6)
6297 else if( i .eq. 2 ) then
6298 c milieu sur le cote 2
6299 nosotr(1) = letree(8)
6300 nosotr(2) = letree(6)
6301 nosotr(3) = letree(7)
6303 c milieu sur le cote 3
6304 nosotr(1) = letree(6)
6305 nosotr(2) = letree(7)
6306 nosotr(3) = letree(8)
6309 c formation des 2 aretes s1 s2 et s2 s3
6316 c ajout eventuel de l'arete dans nosoar
6317 call fasoar( nosotr(i), nosotr(i1), nutr(i), -1, 0,
6318 % mosoar, mxsoar, n1soar, nosoar, noarst,
6320 if( ierr .ne. 0 ) return
6323 c ajout eventuel de l'arete s3 milieu dans nosoar
6324 call fasoar( nosotr(3), nm, nutr(2), -1, 0,
6325 % mosoar, mxsoar, n1soar, nosoar, noarst,
6327 if( ierr .ne. 0 ) return
6329 c ajout eventuel de l'arete milieu s1 dans nosoar
6330 call fasoar( nosotr(1), nm, nutr(1), -1, 0,
6331 % mosoar, mxsoar, n1soar, nosoar, noarst,
6333 if( ierr .ne. 0 ) return
6335 c ajout eventuel de l'arete milieu s2 dans nosoar
6336 call fasoar( nosotr(2), nm, nutr(1), nutr(2), 0,
6337 % mosoar, mxsoar, n1soar, nosoar, noarst,
6339 if( ierr .ne. 0 ) return
6341 c les aretes s1 s2 et s2 s3 dans le tableau noartr
6343 c nosotr(i) est le numero du sommet 1 de l'arete i du te
6344 if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
6349 c l'arete ns1-ns2 dans nosoar est celle du cote du te
6350 noartr( 1, nutr(i) ) = lesign * nuarco(i)
6353 c l'arete mediane s2 milieu
6354 if( nm .eq. nosoar(1,nuarco(5)) ) then
6359 noartr( 2, nutr(1) ) = lesign * nuarco(5)
6360 noartr( 3, nutr(2) ) = -lesign * nuarco(5)
6363 if( nm .eq. nosoar(1,nuarco(4)) ) then
6368 noartr( 3, nutr(1) ) = lesign * nuarco(4)
6371 if( nm .eq. nosoar(1,nuarco(3)) ) then
6376 noartr( 2, nutr(2) ) = lesign * nuarco(3)
6378 c triangulation des 2 demi te par ajout des points internes du te
6379 call trpite( letree, pxyd,
6380 % mosoar, mxsoar, n1soar, nosoar,
6381 % moartr, mxartr, n1artr, noartr, noarst,
6382 % nbtr, nutr, ierr )
6386 subroutine f2trte( letree, pxyd, milieu,
6387 % mosoar, mxsoar, n1soar, nosoar,
6388 % moartr, mxartr, n1artr, noartr,
6390 % nbtr, nutr, ierr )
6391 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6392 c but : former les triangles du triangle equilateral letree
6393 c ----- a partir de 2 milieux des cotes du te
6394 c et des points internes au te
6395 c ils deviennent tous des sommets des sous-triangles du te
6399 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
6400 c si letree(0)>0 alors
6401 c letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
6403 c letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
6405 c ( le te est une feuille de l'arbre )
6406 c letree(4) : no letree du sur-triangle du triangle j
6407 c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
6408 c letree(6:8) : no pxyd des 3 sommets du triangle j
6409 c pxyd : tableau des x y distance_souhaitee de chaque sommet
6410 c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
6411 c 0 si pas de milieu du cote i a ajouter
6412 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
6413 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6414 c moartr : nombre maximal d'entiers par arete du tableau noartr
6415 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
6419 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6420 c une arete i de nosoar est vide <=> nosoar(1,i)=0
6421 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6422 c chainage des aretes frontalieres, chainage du hachage des aretes
6423 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
6424 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6425 c n1artr : numero du premier triangle vide dans le tableau noartr
6426 c le chainage des triangles vides se fait sur noartr(2,.)
6427 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6428 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
6429 c noarst : noarst(np) numero d'une arete du sommet np
6433 c nbtr : nombre de sous-triangles du te, triangulation du te
6434 c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
6435 c ierr : =0 si pas d'erreur
6436 c =1 si le tableau nosoar est sature
6437 c =2 si le tableau noartr est sature
6438 c =3 si aucun des triangles ne contient l'un des points internes au te
6439 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6440 c auteur : alain perronnet analyse numerique paris upmc mars 1997
6441 c....................................................................012
6442 common / unites / lecteu, imprim, nunite(30)
6443 double precision pxyd(3,*)
6444 integer letree(0:8),
6446 % nosoar(mosoar,mxsoar),
6447 % noartr(moartr,mxartr),
6451 integer nosotr(3), nuarco(7)
6453 c le numero des 3 triangles a creer dans le tableau noartr
6455 if( n1artr .le. 0 ) then
6456 c tableau noartr sature
6461 c le nouveau premier triangle libre dans noartr
6462 n1artr = noartr(2,n1artr)
6466 c recherche du premier milieu a creer
6468 if( milieu(i) .ne. 0 ) goto 9
6471 c on se ramene au seul cas i=2 c-a-d le cote 1 n'a pas de milieu
6472 9 if( i .eq. 2 ) then
6473 c pas de milieu sur le cote 1
6474 nosotr(1) = letree(6)
6475 nosotr(2) = letree(7)
6476 nosotr(3) = letree(8)
6477 c le numero pxyd du milieu du cote 2
6479 c le numero pxyd du milieu du cote 3
6481 else if( milieu(2) .ne. 0 ) then
6482 c pas de milieu sur le cote 3
6483 nosotr(1) = letree(8)
6484 nosotr(2) = letree(6)
6485 nosotr(3) = letree(7)
6486 c le numero pxyd du milieu du cote 2
6488 c le numero pxyd du milieu du cote 3
6491 c pas de milieu sur le cote 2
6492 nosotr(1) = letree(7)
6493 nosotr(2) = letree(8)
6494 nosotr(3) = letree(6)
6495 c le numero pxyd du milieu du cote 2
6497 c le numero pxyd du milieu du cote 3
6501 c ici seul le cote 1 n'a pas de milieu
6502 c nm2 est le milieu du cote 2
6503 c nm3 est le milieu du cote 3
6505 c ajout eventuel de l'arete s1 s2 dans nosoar
6506 call fasoar( nosotr(1), nosotr(2), nutr(1), -1, 0,
6507 % mosoar, mxsoar, n1soar, nosoar, noarst,
6509 if( ierr .ne. 0 ) return
6511 c ajout eventuel de l'arete s1 s2 dans nosoar
6512 call fasoar( nosotr(2), nm2, nutr(1), -1, 0,
6513 % mosoar, mxsoar, n1soar, nosoar, noarst,
6515 if( ierr .ne. 0 ) return
6517 c ajout eventuel de l'arete s1 nm2 dans nosoar
6518 call fasoar( nosotr(1), nm2, nutr(1), nutr(2), 0,
6519 % mosoar, mxsoar, n1soar, nosoar, noarst,
6521 if( ierr .ne. 0 ) return
6523 c ajout eventuel de l'arete nm2 nm3 dans nosoar
6524 call fasoar( nm3, nm2, nutr(2), nutr(3), 0,
6525 % mosoar, mxsoar, n1soar, nosoar, noarst,
6527 if( ierr .ne. 0 ) return
6529 c ajout eventuel de l'arete s1 nm3 dans nosoar
6530 call fasoar( nosotr(1), nm3, nutr(2), -1, 0,
6531 % mosoar, mxsoar, n1soar, nosoar, noarst,
6533 if( ierr .ne. 0 ) return
6535 c ajout eventuel de l'arete nm2 s3 dans nosoar
6536 call fasoar( nm2, nosotr(3), nutr(3), -1, 0,
6537 % mosoar, mxsoar, n1soar, nosoar, noarst,
6540 c ajout eventuel de l'arete nm3 s3 dans nosoar
6541 call fasoar( nosotr(3), nm3, nutr(3), -1, 0,
6542 % mosoar, mxsoar, n1soar, nosoar, noarst,
6544 if( ierr .ne. 0 ) return
6546 c le triangle s1 s2 nm2 ou arete1 arete2 arete3
6548 c nosotr(i) est le numero du sommet 1 de l'arete i du te
6549 if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
6554 c l'arete ns1-ns2 dans nosoar est celle du cote du te
6555 noartr( i, nutr(1) ) = lesign * nuarco(i)
6557 if( nm2 .eq. nosoar(1,nuarco(3)) ) then
6562 noartr( 3, nutr(1) ) = lesign * nuarco(3)
6564 c le triangle s1 nm2 nm3
6565 noartr( 1, nutr(2) ) = -lesign * nuarco(3)
6566 if( nm2 .eq. nosoar(1,nuarco(4)) ) then
6571 noartr( 2, nutr(2) ) = lesign * nuarco(4)
6572 noartr( 1, nutr(3) ) = -lesign * nuarco(4)
6573 if( nm3 .eq. nosoar(1,nuarco(5)) ) then
6578 noartr( 3, nutr(2) ) = lesign * nuarco(5)
6580 c le triangle nm2 nm3 s3
6581 if( nm2 .eq. nosoar(1,nuarco(6)) ) then
6586 noartr( 2, nutr(3) ) = lesign * nuarco(6)
6587 if( nm3 .eq. nosoar(1,nuarco(7)) ) then
6592 noartr( 3, nutr(3) ) = lesign * nuarco(7)
6594 c triangulation des 3 sous-te par ajout des points internes du te
6595 call trpite( letree, pxyd,
6596 % mosoar, mxsoar, n1soar, nosoar,
6597 % moartr, mxartr, n1artr, noartr, noarst,
6598 % nbtr, nutr, ierr )
6602 subroutine f3trte( letree, pxyd, milieu,
6603 % mosoar, mxsoar, n1soar, nosoar,
6604 % moartr, mxartr, n1artr, noartr,
6606 % nbtr, nutr, ierr )
6607 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6608 c but : former les triangles du triangle equilateral letree
6609 c ----- a partir de 3 milieux des cotes du te
6610 c et des points internes au te
6611 c ils deviennent tous des sommets des sous-triangles du te
6615 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
6616 c si letree(0)>0 alors
6617 c letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
6619 c letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
6621 c ( le te est une feuille de l'arbre )
6622 c letree(4) : no letree du sur-triangle du triangle j
6623 c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
6624 c letree(6:8) : no pxyd des 3 sommets du triangle j
6625 c pxyd : tableau des x y distance_souhaitee de chaque sommet
6626 c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
6627 c 0 si pas de milieu du cote i a ajouter
6628 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
6629 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6630 c moartr : nombre maximal d'entiers par arete du tableau noartr
6631 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
6635 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6636 c une arete i de nosoar est vide <=> nosoar(1,i)=0
6637 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6638 c chainage des aretes frontalieres, chainage du hachage des aretes
6639 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
6640 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6641 c n1artr : numero du premier triangle vide dans le tableau noartr
6642 c le chainage des triangles vides se fait sur noartr(2,.)
6643 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6644 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
6645 c noarst : noarst(np) numero d'une arete du sommet np
6649 c nbtr : nombre de sous-triangles du te, triangulation du te
6650 c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
6651 c ierr : =0 si pas d'erreur
6652 c =1 si le tableau nosoar est sature
6653 c =2 si le tableau noartr est sature
6654 c =3 si aucun des triangles ne contient l'un des points internes au te
6655 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6656 c auteur : alain perronnet analyse numerique paris upmc mars 1997
6657 c....................................................................012
6658 common / unites / lecteu, imprim, nunite(30)
6659 double precision pxyd(3,*)
6660 integer letree(0:8),
6662 % nosoar(mosoar,mxsoar),
6663 % noartr(moartr,mxartr),
6669 c le numero des 4 triangles a creer dans le tableau noartr
6671 if( n1artr .le. 0 ) then
6672 c tableau noartr sature
6677 c le nouveau premier triangle libre dans noartr
6678 n1artr = noartr(2,n1artr)
6689 c le sommet precedant
6697 c ajout eventuel de l'arete si mi dans nosoar
6698 call fasoar( letree(5+i), milieu(i), nutr(i), -1, 0,
6699 % mosoar, mxsoar, n1soar, nosoar, noarst,
6700 % nuarco(i3-2), ierr )
6701 if( ierr .ne. 0 ) return
6703 c ajout eventuel de l'arete mi mi-1 dans nosoar
6704 call fasoar( milieu(i), milieu(i0), nutr(i), nutr(4), 0,
6705 % mosoar, mxsoar, n1soar, nosoar, noarst,
6706 % nuarco(i3-1), ierr )
6707 if( ierr .ne. 0 ) return
6709 c ajout eventuel de l'arete m i-1 si dans nosoar
6710 call fasoar( milieu(i0), letree(5+i), nutr(i), -1, 0,
6711 % mosoar, mxsoar, n1soar, nosoar, noarst,
6712 % nuarco(i3), ierr )
6713 if( ierr .ne. 0 ) return
6717 c les 3 sous-triangles pres des sommets
6725 c le sommet precedant
6733 c ajout du triangle arete3i-2 arete3i-1 arete3i
6734 if( letree(5+i) .eq. nosoar(1,nuarco(i3-2)) ) then
6739 noartr( 1, nutr(i) ) = lesign * nuarco(i3-2)
6741 if( milieu(i) .eq. nosoar(1,nuarco(i3-1)) ) then
6746 noartr( 2, nutr(i) ) = lesign * nuarco(i3-1)
6748 if( milieu(i0) .eq. nosoar(1,nuarco(i3)) ) then
6753 noartr( 3, nutr(i) ) = lesign * nuarco(i3)
6757 c le sous triangle central
6761 if( milieu(i) .eq. nosoar(1,nuarco(i3)) ) then
6766 noartr( i, nutr(4) ) = lesign * nuarco(i3)
6769 c triangulation des 3 sous-te par ajout des points internes du te
6770 call trpite( letree, pxyd,
6771 % mosoar, mxsoar, n1soar, nosoar,
6772 % moartr, mxartr, n1artr, noartr, noarst,
6773 % nbtr, nutr, ierr )
6778 subroutine hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar,
6780 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6781 c but : rechercher le numero des 2 sommets d'une arete parmi
6782 c ----- les numeros des 2 sommets des aretes du tableau nosoar
6783 c s ils n y sont pas stockes les y ajouter
6784 c dans tous les cas retourner le numero de l'arete dans nosoar
6786 c la methode employee ici est celle du hachage
6787 c avec pour fonction d'adressage h(ns1,ns2)=min(ns1,ns2)
6789 c remarque: h(ns1,ns2)=ns1 + 2*ns2
6790 c ne marche pas si des aretes sont detruites
6791 c et ajoutees aux aretes vides
6792 c le chainage est commun a plusieurs hachages!
6793 c d'ou ce choix du minimum pour le hachage
6797 c mosoar : nombre maximal d'entiers par arete et
6798 c indice dans nosoar de l'arete suivante dans le hachage
6799 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6800 c attention: mxsoar>3*mxsomm obligatoire!
6804 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6805 c une arete i de nosoar est vide <=> nosoar(1,i)=0
6806 c chainage des aretes vides amont et aval
6807 c l'arete vide qui precede=nosoar(4,i)
6808 c l'arete vide qui suit =nosoar(5,i)
6809 c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
6810 c chainage momentan'e d'aretes, chainage du hachage des aretes
6811 c hachage des aretes = min( nosoar(1), nosoar(2) )
6812 c nu2sar : en entree les 2 numeros des sommets de l'arete
6813 c en sortie nu2sar(1)<nu2sar(2) numeros des 2 sommets de l'arete
6817 c noar : numero dans nosoar de l'arete apres hachage
6818 c =0 si saturation du tableau nosoar
6819 c >0 si le tableau nu2sar est l'arete noar retrouvee
6820 c dans le tableau nosoar
6821 c <0 si le tableau nu2sar a ete ajoute et forme l'arete
6822 c -noar du tableau nosoar avec nosoar(1,noar)<nosoar(2,noar)
6823 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6824 c auteur : alain perronnet analyse numerique upmc paris mars 1997
6825 c ...................................................................012
6826 integer nu2sar(2), nosoar(mosoar,mxsoar)
6828 if( nu2sar(1) .gt. nu2sar(2) ) then
6830 c permutation des numeros des 2 sommets pour
6831 c amener le plus petit dans nu2sar(1)
6833 nu2sar(1) = nu2sar(2)
6837 c la fonction d'adressage du hachage des aretes : h(ns1,ns2)=min(ns1,ns2)
6838 c ===============================================
6841 c la recherche de l'arete dans le chainage du hachage
6842 c ---------------------------------------------------
6843 10 if( nu2sar(1) .eq. nosoar(1,noar) ) then
6844 if( nu2sar(2) .eq. nosoar(2,noar) ) then
6846 c l'arete est retrouvee
6847 c .....................
6852 c l'arete suivante parmi celles ayant meme fonction d'adressage
6853 i = nosoar( mosoar, noar )
6859 c noar est ici la derniere arete (sans suivante) du chainage
6860 c a partir de l'adressage du hachage
6862 c l'arete non retrouvee doit etre ajoutee
6863 c .......................................
6864 if( nosoar( 1, nu2sar(1) ) .eq. 0 ) then
6866 c l'adresse de hachage est libre => elle devient la nouvelle arete
6867 c retouche des chainages de cette arete noar qui ne sera plus vide
6869 c l'eventuel chainage du hachage n'est pas modifie
6873 c la premiere arete dans l'adressage du hachage n'est pas libre
6874 c => choix quelconque d'une arete vide pour ajouter cette arete
6875 if( n1soar .le. 0 ) then
6877 c le tableau nosoar est sature avec pour temoin d'erreur
6883 c l'arete n1soar est vide => c'est la nouvelle arete
6884 c mise a jour du chainage de la derniere arete noar du chainage
6885 c sa suivante est la nouvelle arete n1soar
6886 nosoar( mosoar, noar ) = n1soar
6888 c l'arete ajoutee est n1soar
6891 c la nouvelle premiere arete vide
6892 n1soar = nosoar( 5, n1soar )
6894 c la premiere arete vide n1soar n'a pas d'arete vide precedente
6895 nosoar( 4, n1soar ) = 0
6897 c noar la nouvelle arete est la derniere du chainage du hachage
6898 nosoar( mosoar, noar ) = 0
6904 c les 2 sommets de la nouvelle arete noar
6905 nosoar( 1, noar ) = nu2sar(1)
6906 nosoar( 2, noar ) = nu2sar(2)
6908 c le tableau nu2sar a ete ajoute avec l'indice -noar
6913 subroutine mt3str( nt, moartr, noartr, mosoar, nosoar,
6915 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6916 c but : calcul du numero des 3 sommets du triangle nt du tableau noartr
6921 c nt : numero du triangle de noartr a traiter
6922 c moartr : nombre maximal d'entiers par triangle
6923 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6924 c arete1=0 si triangle vide => arete2=triangle vide suivant
6925 c mosoar : nombre maximal d'entiers par arete
6926 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
6927 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6931 c ns1,ns2,ns3 : les 3 numeros des sommets du triangle en sens direct
6933 c si erreur rencontree => ns1 = 0
6934 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6935 c auteur : alain perronnet analyse numerique paris upmc juillet 1995
6936 c2345x7..............................................................012
6937 integer noartr(moartr,*), nosoar(mosoar,*)
6939 c le numero de triangle est il correct ?
6940 c a supprimer apres mise au point
6941 if( nt .le. 0 ) then
6943 c write(kerr(mxlger)(1:6),'(i6)') nt
6944 c kerr(1) = kerr(mxlger)(1:6) //
6945 c % ' no triangle dans noartr incorrect'
6947 write(imprim,*) nt,' no triangle dans noartr incorrect'
6953 if( na .gt. 0 ) then
6954 c arete dans le sens direct
6958 c arete dans le sens indirect
6964 if( na .gt. 0 ) then
6965 c arete dans le sens direct => ns3 est le second sommet de l'arete
6968 c arete dans le sens indirect => ns3 est le premier sommet de l'arete
6972 subroutine trpite( letree, pxyd,
6973 % mosoar, mxsoar, n1soar, nosoar,
6974 % moartr, mxartr, n1artr, noartr,
6976 % nbtr, nutr, ierr )
6977 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6978 c but : former le ou les sous-triangles des nbtr triangles nutr
6979 c ----- qui forment le triangle equilateral letree par ajout
6980 c des points internes au te qui deviennent des sommets des
6981 c sous-triangles des nbtr triangles
6985 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
6986 c letree(0:3):-no pxyd des 1 a 4 points internes au triangle j
6988 c ( le te est ici une feuille de l'arbre )
6989 c letree(4) : no letree du sur-triangle du triangle j
6990 c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
6991 c letree(6:8) : no pxyd des 3 sommets du triangle j
6992 c pxyd : tableau des x y distance_souhaitee de chaque sommet
6993 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
6994 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6995 c moartr : nombre maximal d'entiers par arete du tableau noartr
6996 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
7000 c n1soar : numero de la premiere arete vide dans le tableau nosoar
7001 c une arete i de nosoar est vide <=> nosoar(1,i)=0
7002 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
7003 c chainage des aretes frontalieres, chainage du hachage des aretes
7004 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
7005 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
7006 c n1artr : numero du premier triangle vide dans le tableau noartr
7007 c le chainage des triangles vides se fait sur noartr(2,.)
7008 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
7009 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
7010 c noarst : noarst(i) numero d'une arete de sommet i
7014 c nbtr : nombre de sous-triangles du te
7015 c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
7016 c ierr : =0 si pas d'erreur
7017 c =1 si le tableau nosoar est sature
7018 c =2 si le tableau noartr est sature
7019 c =3 si aucun des triangles ne contient l'un des points internes au te
7020 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7021 c auteur : alain perronnet analyse numerique paris upmc mars 1997
7022 c....................................................................012
7024 common / dv2dco / tratri
7025 c trace ou non des triangles generes dans la triangulation
7026 common / unites / lecteu, imprim, nunite(30)
7027 double precision pxyd(3,*)
7028 integer letree(0:8),
7029 % nosoar(mosoar,mxsoar),
7030 % noartr(moartr,mxartr),
7036 c si pas de point interne alors trace eventuel puis retour
7037 if( letree(0) .eq. 0 ) goto 150
7039 c il existe au moins un point interne a trianguler
7040 c dans les nbtr triangles
7043 c le numero du point
7045 if( np .eq. 0 ) goto 150
7047 c le point np dans pxyd est a traiter
7050 c les numeros des 3 sommets du triangle nt=nutr(n)
7052 call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
7054 c le triangle nt contient il le point np?
7055 call ptdatr( pxyd(1,np), pxyd, nosotr, nsigne )
7056 c nsigne>0 si le point est dans le triangle ou sur une des 3 aretes
7057 c =0 si triangle degenere ou indirect ou ne contient pas le poin
7059 if( nsigne .gt. 0 ) then
7061 c le triangle nt est triangule en 3 sous-triangles
7062 call tr3str( np, nt,
7063 % mosoar, mxsoar, n1soar, nosoar,
7064 % moartr, mxartr, n1artr, noartr,
7066 % nutr(nbtr+1), ierr )
7067 if( ierr .ne. 0 ) return
7069 c reamenagement des 3 triangles crees dans nutr
7070 c en supprimant le triangle nt
7071 nutr( n ) = nutr( nbtr + 3 )
7073 c le point np est triangule
7079 c erreur: le point np n'est pas dans l'un des nbtr triangles
7080 write(imprim,10010) np
7086 10010 format(' erreur trpite: pas de triangle contenant le point',i7)
7090 ccc 150 if( tratri ) then
7091 cccc les traces sont demandes
7093 cccc le cadre objet global en unites utilisateur
7094 ccc xx1 = min(pxyd(1,nosotr(1)),pxyd(1,nosotr(2)),pxyd(1,nosotr(3)))
7095 ccc xx2 = max(pxyd(1,nosotr(1)),pxyd(1,nosotr(2)),pxyd(1,nosotr(3)))
7096 ccc yy1 = min(pxyd(2,nosotr(1)),pxyd(2,nosotr(2)),pxyd(2,nosotr(3)))
7097 ccc yy2 = max(pxyd(2,nosotr(1)),pxyd(2,nosotr(2)),pxyd(2,nosotr(3)))
7098 ccc if( xx1 .ge. xx2 ) xx2 = xx1 + (yy2-yy1)
7099 ccc if( yy1 .ge. yy2 ) yy2 = yy1 + (xx2-xx1)*0.5
7100 ccc call isofenetre( xx1-(xx2-xx1), xx2+(xx2-xx1),
7101 ccc % yy1-(yy2-yy1), yy2+(yy2-yy1) )
7103 cccc trace du triangle nutr(i)
7104 ccc call mttrtr( pxyd, nutr(i), moartr, noartr, mosoar, nosoar,
7112 subroutine sasoar( noar, mosoar, mxsoar, n1soar, nosoar )
7113 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7114 c but : supprimer l'arete noar du tableau nosoar
7115 c ----- si celle ci n'est pas une arete des lignes de la frontiere
7117 c la methode employee ici est celle du hachage
7118 c avec pour fonction d'adressage h = min( nu2sar(1), nu2sar(2) )
7120 c attention: il faut mettre a jour le no d'arete des 2 sommets
7121 c de l'arete supprimee dans le tableau noarst!
7125 c noar : numero de l'arete de nosoar a supprimer
7126 c mosoar : nombre maximal d'entiers par arete et
7127 c indice dans nosoar de l'arete suivante dans le hachage h
7128 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
7129 c attention: mxsoar>3*mxsomm obligatoire!
7133 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
7134 c chainage des vides suivant en 3 et precedant en 2 de nosoar
7135 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
7136 c chainage des aretes frontalieres, chainage du hachage des aretes
7137 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
7138 c nosoar(4,arete vide)=l'arete vide qui precede
7139 c nosoar(5,arete vide)=l'arete vide qui suit
7140 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7141 c auteur : alain perronnet analyse numerique upmc paris mars 1997
7142 c ...................................................................012
7143 common / unites / lecteu, imprim, nunite(30)
7144 integer nosoar(mosoar,mxsoar)
7146 if( nosoar(3,noar) .le. 0 ) then
7148 c l'arete n'est pas frontaliere => elle devient une arete vide
7150 c recherche de l'arete qui precede dans le chainage du hachage
7151 noar1 = nosoar(1,noar)
7153 c parcours du chainage du hachage jusqu'a retrouver l'arete noar
7154 10 if( noar1 .ne. noar ) then
7156 c l'arete suivante parmi celles ayant meme fonction d'adressage
7158 noar1 = nosoar( mosoar, noar1 )
7159 if( noar1 .gt. 0 ) goto 10
7161 c l'arete noar n'a pas ete retrouvee dans le chainage => erreur
7162 write(imprim,*) 'erreur sasoar:arete non dans le chainage '
7164 write(imprim,*) 'arete de st1=',nosoar(1,noar),
7165 % ' st2=',nosoar(2,noar),' ligne=',nosoar(3,noar),
7166 % ' tr1=',nosoar(4,noar),' tr2=',nosoar(5,noar)
7167 write(imprim,*) 'chainages=',(nosoar(i,noar),i=6,mosoar)
7169 c l'arete n'est pas detruite
7174 if( noar .ne. nosoar(1,noar) ) then
7176 c saut de l'arete noar dans le chainage du hachage
7177 c noar0 initialisee est ici l'arete qui precede noar dans ce chainage
7178 nosoar( mosoar, noar0 ) = nosoar( mosoar, noar )
7180 c le chainage du hachage n'existe plus pour noar
7181 c pas utile car mise a zero faite dans le sp hasoar
7182 ccc nosoar( mosoar, noar ) = 0
7184 c noar devient la nouvelle premiere arete du chainage des vides
7185 nosoar( 4, noar ) = 0
7186 nosoar( 5, noar ) = n1soar
7187 c la nouvelle precede l'ancienne premiere
7188 nosoar( 4, n1soar ) = noar
7193 c noar est la premiere arete du chainage du hachage h
7194 c cette arete ne peut etre consideree dans le chainage des vides
7195 c car le chainage du hachage doit etre conserve (sinon perte...)
7199 c le temoin d'arete vide
7200 nosoar( 1, noar ) = 0
7205 subroutine caetoi( noar, mosoar, mxsoar, n1soar, nosoar,
7207 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7208 c but : ajouter (ou retirer) l'arete noar de nosoar de l'etoile
7209 c ----- des aretes simples chainees en position lchain de nosoar
7210 c detruire du tableau nosoar les aretes doubles
7212 c attention: le chainage lchain de nosoar devient celui des cf
7216 c noar : numero dans le tableau nosoar de l'arete a traiter
7217 c mosoar : nombre maximal d'entiers par arete et
7218 c indice dans nosoar de l'arete suivante dans le hachage
7219 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
7220 c attention: mxsoar>3*mxsomm obligatoire!
7222 c entrees et sorties:
7223 c -------------------
7224 c n1soar : numero de la premiere arete vide dans le tableau nosoar
7225 c une arete i de nosoar est vide <=> nosoar(1,i)=0
7226 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
7227 c chainage des aretes frontalieres, chainage du hachage des aretes
7228 c n1aeoc : numero dans nosoar de la premiere arete simple de l'etoile
7232 c nbtrar : 1 si arete ajoutee, 2 si arete double supprimee
7233 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7234 c auteur : alain perronnet analyse numerique paris upmc mars 1997
7235 c2345x7..............................................................012
7236 parameter (lchain=6)
7237 integer nosoar(mosoar,mxsoar)
7239 c si l'arete n'appartient pas aux aretes de l'etoile naetoi
7240 c alors elle est ajoutee a l'etoile dans naetoi
7241 c sinon elle est empilee dans npile pour etre detruite ensuite
7242 c elle est supprimee de l'etoile naetoi
7244 if( nosoar( lchain, noar ) .lt. 0 ) then
7246 c arete de l'etoile vue pour la premiere fois
7247 c elle est ajoutee au chainage
7248 nosoar( lchain, noar ) = n1aeoc
7249 c elle devient la premiere du chainage
7256 c arete double de l'etoile. elle est supprimee du chainage
7259 c parcours des aretes chainees jusqu'a trouver l'arete noar
7260 10 if( na .ne. noar ) then
7261 c passage a la suivante
7263 na = nosoar( lchain, na )
7267 c suppression de noar du chainage des aretes simples de l'etoile
7268 if( na0 .gt. 0 ) then
7269 c il existe une arete qui precede
7270 nosoar( lchain, na0 ) = nosoar( lchain, noar )
7272 c noar est en fait n1aeoc la premiere du chainage
7273 n1aeoc = nosoar( lchain, noar )
7275 c noar n'est plus une arete simple de l'etoile
7276 nosoar( lchain, noar ) = -1
7278 c destruction du tableau nosoar de l'arete double noar
7279 call sasoar( noar, mosoar, mxsoar, n1soar, nosoar )
7287 subroutine focftr( nbtrcf, notrcf, pxyd, noarst,
7288 % mosoar, mxsoar, n1soar, nosoar,
7289 % moartr, n1artr, noartr,
7290 % nbarcf, n1arcf, noarcf,
7292 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7293 c but : former un contour ferme (cf) avec les aretes simples des
7294 c ----- nbtrcf triangles du tableau notrcf
7295 c destruction des nbtrcf triangles du tableau noartr
7296 c destruction des aretes doubles du tableau nosoar
7298 c attention: le chainage lchain de nosoar devient celui des cf
7302 c nbtrcf : nombre de triangles du cf a former
7303 c notrcf : numero des triangles dans le tableau noartr
7304 c pxyd : tableau des coordonnees 2d des points
7305 c par point : x y distance_souhaitee
7307 c mosoar : nombre maximal d'entiers par arete et
7308 c indice dans nosoar de l'arete suivante dans le hachage
7309 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
7310 c attention: mxsoar>3*mxsomm obligatoire!
7311 c moartr : nombre maximal d'entiers par arete du tableau noartr
7313 c entrees et sorties :
7314 c --------------------
7315 c noarst : noarst(i) numero d'une arete de sommet i
7316 c n1soar : numero de la premiere arete vide dans le tableau nosoar
7317 c une arete i de nosoar est vide <=> nosoar(1,i)=0
7318 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
7319 c chainage des aretes frontalieres, chainage du hachage des aretes
7320 c hachage des aretes = nosoar(1)+nosoar(2)*2
7321 c n1artr : numero du premier triangle vide dans le tableau noartr
7322 c le chainage des triangles vides se fait sur noartr(2,.)
7323 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
7324 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
7328 c nbarcf : nombre d'aretes du cf
7329 c n1arcf : numero d'une arete de chaque contour
7330 c noarcf : numero des aretes de la ligne du contour ferme
7331 c attention: chainage circulaire des aretes
7332 c les aretes vides pointes par n1arcf(0) ne sont pas chainees
7333 c ierr : 0 si pas d'erreur
7334 c 14 si les lignes fermees se coupent => donnees a revoir
7335 c 15 si une seule arete simple frontaliere
7336 c 16 si boucle infinie car toutes les aretes simples
7337 c de la boule sont frontalieres!
7338 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7339 c auteur : alain perronnet analyse numerique paris upmc mars 1997
7340 c....................................................................012
7341 parameter (lchain=6)
7342 common / unites / lecteu, imprim, nunite(30)
7343 double precision pxyd(3,*)
7344 integer notrcf(1:nbtrcf)
7345 integer nosoar(mosoar,mxsoar),
7351 c formation des aretes simples du cf autour de l'arete ns1-ns2
7352 c attention: le chainage lchain du tableau nosoar devient actif
7353 c ============================================================
7354 c ici toutes les aretes du tableau nosoar verifient nosoar(lchain,i) = -1
7355 c ce qui equivaut a dire que l'etoile des aretes simples est vide
7356 c (initialisation dans le sp insoar puis remise a -1 dans la suite!)
7359 c ajout a l'etoile des aretes simples des 3 aretes des triangles a supprimer
7360 c suppression des triangles de l'etoile pour les aretes simples de l'etoile
7362 c ajout ou retrait des 3 aretes du triangle notrcf(i) de l'etoile
7365 c l'arete de nosoar a traiter
7366 noar = abs( noartr(j,nt) )
7367 call caetoi( noar, mosoar, mxsoar, n1soar, nosoar,
7369 c si arete simple alors suppression du numero de triangle pour cette a
7370 if( nbtrar .eq. 1 ) then
7371 if( nosoar(4,noar) .eq. nt ) then
7372 nosoar(4,noar) = nosoar(5,noar)
7376 c l'arete appartient a aucun triangle => elle est vide
7377 c les positions 4 et 5 servent maintenant aux chainages des vides
7382 c les aretes simples de l'etoile sont reordonnees pour former une
7383 c ligne fermee = un contour ferme peripherique de l'etoile encore dit 1 cf
7384 c ========================================================================
7387 c la premiere arete du contour ferme
7391 c l'arete est-elle dans le sens direct?
7392 c recherche de l'arete du triangle exterieur nt d'arete na1
7394 if( nt .le. 0 ) nt = nosoar(5,na1)
7396 c attention au cas de l'arete initiale frontaliere de no de triangles 0 et -
7397 if( nt .le. 0 ) then
7398 c permutation circulaire des aretes simples chainees
7399 c la premiere arete doit devenir la derniere du chainage,
7400 c la 2=>1, la 3=>2, ... , la derniere=>l'avant derniere, 1=>derniere
7401 n1aeoc = nosoar( lchain, n1aeoc )
7402 if( n1aeoc .eq. n1ae00 ) then
7403 c attention: boucle infinie si toutes les aretes simples
7404 c de la boule sont frontalieres!... arretee par ce test
7410 14 if( noar .gt. 0 ) then
7411 c la sauvegarde de l'arete et l'arete suivante
7413 noar = nosoar(lchain,noar)
7416 if( na0 .le. 0 ) then
7417 c une seule arete simple frontaliere
7421 c le suivant de l'ancien dernier est l'ancien premier
7422 nosoar(lchain,na0) = na1
7423 c le nouveau dernier est l'ancien premier
7424 nosoar(lchain,na1) = 0
7428 c ici l'arete na1 est l'une des aretes du triangle nt
7430 if( abs(noartr(i,nt)) .eq. na1 ) then
7432 if( noartr(i,nt) .gt. 0 ) then
7433 c elle est parcourue dans le sens indirect de l'etoile
7434 c (car c'est en fait le triangle exterieur a la boule)
7442 c le 1-er sommet ou arete du contour ferme
7444 c le nombre de sommets du contour ferme de l'etoile
7446 c le premier sommet de l'etoile
7447 noarcf( 1, nbarcf ) = ns0
7448 c l'arete suivante du cf
7449 noarcf( 2, nbarcf ) = nbarcf + 1
7450 c le numero de cette arete dans le tableau nosoar
7451 noarcf( 3, nbarcf ) = na1
7452 c mise a jour du numero d'arete du sommet ns0
7455 cccc trace de l'arete
7456 ccc call dvtrar( pxyd, ns0, ns1, ncvert, ncblan )
7458 c l'arete suivante a chainer
7459 n1aeoc = nosoar( lchain, na1 )
7460 c l'arete na1 n'est plus dans l'etoile
7461 nosoar( lchain, na1 ) = -1
7463 c boucle sur les aretes simples de l'etoile
7464 20 if( n1aeoc .gt. 0 ) then
7466 c recherche de l'arete de 1-er sommet ns1
7469 25 if( na1 .gt. 0 ) then
7471 c le numero du dernier sommet de l'arete precedente
7472 c est il l'un des 2 sommets de l'arete na1?
7473 if ( ns1 .eq. nosoar(1,na1) ) then
7474 c l'autre sommet de l'arete na1
7476 else if( ns1 .eq. nosoar(2,na1) ) then
7477 c l'autre sommet de l'arete na1
7480 c non: passage a l'arete suivante
7482 na1 = nosoar( lchain, na1 )
7486 c oui: na1 est l'arete peripherique suivante
7487 c na0 est sa precedente dans le chainage
7488 c une arete de plus dans le contour ferme (cf)
7490 c le premier sommet de l'arete nbarcf peripherique
7491 noarcf( 1, nbarcf ) = ns1
7492 c l'arete suivante du cf
7493 noarcf( 2, nbarcf ) = nbarcf + 1
7494 c le numero de cette arete dans le tableau nosoar
7495 noarcf( 3, nbarcf ) = na1
7496 c mise a jour du numero d'arete du sommet ns1
7499 cccc trace de l'arete
7500 ccc call dvtrar( pxyd, ns1, ns2, ncvert, ncblan )
7502 c suppression de l'arete des aretes simples de l'etoile
7503 if( n1aeoc .eq. na1 ) then
7504 n1aeoc = nosoar( lchain, na1 )
7506 nosoar( lchain, na0 ) = nosoar( lchain, na1 )
7508 c l'arete n'est plus une arete simple de l'etoile
7509 nosoar( lchain, na1 ) = -1
7511 c le sommet final de l'arete a rechercher ensuite
7518 if( ns1 .ne. ns0 ) then
7519 c arete non retrouvee : l'etoile ne se referme pas
7521 c kerr(1) = 'focftr: revoyez vos donnees'
7522 c kerr(2) = 'les lignes fermees doivent etre disjointes'
7523 c kerr(3) = 'verifiez si elles ne se coupent pas'
7525 write(imprim,*) 'focftr: revoyez vos donnees'
7526 write(imprim,*)'les lignes fermees doivent etre disjointes'
7527 write(imprim,*)'verifiez si elles ne se coupent pas'
7532 c l'arete suivant la derniere arete du cf est la premiere du cf
7533 c => realisation d'un chainage circulaire des aretes du cf
7534 noarcf( 2, nbarcf ) = 1
7536 c destruction des triangles de l'etoile du tableau noartr
7537 c -------------------------------------------------------
7539 c le numero du triangle dans noartr
7541 c l'arete 1 de nt0 devient nulle
7542 noartr( 1, nt0 ) = 0
7543 c chainage de nt0 en tete du chainage des triangles vides de noartr
7544 noartr( 2, nt0 ) = n1artr
7550 subroutine int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x0, y0 )
7551 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7552 c but : existence ou non d'une intersection a l'interieur
7553 c ----- des 2 aretes ns1-ns2 et ns3-ns4
7554 c attention les intersections au sommet sont comptees
7558 c ns1,...ns4 : numero pxyd des 4 sommets
7559 c pxyd : les coordonnees des sommets
7563 c linter : -1 si ns3-ns4 parallele a ns1 ns2
7564 c 0 si ns3-ns4 n'intersecte pas ns1-ns2 entre les aretes
7565 c 1 si ns3-ns4 intersecte ns1-ns2 entre les aretes
7566 c 2 si le point d'intersection est ns1 entre ns3-ns4
7567 c 3 si le point d'intersection est ns3 entre ns1-ns2
7568 c 4 si le point d'intersection est ns4 entre ns1-ns2
7569 c x0,y0 : 2 coordonnees du point d'intersection s'il existe(linter>=1)
7570 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7571 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
7572 c2345x7..............................................................012
7573 parameter ( epsmoi=-0.000001d0, eps=0.001d0,
7574 % unmeps= 0.999d0, unpeps=1.000001d0 )
7575 double precision pxyd(3,*), x0, y0
7576 double precision x1,y1,x21,y21,d21,x43,y43,d43,d,x,y,p21,p43
7580 x21 = pxyd(1,ns2) - x1
7581 y21 = pxyd(2,ns2) - y1
7582 d21 = x21**2 + y21**2
7584 x43 = pxyd(1,ns4) - pxyd(1,ns3)
7585 y43 = pxyd(2,ns4) - pxyd(2,ns3)
7586 d43 = x43**2 + y43**2
7588 c les 2 aretes sont-elles jugees paralleles ?
7589 d = x43 * y21 - y43 * x21
7590 if( d*d .le. 0.000001d0 * d21 * d43 ) then
7591 c cote i parallele a ns1-ns2
7596 c les 2 coordonnees du point d'intersection
7597 x =( x1*x43*y21-pxyd(1,ns3)*x21*y43-(y1-pxyd(2,ns3))*x21*x43)/d
7598 y =(-y1*y43*x21+pxyd(2,ns3)*y21*x43+(x1-pxyd(1,ns3))*y21*y43)/d
7600 c coordonnee barycentrique de x,y dans le repere ns1-ns2
7601 p21 = ( ( x - x1 ) * x21 + ( y - y1 ) * y21 ) / d21
7602 c coordonnee barycentrique de x,y dans le repere ns3-ns4
7603 p43 = ( (x - pxyd(1,ns3))* x43 + (y - pxyd(2,ns3)) * y43 ) / d43
7606 if( epsmoi .le. p21 .and. p21 .le. unpeps ) then
7607 c x,y est entre ns1-ns2
7608 if( (p21 .le. eps) .and.
7609 % (epsmoi .le. p43 .and. p43 .le. unpeps) ) then
7610 c le point x,y est proche de ns1 et interne a ns3-ns4
7615 else if( epsmoi .le. p43 .and. p43 .le. eps ) then
7616 c le point x,y est proche de ns3 et entre ns1-ns2
7621 else if( unmeps .le. p43 .and. p43 .le. unpeps ) then
7622 c le point x,y est proche de ns4 et entre ns1-ns2
7627 else if( eps .le. p43 .and. p43 .le. unmeps ) then
7628 c le point x,y est entre ns3-ns4
7636 c pas d'intersection a l'interieur des aretes
7641 subroutine tefoar( narete, nbarpi, pxyd,
7642 % mosoar, mxsoar, n1soar, nosoar,
7643 % moartr, n1artr, noartr, noarst,
7644 % mxarcf, n1arcf, noarcf, larmin, notrcf,
7646 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7647 c but : forcer l'arete narete de nosoar dans la triangulation actuelle
7648 c ----- triangulation frontale pour la reobtenir
7650 c attention: le chainage lchain(=6) de nosoar devient actif
7651 c durant la formation des contours fermes (cf)
7655 c narete : numero nosoar de l'arete frontaliere a forcer
7656 c nbarpi : numero du dernier point interne impose par l'utilisateur
7657 c pxyd : tableau des coordonnees 2d des points
7658 c par point : x y distance_souhaitee
7660 c mosoar : nombre maximal d'entiers par arete et
7661 c indice dans nosoar de l'arete suivante dans le hachage
7662 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
7663 c attention: mxsoar>3*mxsomm obligatoire!
7664 c moartr : nombre maximal d'entiers par arete du tableau noartr
7668 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
7669 c chainage des vides suivant en 3 et precedant en 2 de nosoar
7670 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
7671 c chainage des aretes frontalieres, chainage du hachage des aretes
7672 c hachage des aretes = nosoar(1)+nosoar(2)*2
7673 c avec mxsoar>=3*mxsomm
7674 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
7675 c nosoar(2,arete vide)=l'arete vide qui precede
7676 c nosoar(3,arete vide)=l'arete vide qui suit
7677 c n1artr : numero du premier triangle vide dans le tableau noartr
7678 c le chainage des triangles vides se fait sur noartr(2,.)
7679 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
7680 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
7681 c noarst : noarst(i) numero d'une arete de sommet i
7683 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
7685 c tableaux auxiliaires :
7686 c ----------------------
7687 c n1arcf : tableau (0:mxarcf) auxiliaire
7688 c noarcf : tableau (3,mxarcf) auxiliaire
7689 c larmin : tableau (mxarcf) auxiliaire
7690 c notrcf : tableau (1:mxarcf) auxiliaire
7694 c ierr : 0 si pas d'erreur
7695 c 1 saturation des sommets
7696 c 2 ns1 dans aucun triangle
7697 c 9 tableau nosoar de taille insuffisante car trop d'aretes
7699 c 10 un des tableaux n1arcf, noarcf notrcf est sature
7700 c augmenter a l'appel mxarcf
7701 c 11 algorithme defaillant
7702 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7703 c auteur : alain perronnet analyse numerique paris upmc mars 1997
7704 c....................................................................012
7705 parameter (mxpitr=32)
7706 common / unites / lecteu,imprim,intera,nunite(29)
7708 common / dv2dco / tratri
7709 double precision pxyd(3,*)
7710 integer noartr(moartr,*),
7711 % nosoar(mosoar,mxsoar),
7718 integer lapitr(mxpitr)
7719 double precision x1,y1,x2,y2,d12,d3,d4,x,y,d,dmin
7720 integer nosotr(3), ns(2)
7721 integer nacf(1:2), nacf1, nacf2
7722 equivalence (nacf(1),nacf1), (nacf(2),nacf2)
7724 c traitement de cette arete perdue
7725 ns1 = nosoar( 1, narete )
7726 ns2 = nosoar( 2, narete )
7729 c les traces sont demandes
7731 c le cadre objet global en unites utilisateur
7732 xx1 = min( pxyd(1,ns1), pxyd(1,ns2) )
7733 xx2 = max( pxyd(1,ns1), pxyd(1,ns2) )
7734 yy1 = min( pxyd(2,ns1), pxyd(2,ns2) )
7735 yy2 = max( pxyd(2,ns1), pxyd(2,ns2) )
7736 if( xx1 .ge. xx2 ) xx2 = xx1 + (yy2-yy1)
7737 if( yy1 .ge. yy2 ) yy2 = yy1 + (xx2-xx1)*0.5
7738 c call isofenetre( xx1-(xx2-xx1), xx2+(xx2-xx1),
7739 c % yy1-(yy2-yy1), yy2+(yy2-yy1) )
7742 cccc trace de l'arete perdue
7743 ccc call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
7745 c le sommet ns2 est il correct?
7747 if( na .le. 0 ) then
7748 write(imprim,*) 'tefoar: erreur sommet ',ns2,' sans arete'
7752 if( nosoar(4,na) .le. 0 ) then
7753 write(imprim,*) 'tefoar: erreur sommet ',ns2,
7754 % ' dans aucun triangle'
7759 c recherche du triangle voisin dans le sens indirect de rotation
7761 c le premier passage: recherche dans le sens ns1->ns2
7764 c recherche des triangles intersectes par le segment ns1-ns2
7765 c ==========================================================
7770 d12 = (x2-x1)**2 + (y2-y1)**2
7772 c recherche du no local du sommet ns1 dans l'un de ses triangles
7773 na01 = noarst( ns1 )
7774 if( na01 .le. 0 ) then
7775 write(imprim,*) 'tefoar: sommet ',ns1,' sans arete'
7779 nt0 = nosoar(4,na01)
7780 if( nt0 .le. 0 ) then
7781 write(imprim,*) 'tefoar: sommet ',ns1,' dans aucun triangle'
7786 c le numero des 3 sommets du triangle nt0 dans le sens direct
7787 20 call nusotr( nt0, mosoar, nosoar, moartr, noartr, nosotr )
7789 if( nosotr(na00) .eq. ns1 ) goto 26
7792 25 if( ipas .eq. 0 ) then
7793 c le second passage: recherche dans le sens ns2->ns1
7794 c tentative d'inversion des 2 sommets extremites de l'arete a forcer
7801 c les sens ns1->ns2 et ns2->ns1 ne donne pas de solution!
7802 write(imprim,*)'tefoar:arete ',ns1,' - ',ns2,' a imposer'
7803 write(imprim,*)'tefoar:anomalie sommet ',ns1,
7804 % 'non dans le triangle de sommets ',(nosotr(i),i=1,3)
7810 c le numero des aretes suivante et precedente
7811 26 na0 = nosui3( na00 )
7812 na1 = nopre3( na00 )
7816 cccc trace du triangle nt0 et de l'arete perdue
7817 ccc call mttrtr( pxyd, nt0, moartr, noartr, mosoar, nosoar,
7818 ccc % ncblan, ncjaun )
7819 ccc call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
7820 ccc call dvtrar( pxyd, ns3, ns4, ncbleu, nccyan )
7822 c point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
7823 c ------------------------------------------------------------
7824 call int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x1, y1 )
7825 if( linter .le. 0 ) then
7827 c pas d'intersection: rotation autour du point ns1
7828 c pour trouver le triangle de l'autre cote de l'arete na01
7829 if( nsens .lt. 0 ) then
7830 c sens indirect de rotation: l'arete de sommet ns1
7831 na01 = abs( noartr(na00,nt0) )
7833 c sens direct de rotation: l'arete de sommet ns1 qui precede
7834 na01 = abs( noartr(na1,nt0) )
7836 c le triangle de l'autre cote de l'arete na01
7837 if( nosoar(4,na01) .eq. nt0 ) then
7838 nt0 = nosoar(5,na01)
7840 nt0 = nosoar(4,na01)
7842 if( nt0 .gt. 0 ) goto 20
7844 c le parcours sort du domaine
7845 c il faut tourner dans l'autre sens autour de ns1
7846 if( nsens .lt. 0 ) then
7852 c dans les 2 sens, pas d'intersection => impossible
7853 c essai avec l'arete inversee ns1 <-> ns2
7854 if( ipas .eq. 0 ) goto 25
7855 write(imprim,*) 'tefoar: arete ',ns1,' ',ns2,
7856 % ' sans intersection avec les triangles actuels'
7857 write(imprim,*) 'revoyez les lignes du contour'
7862 c il existe une intersection avec l'arete opposee au sommet ns1
7863 c =============================================================
7864 c nbtrcf : nombre de triangles du cf
7868 c le triangle oppose a l'arete na0 de nt0
7869 30 noar = abs( noartr(na0,nt0) )
7870 if( nosoar(4,noar) .eq. nt0 ) then
7871 nt1 = nosoar(5,noar)
7873 nt1 = nosoar(4,noar)
7876 cccc trace du triangle nt1 et de l'arete perdue
7877 ccc call mttrtr( pxyd, nt1, moartr, noartr, mosoar, nosoar,
7878 ccc % ncjaun, ncmage )
7879 ccc call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
7881 c le numero des 3 sommets du triangle nt1 dans le sens direct
7882 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
7884 c le triangle nt1 contient il ns2 ?
7886 if( nosotr(j) .eq. ns2 ) goto 70
7889 c recherche de l'arete noar, na1 dans nt1 qui est l'arete na0 de nt0
7891 if( abs( noartr(na1,nt1) ) .eq. noar ) goto 35
7894 c trace du triangle nt1 et de l'arete perdue
7896 ccc 35 call mttrtr( pxyd, nt1, moartr, noartr, mosoar, nosoar,
7897 ccc % ncjaun, ncmage )
7898 ccc call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
7900 c recherche de l'intersection de ns1-ns2 avec les 2 autres aretes de nt1
7901 c ======================================================================
7907 c les 2 sommets de l'arete na2 de nt1
7908 noar = abs( noartr(na2,nt1) )
7909 ns3 = nosoar( 1, noar )
7910 ns4 = nosoar( 2, noar )
7911 ccc call dvtrar( pxyd, ns3, ns4, ncbleu, nccyan )
7913 c point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
7914 c ------------------------------------------------------------
7915 call int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x , y )
7916 if( linter .gt. 0 ) then
7918 c les 2 aretes s'intersectent en (x,y)
7919 c distance de (x,y) a ns3 et ns4
7920 d3 = (pxyd(1,ns3)-x)**2 + (pxyd(2,ns3)-y)**2
7921 d4 = (pxyd(1,ns4)-x)**2 + (pxyd(2,ns4)-y)**2
7922 c nsp est le point le plus proche de (x,y)
7923 if( d3 .lt. d4 ) then
7930 if( d .gt. 1d-5*d12 ) goto 60
7932 c ici le sommet nsp est trop proche de l'arete perdue ns1-ns2
7933 if( nsp .le. nbarpi ) then
7934 c point utilisateur ou frontalier non supprimable
7936 write(imprim,*) 'pause dans tefoar 1', d, d3, d4, d12
7941 c le sommet interne nsp est supprime en mettant tous les triangles
7942 c l'ayant comme sommet dans la pile notrcf des triangles a supprimer
7943 c ------------------------------------------------------------------
7944 ccc write(imprim,*) 'tefoar: le sommet ',nsp,' est supprime'
7945 c construction de la liste des triangles de sommet nsp
7946 call trp1st( nsp, noarst, mosoar, nosoar, moartr, noartr,
7947 % mxpitr, nbt, lapitr )
7948 if( nbt .le. 0 ) then
7949 c les triangles de sommet nsp ne forme pas une "boule"
7950 c avec ce sommet nsp pour "centre"
7952 % 'tefoar: pas d''etoile de triangles autour du sommet',nsp
7953 cccc trace des triangles de l'etoile du sommet nsp
7955 ccc call trpltr( nbt, lapitr, pxyd,
7956 ccc % moartr, noartr, mosoar, nosoar,
7957 ccc % ncroug, ncblan )
7958 ccc tratri = .false.
7960 write(imprim,*) 'pause dans tefoar 2'
7965 c ajout des triangles de sommet ns1 a notrcf
7970 if( nt .eq. notrcf(k) ) goto 38
7974 notrcf( nbtrcf ) = nt
7975 ccc call mttrtr( pxyd, nt, moartr, noartr, mosoar, nosoar,
7976 ccc % ncjaun, ncmage )
7977 ccc call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
7980 c ce sommet supprime n'appartient plus a aucun triangle
7983 c ns2 est-il un sommet des triangles empiles?
7984 c -------------------------------------------
7985 do 40 nt=nbtrc0+1,nbtrcf
7986 c le triangle a supprimer nt
7988 c le numero des 3 sommets du triangle nt1 dans le sens direct
7989 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr)
7991 c le sommet k de nt1
7992 if( nosotr( k ) .eq. ns2 ) then
7999 c recherche du plus proche point d'intersection de ns1-ns2
8000 c par rapport a ns2 avec les aretes des triangles ajoutes
8003 do 48 nt=nbtrc0+1,nbtrcf
8005 c le numero des 3 sommets du triangle nt1 dans le sens direct
8006 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr)
8008 c les 2 sommets de l'arete k de nt
8010 ns4 = nosotr( nosui3(k) )
8012 c point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
8013 c ------------------------------------------------------------
8014 call int1sd( ns1, ns2, ns3, ns4, pxyd,
8016 if( linter .gt. 0 ) then
8017 c les 2 aretes s'intersectent en (x,y)
8018 d = (x-x2)**2+(y-y2)**2
8019 if( d .lt. dmin ) then
8028 c redemarrage avec le triangle nt0 et l'arete na0
8029 if( nt0 .gt. 0 ) goto 30
8031 write(imprim,*) 'tefoar: algorithme defaillant'
8038 c pas d'intersection differente de l'initiale => sommet sur ns1-ns2
8039 c rotation autour du sommet par l'arete suivant na1
8041 write(imprim,*) 'tefoar 50: revoyez vos donnees'
8042 write(imprim,*) 'les lignes fermees doivent etre disjointes'
8043 write(imprim,*) 'verifiez si elles ne se coupent pas'
8048 c cas sans probleme : intersection differente de celle initiale
8049 c ================= =========================================
8050 60 nbtrcf = nbtrcf + 1
8051 notrcf( nbtrcf ) = nt1
8052 c passage au triangle suivant
8057 c ----------------------------------------------------------
8058 c ici toutes les intersections de ns1-ns2 ont ete parcourues
8059 c tous les triangles intersectes ou etendus forment les
8060 c nbtrcf triangles du tableau notrcf
8061 c ----------------------------------------------------------
8062 70 nbtrcf = nbtrcf + 1
8063 notrcf( nbtrcf ) = nt1
8065 c formation du cf des aretes simples des triangles de notrcf
8066 c et destruction des nbtrcf triangles du tableau noartr
8067 c attention: le chainage lchain du tableau nosoar devient actif
8068 c =============================================================
8069 80 if( nbtrcf*3 .gt. mxarcf ) then
8070 write(imprim,*) 'saturation du tableau noarcf'
8075 call focftr( nbtrcf, notrcf, pxyd, noarst,
8076 % mosoar, mxsoar, n1soar, nosoar,
8077 % moartr, n1artr, noartr,
8078 % nbarcf, n1arcf, noarcf,
8080 if( ierr .ne. 0 ) return
8082 c chainage des aretes vides dans le tableau noarcf
8083 c ------------------------------------------------
8084 c decalage de 2 aretes car 2 aretes sont necessaires ensuite pour
8085 c integrer 2 fois l'arete perdue et former ainsi 2 cf
8086 c comme nbtrcf*3 minore mxarcf il existe au moins 2 places vides
8087 c derriere => pas de test de debordement
8088 n1arcf(0) = nbarcf+3
8089 mmarcf = min(8*nbarcf,mxarcf)
8090 do 90 i=nbarcf+3,mmarcf
8093 noarcf(2,mmarcf) = 0
8095 c reperage des sommets ns1 ns2 de l'arete perdue dans le cf
8096 c ---------------------------------------------------------
8097 ns1 = nosoar( 1, narete )
8098 ns2 = nosoar( 2, narete )
8102 c la premiere arete dans noarcf du cf
8104 110 if( noarcf(1,na0) .ne. ns(i) ) then
8105 c passage a l'arete suivante
8106 na0 = noarcf( 2, na0 )
8109 c position dans noarcf du sommet i de l'arete perdue
8113 c formation des 2 cf chacun contenant l'arete ns1-ns2
8114 c ---------------------------------------------------
8115 c sauvegarde de l'arete suivante de celle de sommet ns1
8116 na0 = noarcf( 2, nacf1 )
8117 nt1 = noarcf( 3, nacf1 )
8121 c l'arete suivante dans le premier cf
8122 noarcf( 2, nacf1 ) = nacf2
8123 c cette arete est celle perdue
8124 noarcf( 3, nacf1 ) = narete
8130 c le premier sommet de la premiere arete du second cf
8131 noarcf( 1, n1 ) = ns2
8132 c l'arete suivante dans le second cf
8133 noarcf( 2, n1 ) = n2
8134 c cette arete est celle perdue
8135 noarcf( 3, n1 ) = narete
8136 c la seconde arete du second cf
8137 noarcf( 1, n2 ) = ns1
8138 noarcf( 2, n2 ) = na0
8139 noarcf( 3, n2 ) = nt1
8142 c recherche du precedent de nacf2
8143 130 na1 = noarcf( 2, na0 )
8144 if( na1 .ne. nacf2 ) then
8145 c passage a l'arete suivante
8149 c na0 precede nacf2 => il precede n1
8150 noarcf( 2, na0 ) = n1
8155 c triangulation directe des 2 contours fermes
8156 c l'arete ns1-ns2 devient une arete de la triangulation des 2 cf
8157 c ==============================================================
8158 call tridcf( nbcf, pxyd, noarst,
8159 % mosoar, mxsoar, n1soar, nosoar,
8160 % moartr, n1artr, noartr,
8161 % mxarcf, n1arcf, noarcf, larmin,
8162 % nbtrcf, notrcf, ierr )
8166 subroutine te4ste( nbsomm, mxsomm, pxyd, ntrp, letree,
8168 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8169 c but : decouper un te ntrp de letree en 4 sous-triangles
8170 c ----- eliminer les sommets de te trop proches des points
8174 c mxsomm : nombre maximal de points declarables dans pxyd
8175 c ntrp : numero letree du triangle a decouper en 4 sous-triangles
8179 c nbsomm : nombre actuel de points dans pxyd
8180 c pxyd : tableau des coordonnees des points
8181 c par point : x y distance_souhaitee
8182 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
8183 c letree(0,0) : no du 1-er te vide dans letree
8184 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
8185 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
8186 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
8187 c si letree(0,.)>0 alors
8188 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
8190 c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
8192 c ( j est alors une feuille de l'arbre )
8193 c letree(4,j) : no letree du sur-triangle du triangle j
8194 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
8195 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
8199 c ierr : 0 si pas d'erreur, 51 saturation letree, 52 saturation pxyd
8200 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8201 c auteur : alain perronnet analyse numerique paris upmc juillet 1994
8202 c2345x7..............................................................012
8203 common / unites / lecteu,imprim,nunite(30)
8204 integer letree(0:8,0:*)
8205 double precision pxyd(3,mxsomm)
8206 integer np(0:3),milieu(3)
8208 c debut par l'arete 2 du triangle ntrp
8213 c le milieu de l'arete i1 existe t il deja ?
8214 call n1trva( ntrp, i1, letree, noteva, niveau )
8215 if( noteva .gt. 0 ) then
8216 c il existe un te voisin
8217 c s'il existe 4 sous-triangles le milieu existe deja
8218 if( letree(0,noteva) .gt. 0 ) then
8220 nsot = letree(0,noteva)
8221 milieu(i) = letree( 5+nopre3(i1), nsot )
8226 c le milieu n'existe pas. il est cree
8228 if( nbsomm .gt. mxsomm ) then
8229 c plus assez de place dans pxyd
8230 write(imprim,*) 'te4ste: saturation pxyd'
8235 c le milieu de l'arete i
8238 c ntrp est le triangle de milieux d'arete ces 3 sommets
8239 ns1 = letree( 5+i1, ntrp )
8240 ns2 = letree( 5+i2, ntrp )
8241 pxyd(1,nbsomm) = ( pxyd(1,ns1) + pxyd(1,ns2) ) * 0.5
8242 pxyd(2,nbsomm) = ( pxyd(2,ns1) + pxyd(2,ns2) ) * 0.5
8244 c l'arete et milieu suivant
8251 c le premier triangle vide
8253 if( nsot .le. 0 ) then
8254 c manque de place. saturation letree
8256 write(imprim,*) 'te4ste: saturation letree'
8261 c mise a jour du premier te libre
8262 letree(0,0) = letree(0,nsot)
8264 c nsot est le i-eme sous triangle
8270 c le numero des points et sous triangles dans ntrp
8271 np(i) = -letree(i,ntrp)
8272 letree(i,ntrp) = nsot
8274 c le sommet commun avec le triangle ntrp
8275 letree(5+i,nsot) = letree(5+i,ntrp)
8277 c le sur-triangle et numero de sous-triangle de nsot
8278 c a laisser ici car incorrect sinon pour i=0
8279 letree(4,nsot) = ntrp
8282 c le sous-triangle du triangle
8283 letree(i,ntrp) = nsot
8286 c le numero des nouveaux sommets milieux
8287 nsot = letree(0,ntrp)
8288 letree(6,nsot) = milieu(1)
8289 letree(7,nsot) = milieu(2)
8290 letree(8,nsot) = milieu(3)
8292 nsot = letree(1,ntrp)
8293 letree(7,nsot) = milieu(3)
8294 letree(8,nsot) = milieu(2)
8296 nsot = letree(2,ntrp)
8297 letree(6,nsot) = milieu(3)
8298 letree(8,nsot) = milieu(1)
8300 nsot = letree(3,ntrp)
8301 letree(6,nsot) = milieu(2)
8302 letree(7,nsot) = milieu(1)
8304 c repartition des eventuels 4 points np dans ces 4 sous-triangles
8305 c il y a obligatoirement suffisamment de place
8307 if( np(i) .gt. 0 ) then
8308 nsot = notrpt( pxyd(1,np(i)), pxyd, ntrp, letree )
8311 if( letree(i1,nsot) .eq. 0 ) then
8312 c place libre a occuper
8313 letree(i1,nsot) = -np(i)