1 c MEFISTO2: a library to compute 2D triangulation from segmented boundaries
3 c Copyright (C) 2006-2016 CEA/DEN, EDF R&D, OPEN CASCADE
5 c This library is free software; you can redistribute it and/or
6 c modify it under the terms of the GNU Lesser General Public
7 c License as published by the Free Software Foundation; either
8 c version 2.1 of the License, or (at your option) any later version.
10 c This library is distributed in the hope that it will be useful,
11 c but WITHOUT ANY WARRANTY; without even the implied warranty of
12 c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 c Lesser General Public License for more details.
15 c You should have received a copy of the GNU Lesser General Public
16 c License along with this library; if not, write to the Free Software
17 c Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19 c See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com
21 c File : trte.f le Fortran du trianguleur plan
23 c Author : Alain PERRONNET
24 c Date : 13 novembre 2006
26 double precision function diptdr( pt , p1dr , p2dr )
27 c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++012
28 c but : calculer la distance entre un point et une droite
29 c ----- definie par 2 points p1dr et p2dr
33 c pt : le point de R ** 2
34 c p1dr p2dr : les 2 points de R ** 2 de la droite
35 c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++012
36 c programmeur : alain perronnet analyse numrique paris janvier 1986
37 c....................................................................012
38 double precision pt(2),p1dr(2),p2dr(2), a, b, c
40 c les coefficients de la droite a x + by + c =0
43 c = - a * p1dr(1) - b * p1dr(2)
45 c la distance = | a * x + b * y + c | / sqrt( a*a + b*b )
46 diptdr = abs( a * pt(1) + b * pt(2) + c ) / sqrt( a*a + b*b )
49 subroutine qutr2d( p1, p2, p3, qualite )
50 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
51 c but : calculer la qualite d'un triangle de r**2
52 c ----- 2 coordonnees des 3 sommets en double precision
56 c p1,p2,p3 : les 3 coordonnees des 3 sommets du triangle
57 c sens direct pour une surface et qualite >0
60 c qualite: valeur de la qualite du triangle entre 0 et 1 (equilateral)
61 c 1 etant la qualite optimale
62 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
63 c auteur : alain perronnet analyse numerique upmc paris janvier 1995
64 c2345x7..............................................................012
65 parameter ( d2uxr3 = 3.4641016151377544d0 )
66 c d2uxr3 = 2 * sqrt(3)
67 double precision p1(2), p2(2), p3(2), qualite, a, b, c, p
69 c la longueur des 3 cotes
70 a = sqrt( (p2(1)-p1(1))**2 + (p2(2)-p1(2))**2 )
71 b = sqrt( (p3(1)-p2(1))**2 + (p3(2)-p2(2))**2 )
72 c = sqrt( (p1(1)-p3(1))**2 + (p1(2)-p3(2))**2 )
77 if ( (a*b*c) .ne. 0d0 ) then
78 c critere : 2 racine(3) * rayon_inscrit / plus longue arete
79 qualite = d2uxr3 * sqrt( abs( (p-a) / p * (p-b) * (p-c) ) )
86 c autres criteres possibles:
87 c critere : 2 * rayon_inscrit / rayon_circonscrit
88 c qualite = 8d0 * (p-a) * (p-b) * (p-c) / (a * b * c)
90 c critere : 3*sqrt(3.) * ray_inscrit / demi perimetre
91 c qualite = 3*sqrt(3.) * sqrt ((p-a)*(p-b)*(p-c) / p**3)
93 c critere : 2*sqrt(3.) * ray_inscrit / max( des aretes )
94 c qualite = 2*sqrt(3.) * sqrt( (p-a)*(p-b)*(p-c) / p ) / max(a,b,c)
98 double precision function surtd2( p1 , p2 , p3 )
99 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
100 c but : calcul de la surface d'un triangle defini par 3 points de R**2
102 c parametres d entree :
103 c ---------------------
104 c p1 p2 p3 : les 3 fois 2 coordonnees des sommets du triangle
106 c parametre resultat :
107 c --------------------
108 c surtd2 : surface du triangle
109 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
110 c auteur : alain perronnet analyse numerique upmc paris fevrier 1992
111 c2345x7..............................................................012
112 double precision p1(2), p2(2), p3(2)
114 c la surface du triangle
115 surtd2 = ( ( p2(1)-p1(1) ) * ( p3(2)-p1(2) )
116 % - ( p2(2)-p1(2) ) * ( p3(1)-p1(1) ) ) * 0.5d0
119 integer function nopre3( i )
120 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
121 c but : numero precedent i dans le sens circulaire 1 2 3 1 ...
123 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
124 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
125 c2345x7..............................................................012
133 integer function nosui3( i )
134 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
135 c but : numero suivant i dans le sens circulaire 1 2 3 1 ...
137 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
138 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
139 c2345x7..............................................................012
147 subroutine provec( v1 , v2 , v3 )
148 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
149 c but : v3 vecteur = produit vectoriel de 2 vecteurs de r ** 3
153 c v1, v2 : les 2 vecteurs de 3 composantes
157 c v3 : vecteur = v1 produit vectoriel v2
158 cc++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
159 c auteur : perronnet alain upmc analyse numerique paris mars 1987
160 c2345x7..............................................................012
161 double precision v1(3), v2(3), v3(3)
163 v3( 1 ) = v1( 2 ) * v2( 3 ) - v1( 3 ) * v2( 2 )
164 v3( 2 ) = v1( 3 ) * v2( 1 ) - v1( 1 ) * v2( 3 )
165 v3( 3 ) = v1( 1 ) * v2( 2 ) - v1( 2 ) * v2( 1 )
170 subroutine norme1( n, v, ierr )
171 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
172 c but : normalisation euclidienne a 1 d un vecteur v de n composantes
176 c n : nombre de composantes du vecteur
180 c v : le vecteur a normaliser a 1
184 c ierr : 1 si la norme de v est egale a 0
186 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
187 c auteur : alain perronnet analyse numerique paris mars 1987
188 c ......................................................................
189 double precision v( n ), s, sqrt
193 s = s + v( i ) * v( i )
196 c test de nullite de la norme du vecteur
197 c --------------------------------------
198 if( s .le. 0.0d0 ) then
199 c norme nulle du vecteur non normalisable a 1
204 s = 1.0d0 / sqrt( s )
213 subroutine insoar( mxsomm, mosoar, mxsoar, n1soar, nosoar )
214 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
215 c but : initialiser le tableau nosoar pour le hachage des aretes
220 c mxsomm : plus grand numero de sommet d'une arete au cours du calcul
221 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
222 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
223 c avec mxsoar>=3*mxsomm
227 c n1soar : numero de la premiere arete vide dans le tableau nosoar
228 c une arete i de nosoar est vide <=> nosoar(1,i)=0
229 c chainage des aretes vides amont et aval
230 c l'arete vide qui precede=nosoar(4,i)
231 c l'arete vide qui suit =nosoar(5,i)
232 c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
233 c chainage momentan'e d'aretes, chainage du hachage des aretes
234 c hachage des aretes = min( nosoar(1), nosoar(2) )
235 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
236 c auteur : alain perronnet analyse numerique paris upmc mars 1997
237 c2345x7..............................................................012
238 integer nosoar(mosoar,mxsoar)
240 c initialisation des aretes 1 a mxsomm
243 c sommet 1 = 0 <=> temoin d'arete vide pour le hachage
246 c arete sur aucune ligne
249 c la position de l'arete interne ou frontaliere est inconnue
252 c fin de chainage du hachage pas d'arete suivante
253 nosoar( mosoar, i ) = 0
257 c la premiere arete vide chainee est la mxsomm+1 du tableau
258 c car ces aretes ne sont pas atteignables par le hachage direct
261 c initialisation des aretes vides et des chainages
262 do 20 i = n1soar, mxsoar
264 c sommet 1 = 0 <=> temoin d'arete vide pour le hachage
267 c arete sur aucune ligne
270 c chainage sur l'arete vide qui precede
271 c (si arete occupee cela deviendra le no du triangle 1 de l'arete)
274 c chainage sur l'arete vide qui suit
275 c (si arete occupee cela deviendra le no du triangle 2 de l'arete)
278 c chainages des aretes frontalieres ou internes ou ...
281 c fin de chainage du hachage
282 nosoar( mosoar, i ) = 0
286 c la premiere arete vide n'a pas de precedent
287 nosoar( 4, n1soar ) = 0
289 c la derniere arete vide est mxsoar sans arete vide suivante
290 nosoar( 5, mxsoar ) = 0
294 subroutine azeroi ( l , ntab )
295 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
296 c but : initialisation a zero d un tableau ntab de l variables entieres
298 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
299 c auteur : alain perronnet analyse numerique upmc paris septembre 1988
300 c23456---------------------------------------------------------------012
308 subroutine fasoar( ns1, ns2, nt1, nt2, nolign,
309 % mosoar, mxsoar, n1soar, nosoar, noarst,
311 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
312 c but : former l'arete de sommet ns1-ns2 dans le hachage du tableau
313 c ----- nosoar des aretes de la triangulation
317 c ns1 ns2: numero pxyd des 2 sommets de l'arete
318 c nt1 : numero du triangle auquel appartient l'arete
319 c nt1=-1 si numero inconnu
320 c nt2 : numero de l'eventuel second triangle de l'arete si connu
321 c nt2=-1 si numero inconnu
322 c nolign : numero de la ligne de l'arete dans ladefi(wulftr-1+nolign)
323 c =0 si l'arete n'est une arete de ligne
324 c ce numero est ajoute seulement si l'arete est creee
325 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
326 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
330 c n1soar : numero de la premiere arete vide dans le tableau nosoar
331 c une arete i de nosoar est vide <=> nosoar(1,i)=0
332 c chainage des aretes vides amont et aval
333 c l'arete vide qui precede=nosoar(4,i)
334 c l'arete vide qui suit =nosoar(5,i)
335 c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
336 c chainage momentan'e d'aretes, chainage du hachage des aretes
337 c hachage des aretes = min( nosoar(1), nosoar(2) )
338 c noarst : noarst(np) numero d'une arete du sommet np
340 c ierr : si < 0 en entree pas d'affichage en cas d'erreur du type
341 c "arete appartenant a plus de 2 triangles et a creer!"
342 c si >=0 en entree affichage de ce type d'erreur
346 c noar : >0 numero de l'arete retrouvee ou ajoutee
347 c ierr : =0 si pas d'erreur
348 c =1 si le tableau nosoar est sature
349 c =2 si arete a creer et appartenant a 2 triangles distincts
350 c des triangles nt1 et nt2
351 c =3 si arete appartenant a 2 triangles distincts
352 c differents des triangles nt1 et nt2
353 c =4 si arete appartenant a 2 triangles distincts
354 c dont le second n'est pas le triangle nt2
355 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
356 c auteur : alain perronnet analyse numerique paris upmc mars 1997
357 c2345x7..............................................................012
359 common / unites / lecteu, imprim, nunite(30)
360 integer nosoar(mosoar,mxsoar), noarst(*)
365 c ajout eventuel de l'arete s1 s2 dans nosoar
369 c hachage de l'arete de sommets nu2sar
370 call hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar, noar )
371 c en sortie: noar>0 => no arete retrouvee
372 c <0 => no arete ajoutee
373 c =0 => saturation du tableau nosoar
375 if( noar .eq. 0 ) then
377 c saturation du tableau nosoar
378 write(imprim,*) 'fasoar: tableau nosoar sature'
382 else if( noar .lt. 0 ) then
384 c l'arete a ete ajoutee. initialisation des autres informations
386 c le numero de la ligne de l'arete
387 nosoar(3,noar) = nolign
388 c le triangle 1 de l'arete => le triangle nt1
390 c le triangle 2 de l'arete => le triangle nt2
392 c le chainage est mis a -1
393 nosoar(lchain,noar) = -1
395 c le sommet appartient a l'arete noar
396 noarst( nu2sar(1) ) = noar
397 noarst( nu2sar(2) ) = noar
401 c l'arete a ete retrouvee.
402 c si elle appartient a 2 triangles differents de nt1 et nt2
403 c alors il y a une erreur
404 if( nosoar(4,noar) .gt. 0 .and.
405 % nosoar(5,noar) .gt. 0 ) then
406 if( nosoar(4,noar) .ne. nt1 .and.
407 % nosoar(4,noar) .ne. nt2 .or.
408 % nosoar(5,noar) .ne. nt1 .and.
409 % nosoar(5,noar) .ne. nt2 ) then
410 c arete appartenant a plus de 2 triangles => erreur
411 if( ierr .ge. 0 ) then
412 write(imprim,*) 'erreur fasoar: arete ',noar,
413 % ' dans 2 triangles',nosoar(4,noar),nosoar(5,noar),
414 % ' et ajouter',nt1,nt2
415 write(imprim,*)'arete',noar,(nosoar(i,noar),i=1,mosoar)
418 c ERREUR. CORRECTION POUR VOIR ...
426 c mise a jour du numero des triangles de l'arete noar
427 c le triangle 2 de l'arete => le triangle nt1
428 if( nosoar(4,noar) .le. 0 ) then
429 c pas de triangle connu pour cette arete
432 c deja un triangle connu. ce nouveau est le second
433 if( nosoar(5,noar) .gt. 0 .and. nt1 .gt. 0 .and.
434 % nosoar(5,noar) .ne. nt1 ) then
435 c arete appartenant a plus de 2 triangles => erreur
436 write(imprim,*) 'erreur fasoar: arete ',noar,
437 % ' dans triangles',nosoar(4,noar),nosoar(5,noar),
438 % ' et ajouter triangle',nt1
446 c cas de l'arete frontaliere retrouvee comme diagonale d'un quadrangle
447 if( nt2 .gt. 0 ) then
448 c l'arete appartient a 2 triangles
449 if( nosoar(5,noar) .gt. 0 .and.
450 % nosoar(5,noar) .ne. nt2 ) then
451 c arete appartenant a plus de 2 triangles => erreur
452 write(imprim,*) 'erreur fasoar: arete ',noar,
453 % ' de st',nosoar(1,noar),'-',nosoar(2,noar),
454 % ' dans plus de 2 triangles'
467 subroutine fq1inv( x, y, s, xc, yc, ierr )
468 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
469 c but : calcul des 2 coordonnees (xc,yc) dans le carre (0,1)
470 c ----- image par f:carre unite-->quadrangle appartenant a q1**2
471 c par une resolution directe due a Nicolas Thenault
475 c x,y : coordonnees du point image dans le quadrangle de sommets s
476 c s : les 2 coordonnees des 4 sommets du quadrangle
480 c xc,yc : coordonnees dans le carre dont l'image par f vaut (x,y)
481 c ierr : 0 si calcul sans erreur, 1 si quadrangle degenere
482 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
483 c auteurs: thenault tulenew analyse numerique paris janvier 1998
484 c modifs : perronnet alain analyse numerique paris janvier 1998
485 c234567..............................................................012
486 real s(1:2,1:4), dist(2)
487 double precision a,b,c,d,alpha,beta,gamma,delta,x0,y0,t(2),u,v,w
492 d = s(1,1) - s(1,2) + s(1,3) - s(1,4)
495 beta = s(2,2) - s(2,1)
496 gamma = s(2,4) - s(2,1)
497 delta = s(2,1) - s(2,2) + s(2,3) - s(2,4)
499 u = beta * c - b * gamma
501 c quadrangle degenere
505 v = delta * c - d * gamma
506 w = b * delta - beta * d
508 x0 = c * (y-alpha) - gamma * (x-a)
509 y0 = b * (y-alpha) - beta * (x-a)
512 b = u * u - w * x0 - v * y0
517 delta = sqrt( b*b-4*a*c )
518 if( b .ge. 0.0 ) then
523 c la racine de plus grande valeur absolue
524 c (elle donne le plus souvent le point exterieur au carre unite
525 c donc a tester en second pour reduire les calculs)
526 t(2) = t(2) / ( 2 * a )
527 c calcul de la seconde racine a partir de la somme => plus stable
532 c la solution i donne t elle un point interne au carre unite?
533 xc = ( x0 - v * t(i) ) / u
534 yc = ( w * t(i) - y0 ) / u
535 if( 0.0 .le. xc .and. xc .le. 1.0 ) then
536 if( 0.0 .le. yc .and. yc .le. 1.0 ) goto 9000
539 c le point (xc,yc) n'est pas dans le carre unite
540 c cela peut etre du aux erreurs d'arrondi
541 c => choix par le minimum de la distance aux bords du carre
542 dist(i) = max( 0.0, -xc, xc-1.0, -yc, yc-1.0 )
546 if( dist(1) .gt. dist(2) ) then
547 c f(xc,yc) pour la racine 2 est plus proche de x,y
548 c xc yc sont deja calcules
552 else if ( b .ne. 0 ) then
558 c les 2 coordonnees du point dans le carre unite
559 xc = ( x0 - v * t(1) ) / u
560 yc = ( w * t(1) - y0 ) / u
567 subroutine ptdatr( point, pxyd, nosotr, nsigne )
568 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
569 c but : le point est il dans le triangle de sommets nosotr
574 c point : les 2 coordonnees du point
575 c pxyd : les 2 coordonnees et distance souhaitee des points du maillage
576 c nosotr : le numero des 3 sommets du triangle
580 c nsigne : >0 si le point est dans le triangle ou sur une des 3 aretes
581 c =0 si le triangle est degenere ou indirect ou ne contient pas le poin
582 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
583 c auteur : alain perronnet analyse numerique paris upmc mars 1997
584 c....................................................................012
586 double precision point(2), pxyd(3,*)
587 double precision xp,yp, x1,x2,x3, y1,y2,y3, d,dd, cb1,cb2,cb3
604 c 2 fois la surface du triangle = determinant de la matrice
605 c de calcul des coordonnees barycentriques du point p
606 d = ( x2 - x1 ) * ( y3 - y1 ) - ( x3 - x1 ) * ( y2 - y1 )
610 c triangle non degenere
611 c =====================
612 c calcul des 3 coordonnees barycentriques du
613 c point xp yp dans le triangle
614 cb1 = ( ( x2-xp ) * ( y3-yp ) - ( x3-xp ) * ( y2-yp ) ) / d
615 cb2 = ( ( x3-xp ) * ( y1-yp ) - ( x1-xp ) * ( y3-yp ) ) / d
617 ccc cb3 = ( ( x1-xp ) * ( y2-yp ) - ( x2-xp ) * ( y1-yp ) ) / d
619 ccc if( cb1 .ge. -0.00005d0 .and. cb1 .le. 1.00005d0 .and.
620 if( cb1 .ge. 0d0 .and. cb1 .le. 1d0 .and.
621 % cb2 .ge. 0d0 .and. cb2 .le. 1d0 .and.
622 % cb3 .ge. 0d0 .and. cb3 .le. 1d0 ) then
624 c le triangle nosotr contient le point
634 c le point est il du meme cote que le sommet oppose de chaque arete?
637 c le sinus de l'angle p1 p2-p1 point
640 d = ( pxyd(1,n2) - x1 ) * ( point(2) - y1 )
641 % - ( pxyd(2,n2) - y1 ) * ( point(1) - x1 )
642 dd = ( pxyd(1,n2) - x1 ) * ( pxyd(2,n3) - y1 )
643 % - ( pxyd(2,n2) - y1 ) * ( pxyd(1,n3) - x1 )
644 cb1 = ( pxyd(1,n2) - x1 ) ** 2
645 % + ( pxyd(2,n2) - y1 ) ** 2
646 cb2 = ( point(1) - x1 ) ** 2
647 % + ( point(2) - y1 ) ** 2
648 cb3 = ( pxyd(1,n3) - x1 ) ** 2
649 % + ( pxyd(2,n3) - y1 ) ** 2
650 if( abs( dd ) .le. 1e-4 * sqrt( cb1 * cb3 ) ) then
651 c le point 3 est sur l'arete 1-2
652 c le point doit y etre aussi
653 if( abs( d ) .le. 1e-4 * sqrt( cb1 * cb2 ) ) then
658 c le point 3 n'est pas sur l'arete . test des signes
659 if( d * dd .ge. 0 ) then
663 c permutation circulaire des 3 sommets et aretes
669 if( nsigne .ne. 3 ) nsigne = 0
673 integer function nosstr( p, pxyd, nt, letree )
674 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
675 c but : calculer le numero 0 a 3 du sous-triangle te contenant
680 c p : point de r**2 contenu dans le te nt de letree
681 c pxyd : x y distance des points
682 c nt : numero letree du te de te voisin a calculer
683 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
684 c letree(0,0) no du 1-er te vide dans letree
685 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
686 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
687 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
688 c si letree(0,.)>0 alors
689 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
691 c letree(0:3,j) :-no pxyd des 1
\85a 4 points internes au triangle j
693 c ( j est alors une feuille de l'arbre )
694 c letree(4,j) : no letree du sur-triangle du triangle j
695 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
696 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
700 c nosstr : 0 si le sous-triangle central contient p
701 c i =1,2,3 numero du sous-triangle contenant p
702 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
703 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
704 c2345x7..............................................................012
705 integer letree(0:8,0:*)
706 double precision pxyd(3,*), p(2),
707 % x1, y1, x21, y21, x31, y31, d, xe, ye
709 c le numero des 3 sommets du triangle
710 ns1 = letree( 6, nt )
711 ns2 = letree( 7, nt )
712 ns3 = letree( 8, nt )
714 c les coordonnees entre 0 et 1 du point p
718 x21 = pxyd(1,ns2) - x1
719 y21 = pxyd(2,ns2) - y1
721 x31 = pxyd(1,ns3) - x1
722 y31 = pxyd(2,ns3) - y1
724 d = 1.0 / ( x21 * y31 - x31 * y21 )
726 xe = ( ( p(1) - x1 ) * y31 - ( p(2) - y1 ) * x31 ) * d
727 ye = ( ( p(2) - y1 ) * x21 - ( p(1) - x1 ) * y21 ) * d
729 if( xe .gt. 0.5d0 ) then
730 c sous-triangle droit
732 else if( ye .gt. 0.5d0 ) then
735 else if( xe+ye .lt. 0.5d0 ) then
736 c sous-triangle gauche
739 c sous-triangle central
745 integer function notrpt( p, pxyd, notrde, letree )
746 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
747 c but : calculer le numero letree du sous-triangle feuille contenant
748 c ----- le point p a partir du te notrde de letree
752 c p : point de r**2 contenu dans le te nt de letree
753 c pxyd : x y distance des points
754 c notrde : numero letree du triangle depart de recherche (1=>racine)
755 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
756 c letree(0,0) no du 1-er te vide dans letree
757 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
758 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
759 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
760 c si letree(0,.)>0 alors
761 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
763 c letree(0:3,j) :-no pxyd des 1
\85 4 points internes au triangle j
765 c ( j est alors une feuille de l'arbre )
766 c letree(4,j) : no letree du sur-triangle du triangle j
767 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
768 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
772 c notrpt : numero letree du triangle contenant le point p
773 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
774 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
775 c2345x7..............................................................012
776 integer letree(0:8,0:*)
777 double precision pxyd(1:3,*), p(2)
779 c la racine depart de la recherche
782 c tant que la feuille n'est pas atteinte descendre l'arbre
783 10 if( letree(0,notrpt) .gt. 0 ) then
785 c recherche du sous-triangle contenant p
786 nsot = nosstr( p, pxyd, notrpt, letree )
788 c le numero letree du sous-triangle
789 notrpt = letree( nsot, notrpt )
796 subroutine teajpt( ns, nbsomm, mxsomm, pxyd, letree,
798 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
799 c but : ajout du point ns de pxyd dans letree
804 c ns : numero du point a ajouter dans letree
805 c mxsomm : nombre maximal de points declarables dans pxyd
806 c pxyd : tableau des coordonnees des points
807 c par point : x y distance_souhaitee
811 c nbsomm : nombre actuel de points dans pxyd
813 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
814 c letree(0,0) : no du 1-er te vide dans letree
815 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
816 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
817 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
818 c si letree(0,.)>0 alors
819 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
821 c letree(0:3,j) :-no pxyd des 1
\85a 4 points internes au triangle j
823 c ( j est alors une feuille de l'arbre )
824 c letree(4,j) : no letree du sur-triangle du triangle j
825 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
826 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
830 c ntrp : numero letree du triangle te ou a ete ajoute le point
831 c ierr : 0 si pas d'erreur, 51 saturation letree, 52 saturation pxyd
832 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
833 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
834 c2345x7..............................................................012
835 integer letree(0:8,0:*)
836 double precision pxyd(3,mxsomm)
838 c depart de la racine
841 c recherche du triangle contenant le point pxyd(ns)
842 1 ntrp = notrpt( pxyd(1,ns), pxyd, ntrp, letree )
844 c existe t il un point libre
846 if( letree(i,ntrp) .eq. 0 ) then
847 c la place i est libre
854 c pas de place libre => 4 sous-triangles sont crees
855 c a partir des 3 milieux des aretes
856 call te4ste( nbsomm, mxsomm, pxyd, ntrp, letree, ierr )
857 if( ierr .ne. 0 ) return
863 subroutine n1trva( nt, lar, letree, notrva, lhpile )
864 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
865 c but : calculer le numero letree du triangle voisin du te nt
866 c ----- par l'arete lar (1 a 3 ) de nt
867 c attention : notrva n'est pas forcement minimal
871 c nt : numero letree du te de te voisin a calculer
872 c lar : numero 1 a 3 de l'arete du triangle nt
873 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
874 c letree(0,0) no du 1-er te vide dans letree
875 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
876 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
877 c letree(0:8,1) : racine de l'arbre (triangle sans sur-triangle)
878 c si letree(0,.)>0 alors
879 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
881 c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
883 c ( j est alors une feuille de l'arbre )
884 c letree(4,j) : no letree du sur-triangle du triangle j
885 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
886 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
890 c notrva : >0 numero letree du te voisin par l'arete lar
891 c =0 si pas de te voisin (racine , ... )
892 c lhpile : =0 si nt et notrva ont meme taille
893 c >0 nt est 4**lhpile fois plus petit que notrva
894 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
895 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
896 c2345x7..............................................................012
897 integer letree(0:8,0:*)
900 c initialisation de la pile
901 c le triangle est empile
905 c tant qu'il existe un sur-triangle
906 10 ntr = lapile( lhpile )
907 if( ntr .eq. 1 ) then
908 c racine atteinte => pas de triangle voisin
914 c le type du triangle ntr
915 nty = letree( 5, ntr )
916 c l'eventuel sur-triangle
917 nsut = letree( 4, ntr )
919 if( nty .eq. 0 ) then
921 c triangle de type 0 => triangle voisin de type precedent(lar)
922 c dans le sur-triangle de ntr
923 c ce triangle remplace ntr dans lapile
924 lapile( lhpile ) = letree( nopre3(lar), nsut )
928 c triangle ntr de type nty>0
929 if( nosui3(nty) .eq. lar ) then
931 c le triangle voisin par lar est le triangle 0
932 lapile( lhpile ) = letree( 0, nsut )
936 c triangle sans voisin direct => passage par le sur-triangle
937 if( nsut .eq. 0 ) then
939 c ntr est la racine => pas de triangle voisin par cette arete
944 c le sur-triangle est empile
946 lapile(lhpile) = nsut
950 c descente aux sous-triangles selon la meme arete
951 20 notrva = lapile( lhpile )
953 30 lhpile = lhpile - 1
954 if( letree(0,notrva) .le. 0 ) then
955 c le triangle est une feuille de l'arbre 0 sous-triangle
956 c lhpile = nombre de differences de niveaux dans l'arbre
959 c le triangle a 4 sous-triangles
960 if( lhpile .gt. 0 ) then
962 c bas de pile non atteint
963 nty = letree( 5, lapile(lhpile) )
964 if( nty .eq. lar ) then
965 c l'oppose est suivant(nty) de notrva
966 notrva = letree( nosui3(nty) , notrva )
968 c l'oppose est precedent(nty) de notrva
969 notrva = letree( nopre3(nty) , notrva )
975 c meme niveau dans l'arbre lhpile = 0
979 subroutine cenced( xy1, xy2, xy3, cetria, ierr )
980 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
981 c but : calcul des coordonnees du centre du cercle circonscrit
982 c ----- du triangle defini par ses 3 sommets de coordonnees
983 c xy1 xy2 xy3 ainsi que le carre du rayon de ce cercle
987 c xy1 xy2 xy3 : les 2 coordonnees des 3 sommets du triangle
988 c ierr : <0 => pas d'affichage si triangle degenere
989 c >=0 => affichage si triangle degenere
993 c cetria : cetria(1)=abcisse du centre
994 c cetria(2)=ordonnee du centre
995 c cetria(3)=carre du rayon 1d28 si triangle degenere
996 c ierr : 0 si triangle non degenere
997 c 1 si triangle degenere
998 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
999 c auteur : perronnet alain upmc analyse numerique paris juin 1995
1000 c2345x7..............................................................012
1001 parameter (epsurf=1d-7)
1002 common / unites / lecteu,imprim,nunite(30)
1003 double precision x1,y1,x21,y21,x31,y31,
1005 % xy1(2),xy2(2),xy3(2),cetria(3)
1007 c le calcul de 2 fois l'aire du triangle
1008 c attention l'ordre des 3 sommets est direct ou non
1017 aire2 = x21 * y31 - x31 * y21
1019 c recherche d'un test relatif peu couteux
1020 c pour reperer la degenerescence du triangle
1022 % epsurf*(abs(x21)+abs(x31))*(abs(y21)+abs(y31)) ) then
1023 c triangle de qualite trop faible
1024 if( ierr .ge. 0 ) then
1026 c kerr(1) = 'erreur cenced: triangle degenere'
1028 write(imprim,*) 'erreur cenced: triangle degenere'
1029 write(imprim,10000) xy1,xy2,xy3,aire2
1031 10000 format( 3(' x=',g24.16,' y=',g24.16/),' aire*2=',g24.16)
1039 c les 2 coordonnees du centre intersection des 2 mediatrices
1040 c x = (x1+x2)/2 + lambda * (y2-y1)
1041 c y = (y1+y2)/2 - lambda * (x2-x1)
1042 c x = (x1+x3)/2 + rot * (y3-y1)
1043 c y = (y1+y3)/2 - rot * (x3-x1)
1044 c ==========================================================
1045 rot = ((xy2(1)-xy3(1))*x21 + (xy2(2)-xy3(2))*y21) / (2 * aire2)
1047 xc = ( x1 + xy3(1) ) * 0.5d0 + rot * y31
1048 yc = ( y1 + xy3(2) ) * 0.5d0 - rot * x31
1054 cetria(3) = (x1-xc) ** 2 + (y1-yc) ** 2
1056 c pas d'erreur rencontree
1061 double precision function angled( p1, p2, p3 )
1062 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1063 c but : calculer l'angle (p1p2,p1p3) en radians
1068 c p1,p2,p3 : les 2 coordonnees des 3 sommets de l'angle
1069 c sens direct pour une surface >0
1072 c angled : angle (p1p2,p1p3) en radians entre [0 et 2pi]
1073 c 0 si p1=p2 ou p1=p3
1074 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1075 c auteur : alain perronnet analyse numerique upmc paris fevrier 1992
1076 c2345x7..............................................................012
1077 double precision p1(2),p2(2),p3(2),x21,y21,x31,y31,a1,a2,d,c
1085 c longueur des cotes
1086 a1 = x21 * x21 + y21 * y21
1087 a2 = x31 * x31 + y31 * y31
1094 c cosinus de l'angle
1095 c = ( x21 * x31 + y21 * y31 ) / d
1096 if( c .le. -1.d0 ) then
1097 c tilt sur apollo si acos( -1 -eps )
1098 angled = atan( 1.d0 ) * 4.d0
1100 else if( c .ge. 1.d0 ) then
1101 c tilt sur apollo si acos( 1 + eps )
1107 if( x21 * y31 - x31 * y21 .lt. 0 ) then
1108 c demi plan inferieur
1109 angled = 8.d0 * atan( 1.d0 ) - angled
1114 subroutine teajte( mxsomm, nbsomm, pxyd, comxmi,
1115 % aretmx, mxtree, letree,
1117 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1118 c but : initialisation des tableaux letree
1119 c ----- ajout des sommets 1 a nbsomm (valeur en entree) dans letree
1123 c mxsomm : nombre maximal de sommets permis pour la triangulation
1124 c mxtree : nombre maximal de triangles equilateraux (te) declarables
1125 c aretmx : longueur maximale des aretes des triangles equilateraux
1127 c entrees et sorties :
1128 c --------------------
1129 c nbsomm : nombre de sommets apres identification
1130 c pxyd : tableau des coordonnees 2d des points
1131 c par point : x y distance_souhaitee
1132 c tableau reel(3,mxsomm)
1136 c comxmi : coordonnees minimales et maximales des points frontaliers
1137 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
1138 c letree(0,0) : no du 1-er te vide dans letree
1139 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
1140 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
1141 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
1142 c si letree(0,.)>0 alors
1143 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
1145 c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
1147 c ( j est alors une feuille de l'arbre )
1148 c letree(4,j) : no letree du sur-triangle du triangle j
1149 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
1150 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
1152 c ierr : 0 si pas d'erreur
1153 c 51 saturation letree
1154 c 52 saturation pxyd
1155 c 7 tous les points sont alignes
1156 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1157 c auteur : alain perronnet analyse numerique paris upmc juillet 1994
1158 c....................................................................012
1159 integer letree(0:8,0:mxtree)
1160 double precision pxyd(3,mxsomm)
1161 double precision comxmi(3,2)
1162 double precision a(2),s,aretmx,rac3
1164 c protection du nombre de sommets avant d'ajouter ceux de tetree
1168 comxmi(1,1) = min( comxmi(1,1), pxyd(1,i) )
1169 comxmi(1,2) = max( comxmi(1,2), pxyd(1,i) )
1170 comxmi(2,1) = min( comxmi(2,1), pxyd(2,i) )
1171 comxmi(2,2) = max( comxmi(2,2), pxyd(2,i) )
1174 c creation de l'arbre letree
1175 c ==========================
1176 c la premiere colonne vide de letree
1178 c chainage des te vides
1182 letree(0,mxtree) = 0
1183 c les maxima des 2 indices de letree
1185 letree(2,0) = mxtree
1188 c aucun point interne au triangle equilateral (te) 1
1193 c pas de sur-triangle
1196 c le numero pxyd des 3 sommets du te 1
1197 letree(6,1) = nbsomm + 1
1198 letree(7,1) = nbsomm + 2
1199 letree(8,1) = nbsomm + 3
1201 c calcul de la largeur et hauteur du rectangle englobant
1202 c ======================================================
1203 a(1) = comxmi(1,2) - comxmi(1,1)
1204 a(2) = comxmi(2,2) - comxmi(2,1)
1205 c la longueur de la diagonale
1206 s = sqrt( a(1)**2 + a(2)**2 )
1208 if( a(k) .lt. 1e-4 * s ) then
1210 write(imprim,*) 'tous les points sont alignes'
1217 c le maximum des ecarts
1220 c le triangle equilateral englobant
1221 c =================================
1222 c ecart du rectangle au triangle equilateral
1223 rac3 = sqrt( 3.0d0 )
1224 arete = a(1) + 2 * aretmx + 2 * ( a(2) + aretmx ) / rac3
1226 c le point nbsomm + 1 en bas a gauche
1228 pxyd(1,nbsomm) = (comxmi(1,1)+comxmi(1,2))*0.5d0 - arete*0.5d0
1229 pxyd(2,nbsomm) = comxmi(2,1) - aretmx
1232 c le point nbsomm + 2 en bas a droite
1234 pxyd(1,nbsomm) = pxyd(1,nbsomm-1) + arete
1235 pxyd(2,nbsomm) = pxyd(2,nbsomm-1)
1238 c le point nbsomm + 3 sommet au dessus
1240 pxyd(1,nbsomm) = pxyd(1,nbsomm-2) + arete * 0.5d0
1241 pxyd(2,nbsomm) = pxyd(2,nbsomm-2) + arete * 0.5d0 * rac3
1244 c ajout des sommets des lignes pour former letree
1245 c ===============================================
1247 c ajout du point i de pxyd a letree
1248 call teajpt( i, nbsomm, mxsomm, pxyd, letree,
1250 if( ierr .ne. 0 ) return
1257 subroutine tetaid( nutysu, dx, dy, longai, ierr )
1258 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1259 c but : calculer la longueur de l'arete ideale longai en dx,dy
1263 c nutysu : numero de traitement de areteideale() selon le type de surface
1264 c 0 pas d'emploi de la fonction areteideale() => aretmx active
1265 c 1 il existe une fonction areteideale(xyz,xyzdir)
1266 c ... autres options a definir ...
1267 c dx, dy : abscisse et ordonnee dans le plan du point (reel2!)
1271 c longai : longueur de l'areteideale(xyz,xyzdir) autour du point xyz
1272 c ierr : 0 si pas d'erreur, <>0 sinon
1273 c 1 calcul incorrect de areteideale(xyz,xyzdir)
1274 c 2 longueur calculee nulle
1275 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1276 c auteur : alain perronnet analyse numerique paris upmc mars 1997
1277 c2345x7..............................................................012
1278 common / unites / lecteu, imprim, nunite(30)
1280 double precision areteideale
1281 double precision dx, dy, longai
1282 double precision xyz(3), xyzd(3), d0
1285 if( nutysu .gt. 0 ) then
1287 c le point ou se calcule la longueur
1290 c z pour le calcul de la longueur (inactif ici!)
1292 c la direction pour le calcul de la longueur (inactif ici!)
1297 longai = areteideale(xyz,xyzd)
1299 if( longai .lt. 0d0 ) then
1300 write(imprim,10000) xyz
1301 10000 format('attention: longueur de areteideale(',
1302 % g14.6,',',g14.6,',',g14.6,')<=0! => rendue >0' )
1305 if( longai .eq. 0d0 ) then
1306 write(imprim,10001) xyz
1307 10001 format('erreur: longueur de areteideale(',
1308 % g14.6,',',g14.6,',',g14.6,')=0!' )
1316 subroutine tehote( nutysu,
1317 % nbarpi, mxsomm, nbsomm, pxyd,
1319 % letree, mxqueu, laqueu,
1321 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1322 c but : homogeneisation de l'arbre des te a un saut de taille au plus
1323 c ----- prise en compte des distances souhaitees autour des sommets initiaux
1327 c nutysu : numero de traitement de areteideale() selon le type de surface
1328 c 0 pas d'emploi de la fonction areteideale() => aretmx active
1329 c 1 il existe une fonction areteideale()
1330 c dont seules les 2 premieres composantes de uv sont actives
1331 c autres options a definir...
1332 c nbarpi : nombre de sommets de la frontiere + nombre de points internes
1333 c imposes par l'utilisateur
1334 c mxsomm : nombre maximal de sommets permis pour la triangulation et te
1335 c mxqueu : nombre d'entiers utilisables dans laqueu
1336 c comxmi : minimum et maximum des coordonnees de l'objet
1337 c aretmx : longueur maximale des aretes des triangles equilateraux
1338 c permtr : perimetre de la ligne enveloppe dans le plan
1339 c avant mise a l'echelle a 2**20
1343 c nbsomm : nombre de sommets apres identification
1344 c pxyd : tableau des coordonnees 2d des points
1345 c par point : x y distance_souhaitee
1346 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
1347 c letree(0,0) : no du 1-er te vide dans letree
1348 c letree(1,0) : maximum du 1-er indice de letree (ici 8)
1349 c letree(2,0) : maximum declare du 2-eme indice de letree (ici mxtree)
1350 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
1351 c si letree(0,.)>0 alors
1352 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
1354 c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
1356 c ( j est alors une feuille de l'arbre )
1357 c letree(4,j) : no letree du sur-triangle du triangle j
1358 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
1359 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
1363 c laqueu : mxqueu entiers servant de queue pour le parcours de letree
1367 c ierr : 0 si pas d'erreur
1368 c 51 si saturation letree dans te4ste
1369 c 52 si saturation pxyd dans te4ste
1370 c >0 si autre erreur
1371 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1372 c auteur : alain perronnet analyse numerique paris upmc avril 1997
1373 c2345x7..............................................................012
1374 double precision ampli
1375 parameter (ampli=1.34d0)
1376 common / unites / lecteu, imprim, intera, nunite(29)
1378 double precision pxyd(3,mxsomm), d2, aretm2
1379 double precision comxmi(3,2),aretmx,a,s,xrmin,xrmax,yrmin,yrmax
1380 double precision dmin, dmax
1381 integer letree(0:8,0:*)
1383 integer laqueu(1:mxqueu),lequeu
1384 c lequeu : entree dans la queue
1385 c lhqueu : longueur de la queue
1386 c gestion circulaire
1389 equivalence (nuste(1),ns1),(nuste(2),ns2),(nuste(3),ns3)
1393 c existence ou non de la fonction 'taille_ideale' des aretes
1394 c autour du point. ici la carte est supposee isotrope
1395 c ==========================================================
1396 c attention: si la fonction taille_ideale existe
1397 c alors pxyd(3,*) est la taille_ideale dans l'espace initial
1398 c sinon pxyd(3,*) est la distance calculee dans le plan par
1399 c propagation a partir des tailles des aretes de la frontiere
1401 if( nutysu .gt. 0 ) then
1403 c la fonction taille_ideale(x,y,z) existe
1404 c ---------------------------------------
1405 c initialisation de la distance souhaitee autour des points 1 a nbsomm
1407 c calcul de pxyzd(3,i)
1408 call tetaid( nutysu, pxyd(1,i), pxyd(2,i),
1410 if( ierr .ne. 0 ) goto 9999
1415 c la fonction taille_ideale(x,y,z) n'existe pas
1416 c ---------------------------------------------
1417 c prise en compte des distances souhaitees dans le plan
1418 c autour des points frontaliers et des points internes imposes
1419 c toutes les autres distances souhaitees ont ete mis a aretmx
1420 c lors de l'execution du sp teqini
1422 c le sommet i n'est pas un sommet de letree => sommet frontalier
1423 c recherche du sous-triangle minimal feuille contenant le point i
1425 2 nte = notrpt( pxyd(1,i), pxyd, nte, letree )
1426 c la distance au sommet le plus eloigne est elle inferieure
1427 c a la distance souhaitee?
1431 d2 = max( ( pxyd(1,i)-pxyd(1,ns1) )**2 +
1432 % ( pxyd(2,i)-pxyd(2,ns1) )**2
1433 % , ( pxyd(1,i)-pxyd(1,ns2) )**2 +
1434 % ( pxyd(2,i)-pxyd(2,ns2) )**2
1435 % , ( pxyd(1,i)-pxyd(1,ns3) )**2 +
1436 % ( pxyd(2,i)-pxyd(2,ns3) )**2 )
1437 if( d2 .gt. pxyd(3,i)**2 ) then
1438 c le triangle nte trop grand doit etre subdivise en 4 sous-triangle
1439 call te4ste( nbsomm, mxsomm, pxyd, nte, letree,
1441 if( ierr .ne. 0 ) return
1447 c le sous-triangle central de la racine est decoupe systematiquement
1448 c ==================================================================
1450 if( letree(0,2) .le. 0 ) then
1451 c le sous-triangle central de la racine n'est pas subdivise
1452 c il est donc decoupe en 4 soustriangles
1454 call te4ste( nbsomm, mxsomm, pxyd, nte, letree,
1456 if( ierr .ne. 0 ) return
1457 do 4 i=nbsom0+1,nbsomm
1458 c mise a jour de taille_ideale des nouveaux sommets de te
1459 call tetaid( nutysu, pxyd(1,i), pxyd(2,i),
1461 if( ierr .ne. 0 ) goto 9999
1465 c le carre de la longueur de l'arete de triangles equilateraux
1466 c souhaitee pour le fond de la triangulation
1467 aretm2 = (aretmx*ampli) ** 2
1469 c tout te contenu dans le rectangle englobant doit avoir un
1470 c cote < aretmx et etre de meme taille que les te voisins
1471 c s'il contient un point; sinon un seul saut de taille est permis
1472 c ===============================================================
1473 c le rectangle englobant pour selectionner les te "internes"
1474 c le numero des 3 sommets du te englobant racine de l'arbre des te
1479 c abscisse du milieu de l'arete gauche du te 1
1480 s = ( pxyd(1,ns1) + pxyd(1,ns3) ) / 2
1481 xrmin = min( s, comxmi(1,1) - aretmx ) - a
1482 c abscisse du milieu de l'arete droite du te 1
1483 s = ( pxyd(1,ns2) + pxyd(1,ns3) ) / 2
1484 xrmax = max( s, comxmi(1,2) + aretmx ) + a
1485 yrmin = comxmi(2,1) - aretmx
1486 c ordonnee de la droite passant par les milieus des 2 aretes
1487 c droite gauche du te 1
1488 s = ( pxyd(2,ns1) + pxyd(2,ns3) ) / 2
1489 yrmax = max( s, comxmi(2,2) + aretmx ) + a
1491 c cas particulier de 3 ou 4 ou peu d'aretes frontalieres
1492 if( nbarpi .le. 8 ) then
1493 c tout le triangle englobant (racine) est a prendre en compte
1494 xrmin = pxyd(1,ns1) - a
1495 xrmax = pxyd(1,ns2) + a
1496 yrmin = pxyd(2,ns1) - a
1497 yrmax = pxyd(2,ns3) + a
1503 c initialisation de la queue
1504 5 nbiter = nbiter + 1
1507 c la racine de letree initialise la queue
1510 c tant que la longueur de la queue est >=0 traiter le debut de queue
1511 10 if( lhqueu .ge. 0 ) then
1513 c le triangle te a traiter
1515 if( i .le. 0 ) i = mxqueu + i
1517 c la longueur de la queue est reduite
1520 c nte est il un sous-triangle feuille minimal ?
1521 15 if( letree(0,nte) .gt. 0 ) then
1523 c non les 4 sous-triangles sont mis dans la queue
1524 if( lhqueu + 4 .ge. mxqueu ) then
1525 write(imprim,*) 'tehote: saturation de la queue'
1530 c ajout du sous-triangle i
1533 if( lequeu .gt. mxqueu ) lequeu = lequeu - mxqueu
1534 laqueu( lequeu ) = letree( i, nte )
1540 c ici nte est un triangle minimal non subdivise
1541 c ---------------------------------------------
1542 c le te est il dans le cadre englobant de l'objet ?
1546 if( pxyd(1,ns1) .gt. pxyd(1,ns2) ) then
1553 if( (xrmin .le. dmin .and. dmin .le. xrmax) .or.
1554 % (xrmin .le. dmax .and. dmax .le. xrmax) ) then
1555 if( pxyd(2,ns1) .gt. pxyd(2,ns3) ) then
1562 if( (yrmin .le. dmin .and. dmin .le. yrmax) .or.
1563 % (yrmin .le. dmax .and. dmax .le. yrmax) ) then
1565 c nte est un te feuille et interne au rectangle englobant
1566 c =======================================================
1567 c le carre de la longueur de l'arete du te de numero nte
1568 d2 = (pxyd(1,ns1)-pxyd(1,ns2)) ** 2 +
1569 % (pxyd(2,ns1)-pxyd(2,ns2)) ** 2
1571 if( nutysu .eq. 0 ) then
1573 c il n'existe pas de fonction 'taille_ideale'
1574 c -------------------------------------------
1575 c si la taille effective de l'arete du te est superieure a aretmx
1576 c alors le te est decoupe
1577 if( d2 .gt. aretm2 ) then
1578 c le triangle nte trop grand doit etre subdivise
1579 c en 4 sous-triangles
1580 call te4ste( nbsomm,mxsomm, pxyd,
1581 % nte, letree, ierr )
1582 if( ierr .ne. 0 ) return
1588 c il existe ici une fonction 'taille_ideale'
1589 c ------------------------------------------
1590 c si la taille effective de l'arete du te est superieure au mini
1591 c des 3 tailles_ideales aux sommets alors le te est decoupe
1593 if( d2 .gt. (pxyd(3,nuste(i))*ampli)**2 ) then
1594 c le triangle nte trop grand doit etre subdivise
1595 c en 4 sous-triangles
1597 call te4ste( nbsomm, mxsomm, pxyd,
1598 & nte, letree, ierr )
1599 if( ierr .ne. 0 ) return
1600 do 27 j=nbsom0+1,nbsomm
1601 c mise a jour de taille_ideale des nouveaux sommets de
1602 call tetaid( nutysu, pxyd(1,j), pxyd(2,j),
1604 if( ierr .ne. 0 ) goto 9999
1611 c recherche du nombre de niveaux entre nte et les te voisins par se
1612 c si la difference de subdivisions excede 1 alors le plus grand des
1613 c =================================================================
1616 c noteva triangle voisin de nte par l'arete i
1617 call n1trva( nte, i, letree, noteva, niveau )
1618 if( noteva .le. 0 ) goto 30
1619 c il existe un te voisin
1620 if( niveau .gt. 0 ) goto 30
1621 c nte a un te voisin plus petit ou egal
1622 if( letree(0,noteva) .le. 0 ) goto 30
1623 c nte a un te voisin noteva subdivise au moins une fois
1625 if( nbiter .gt. 0 ) then
1626 c les 2 sous triangles voisins sont-ils subdivises?
1627 ns2 = letree(i,noteva)
1628 if( letree(0,ns2) .le. 0 ) then
1629 c ns2 n'est pas subdivise
1630 ns2 = letree(nosui3(i),noteva)
1631 if( letree(0,ns2) .le. 0 ) then
1632 c les 2 sous-triangles ne sont pas subdivises
1638 c saut>1 => le triangle nte doit etre subdivise en 4 sous-triang
1639 c --------------------------------------------------------------
1641 call te4ste( nbsomm,mxsomm, pxyd, nte, letree,
1643 if( ierr .ne. 0 ) return
1644 if( nutysu .gt. 0 ) then
1645 do 32 j=nbsom0+1,nbsomm
1646 c mise a jour de taille_ideale des nouveaux sommets de te
1647 call tetaid( nutysu, pxyd(1,j), pxyd(2,j),
1649 if( ierr .ne. 0 ) goto 9999
1659 if( nbs0 .lt. nbsomm ) then
1665 c pb dans le calcul de la fonction taille_ideale
1667 9999 write(imprim,*) 'pb dans le calcul de taille_ideale'
1669 c kerr(1) = 'pb dans le calcul de taille_ideale'
1675 subroutine tetrte( comxmi, aretmx, nbarpi, mxsomm, pxyd,
1676 % mxqueu, laqueu, letree,
1677 % mosoar, mxsoar, n1soar, nosoar,
1678 % moartr, mxartr, n1artr, noartr, noarst,
1680 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1681 c but : trianguler les triangles equilateraux feuilles et
1682 c ----- les points de la frontiere et les points internes imposes
1684 c attention: la triangulation finale n'est pas de type delaunay!
1688 c comxmi : minimum et maximum des coordonnees de l'objet
1689 c aretmx : longueur maximale des aretes des triangles equilateraux
1690 c nbarpi : nombre de sommets de la frontiere + nombre de points internes
1691 c imposes par l'utilisateur
1692 c mxsomm : nombre maximal de sommets declarables dans pxyd
1693 c pxyd : tableau des coordonnees 2d des points
1694 c par point : x y distance_souhaitee
1696 c mxqueu : nombre d'entiers utilisables dans laqueu
1697 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
1698 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
1699 c moartr : nombre maximal d'entiers par arete du tableau noartr
1700 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
1701 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
1702 c letree(0,0) : no du 1-er te vide dans letree
1703 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
1704 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
1705 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
1706 c si letree(0,.)>0 alors
1707 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
1709 c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
1711 c ( j est alors une feuille de l'arbre )
1712 c letree(4,j) : no letree du sur-triangle du triangle j
1713 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
1714 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
1718 c n1soar : numero de la premiere arete vide dans le tableau nosoar
1719 c une arete i de nosoar est vide <=> nosoar(1,i)=0
1720 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
1721 c chainage des aretes frontalieres, chainage du hachage des aretes
1722 c hachage des aretes = nosoar(1)+nosoar(2)*2
1723 c noarst : noarst(i) numero d'une arete de sommet i
1727 c laqueu : mxqueu entiers servant de queue pour le parcours de letree
1731 c n1artr : numero du premier triangle vide dans le tableau noartr
1732 c le chainage des triangles vides se fait sur noartr(2,.)
1733 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
1734 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
1735 c ierr : =0 si pas d'erreur
1736 c =1 si le tableau nosoar est sature
1737 c =2 si le tableau noartr est sature
1738 c =3 si aucun des triangles ne contient l'un des points internes d'un t
1739 c =5 si saturation de la queue de parcours de l'arbre des te
1740 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1741 c auteur : alain perronnet analyse numerique paris upmc mars 1997
1742 c2345x7..............................................................012
1743 common / unites / lecteu, imprim, intera, nunite(29)
1745 double precision pxyd(3,mxsomm)
1746 double precision comxmi(3,2),aretmx,a,s,xrmin,xrmax,yrmin,yrmax
1747 double precision dmin, dmax
1749 integer nosoar(mosoar,mxsoar),
1750 % noartr(moartr,mxartr),
1753 integer letree(0:8,0:*)
1754 integer laqueu(1:mxqueu)
1755 c lequeu:entree dans la queue en gestion circulaire
1756 c lhqueu:longueur de la queue en gestion circulaire
1758 integer milieu(3), nutr(1:13)
1760 c le rectangle englobant pour selectionner les te "internes"
1761 c le numero des 3 sommets du te englobant racine de l'arbre des te
1766 c abscisse du milieu de l'arete gauche du te 1
1767 s = ( pxyd(1,ns1) + pxyd(1,ns3) ) / 2
1768 xrmin = min( s, comxmi(1,1) - aretmx ) - a
1769 c abscisse du milieu de l'arete droite du te 1
1770 s = ( pxyd(1,ns2) + pxyd(1,ns3) ) / 2
1771 xrmax = max( s, comxmi(1,2) + aretmx ) + a
1772 yrmin = comxmi(2,1) - aretmx
1773 c ordonnee de la droite passant par les milieus des 2 aretes
1774 c droite gauche du te 1
1775 s = ( pxyd(2,ns1) + pxyd(2,ns3) ) / 2
1776 yrmax = max( s, comxmi(2,2) + aretmx ) + a
1778 c cas particulier de 3 ou 4 ou peu d'aretes frontalieres
1779 if( nbarpi .le. 8 ) then
1780 c tout le triangle englobant (racine) est a prendre en compte
1781 xrmin = pxyd(1,ns1) - a
1782 xrmax = pxyd(1,ns2) + a
1783 yrmin = pxyd(2,ns1) - a
1784 yrmax = pxyd(2,ns3) + a
1787 c initialisation du tableau noartr
1789 c le numero de l'arete est inconnu
1791 c le chainage sur le triangle vide suivant
1794 noartr(2,mxartr) = 0
1797 c parcours des te jusqu'a trianguler toutes les feuilles (triangles eq)
1798 c =====================================================================
1799 c initialisation de la queue sur les te
1803 c la racine de letree initialise la queue
1806 c tant que la longueur de la queue est >=0 traiter le debut de queue
1807 10 if( lhqueu .ge. 0 ) then
1809 c le triangle te a traiter
1811 if( i .le. 0 ) i = mxqueu + i
1813 c la longueur est reduite
1816 c nte est il un sous-triangle feuille (minimal) ?
1817 15 if( letree(0,nte) .gt. 0 ) then
1818 c non les 4 sous-triangles sont mis dans la queue
1819 if( lhqueu + 4 .ge. mxqueu ) then
1820 write(imprim,*) 'tetrte: saturation de la queue'
1825 c ajout du sous-triangle i
1828 if( lequeu .gt. mxqueu ) lequeu = lequeu - mxqueu
1829 laqueu( lequeu ) = letree( i, nte )
1834 c ici nte est un triangle minimal non subdivise
1835 c ---------------------------------------------
1836 c le te est il dans le cadre englobant de l'objet ?
1840 if( pxyd(1,ns1) .gt. pxyd(1,ns2) ) then
1847 if( (xrmin .le. dmin .and. dmin .le. xrmax) .or.
1848 % (xrmin .le. dmax .and. dmax .le. xrmax) ) then
1849 if( pxyd(2,ns1) .gt. pxyd(2,ns3) ) then
1856 if( (yrmin .le. dmin .and. dmin .le. yrmax) .or.
1857 % (yrmin .le. dmax .and. dmax .le. yrmax) ) then
1859 c te minimal et interne au rectangle englobant
1860 c --------------------------------------------
1861 c recherche du nombre de niveaux entre nte et les te voisins
1866 c a priori pas de milieu de l'arete i du te nte
1869 c recherche de noteva te voisin de nte par l'arete i
1870 call n1trva( nte, i, letree, noteva, niveau )
1871 c noteva : >0 numero letree du te voisin par l'arete i
1872 c =0 si pas de te voisin (racine , ... )
1873 c niveau : =0 si nte et noteva ont meme taille
1874 c >0 nte est 4**niveau fois plus petit que noteva
1875 if( noteva .gt. 0 ) then
1876 c il existe un te voisin
1877 if( letree(0,noteva) .gt. 0 ) then
1878 c noteva est plus petit que nte
1879 c => recherche du numero du milieu du cote=sommet du te no
1880 c le sous-te 0 du te noteva
1881 nsot = letree(0,noteva)
1882 c le numero dans pxyd du milieu de l'arete i de nte
1883 milieu( i ) = letree( 5+nopre3(i), nsot )
1890 c triangulation du te nte en fonction du nombre de ses milieux
1891 goto( 50, 100, 200, 300 ) , nbmili + 1
1893 c 0 milieu => 1 triangle = le te nte
1894 c ----------------------------------
1895 50 call f0trte( letree(0,nte), pxyd,
1896 % mosoar, mxsoar, n1soar, nosoar,
1897 % moartr, mxartr, n1artr, noartr,
1899 % nbtr, nutr, ierr )
1900 if( ierr .ne. 0 ) return
1903 c 1 milieu => 2 triangles = 2 demi te
1904 c -----------------------------------
1905 100 call f1trte( letree(0,nte), pxyd, milieu,
1906 % mosoar, mxsoar, n1soar, nosoar,
1907 % moartr, mxartr, n1artr, noartr,
1909 % nbtr, nutr, ierr )
1910 if( ierr .ne. 0 ) return
1913 c 2 milieux => 3 triangles
1914 c -----------------------------------
1915 200 call f2trte( letree(0,nte), pxyd, milieu,
1916 % mosoar, mxsoar, n1soar, nosoar,
1917 % moartr, mxartr, n1artr, noartr,
1919 % nbtr, nutr, ierr )
1920 if( ierr .ne. 0 ) return
1923 c 3 milieux => 4 triangles = 4 quart te
1924 c -------------------------------------
1925 300 call f3trte( letree(0,nte), pxyd, milieu,
1926 % mosoar, mxsoar, n1soar, nosoar,
1927 % moartr, mxartr, n1artr, noartr,
1929 % nbtr, nutr, ierr )
1930 if( ierr .ne. 0 ) return
1939 subroutine aisoar( mosoar, mxsoar, nosoar, na1 )
1940 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1941 c but : chainer en colonne lchain les aretes non vides et
1942 c ----- non frontalieres du tableau nosoar
1946 c mosoar : nombre maximal d'entiers par arete dans le tableau nosoar
1947 c mxsoar : nombre maximal d'aretes frontalieres declarables
1951 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
1952 c nosoar(lchain,i)=arete interne suivante
1956 c na1 : numero dans nosoar de la premiere arete interne
1957 c les suivantes sont nosoar(lchain,na1), ...
1958 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1959 c auteur : alain perronnet analyse numerique paris upmc mars 1997
1960 c....................................................................012
1961 parameter (lchain=6)
1962 integer nosoar(mosoar,mxsoar)
1964 c formation du chainage des aretes internes a echanger eventuellement
1965 c recherche de la premiere arete non vide et non frontaliere
1967 if( nosoar(1,na1) .gt. 0 .and. nosoar(3,na1) .le. 0 ) goto 15
1970 c protection de la premiere arete non vide et non frontaliere
1972 do 20 na=na1+1,mxsoar
1973 if( nosoar(1,na) .gt. 0 .and. nosoar(3,na) .le. 0 ) then
1974 c arete interne => elle est chainee a partir de la precedente
1975 nosoar(lchain,na0) = na
1980 c la derniere arete interne n'a pas de suivante
1981 nosoar(lchain,na0) = 0
1985 subroutine tedela( pxyd, noarst,
1986 % mosoar, mxsoar, n1soar, nosoar, n1ardv,
1987 % moartr, mxartr, n1artr, noartr, modifs )
1988 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1989 c but : pour toutes les aretes chainees dans nosoar(lchain,*)
1990 c ----- du tableau nosoar
1991 c echanger la diagonale des 2 triangles si le sommet oppose
1992 c a un triangle ayant en commun une arete appartient au cercle
1993 c circonscrit de l'autre (violation boule vide delaunay)
1997 c pxyd : tableau des x y distance_souhaitee de chaque sommet
2001 c noarst : noarst(i) numero d'une arete de sommet i
2002 c mosoar : nombre maximal d'entiers par arete dans le tableau nosoar
2003 c mxsoar : nombre maximal d'aretes frontalieres declarables
2004 c n1soar : numero de la premiere arete vide dans le tableau nosoar
2005 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
2006 c n1ardv : numero dans nosoar de la premiere arete du chainage
2007 c des aretes a rendre delaunay
2009 c moartr : nombre d'entiers par triangle dans le tableau noartr
2010 c mxartr : nombre maximal de triangles declarables dans noartr
2011 c n1artr : numero du premier triangle vide dans le tableau noartr
2012 c le chainage des triangles vides se fait sur noartr(2,.)
2013 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2014 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
2015 c modifs : nombre d'echanges de diagonales pour maximiser la qualite
2016 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2017 c auteur : alain perronnet analyse numerique paris upmc mars 1997
2018 c....................................................................012
2019 parameter (lchain=6)
2020 common / unites / lecteu, imprim, nunite(30)
2021 double precision pxyd(3,*), surtd2, s123, s142, s143, s234,
2022 % s12, s34, a12, cetria(3), r0
2023 integer nosoar(mosoar,mxsoar),
2024 % noartr(moartr,mxartr),
2027 c le nombre d'echanges de diagonales pour minimiser l'aire
2031 c la premiere arete du chainage des aretes a rendre delaunay
2034 c tant que la pile des aretes a echanger eventuellement est non vide
2035 c ==================================================================
2036 20 if( na0 .gt. 0 ) then
2040 c la prochaine arete a traiter
2041 na0 = nosoar(lchain,na0)
2043 c l'arete est marquee traitee avec le numero -1
2044 nosoar(lchain,na) = -1
2046 c l'arete est elle active?
2047 if( nosoar(1,na) .eq. 0 ) goto 20
2049 c si arete frontaliere pas d'echange possible
2050 if( nosoar(3,na) .gt. 0 ) goto 20
2052 c existe-t-il 2 triangles ayant cette arete commune?
2053 if( nosoar(4,na) .le. 0 .or. nosoar(5,na) .le. 0 ) goto 20
2055 c aucun des 2 triangles est-il desactive?
2056 if( noartr(1,nosoar(4,na)) .eq. 0 .or.
2057 % noartr(1,nosoar(5,na)) .eq. 0 ) goto 20
2059 c l'arete appartient a deux triangles actifs
2060 c le numero des 4 sommets du quadrangle des 2 triangles
2061 call mt4sqa( na, moartr, noartr, mosoar, nosoar,
2062 % ns1, ns2, ns3, ns4 )
2063 if( ns4 .eq. 0 ) goto 20
2065 c carre de la longueur de l'arete ns1 ns2
2066 a12 = (pxyd(1,ns2)-pxyd(1,ns1))**2+(pxyd(2,ns2)-pxyd(2,ns1))**2
2068 c comparaison de la somme des aires des 2 triangles
2069 c -------------------------------------------------
2070 c calcul des surfaces des triangles 123 et 142 de cette arete
2071 s123=surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
2072 s142=surtd2( pxyd(1,ns1), pxyd(1,ns4), pxyd(1,ns2) )
2073 s12 = abs( s123 ) + abs( s142 )
2074 if( s12 .le. 0.001*a12 ) goto 20
2076 c calcul des surfaces des triangles 143 et 234 de cette arete
2077 s143=surtd2( pxyd(1,ns1), pxyd(1,ns4), pxyd(1,ns3) )
2078 s234=surtd2( pxyd(1,ns2), pxyd(1,ns3), pxyd(1,ns4) )
2079 s34 = abs( s234 ) + abs( s143 )
2081 if( abs(s34-s12) .gt. 1d-15*s34 ) goto 20
2083 c quadrangle convexe : le critere de delaunay intervient
2084 c ------------------ ---------------------------------
2085 c calcul du centre et rayon de la boule circonscrite a ns123
2086 c pas d'affichage si le triangle est degenere
2088 call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), cetria,
2090 if( ierr .gt. 0 ) then
2091 c ierr=1 si triangle degenere => abandon
2095 if( (cetria(1)-pxyd(1,ns4))**2+(cetria(2)-pxyd(2,ns4))**2
2096 % .lt. cetria(3) ) then
2098 c protection contre une boucle infinie sur le meme cercle
2099 if( r0 .eq. cetria(3) ) goto 20
2101 c oui: ns4 est dans le cercle circonscrit a ns1 ns2 ns3
2102 c => ns3 est aussi dans le cercle circonscrit de ns1 ns2 ns4
2103 c echange de la diagonale 12 par 34 des 2 triangles
2104 call te2t2t( na, mosoar, n1soar, nosoar, noarst,
2105 % moartr, noartr, na34 )
2106 if( na34 .eq. 0 ) goto 20
2109 c l'arete na34 est marquee traitee
2110 nosoar(lchain,na34) = -1
2113 c les aretes internes peripheriques des 2 triangles sont enchainees
2117 n = abs( noartr(i,nt) )
2118 if( n .ne. na34 ) then
2119 if( nosoar(3,n) .eq. 0 .and.
2120 % nosoar(lchain,n) .eq. -1 ) then
2121 c cette arete marquee est chainee pour etre traitee
2122 nosoar(lchain,n) = na0
2131 c retour en haut de la pile des aretes a traiter
2139 subroutine terefr( nbarpi, pxyd,
2140 % mosoar, mxsoar, n1soar, nosoar,
2141 % moartr, mxartr, n1artr, noartr, noarst,
2142 % mxarcf, n1arcf, noarcf, larmin, notrcf,
2144 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2145 c but : recherche des aretes de la frontiere non dans la triangulation
2146 c ----- triangulation frontale pour les reobtenir
2148 c attention: le chainage lchain de nosoar devient celui des cf
2153 c nbarpi : numero du dernier point interne impose par l'utilisateur
2154 c pxyd : tableau des coordonnees 2d des points
2155 c par point : x y distance_souhaitee
2156 c mosoar : nombre maximal d'entiers par arete et
2157 c indice dans nosoar de l'arete suivante dans le hachage
2158 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
2159 c attention: mxsoar>3*mxsomm obligatoire!
2160 c moartr : nombre maximal d'entiers par arete du tableau noartr
2161 c mxartr : nombre maximal de triangles declarables dans noartr
2162 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
2166 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
2167 c chainage des vides suivant en 3 et precedant en 2 de nosoar
2168 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
2169 c chainage des aretes frontalieres, chainage du hachage des aretes
2170 c hachage des aretes = nosoar(1)+nosoar(2)*2
2171 c avec mxsoar>=3*mxsomm
2172 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
2173 c nosoar(2,arete vide)=l'arete vide qui precede
2174 c nosoar(3,arete vide)=l'arete vide qui suit
2175 c n1artr : numero du premier triangle vide dans le tableau noartr
2176 c le chainage des triangles vides se fait sur noartr(2,.)
2177 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2178 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
2179 c noarst : noarst(i) numero d'une arete de sommet i
2184 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
2185 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
2186 c larmin : tableau (mxarcf) auxiliaire d'entiers
2187 c notrcf : tableau (mxarcf) auxiliaire d'entiers
2191 c nbarpe : nombre d'aretes perdues puis retrouvees
2192 c ierr : =0 si pas d'erreur
2193 c >0 si une erreur est survenue
2194 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2195 c auteur : alain perronnet analyse numerique paris upmc mars 1997
2196 c....................................................................012
2197 parameter (lchain=6)
2198 common / unites / lecteu,imprim,intera,nunite(29)
2199 double precision pxyd(3,*)
2200 integer nosoar(mosoar,mxsoar),
2201 % noartr(moartr,mxartr),
2210 c le nombre d'aretes de la frontiere non arete de la triangulation
2213 c initialisation du chainage des aretes des cf => 0 arete de cf
2214 do 10 narete=1,mxsoar
2215 nosoar( lchain, narete) = -1
2218 c boucle sur l'ensemble des aretes actuelles
2219 c ==========================================
2220 do 30 narete=1,mxsoar
2222 if( nosoar(3,narete) .gt. 0 ) then
2223 c arete appartenant a une ligne => frontaliere
2225 if(nosoar(4,narete) .le. 0 .or. nosoar(5,narete) .le. 0)then
2226 c l'arete narete frontaliere n'appartient pas a 2 triangles
2227 c => elle est perdue
2230 c le numero des 2 sommets de l'arete frontaliere perdue
2231 ns1 = nosoar( 1, narete )
2232 ns2 = nosoar( 2, narete )
2233 c write(imprim,10000) ns1,(pxyd(j,ns1),j=1,2),
2234 c % ns2,(pxyd(j,ns2),j=1,2)
2235 10000 format(' arete perdue a forcer',
2236 % (t24,'sommet=',i6,' x=',g13.5,' y=',g13.5))
2238 c traitement de cette arete perdue ns1-ns2
2239 call tefoar( narete, nbarpi, pxyd,
2240 % mosoar, mxsoar, n1soar, nosoar,
2241 % moartr, mxartr, n1artr, noartr, noarst,
2242 % mxarcf, n1arcf, noarcf, larmin, notrcf,
2244 if( ierr .ne. 0 ) return
2246 c fin du traitement de cette arete perdue et retrouvee
2254 subroutine tesuex( nblftr, nulftr,
2255 % ndtri0, nbsomm, pxyd, nslign,
2256 % mosoar, mxsoar, nosoar,
2257 % moartr, mxartr, n1artr, noartr, noarst,
2258 % nbtria, letrsu, ierr )
2259 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2260 c but : supprimer du tableau noartr les triangles externes au domaine
2261 c ----- en annulant le numero de leur 1-ere arete dans noartr
2262 c et en les chainant comme triangles vides
2266 c nblftr : nombre de lignes fermees definissant la surface
2267 c nulftr : numero des lignes fermees definissant la surface
2268 c ndtri0 : plus grand numero dans noartr d'un triangle
2269 c pxyd : tableau des coordonnees 2d des points
2270 c par point : x y distance_souhaitee
2271 c nslign : tableau du numero de sommet dans sa ligne pour chaque
2273 c numero du point dans le lexique point si interne impose
2274 c 0 si le point est interne non impose par l'utilisateur
2275 c -1 si le sommet est externe au domaine
2276 c mosoar : nombre maximal d'entiers par arete et
2277 c indice dans nosoar de l'arete suivante dans le hachage
2278 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
2279 c attention: mxsoar>3*mxsomm obligatoire!
2280 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
2281 c chainage des aretes frontalieres, chainage du hachage des aretes
2282 c hachage des aretes = nosoar(1)+nosoar(2)*2
2283 c avec mxsoar>=3*mxsomm
2284 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
2285 c nosoar(2,arete vide)=l'arete vide qui precede
2286 c nosoar(3,arete vide)=l'arete vide qui suit
2287 c moartr : nombre maximal d'entiers par arete du tableau noartr
2288 c mxartr : nombre maximal de triangles declarables
2289 c n1artr : numero du premier triangle vide dans le tableau noartr
2290 c le chainage des triangles vides se fait sur noartr(2,.)
2291 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2292 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
2293 c noarst : noarst(i) numero nosoar d'une arete de sommet i
2297 c nbtria : nombre de triangles internes au domaine
2298 c letrsu : letrsu(nt)=numero du triangle interne, 0 sinon
2299 c noarst : noarst(i) numero nosoar d'une arete du sommet i (modifi'e)
2300 c ierr : 0 si pas d'erreur, >0 sinon
2301 cc++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2302 c auteur : alain perronnet analyse numerique paris upmc mai 1999
2303 c2345x7..............................................................012
2304 common / unites / lecteu,imprim,intera,nunite(29)
2305 double precision pxyd(3,*)
2306 integer nulftr(nblftr),nslign(nbsomm),
2307 % nosoar(mosoar,mxsoar),
2308 % noartr(moartr,mxartr),
2310 integer letrsu(1:ndtri0)
2311 double precision dmin
2313 c les triangles sont a priori non marques
2318 c les aretes sont marquees non chainees
2319 do 10 noar1=1,mxsoar
2320 nosoar(6,noar1) = -2
2323 c recherche du sommet de la triangulation de plus petite abscisse
2324 c ===============================================================
2328 if( pxyd(1,i) .lt. dmin ) then
2329 c le nouveau minimum
2331 if( noar1 .gt. 0 ) then
2332 c le sommet appartient a une arete de triangle
2333 if( nosoar(4,noar1) .gt. 0 ) then
2334 c le nouveau minimum
2342 c une arete de sommet ntmin
2343 noar1 = noarst( ntmin )
2344 c un triangle d'arete noar1
2345 ntmin = nosoar( 4, noar1 )
2346 if( ntmin .le. 0 ) then
2348 c kerr(1) = 'pas de triangle d''abscisse minimale'
2350 write(imprim,*) 'pas de triangle d''abscisse minimale'
2355 c chainage des 3 aretes du triangle ntmin
2356 c =======================================
2357 c la premiere arete du chainage des aretes traitees
2358 noar1 = abs( noartr(1,ntmin) )
2359 na0 = abs( noartr(2,ntmin) )
2360 c elle est chainee sur la seconde arete du triangle ntmin
2361 nosoar(6,noar1) = na0
2362 c les 2 autres aretes du triangle ntmin sont chainees
2363 na1 = abs( noartr(3,ntmin) )
2364 c la seconde est chainee sur la troisieme arete
2366 c la troisieme n'a pas de suivante
2369 c le triangle ntmin est a l'exterieur du domaine
2370 c tous les triangles externes sont marques -123 456 789
2371 c les triangles de l'autre cote d'une arete sur une ligne
2372 c sont marques: no de la ligne de l'arete * signe oppose
2373 c =======================================================
2375 ligne = -123 456 789
2377 40 if( noar1 .ne. 0 ) then
2379 c l'arete noar1 du tableau nosoar est a traiter
2380 c ---------------------------------------------
2382 c l'arete suivante devient la premiere a traiter ensuite
2383 noar1 = nosoar(6,noar1)
2384 c l'arete noar est traitee
2389 c l'un des 2 triangles de l'arete
2391 if( nt .gt. 0 ) then
2393 c triangle deja traite pour une ligne anterieure?
2394 if( letrsu(nt) .ne. 0 .and.
2395 % abs(letrsu(nt)) .ne. ligne ) goto 60
2397 c le triangle est marque avec la valeur de ligne
2400 c chainage eventuel des autres aretes de ce triangle
2401 c si ce n'est pas encore fait
2404 c le numero na de l'arete j du triangle nt dans nosoar
2405 na = abs( noartr(j,nt) )
2406 if( nosoar(6,na) .ne. -2 ) goto 50
2408 c le numero de 1 a nblftr dans nulftr de la ligne de l'arete
2411 c si l'arete est sur une ligne fermee differente de celle envelo
2412 c et non marquee alors examen du triangle oppose
2413 if( nl .gt. 0 ) then
2415 if( nl .eq. ligne0 ) goto 50
2417 c arete frontaliere de ligne non traitee
2418 c => passage de l'autre cote de la ligne
2419 c le triangle de l'autre cote de la ligne est recherche
2420 if( nt .eq. abs( nosoar(4,na) ) ) then
2425 nt2 = abs( nosoar(nt2,na) )
2426 if( nt2 .gt. 0 ) then
2428 c le triangle nt2 de l'autre cote est marque avec le
2429 c avec le signe oppose de celui de ligne
2430 if( ligne .ge. 0 ) then
2435 letrsu(nt2) = lsigne * nl
2437 c temoin de ligne a traiter ensuite dans nulftr
2438 nulftr(nl) = -abs( nulftr(nl) )
2440 c l'arete est traitee
2445 c l'arete est traitee
2450 c arete non traitee => elle est chainee
2451 nosoar(6,na) = noar1
2461 c les triangles de la ligne fermee ont tous ete marques
2462 c plus d'arete chainee
2464 c recherche d'une nouvelle ligne fermee a traiter
2465 c ===============================================
2466 65 do 70 nl=1,nblftr
2467 if( nulftr(nl) .lt. 0 ) goto 80
2469 c plus de ligne fermee a traiter
2472 c tous les triangles de cette composante connexe
2473 c entre ligne et ligne0 vont etre marques
2474 c ==============================================
2475 c remise en etat du numero de ligne
2476 c nl est le numero de la ligne dans nulftr a traiter
2477 80 nulftr(nl) = -nulftr(nl)
2479 if( abs(letrsu(nt2)) .eq. nl ) goto 92
2482 c recherche de l'arete j du triangle nt2 avec ce numero de ligne nl
2485 c le numero de l'arete j du triangle dans nosoar
2487 na0 = abs( noartr(j,nt2) )
2488 if( nl .eq. nosoar(3,na0) ) then
2490 c na0 est l'arete de ligne nl
2491 c l'arete suivante du triangle nt2
2493 c le numero dans nosoar de l'arete i de nt2
2494 na1 = abs( noartr(i,nt2) )
2495 if( nosoar(6,na1) .eq. -2 ) then
2496 c arete non traitee => elle est la premiere du chainage
2498 c pas de suivante dans ce chainage
2504 c l'eventuelle seconde arete suivante
2506 na = abs( noartr(i,nt2) )
2507 if( nosoar(6,na) .eq. -2 ) then
2508 if( na1 .eq. 0 ) then
2509 c 1 arete non traitee et seule a chainer
2513 c 2 aretes a chainer
2519 if( noar1 .gt. 0 ) then
2521 c il existe au moins une arete a visiter pour ligne
2522 c marquage des triangles internes a la ligne nl
2529 c nt2 est le seul triangle de la ligne fermee
2536 c reperage des sommets internes ou externes dans nslign
2537 c nslign(sommet externe au domaine)=-1
2538 c nslign(sommet interne au domaine)= 0
2539 c =====================================================
2540 110 do 170 ns1=1,nbsomm
2541 c tout sommet non sur la frontiere ou interne impose
2542 c est suppose externe
2543 if( nslign(ns1) .eq. 0 ) nslign(ns1) = -1
2546 c les triangles externes sont marques vides dans le tableau noartr
2547 c ================================================================
2551 if( letrsu(nt) .le. 0 ) then
2553 c triangle nt externe
2554 if( noartr(1,nt) .ne. 0 ) then
2555 c la premiere arete est annulee
2557 c le triangle nt est considere comme etant vide
2558 noartr(2,nt) = n1artr
2564 c triangle nt interne
2568 c marquage des 3 sommets du triangle nt
2570 c le numero nosoar de l'arete i du triangle nt
2571 noar = abs( noartr(i,nt) )
2572 c le numero des 2 sommets
2573 ns1 = nosoar(1,noar)
2574 ns2 = nosoar(2,noar)
2575 c mise a jour du numero d'une arete des 2 sommets de l'arete
2576 noarst( ns1 ) = noar
2577 noarst( ns2 ) = noar
2578 c ns1 et ns2 sont des sommets de la triangulation du domaine
2579 if( nslign(ns1) .lt. 0 ) nslign(ns1)=0
2580 if( nslign(ns2) .lt. 0 ) nslign(ns2)=0
2586 c ici tout sommet externe ns verifie nslign(ns)=-1
2588 c les triangles externes sont mis a zero dans nosoar
2589 c ==================================================
2590 do 300 noar=1,mxsoar
2592 if( nosoar(1,noar) .gt. 0 ) then
2594 c le second triangle de l'arete noar
2596 if( nt .gt. 0 ) then
2597 c si le triangle nt est externe
2598 c alors il est supprime pour l'arete noar
2599 if( letrsu(nt) .le. 0 ) nosoar(5,noar)=0
2602 c le premier triangle de l'arete noar
2604 if( nt .gt. 0 ) then
2605 if( letrsu(nt) .le. 0 ) then
2606 c si le triangle nt est externe
2607 c alors il est supprime pour l'arete noar
2608 c et l'eventuel triangle oppose prend sa place
2609 c en position 4 de nosoar
2610 if( nosoar(5,noar) .gt. 0 ) then
2611 nosoar(4,noar)=nosoar(5,noar)
2622 c remise en etat pour eviter les modifications de ladefi
2623 9990 do 9991 nl=1,nblftr
2624 if( nulftr(nl) .lt. 0 ) nulftr(nl)=-nulftr(nl)
2630 subroutine trp1st( ns, noarst, mosoar, nosoar,
2631 % moartr, mxartr, noartr,
2632 % mxpile, lhpile, lapile )
2633 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2634 c but : recherche des triangles de noartr partageant le sommet ns
2636 c limite: un camembert de centre ns entame 2 fois
2637 c ne donne que l'une des parties
2641 c ns : numero du sommet
2642 c noarst : noarst(i) numero d'une arete de sommet i
2643 c mosoar : nombre maximal d'entiers par arete et
2644 c indice dans nosoar de l'arete suivante dans le hachage
2645 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
2646 c chainage des aretes frontalieres, chainage du hachage des aretes
2647 c moartr : nombre maximal d'entiers par arete du tableau noartr
2648 c mxartr : nombre de triangles declares dans noartr
2649 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2650 c mxpile : nombre maximal de triangles empilables
2654 c lhpile : >0 nombre de triangles empiles
2655 c =0 si impossible de tourner autour du point
2656 c ou zero triangle contenant le sommet ns
2657 c =-lhpile si apres butee sur la frontiere il y a a nouveau
2658 c butee sur la frontiere . a ce stade on ne peut dire si tous
2659 c les triangles ayant ce sommet ont ete recenses
2660 c ce cas arrive seulement si le sommet est sur la frontiere
2661 c par un balayage de tous les triangles, lhpile donne le
2662 c nombre de triangles de sommet ns
2663 c remarque: si la pile est saturee recherche de tous les
2664 c triangles de sommet ns par balayage de tous les triangles
2665 c lapile : numero dans noartr des triangles de sommet ns
2666 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2667 c auteur: alain perronnet analyse numerique paris upmc mars 1997
2668 c modifs: alain perronnet Laboratoire J-L. Lions UPMC Paris octobre 2006
2669 c....................................................................012
2670 common / unites / lecteu, imprim, nunite(30)
2671 integer noartr(moartr,mxartr),
2674 integer lapile(1:mxpile)
2679 c la premiere arete de sommet ns
2681 if( nar .le. 0 ) then
2682 ccc write(imprim,*) 'trp1st: sommet',ns,' sans arete'
2686 c l'arete nar est elle active?
2687 if( nosoar(1,nar) .le. 0 ) then
2688 ccc write(imprim,*) 'trp1st: arete vide',nar,
2689 ccc % ' st1:', nosoar(1,nar),' st2:',nosoar(2,nar)
2693 c le premier triangle de sommet ns
2694 nt0 = abs( nosoar(4,nar) )
2695 if( nt0 .le. 0 ) then
2696 write(imprim,*) 'trp1st: sommet',ns,' dans aucun triangle'
2700 c le triangle est il actif?
2701 if( noartr(1,nt0) .eq. 0 ) goto 100
2703 c le numero des 3 sommets du triangle nt0 dans le sens direct
2704 call nusotr( nt0, mosoar, nosoar, moartr, noartr, nosotr )
2706 c reperage du sommet ns dans le triangle nt0
2708 if( nosotr(nar) .eq. ns ) goto 10
2710 c pas de sommet ns dans le triangle nt0
2713 c ns retrouve : le triangle nt0 de sommet ns est empile
2718 c recherche dans le sens des aiguilles d'une montre
2719 c (sens indirect) du triangle nt1 de l'autre cote de l'arete
2720 c nar du triangle et en tournant autour du sommet ns
2721 c ==========================================================
2722 noar = abs( noartr(nar,nt0) )
2723 c le triangle nt1 oppose du triangle nt0 par l'arete noar
2724 if( nosoar(4,noar) .eq. nt0 ) then
2725 nt1 = nosoar(5,noar)
2726 else if( nosoar(5,noar) .eq. nt0 ) then
2727 nt1 = nosoar(4,noar)
2729 write(imprim,*)'trp1st: anomalie arete',noar,' sans triangle',nt0
2733 c la boucle sur les triangles nt1 de sommet ns dans le sens indirect
2734 c ==================================================================
2735 if( nt1 .gt. 0 ) then
2737 if( noartr(1,nt1) .eq. 0 ) goto 30
2739 c le triangle nt1 n'a pas ete detruit. il est actif
2740 c le triangle oppose par l'arete noar existe
2741 c le numero des 3 sommets du triangle nt1 dans le sens direct
2742 15 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
2744 c reperage du sommet ns dans nt1
2746 if( nosotr(nar) .eq. ns ) goto 25
2748 c pas de sommet ns dans le triangle nt1
2752 25 if( lhpile .ge. mxpile ) goto 100
2754 lapile(lhpile) = nt1
2756 c le triangle nt1 de l'autre cote de l'arete de sommet ns
2757 c sauvegarde du precedent triangle dans nta
2759 noar = abs( noartr(nar,nt1) )
2760 if( nosoar(4,noar) .eq. nt1 ) then
2761 nt1 = nosoar(5,noar)
2762 else if( nosoar(5,noar) .eq. nt1 ) then
2763 nt1 = nosoar(4,noar)
2765 write(imprim,*)'trp1st: Anomalie arete',noar,
2766 % ' sans triangle',nt1
2770 c le triangle suivant est il a l'exterieur?
2771 if( nt1 .le. 0 ) goto 30
2773 c non: est il le premier triangle de sommet ns?
2774 if( nt1 .ne. nt0 ) goto 15
2776 c oui: recherche terminee par arrivee sur nt0
2777 c les triangles forment un "cercle" de "centre" ns
2778 c lhpile ressort avec le signe +
2783 c pas de triangle voisin a nt1 qui doit etre frontalier
2784 c =====================================================
2785 c le parcours passe par 1 des triangles exterieurs
2786 c le parcours est inverse par l'arete de gauche
2787 c le triangle nta est le premier triangle empile
2789 lapile(lhpile) = nta
2791 c le numero des 3 sommets du triangle nta dans le sens direct
2792 call nusotr( nta, mosoar, nosoar, moartr, noartr, nosotr )
2794 if( nosotr(nar) .eq. ns ) goto 33
2798 c l'arete qui precede (rotation / ns dans le sens direct)
2799 33 if( nar .eq. 1 ) then
2805 c le triangle voisin de nta dans le sens direct
2806 noar = abs( noartr(nar,nta) )
2807 if( nosoar(4,noar) .eq. nta ) then
2808 nt1 = nosoar(5,noar)
2809 else if( nosoar(5,noar) .eq. nta ) then
2810 nt1 = nosoar(4,noar)
2812 write(imprim,*)'trp1st: Anomalie arete',noar,
2813 % ' SANS triangle',nta
2816 if( nt1 .le. 0 ) then
2817 c un seul triangle contient ns
2818 c parcours de tous les triangles pour lever le doute
2822 c boucle sur les triangles de sommet ns dans le sens direct
2823 c ==========================================================
2824 40 if( noartr(1,nt1) .eq. 0 ) goto 70
2826 c le triangle nt1 n'a pas ete detruit. il est actif
2827 c le numero des 3 sommets du triangle nt1 dans le sens direct
2828 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
2830 c reperage du sommet ns dans nt1
2832 if( nosotr(nar) .eq. ns ) goto 60
2837 60 if( lhpile .ge. mxpile ) goto 70
2839 lapile(lhpile) = nt1
2841 c l'arete qui precede dans le sens direct
2842 if( nar .eq. 1 ) then
2848 c l'arete de sommet ns dans nosoar
2849 noar = abs( noartr(nar,nt1) )
2851 c le triangle voisin de nta dans le sens direct
2853 if( nosoar(4,noar) .eq. nt1 ) then
2854 nt1 = nosoar(5,noar)
2855 else if( nosoar(5,noar) .eq. nt1 ) then
2856 nt1 = nosoar(4,noar)
2858 write(imprim,*)'trp1st: anomalie arete',noar,
2859 % ' SANS triangle',nt1
2862 if( nt1 .gt. 0 ) goto 40
2864 c butee sur le trou => fin des triangles de sommet ns
2865 c ----------------------------------------------------
2866 c impossible ici de trouver tous les triangles de sommet ns directement
2867 c les triangles de sommet ns ne forment pas une boule de centre ns
2868 c au moins 1, voire 2 triangles frontaliers de sommet ns
2872 c Balayage de tous les triangles actifs et de sommet ns
2873 c methode lourde et couteuse mais a priori tres fiable
2874 c -----------------------------------------------------
2877 if( noartr(1,nt1) .ne. 0 ) then
2878 c le numero des 3 sommets du triangle i
2879 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
2881 if( nosotr(j) .eq. ns ) then
2882 c le triangle contient le sommet ns
2884 if( lhpile .gt. mxpile ) goto 9990
2885 lapile( lhpile ) = nt1
2890 c il n'est pas sur que ces triangles forment une boule de centre ns
2894 c saturation de la pile des triangles
2895 c -----------------------------------
2896 9990 write(imprim,*)'trp1st: saturation pile des triangles autour du so
2898 write(imprim,*) 'Plus de',mxpile,' triangles de sommet',ns
2899 write(imprim,19990) (ii,lapile(ii),ii=1,mxpile)
2900 19990 format(5(' triangle',i9))
2908 subroutine nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
2909 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2910 c but : calcul du numero des 3 sommets du triangle nt de noartr
2911 c ----- dans le sens direct (aire>0 si non degenere)
2915 c nt : numero du triangle dans le tableau noartr
2916 c mosoar : nombre maximal d'entiers par arete
2917 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
2918 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
2919 c moartr : nombre maximal d'entiers par arete du tableau noartr
2920 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2921 c arete1=0 si triangle vide => arete2=triangle vide suivant
2925 c nosotr : numero (dans le tableau pxyd) des 3 sommets du triangle
2926 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2927 c auteur : alain perronnet analyse numerique paris upmc mars 1997
2928 c2345x7..............................................................012
2929 integer nosoar(mosoar,*), noartr(moartr,*), nosotr(3)
2931 c les 2 sommets de l'arete 1 du triangle nt dans le sens direct
2932 na = noartr( 1, nt )
2933 if( na .gt. 0 ) then
2941 nosotr(1) = nosoar( nosotr(1), na )
2942 nosotr(2) = nosoar( nosotr(2), na )
2945 na = abs( noartr(2,nt) )
2947 c le sommet nosotr(3 du triangle 123
2948 nosotr(3) = nosoar( 1, na )
2949 if( nosotr(3) .eq. nosotr(1) .or. nosotr(3) .eq. nosotr(2) ) then
2950 nosotr(3) = nosoar(2,na)
2955 subroutine tesusp( quamal, nbarpi, pxyd, noarst,
2956 % mosoar, mxsoar, n1soar, nosoar,
2957 % moartr, mxartr, n1artr, noartr,
2958 % mxarcf, n1arcf, noarcf, larmin, notrcf, liarcf,
2960 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2961 c but : supprimer de la triangulation les sommets de te trop proches
2962 c ----- soit d'un sommet frontalier ou point interne impose
2963 c soit d'une arete frontaliere si la qualite minimale des triangles
2964 c est inferieure a quamal
2966 c attention: le chainage lchain de nosoar devient celui des cf
2970 c quamal : qualite des triangles au dessous de laquelle supprimer des sommets
2971 c nbarpi : numero du dernier point interne impose par l'utilisateur
2972 c pxyd : tableau des coordonnees 2d des points
2973 c par point : x y distance_souhaitee
2974 c mosoar : nombre maximal d'entiers par arete et
2975 c indice dans nosoar de l'arete suivante dans le hachage
2976 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
2977 c attention: mxsoar>3*mxsomm obligatoire!
2978 c moartr : nombre maximal d'entiers par arete du tableau noartr
2979 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
2983 c noarst : noarst(i) numero d'une arete de sommet i
2984 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
2985 c chainage des vides suivant en 3 et precedant en 2 de nosoar
2986 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
2987 c chainage des aretes frontalieres, chainage du hachage des aretes
2988 c hachage des aretes = nosoar(1)+nosoar(2)*2
2989 c avec mxsoar>=3*mxsomm
2990 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
2991 c nosoar(2,arete vide)=l'arete vide qui precede
2992 c nosoar(3,arete vide)=l'arete vide qui suit
2993 c n1artr : numero du premier triangle vide dans le tableau noartr
2994 c le chainage des triangles vides se fait sur noartr(2,.)
2995 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2996 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
3001 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
3002 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
3003 c larmin : tableau ( mxarcf ) auxiliaire d'entiers
3004 c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
3005 c liarcf : tableau ( mxarcf ) auxiliaire d'entiers
3009 c ierr : =0 si pas d'erreur
3010 c >0 si une erreur est survenue
3011 c 11 algorithme defaillant
3012 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3013 c auteur : alain perronnet analyse numerique paris upmc mars 1997
3014 c....................................................................012
3015 parameter ( lchain=6 )
3016 common / unites / lecteu,imprim,intera,nunite(29)
3017 double precision pxyd(3,*), quamal, qualit, quaopt, quamin
3018 integer nosoar(mosoar,mxsoar),
3019 % noartr(moartr,mxartr),
3028 equivalence (nosotr(1),ns1), (nosotr(2),ns2),
3031 c le nombre de sommets de te supprimes
3035 c initialisation du chainage des aretes des cf => 0 arete de cf
3036 do 10 narete=1,mxsoar
3037 nosoar( lchain, narete ) = -1
3040 c boucle sur l'ensemble des sommets frontaliers ou points internes
3041 c ================================================================
3042 do 100 ns = 1, nbarpi
3044 c le nombre de sommets supprimes pour ce sommet ns
3046 c la qualite minimale au dessous de laquelle le point proche
3047 c interne est supprime
3050 c une arete de sommet ns
3051 15 narete = noarst( ns )
3052 if( narete .le. 0 ) then
3053 c erreur: le point appartient a aucune arete
3054 write(imprim,*) 'sommet ',ns,' dans aucune arete'
3059 c recherche des triangles de sommet ns
3060 call trp1st( ns, noarst, mosoar, nosoar,
3061 % moartr, mxartr, noartr,
3062 % mxarcf, nbtrcf, notrcf )
3063 if( nbtrcf .eq. 0 ) goto 100
3064 if( nbtrcf .lt. 0 ) then
3065 c impossible de trouver tous les triangles de sommet ns
3066 c seule une partie est a priori retrouvee ce qui est normal
3067 c si ns est un sommet frontalier
3071 c boucle sur les triangles de l'etoile du sommet ns
3072 c recherche du triangle de sommet ns ayant la plus basse qualite
3075 c le numero des 3 sommets du triangle nt
3077 call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
3078 c nosotr(1:3) est en equivalence avec ns1, ns2, ns3
3079 c la qualite du triangle ns1 ns2 ns3
3080 call qutr2d( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), qualit )
3081 if( qualit .lt. quamin ) then
3087 c bilan sur la qualite des triangles de sommet ns
3088 if( quamin .lt. quaopt ) then
3090 c recherche du sommet de ntqmin le plus proche et non frontalier
3091 c ==============================================================
3092 c le numero des 3 sommets du triangle ntqmin
3093 call nusotr(ntqmin, mosoar, nosoar, moartr, noartr, nosotr)
3098 if( nst .ne. ns .and. nst .gt. nbarpi ) then
3099 d = (pxyd(1,nst)-pxyd(1,ns))**2
3100 % + (pxyd(2,nst)-pxyd(2,ns))**2
3101 if( d .lt. d0 ) then
3108 if( nste .gt. 0 ) then
3110 c nste est le sommet le plus proche de ns de ce
3111 c triangle de mauvaise qualite et sommet non encore traite
3112 nste = nosotr( nste )
3114 c nste est un sommet de triangle equilateral
3115 c => le sommet nste va etre supprime
3116 c ==========================================
3117 call te1stm( nste, nbarpi, pxyd, noarst,
3118 % mosoar, mxsoar, n1soar, nosoar,
3119 % moartr, mxartr, n1artr, noartr,
3120 % mxarcf, n1arcf, noarcf,
3121 % larmin, notrcf, liarcf, ierr )
3122 if( ierr .eq. 0 ) then
3123 c un sommet de te supprime de plus
3126 c boucle jusqu'a obtenir une qualite suffisante
3127 c si triangulation tres irreguliere =>
3128 c destruction de beaucoup de points internes
3129 c les 2 variables suivantes brident ces destructions massives
3131 quaopt = quaopt * 0.8
3132 if( nbsuns .lt. 5 ) goto 15
3134 if( ierr .lt. 0 ) then
3135 c le sommet nste est externe donc non supprime
3136 c ou bien le sommet nste est le centre d'un cf dont toutes
3137 c les aretes simples sont frontalieres
3138 c dans les 2 cas le sommet n'est pas supprime
3142 c erreur motivant un arret de la triangulation
3151 write(imprim,*)'tesusp: suppression de',nbstsu,
3152 % ' sommets de te trop proches de la frontiere'
3157 subroutine teamqa( nutysu, airemx,
3158 % noarst, mosoar, mxsoar, n1soar, nosoar,
3159 % moartr, mxartr, n1artr, noartr,
3160 % mxtrcf, notrcf, nostbo,
3161 % n1arcf, noarcf, larmin,
3162 % nbarpi, nbsomm, mxsomm, pxyd, nslign,
3164 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3165 c but: Boucles sur les aretes actives de la triangulation actuelle
3166 c ---- si la taille de l'arete moyenne est >ampli*taille souhaitee
3167 c alors ajout d'un sommet barycentre du plus grand triangle
3169 c si la taille de l'arete moyenne est <ampli/2*taille souhaitee
3170 c alors suppression du sommet ns
3171 c sinon le sommet ns devient le barycentre pondere de ses voisins
3173 c remarque: ampli est defini dans $mefisto/mail/tehote.f
3174 c et doit avoir la meme valeur pour eviter trop de modifications
3178 c nutysu : numero de traitement de areteideale() selon le type de surface
3179 c 0 pas d'emploi de la fonction areteideale() => aretmx active
3180 c 1 il existe une fonction areteideale()
3181 c dont seules les 2 premieres composantes de uv sont actives
3182 c autres options a definir...
3183 c airemx : aire maximale d'un triangle
3184 c noarst : noarst(i) numero d'une arete de sommet i
3185 c mosoar : nombre maximal d'entiers par arete et
3186 c indice dans nosoar de l'arete suivante dans le hachage
3187 c mxsoar : nombre maximal d'aretes frontalieres declarables
3188 c n1soar : numero de la premiere arete vide dans le tableau nosoar
3189 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
3190 c chainage des aretes frontalieres, chainage du hachage des aretes
3191 c moartr : nombre maximal d'entiers par arete du tableau noartr
3192 c mxartr : nombre maximal de triangles declarables dans noartr
3193 c n1artr : numero du premier triangle vide dans le tableau noartr
3194 c le chainage des triangles vides se fait sur noartr(2,.)
3195 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
3196 c mxtrcf : nombre maximal de triangles empilables
3197 c nbarpi : numero du dernier sommet frontalier ou interne impose
3198 c nslign : tableau du numero de sommet dans sa ligne pour chaque
3200 c numero du point dans le lexique point si interne impose
3201 c 0 si le point est interne non impose par l'utilisateur
3202 c -1 si le sommet est externe au domaine
3206 c nbsomm : nombre actuel de sommets de la triangulation
3207 c (certains sommets internes ont ete desactives ou ajoutes)
3208 c pxyd : tableau des coordonnees 2d des points
3212 c notrcf : tableau ( mxtrcf ) auxiliaire d'entiers
3213 c numero dans noartr des triangles de sommet ns
3214 c nostbo : tableau ( mxtrcf ) auxiliaire d'entiers
3215 c numero dans pxyd des sommets des aretes simples de la boule
3216 c n1arcf : tableau (0:mxtrcf) auxiliaire d'entiers
3217 c noarcf : tableau (3,mxtrcf) auxiliaire d'entiers
3218 c larmin : tableau ( mxtrcf ) auxiliaire d'entiers
3219 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3220 c auteur : alain perronnet analyse numerique paris upmc juin 1997
3221 c....................................................................012
3222 double precision ampli,ampli2
3223 parameter (ampli=1.34d0,ampli2=ampli/2d0)
3224 parameter (lchain=6)
3225 common / unites / lecteu, imprim, nunite(30)
3226 double precision pxyd(3,*), airemx
3227 double precision ponder, ponde1, xbar, ybar, x, y, surtd2,
3229 double precision d, dmoy, dmax, dmin, dns, xyzns(3), s0, s1
3230 integer noartr(moartr,mxartr),
3231 % nosoar(mosoar,mxsoar),
3241 c initialisation du chainage des aretes des cf => 0 arete de cf
3243 nosoar( lchain, noar ) = -1
3247 c le nombre d'iterations pour ameliorer la qualite
3251 c initialisation du parcours
3256 do 5000 iter=1,nbitaq
3258 cccc le nombre de barycentres ajoutes
3261 c coefficient de ponderation croissant avec les iterations
3262 ponder = 0.1d0 + iter * 0.5d0 / nbitaq
3263 ccc 9 octobre 2006 ponder = min( 1d0, 0.1d0 + iter * 0.9d0 / nbitaq )
3264 ccc 9 mars 2006 ponder = min( 1d0, ( 50 + (50*iter)/nbitaq ) * 0.01d0 )
3265 ponde1 = 1d0 - ponder
3267 c l'ordre du parcours dans le sens croissant ou decroissant
3268 c alternance du parcours
3274 do 1000 ns = nbs1, nbs2, nbs3
3276 c le sommet est il interne au domaine?
3277 if( nslign(ns) .ne. 0 ) goto 1000
3279 c existe-t-il une arete de sommet ns ?
3281 if( noar .le. 0 ) goto 1000
3282 if( nosoar(1,noar) .le. 0 ) goto 1000
3284 c le 1-er triangle de l'arete noar
3285 nt = nosoar( 4, noar )
3286 if( nt .le. 0 ) goto 1000
3288 c recherche des triangles de sommet ns
3289 c ils doivent former un contour ferme de type etoile
3290 call trp1st( ns, noarst, mosoar, nosoar,
3291 % moartr, mxartr, noartr,
3292 % mxtrcf, nbtrcf, notrcf )
3293 if( nbtrcf .le. 0 ) goto 1000
3295 c mise a jour de la distance souhaitee autour de ns
3298 if( nutysu .gt. 0 ) then
3299 c la fonction taille_ideale(x,y,z) existe
3300 call tetaid( nutysu, xns, yns,
3304 c boucle sur les triangles qui forment une etoile autour du sommet ns
3305 c chainage des aretes simples de l'etoile formee par ces triangles
3307 c remise a zero du lien nosoar des aretes a rendre Delaunay
3308 19 if( noar0 .gt. 0 ) then
3309 noar = nosoar(lchain,noar0)
3310 nosoar(lchain,noar0) = -1
3319 c recherche du triangle de plus grande aire
3321 call nusotr( nt, mosoar, nosoar,
3322 % moartr, noartr, nosotr )
3323 d = surtd2( pxyd(1,nosotr(1)),
3324 % pxyd(1,nosotr(2)),
3325 % pxyd(1,nosotr(3)) )
3326 if( d .gt. airetm ) then
3329 else if( d .le. 0 ) then
3330 write(imprim,*)'teamqa: triangle notrcf(',i,')=',
3331 % notrcf(i),' st', nosotr,' AIRE=',d,'<=0'
3335 c le no de l'arete du triangle nt ne contenant pas le sommet ns
3337 c le numero de l'arete na dans le tableau nosoar
3338 noar = abs( noartr(na,nt) )
3339 if( nosoar(1,noar) .ne. ns .and.
3340 % nosoar(2,noar) .ne. ns ) goto 25
3342 write(imprim,*)'teamqa: ERREUR triangle',nt,
3345 c construction de la liste des sommets des aretes simples
3346 c de la boule des triangles de sommet ns
3347 c -------------------------------------------------------
3349 ns1 = nosoar(na,noar)
3351 if( ns1 .eq. nostbo(j) ) goto 35
3353 c ns1 est un nouveau sommet a ajouter a l'etoile
3355 nostbo(nbstbo) = ns1
3358 c noar est une arete potentielle a rendre Delaunay
3359 if( nosoar(3,noar) .eq. 0 ) then
3360 c arete non frontaliere
3361 nosoar(lchain,noar) = noar0
3367 c calcul des 2 coordonnees du barycentre de la boule du sommet ns
3368 c calcul de la longueur moyenne des aretes issues du sommet ns
3369 c ---------------------------------------------------------------
3382 d = sqrt( (x-xns)**2 + (y-yns)**2 )
3384 dmax = max( dmax, d )
3385 dmin = min( dmin, d )
3386 dns = dns + pxyd(3,nst)
3388 xbar = xbar / nbstbo
3389 ybar = ybar / nbstbo
3390 dmoy = dmoy / nbstbo
3393 c pas de modification de la topologie lors de la derniere iteration
3394 c =================================================================
3395 if( iter .eq. nbitaq ) goto 200
3397 c si la taille de l'arete maximale est >ampli*taille souhaitee
3398 c alors ajout d'un sommet barycentre du plus grand triangle
3400 c ============================================================
3401 if( airetm .gt. airemx .or. dmax .gt. ampli*dns ) then
3403 c ajout du barycentre du triangle notrcf(imax)
3405 call nusotr( nt, mosoar, nosoar,
3406 % moartr, noartr, nosotr )
3407 if( nbsomm .ge. mxsomm ) then
3408 write(imprim,*) 'saturation du tableau pxyd'
3409 c abandon de l'amelioration du sommet ns
3414 pxyd(i,nbsomm) = ( pxyd(i,nosotr(1))
3415 % + pxyd(i,nosotr(2))
3416 % + pxyd(i,nosotr(3)) ) / 3d0
3418 if( nutysu .gt. 0 ) then
3419 c la fonction taille_ideale(x,y,z) existe
3420 call tetaid( nutysu, pxyd(1,nbsomm), pxyd(2,nbsomm),
3421 % pxyd(3,nbsomm), ier )
3424 c sommet interne a la triangulation
3427 c les 3 aretes du triangle nt sont a rendre delaunay
3429 noar = abs( noartr(i,nt) )
3430 if( nosoar(3,noar) .eq. 0 ) then
3431 c arete non frontaliere
3432 if( nosoar(lchain,noar) .lt. 0 ) then
3433 c arete non encore chainee
3434 nosoar(lchain,noar) = noar0
3440 c triangulation du triangle de barycentre nbsomm
3441 c protection a ne pas modifier sinon erreur!
3442 call tr3str( nbsomm, nt,
3443 % mosoar, mxsoar, n1soar, nosoar,
3444 % moartr, mxartr, n1artr, noartr,
3445 % noarst, nosotr, ierr )
3446 if( ierr .ne. 0 ) goto 9999
3448 cccc un barycentre ajoute de plus
3449 ccc nbbaaj = nbbaaj + 1
3451 c les aretes chainees de la boule sont rendues delaunay
3456 c les 2 coordonnees du barycentre des sommets des aretes
3457 c simples de la boule du sommet ns
3458 c ======================================================
3459 C DEBUT AJOUT 10 octobre 2006
3460 C PONDERATION POUR EVITER LES DEGENERESCENSES AVEC PROTECTION
3461 C SI UN TRIANGLE DE SOMMET NS A UNE AIRE NEGATIVE APRES BARYCENTRAGE
3462 C ALORS LE SOMMET NS N'EST PAS BOUGE
3464 c protection des XY du point initial
3465 200 xyzns(1) = pxyd(1,ns)
3466 xyzns(2) = pxyd(2,ns)
3467 xyzns(3) = pxyd(3,ns)
3469 c ponderation pour eviter les degenerescenses
3470 pxyd(1,ns) = ponde1 * pxyd(1,ns) + ponder * xbar
3471 pxyd(2,ns) = ponde1 * pxyd(2,ns) + ponder * ybar
3472 if( nutysu .gt. 0 ) then
3473 c la fonction taille_ideale(x,y,z) existe
3474 call tetaid( nutysu, pxyd(1,ns), pxyd(2,ns),
3478 c calcul des surfaces avant et apres deplacement de ns
3482 c le numero de l'arete du triangle nt ne contenant pas le sommet ns
3485 c le numero de l'arete na dans le tableau nosoar
3486 noar = abs( noartr(na,nt) )
3487 if( nosoar(1,noar) .ne. ns .and.
3488 % nosoar(2,noar) .ne. ns ) then
3489 ns2 = nosoar(1,noar)
3490 ns3 = nosoar(2,noar)
3494 c aire signee des 2 triangles
3495 206 s0 = s0 + abs(surtd2(xyzns, pxyd(1,ns2),pxyd(1,ns3)))
3496 s1 = s1 + abs(surtd2(pxyd(1,ns),pxyd(1,ns2),pxyd(1,ns3)))
3498 if( abs(s0-s1) .gt. 1d-10*abs(s0) ) then
3499 c retour a la position initiale
3500 c car le point est passe au dela d'une arete de son etoile
3501 pxyd(1,ns) = xyzns(1)
3502 pxyd(2,ns) = xyzns(2)
3503 pxyd(3,ns) = xyzns(3)
3504 c la ponderation est reduite 10 octobre 2006
3505 ponder = max( 0.1d0, ponder*0.5d0 )
3506 ponde1 = 1d0 - ponder
3510 c les aretes chainees de la boule sont rendues delaunay
3511 900 call tedela( pxyd, noarst,
3512 % mosoar, mxsoar, n1soar, nosoar, noar0,
3513 % moartr, mxartr, n1artr, noartr, modifs )
3517 ccc write(imprim,11000) iter, nbbaaj
3518 ccc11000 format('teamqa: iteration',i3,' =>',i6,' barycentres ajoutes')
3520 c mise a jour pour ne pas oublier les nouveaux sommets
3521 if( nbs1 .gt. nbs2 ) then
3533 subroutine teamqt( nutysu, aretmx, airemx,
3534 % noarst, mosoar, mxsoar, n1soar, nosoar,
3535 % moartr, mxartr, n1artr, noartr,
3536 % mxarcf, notrcf, nostbo,
3537 % n1arcf, noarcf, larmin,
3538 % nbarpi, nbsomm, mxsomm, pxyd, nslign,
3540 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3541 c but : amelioration de la qualite de la triangulation
3546 c nutysu : numero de traitement de areteideale() selon le type de surface
3547 c 0 pas d'emploi de la fonction areteideale() => aretmx active
3548 c 1 il existe une fonction areteideale()
3549 c dont seules les 2 premieres composantes de uv sont actives
3550 c autres options a definir...
3551 c aretmx : longueur maximale des aretes de la future triangulation
3552 c airemx : aire maximale souhaitee des triangles
3553 c noarst : noarst(i) numero d'une arete de sommet i
3554 c mosoar : nombre maximal d'entiers par arete et
3555 c indice dans nosoar de l'arete suivante dans le hachage
3556 c mxsoar : nombre maximal d'aretes frontalieres declarables
3557 c n1soar : numero de la premiere arete vide dans le tableau nosoar
3558 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
3559 c chainage des aretes frontalieres, chainage du hachage des aretes
3560 c moartr : nombre maximal d'entiers par arete du tableau noartr
3561 c mxartr : nombre maximal de triangles declarables dans noartr
3562 c n1artr : numero du premier triangle vide dans le tableau noartr
3563 c le chainage des triangles vides se fait sur noartr(2,.)
3564 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
3565 c mxarcf : nombre maximal de triangles empilables
3566 c nbarpi : numero du dernier sommet frontalier ou interne impose
3567 c nslign : tableau du numero de sommet dans sa ligne pour chaque
3569 c numero du point dans le lexique point si interne impose
3570 c 0 si le point est interne non impose par l'utilisateur
3571 c -1 si le sommet est externe au domaine
3575 c nbsomm : nombre actuel de sommets de la triangulation
3576 c (certains sommets internes ont ete desactives ou ajoutes)
3577 c pxyd : tableau des coordonnees 2d des points
3581 c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
3582 c numero dans noartr des triangles de sommet ns
3583 c nostbo : tableau ( mxarcf ) auxiliaire d'entiers
3584 c numero dans pxyd des sommets des aretes simples de la boule
3585 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
3586 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
3587 c larmin : tableau ( mxarcf ) auxiliaire d'entiers
3588 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3589 c auteur : alain perronnet analyse numerique paris upmc juin 1997
3590 c....................................................................012
3591 double precision quamal
3592 c parameter ( quamal=0.3d0 ) => ok
3593 c parameter ( quamal=0.4d0 ) => pb pour le test ocean
3594 c parameter ( quamal=0.5d0 ) => pb pour le test ocean
3595 parameter ( quamal=0.1d0 )
3596 c quamal=0.1d0 est choisi pour ne pas trop detruire de sommets
3598 common / unites / lecteu, imprim, nunite(30)
3599 double precision pxyd(3,*)
3600 integer noartr(moartr,*),
3609 double precision aretmx, airemx
3610 double precision quamoy, quamin
3614 c supprimer de la triangulation les triangles de qualite
3615 c inferieure a quamal
3616 c ======================================================
3617 call tesuqm( quamal, nbarpi, pxyd, noarst,
3618 % mosoar, mxsoar, n1soar, nosoar,
3619 % moartr, mxartr, n1artr, noartr,
3620 % mxarcf, n1arcf, noarcf,
3621 % larmin, notrcf, nostbo,
3623 call qualitetrte( pxyd, mosoar, mxsoar, nosoar,
3624 % moartr, mxartr, noartr,
3625 % nbtria, quamoy, quamin )
3627 c suppression des sommets de triangles equilateraux trop proches
3628 c d'un sommet frontalier ou d'un point interne impose par
3629 c triangulation frontale de l'etoile et mise en delaunay
3630 c ==============================================================
3631 if( quamin .le. quamal ) then
3632 call tesusp( quamal, nbarpi, pxyd, noarst,
3633 % mosoar, mxsoar, n1soar, nosoar,
3634 % moartr, mxartr, n1artr, noartr,
3635 % mxarcf, n1arcf, noarcf,
3636 % larmin, notrcf, nostbo,
3638 if( ierr .ne. 0 ) goto 9999
3641 c ajustage des tailles moyennes des aretes avec ampli=1.34d0 entre
3642 c ampli/2 x taille_souhaitee et ampli x taille_souhaitee
3643 c + barycentrage des sommets et mise en triangulation delaunay
3644 c ================================================================
3645 call teamqa( nutysu, airemx,
3646 % noarst, mosoar, mxsoar, n1soar, nosoar,
3647 % moartr, mxartr, n1artr, noartr,
3648 % mxarcf, notrcf, nostbo,
3649 % n1arcf, noarcf, larmin,
3650 % nbarpi, nbsomm, mxsomm, pxyd, nslign,
3652 call qualitetrte( pxyd, mosoar, mxsoar, nosoar,
3653 % moartr, mxartr, noartr,
3654 % nbtria, quamoy, quamin )
3655 if( ierr .ne. 0 ) goto 9999
3660 subroutine trfrcf( nscent, mosoar, nosoar, moartr, noartr,
3661 % nbtrcf, notrcf, nbarfr )
3662 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3663 c but : calculer le nombre d'aretes simples du contour ferme des
3664 c ----- nbtrcf triangles de numeros stockes dans le tableau notrcf
3665 c ayant tous le sommet nscent
3669 c nscent : numero du sommet appartenant a tous les triangles notrcf
3670 c mosoar : nombre maximal d'entiers par arete et
3671 c indice dans nosoar de l'arete suivante dans le hachage
3672 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
3673 c chainage des aretes frontalieres, chainage du hachage des aretes
3674 c moartr : nombre maximal d'entiers par arete du tableau noartr
3675 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
3676 c nbtrcf : >0 nombre de triangles empiles
3677 c =0 si impossible de tourner autour du point
3678 c =-nbtrcf si apres butee sur la frontiere il y a a nouveau
3679 c butee sur la frontiere . a ce stade on ne peut dire si tous
3680 c les triangles ayant ce sommet ont ete recenses
3681 c ce cas arrive seulement si le sommet est sur la frontiere
3682 c notrcf : numero dans noartr des triangles de sommet ns
3686 c nbarfr : nombre d'aretes simples frontalieres
3687 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3688 c auteur : alain perronnet analyse numerique paris upmc juin 1997
3689 c....................................................................012
3690 integer noartr(moartr,*),
3696 c le numero du triangle n dans le tableau noartr
3698 c parcours des 3 aretes du triangle nt
3700 c le numero de l'arete i dans le tableau nosoar
3701 noar = abs( noartr( i, nt ) )
3703 c le numero du sommet j de l'arete noar
3704 ns = nosoar( j, noar )
3705 if( ns .eq. nscent ) goto 40
3707 c l'arete noar (sans sommet nscent) est elle frontaliere?
3708 if( nosoar( 5, noar ) .le. 0 ) then
3709 c l'arete appartient au plus a un triangle
3710 c une arete simple frontaliere de plus
3713 c le triangle a au plus une arete sans sommet nscent
3719 subroutine int2ar( p1, p2, p3, p4, oui )
3720 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3721 c but : les 2 aretes de r**2 p1-p2 p3-p4 s'intersectent elles
3722 c ----- entre leurs sommets?
3726 c p1,p2,p3,p4 : les 2 coordonnees reelles des sommets des 2 aretes
3730 c oui : .true. si intersection, .false. sinon
3731 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3732 c auteur : alain perronnet analyse numerique paris upmc octobre 1991
3733 c2345x7..............................................................012
3734 double precision p1(2),p2(2),p3(2),p4(2)
3735 double precision x21,y21,d21,x43,y43,d43,d,x,y,xx
3738 c longueur des aretes
3741 d21 = x21**2 + y21**2
3745 d43 = x43**2 + y43**2
3747 c les 2 aretes sont-elles jugees paralleles ?
3748 d = x43 * y21 - y43 * x21
3749 if( abs(d) .le. 0.001 * sqrt(d21 * d43) ) then
3750 c aretes paralleles . pas d'intersection
3755 c les 2 coordonnees du point d'intersection
3756 x = ( p1(1)*x43*y21 - p3(1)*x21*y43 - (p1(2)-p3(2))*x21*x43 ) / d
3757 y =-( p1(2)*y43*x21 - p3(2)*y21*x43 - (p1(1)-p3(1))*y21*y43 ) / d
3759 c coordonnees de x,y dans le repere ns1-ns2
3760 xx = ( x - p1(1) ) * x21 + ( y - p1(2) ) * y21
3761 c le point est il entre p1 et p2 ?
3762 oui = -0.00001d0*d21 .le. xx .and. xx .le. 1.00001d0*d21
3764 c coordonnees de x,y dans le repere ns3-ns4
3765 xx = ( x - p3(1) ) * x43 + ( y - p3(2) ) * y43
3766 c le point est il entre p3 et p4 ?
3767 oui = oui .and. -0.00001d0*d43 .le. xx .and. xx .le. 1.00001d0*d43
3771 subroutine trchtd( pxyd, nar00, nar0, noarcf,
3772 % namin0, namin, larmin )
3773 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3774 c but : recherche dans le contour ferme du sommet qui joint a la plus
3775 c ----- courte arete nar00 donne le triangle sans intersection
3776 c avec le contour ferme de meilleure qualite
3780 c pxyd : tableau des coordonnees des sommets et distance_souhaitee
3782 c entrees et sorties:
3783 c -------------------
3784 c nar00 : numero dans noarcf de l'arete avant nar0
3785 c nar0 : numero dans noarcf de la plus petite arete du contour ferme
3786 c a joindre a noarcf(1,namin) pour former le triangle ideal
3787 c noarcf : numero du sommet , numero de l'arete suivante
3788 c numero du triangle exterieur a l'etoile
3792 c namin0 : numero dans noarcf de l'arete avant namin
3793 c namin : numero dans noarcf du sommet choisi
3794 c 0 si contour ferme reduit a moins de 3 aretes
3795 c larmin : tableau auxiliaire pour stocker la liste des numeros des
3796 c aretes de meilleure qualite pour faire le choix final
3797 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3798 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
3799 c2345x7..............................................................012
3800 double precision dmaxim, precision
3801 parameter (dmaxim=1.7d+308, precision=1d-16)
3802 c ATTENTION:variables a ajuster selon la machine!
3803 c ATTENTION:dmaxim : le plus grand reel machine
3804 c ATTENTION:sur dec-alpha la precision est de 10**-14 seulement
3806 common / unites / lecteu,imprim,nunite(30)
3807 double precision pxyd(1:3,1:*)
3808 integer noarcf(1:3,1:*),
3810 double precision q, dd, dmima,
3811 % unpeps, rayon, surtd2
3813 double precision centre(3)
3816 c dmaxim : le plus grand reel machine
3817 unpeps = 1d0 + 100d0 * precision
3819 c recherche de la plus courte arete du contour ferme
3825 2 na0 = noarcf( 2, na00 )
3826 na1 = noarcf( 2, na0 )
3828 c les 2 sommets de l'arete na0 du cf
3829 ns1 = noarcf( 1, na0 )
3830 ns2 = noarcf( 1, na1 )
3831 dd = (pxyd(1,ns2)-pxyd(1,ns1))**2 + (pxyd(2,ns2)-pxyd(2,ns1))**2
3832 if( dd .lt. dmima ) then
3837 if( na00 .ne. nar00 ) then
3838 c derniere arete non atteinte
3842 if( nbar .eq. 3 ) then
3844 c contour ferme reduit a un triangle
3845 c ----------------------------------
3847 nar0 = noarcf( 2, nar00 )
3848 namin0 = noarcf( 2, nar0 )
3851 else if( nbar .le. 2 ) then
3852 write(imprim,*) 'erreur trchtd: cf<3 aretes'
3858 c cf non reduit a un triangle
3859 c la plus petite arete est nar0 dans noarcf
3861 nar0 = noarcf( 2, nar00 )
3862 nar = noarcf( 2, nar0 )
3864 ns1 = noarcf( 1, nar0 )
3865 ns2 = noarcf( 1, nar )
3867 c recherche dans cette etoile du sommet offrant la meilleure qualite
3868 c du triangle ns1-ns2 ns3 sans intersection avec le contour ferme
3869 c ==================================================================
3873 c parcours des sommets possibles ns3
3874 10 nar3 = noarcf( 2, nar3 )
3875 if( nar3 .ne. nar0 ) then
3877 c il existe un sommet ns3 different de ns1 et ns2
3878 ns3 = noarcf( 1, nar3 )
3880 c les aretes ns1-ns3 et ns2-ns3 intersectent-elles une arete
3881 c du contour ferme ?
3882 c ----------------------------------------------------------
3883 c intersection de l'arete ns2-ns3 et des aretes du cf
3884 c jusqu'au sommet ns3
3885 nar1 = noarcf( 2, nar )
3887 15 if( nar1 .ne. nar3 .and. noarcf( 2, nar1 ) .ne. nar3 ) then
3889 nar2 = noarcf( 2, nar1 )
3890 c le numero des 2 sommets de l'arete
3891 np1 = noarcf( 1, nar1 )
3892 np2 = noarcf( 1, nar2 )
3893 call int2ar( pxyd(1,ns2), pxyd(1,ns3),
3894 % pxyd(1,np1), pxyd(1,np2), oui )
3896 c les 2 aretes ne s'intersectent pas entre leurs sommets
3901 c intersection de l'arete ns3-ns1 et des aretes du cf
3902 c jusqu'au sommet de l'arete nar0
3903 nar1 = noarcf( 2, nar3 )
3905 18 if( nar1 .ne. nar0 .and. noarcf( 2, nar1 ) .ne. nar0 ) then
3907 nar2 = noarcf( 2, nar1 )
3908 c le numero des 2 sommets de l'arete
3909 np1 = noarcf( 1, nar1 )
3910 np2 = noarcf( 1, nar2 )
3911 call int2ar( pxyd(1,ns1), pxyd(1,ns3),
3912 % pxyd(1,np1), pxyd(1,np2), oui )
3914 c les 2 aretes ne s'intersectent pas entre leurs sommets
3919 c le triangle ns1-ns2-ns3 n'intersecte pas une arete du contour ferme
3920 c le calcul de la surface du triangle
3921 dd = surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
3922 if( dd .le. 0d0 ) then
3923 c surface negative => triangle a rejeter
3926 c calcul de la qualite du triangle ns1-ns2-ns3
3927 call qutr2d( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), q )
3930 if( q .ge. qmima*1.00001 ) then
3931 c q est un vrai maximum de la qualite
3935 else if( q .ge. qmima*0.999998 ) then
3936 c q est voisin de qmima
3939 larmin( nbmin ) = nar3
3944 c bilan : existe t il plusieurs sommets de meme qualite?
3945 c ======================================================
3946 if( nbmin .gt. 1 ) then
3948 c oui:recherche de ceux de cercle ne contenant pas d'autres sommets
3952 if( nar .le. 0 ) goto 80
3954 c les coordonnees du centre du cercle circonscrit
3957 call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3),
3959 if( ier .ne. 0 ) then
3960 c le sommet ns3 ne convient pas
3964 rayon = centre(3) * unpeps
3969 if( nar1 .le. 0 ) goto 70
3970 ns4 = noarcf(1,nar1)
3971 c appartient t il au cercle ns1 ns2 ns3 ?
3972 dd = (centre(1)-pxyd(1,ns4))**2 +
3973 % (centre(2)-pxyd(2,ns4))**2
3974 if( dd .le. rayon ) then
3975 c ns4 est dans le cercle circonscrit ns1 ns2 ns3
3976 c le sommet ns3 ne convient pas
3984 c existe t il plusieurs sommets ?
3987 if( larmin( i ) .gt. 0 ) then
3988 c compactage des min
3990 larmin(j) = larmin(i)
3995 c oui : choix du plus petit rayon de cercle circonscrit
3998 ns3 = noarcf(1,larmin(i))
4000 c les coordonnees du centre de cercle circonscrit
4001 c au triangle nt et son rayon
4003 call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3),
4005 if( ier .ne. 0 ) then
4006 c le sommet ns3 ne convient pas
4009 rayon = sqrt( centre(3) )
4010 if( rayon .lt. dmima ) then
4012 larmin(1) = larmin(i)
4022 c recherche de l'arete avant namin ( nar0 <> namin )
4023 c ==================================================
4025 200 if( nar1 .ne. namin ) then
4027 nar1 = noarcf( 2, nar1 )
4032 subroutine trcf0a( nbcf, na01, na1, na2, na3,
4033 % noar1, noar2, noar3,
4034 % mosoar, mxsoar, n1soar, nosoar,
4035 % moartr, n1artr, noartr, noarst,
4036 % mxarcf, n1arcf, noarcf, nt )
4037 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4038 c but : modification de la triangulation du contour ferme nbcf
4039 c ----- par ajout d'un triangle ayant 0 arete sur le contour
4040 c creation des 3 aretes dans le tableau nosoar
4041 c modification du contour par ajout de la 3-eme arete
4042 c creation d'un contour ferme a partir de la seconde arete
4046 c nbcf : numero dans n1arcf du cf traite ici
4047 c na01 : numero noarcf de l'arete precedent l'arete na1 de noarcf
4048 c na1 : numero noarcf du 1-er sommet du triangle
4049 c implicitement l'arete na1 n'est pas une arete du triangle
4050 c na2 : numero noarcf du 2-eme sommet du triangle
4051 c implicitement l'arete na1 n'est pas une arete du triangle
4052 c na3 : numero noarcf du 3-eme sommet du triangle
4053 c implicitement l'arete na1 n'est pas une arete du triangle
4055 c mosoar : nombre maximal d'entiers par arete et
4056 c indice dans nosoar de l'arete suivante dans le hachage
4057 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
4058 c attention: mxsoar>3*mxsomm obligatoire!
4059 c moartr : nombre maximal d'entiers par arete du tableau noartr
4061 c entrees et sorties :
4062 c --------------------
4063 c n1soar : numero de la premiere arete vide dans le tableau nosoar
4064 c une arete i de nosoar est vide <=> nosoar(1,i)=0
4065 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4066 c chainage des aretes frontalieres, chainage du hachage des aretes
4067 c hachage des aretes = nosoar(1)+nosoar(2)*2
4068 c n1artr : numero du premier triangle vide dans le tableau noartr
4069 c le chainage des triangles vides se fait sur noartr(2,.)
4070 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4071 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
4073 c noarst : noarst(i) numero d'une arete de sommet i
4074 c n1arcf : numero d'une arete de chaque contour
4075 c noarcf : numero des aretes de la ligne du contour ferme
4076 c attention : chainage circulaire des aretes
4080 c noar1 : numero dans le tableau nosoar de l'arete 1 du triangle
4081 c noar2 : numero dans le tableau nosoar de l'arete 2 du triangle
4082 c noar3 : numero dans le tableau nosoar de l'arete 3 du triangle
4083 c nt : numero du triangle ajoute dans noartr
4084 c 0 si saturation du tableau noartr ou noarcf ou n1arcf
4085 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4086 c auteur : alain perronnet analyse numerique paris upmc mars 1997
4087 c2345x7..............................................................012
4088 common / unites / lecteu, imprim, nunite(30)
4089 integer nosoar(mosoar,*),
4097 c 2 contours fermes peuvent ils etre ajoutes ?
4098 if( nbcf+2 .gt. mxarcf ) goto 9100
4100 c creation des 3 aretes du triangle dans le tableau nosoar
4101 c ========================================================
4102 c la formation de l'arete sommet1-sommet2 dans le tableau nosoar
4103 call fasoar( noarcf(1,na1), noarcf(1,na2), -1, -1, 0,
4104 % mosoar, mxsoar, n1soar, nosoar, noarst,
4106 if( ierr .ne. 0 ) goto 9900
4108 c la formation de l'arete sommet2-sommet3 dans le tableau nosoar
4109 call fasoar( noarcf(1,na2), noarcf(1,na3), -1, -1, 0,
4110 % mosoar, mxsoar, n1soar, nosoar, noarst,
4112 if( ierr .ne. 0 ) goto 9900
4114 c la formation de l'arete sommet3-sommet1 dans le tableau nosoar
4115 call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1, 0,
4116 % mosoar, mxsoar, n1soar, nosoar, noarst,
4118 if( ierr .ne. 0 ) goto 9900
4120 c ajout dans noartr de ce triangle nt
4121 c ===================================
4122 call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
4123 % noar1, noar2, noar3,
4125 % moartr, n1artr, noartr,
4127 if( nt .le. 0 ) return
4129 c modification du contour nbcf existant
4130 c chainage de l'arete na2 vers l'arete na1
4131 c ========================================
4132 c modification du cf en pointant na2 sur na1
4133 na2s = noarcf( 2, na2 )
4134 noarcf( 2, na2 ) = na1
4135 c le numero de l'arete dans le tableau nosoar
4136 noar2s = noarcf( 3, na2 )
4137 c le numero de l'arete dans le tableau nosoar
4138 noarcf( 3, na2 ) = noar1
4140 n1arcf( nbcf ) = na2
4142 c creation d'un nouveau contour ferme na2 - na3
4143 c =============================================
4145 c recherche d'une arete de cf vide
4147 if( nav .le. 0 ) goto 9100
4148 c la 1-ere arete vide est mise a jour
4149 n1arcf(0) = noarcf( 2, nav )
4151 c ajout de l'arete nav pointant sur na2s
4152 c le numero du sommet
4153 noarcf( 1, nav ) = noarcf( 1, na2 )
4155 noarcf( 2, nav ) = na2s
4156 c le numero nosoar de cette arete
4157 noarcf( 3, nav ) = noar2s
4159 c l'arete na3 se referme sur nav
4160 na3s = noarcf( 2, na3 )
4161 noarcf( 2, na3 ) = nav
4162 c le numero de l'arete dans le tableau nosoar
4163 noar3s = noarcf( 3, na3 )
4164 noarcf( 3, na3 ) = noar2
4166 n1arcf( nbcf ) = na3
4168 c creation d'un nouveau contour ferme na3 - na1
4169 c =============================================
4171 c recherche d'une arete de cf vide
4173 if( nav .le. 0 ) goto 9100
4174 c la 1-ere arete vide est mise a jour
4175 n1arcf(0) = noarcf( 2, nav )
4177 c ajout de l'arete nav pointant sur na3s
4178 c le numero du sommet
4179 noarcf( 1, nav ) = noarcf( 1, na3 )
4181 noarcf( 2, nav ) = na3s
4182 c le numero de l'arete dans le tableau nosoar
4183 noarcf( 3, nav ) = noar3s
4185 c recherche d'une arete de cf vide
4187 if( nav1 .le. 0 ) goto 9100
4188 c la 1-ere arete vide est mise a jour
4189 n1arcf(0) = noarcf( 2, nav1 )
4191 c l'arete precedente na01 de na1 pointe sur la nouvelle nav1
4192 noarcf( 2, na01 ) = nav1
4194 c ajout de l'arete nav1 pointant sur nav
4195 c le numero du sommet
4196 noarcf( 1, nav1 ) = noarcf( 1, na1 )
4198 noarcf( 2, nav1 ) = nav
4199 c le numero de l'arete dans le tableau nosoar
4200 noarcf( 3, nav1 ) = noar3
4203 n1arcf( nbcf ) = nav1
4207 9100 write(imprim,*) 'saturation du tableau mxarcf'
4211 c erreur tableau nosoar sature
4212 9900 write(imprim,*) 'saturation du tableau nosoar'
4218 subroutine trcf1a( nbcf, na01, na1, na2, noar1, noar3,
4219 % mosoar, mxsoar, n1soar, nosoar,
4220 % moartr, n1artr, noartr, noarst,
4221 % mxarcf, n1arcf, noarcf, nt )
4222 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4223 c but : modification de la triangulation du contour ferme nbcf
4224 c ----- par ajout d'un triangle ayant 1 arete sur le contour
4225 c modification du contour par ajout de la 3-eme arete
4226 c creation d'un contour ferme a partir de la seconde arete
4230 c nbcf : numero dans n1arcf du cf traite ici
4231 c na01 : numero noarcf de l'arete precedant l'arete na1 de noarcf
4232 c na1 : numero noarcf du 1-er sommet du triangle
4233 c implicitement l'arete na1 n'est pas une arete du triangle
4234 c na2 : numero noarcf du 2-eme sommet du triangle
4235 c cette arete est l'arete 2 du triangle a ajouter
4236 c son arete suivante dans noarcf n'est pas sur le contour
4237 c mosoar : nombre maximal d'entiers par arete et
4238 c indice dans nosoar de l'arete suivante dans le hachage
4239 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
4240 c attention: mxsoar>3*mxsomm obligatoire!
4241 c moartr : nombre maximal d'entiers par arete du tableau noartr
4243 c entrees et sorties :
4244 c --------------------
4245 c n1soar : numero de la premiere arete vide dans le tableau nosoar
4246 c une arete i de nosoar est vide <=> nosoar(1,i)=0
4247 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4248 c chainage des aretes frontalieres, chainage du hachage des aretes
4249 c hachage des aretes = nosoar(1)+nosoar(2)*2
4250 c n1artr : numero du premier triangle vide dans le tableau noartr
4251 c le chainage des triangles vides se fait sur noartr(2,.)
4252 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4253 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
4255 c noarst : noarst(i) numero d'une arete de sommet i
4256 c n1arcf : numero d'une arete de chaque contour
4257 c noarcf : numero des aretes de la ligne du contour ferme
4258 c attention : chainage circulaire des aretes
4262 c noar1 : numero nosoar de l'arete 1 du triangle cree
4263 c noar3 : numero nosoar de l'arete 3 du triangle cree
4264 c nt : numero du triangle ajoute dans notria
4265 c 0 si saturation du tableau notria ou noarcf ou n1arcf
4266 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4267 c auteur : alain perronnet analyse numerique paris upmc mars 1997
4268 c2345x7..............................................................012
4269 common / unites / lecteu, imprim, nunite(30)
4270 integer nosoar(mosoar,mxsoar),
4276 c un cf supplementaire peut il etre ajoute ?
4277 if( nbcf .ge. mxarcf ) then
4278 write(imprim,*) 'saturation du tableau noarcf'
4285 c l' arete suivante du triangle non sur le cf
4286 na3 = noarcf( 2, na2 )
4288 c creation des 2 nouvelles aretes du triangle dans le tableau nosoar
4289 c ==================================================================
4290 c la formation de l'arete sommet1-sommet2 dans le tableau nosoar
4291 call fasoar( noarcf(1,na1), noarcf(1,na2), -1, -1, 0,
4292 % mosoar, mxsoar, n1soar, nosoar, noarst,
4294 if( ierr .ne. 0 ) goto 9900
4296 c la formation de l'arete sommet1-sommet3 dans le tableau nosoar
4297 call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1, 0,
4298 % mosoar, mxsoar, n1soar, nosoar, noarst,
4300 if( ierr .ne. 0 ) goto 9900
4302 c le triangle nt de noartr a l'arete 2 comme arete du contour na2
4303 c ===============================================================
4304 call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
4305 % noar1, noarcf(3,na2), noar3,
4307 % moartr, n1artr, noartr,
4309 if( nt .le. 0 ) return
4311 c modification du contour ferme existant
4312 c suppression de l'arete na2 du cf
4313 c ======================================
4314 c modification du cf en pointant na2 sur na1
4315 noarcf( 2, na2 ) = na1
4316 noarcf( 3, na2 ) = noar1
4318 n1arcf( nbcf ) = na2
4320 c creation d'un nouveau contour ferme na3 - na1
4321 c =============================================
4324 c recherche d'une arete de cf vide
4326 if( nav .le. 0 ) then
4327 write(imprim,*) 'saturation du tableau noarcf'
4332 c la 1-ere arete vide est mise a jour
4333 n1arcf(0) = noarcf( 2, nav )
4335 c ajout de l'arete nav pointant sur na3
4336 c le numero du sommet
4337 noarcf( 1, nav ) = noarcf( 1, na1 )
4339 noarcf( 2, nav ) = na3
4340 c le numero de l'arete dans le tableau nosoar
4341 noarcf( 3, nav ) = noar3
4343 c l'arete precedente na01 de na1 pointe sur la nouvelle nav
4344 noarcf( 2, na01 ) = nav
4347 n1arcf( nbcf ) = nav
4350 c erreur tableau nosoar sature
4351 9900 write(imprim,*) 'saturation du tableau nosoar'
4357 subroutine trcf2a( nbcf, na1, noar3,
4358 % mosoar, mxsoar, n1soar, nosoar,
4359 % moartr, n1artr, noartr, noarst,
4360 % n1arcf, noarcf, nt )
4361 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4362 c but : modification de la triangulation du contour ferme nbcf
4363 c ----- par ajout d'un triangle ayant 2 aretes sur le contour
4364 c creation d'une arete dans nosoar (sommet3-sommet1)
4365 c et modification du contour par ajout de la 3-eme arete
4369 c nbcf : numero dans n1arcf du cf traite ici
4370 c na1 : numero noarcf de la premiere arete sur le contour
4371 c implicitement sa suivante est sur le contour
4372 c la suivante de la suivante n'est pas sur le contour
4373 c mosoar : nombre maximal d'entiers par arete et
4374 c indice dans nosoar de l'arete suivante dans le hachage
4375 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
4376 c attention: mxsoar>3*mxsomm obligatoire!
4377 c moartr : nombre maximal d'entiers par arete du tableau noartr
4379 c entrees et sorties :
4380 c --------------------
4381 c n1soar : numero de la premiere arete vide dans le tableau nosoar
4382 c une arete i de nosoar est vide <=> nosoar(1,i)=0
4383 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4384 c chainage des aretes frontalieres, chainage du hachage des aretes
4385 c hachage des aretes = nosoar(1)+nosoar(2)*2
4386 c n1artr : numero du premier triangle vide dans le tableau noartr
4387 c le chainage des triangles vides se fait sur noartr(2,.)
4388 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4389 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
4391 c noarst : noarst(i) numero d'une arete de sommet i
4392 c n1arcf : numero d'une arete de chaque contour
4393 c noarcf : numero des aretes de la ligne du contour ferme
4394 c attention : chainage circulaire des aretes
4398 c noar3 : numero de l'arete 3 dans le tableau nosoar
4399 c nt : numero du triangle ajoute dans noartr
4400 c 0 si saturation du tableau noartr ou nosoar
4401 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4402 c auteur : alain perronnet analyse numerique paris upmc mars 1997
4403 c2345x7..............................................................012
4404 common / unites / lecteu, imprim, nunite(30)
4405 integer nosoar(mosoar,*),
4408 integer n1arcf(0:*),
4413 c l'arete suivante de l'arete na1 dans noarcf
4414 na2 = noarcf( 2, na1 )
4415 c l'arete suivante de l'arete na2 dans noarcf
4416 na3 = noarcf( 2, na2 )
4418 c la formation de l'arete sommet3-sommet1 dans le tableau nosoar
4419 call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1, 0,
4420 % mosoar, mxsoar, n1soar, nosoar, noarst,
4422 if( ierr .ne. 0 ) then
4423 if( ierr .eq. 1 ) then
4424 write(imprim,*) 'saturation des aretes (tableau nosoar)'
4430 c le triangle a ses 2 aretes na1 na2 sur le contour ferme
4431 c ajout dans noartr de ce triangle nt
4432 call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
4433 % noarcf(3,na1), noarcf(3,na2), noar3,
4435 % moartr, n1artr, noartr,
4437 if( nt .le. 0 ) return
4439 c suppression des 2 aretes (na1 na2) du cf
4440 c ces 2 aretes se suivent dans le chainage du cf
4441 c ajout de la 3-eme arete (noar3) dans le cf
4442 c l'arete suivante de na1 devient la suivante de na2
4444 noarcf(3,na1) = noar3
4446 c l'arete na2 devient vide dans noarcf
4447 noarcf(2,na2) = n1arcf( 0 )
4450 c la premiere pointee dans noarcf est na1
4451 c chainage circulaire => ce peut etre n'importe laquelle
4456 subroutine trcf3a( ns1, ns2, ns3,
4457 % noar1, noar2, noar3,
4459 % moartr, n1artr, noartr,
4461 c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4462 c but : ajouter dans le tableau noartr le triangle
4463 c ----- de sommets ns1 ns2 ns3
4464 c d'aretes noar1 noar2 noar3 deja existantes
4465 c dans le tableau nosoar des aretes
4469 c ns1, ns2, ns3 : le numero dans pxyd des 3 sommets du triangle
4470 c noar1,noar2,noar3 : le numero dans nosoar des 3 aretes du triangle
4471 c mosoar : nombre maximal d'entiers par arete et
4472 c indice dans nosoar de l'arete suivante dans le hachage
4473 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
4474 c attention: mxsoar>3*mxsomm obligatoire!
4475 c moartr : nombre maximal d'entiers par arete du tableau noartr
4476 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
4480 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4481 c chainage des aretes frontalieres, chainage du hachage des aretes
4482 c hachage des aretes = nosoar(1)+nosoar(2)*2
4483 c n1artr : numero du premier triangle vide dans le tableau noartr
4484 c le chainage des triangles vides se fait sur noartr(2,.)
4485 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4486 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
4490 c nt : numero dans noartr du triangle ajoute
4491 c =0 si le tableau noartr est sature
4492 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4493 c auteur : alain perronnet analyse numerique paris upmc mars 1997
4494 c....................................................................012
4495 common / unites / lecteu,imprim,nunite(30)
4496 integer nosoar(mosoar,*),
4499 c recherche d'un triangle libre dans le tableau noartr
4500 if( n1artr .le. 0 ) then
4501 write(imprim,*) 'saturation du tableau noartr des aretes'
4506 c le numero dans noartr du nouveau triangle
4509 c le nouveau premier triangle vide dans le tableau noartr
4510 n1artr = noartr(2,n1artr)
4512 c arete 1 du triangle nt
4513 c ======================
4514 c orientation des 3 aretes du triangle pour qu'il soit direct
4515 if( ns1 .eq. nosoar(1,noar1) ) then
4520 c le numero de l'arete 1 du triangle nt
4521 noartr(1,nt) = n * noar1
4523 c le numero du triangle nt pour l'arete
4524 if( nosoar(4,noar1) .le. 0 ) then
4529 nosoar(n,noar1) = nt
4531 c arete 2 du triangle nt
4532 c ======================
4533 c orientation des 3 aretes du triangle pour qu'il soit direct
4534 if( ns2 .eq. nosoar(1,noar2) ) then
4539 c le numero de l'arete 2 du triangle nt
4540 noartr(2,nt) = n * noar2
4542 c le numero du triangle nt pour l'arete
4543 if( nosoar(4,noar2) .le. 0 ) then
4548 nosoar(n,noar2) = nt
4550 c arete 3 du triangle nt
4551 c ======================
4552 c orientation des 3 aretes du triangle pour qu'il soit direct
4553 if( ns3 .eq. nosoar(1,noar3) ) then
4558 c le numero de l'arete 3 du triangle nt
4559 noartr(3,nt) = n * noar3
4561 c le numero du triangle nt pour l'arete
4562 if( nosoar(4,noar3) .le. 0 ) then
4567 nosoar(n,noar3) = nt
4572 subroutine trcf3s( nbcf, na01, na1, na02, na2, na03, na3,
4573 % mosoar, mxsoar, n1soar, nosoar,
4574 % moartr, n1artr, noartr, noarst,
4575 % mxarcf, n1arcf, noarcf, nt )
4576 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4577 c but : ajout d'un triangle d'aretes na1 2 3 du tableau noarcf
4578 c ----- a la triangulation d'un contour ferme (cf)
4582 c nbcf : numero dans n1arcf du cf traite ici
4583 c mais aussi nombre actuel de cf avant ajout du triangle
4584 c na01 : numero noarcf de l'arete precedent l'arete na1 de noarcf
4585 c na1 : numero noarcf du 1-er sommet du triangle
4586 c na02 : numero noarcf de l'arete precedent l'arete na2 de noarcf
4587 c na2 : numero noarcf du 2-eme sommet du triangle
4588 c na03 : numero noarcf de l'arete precedent l'arete na3 de noarcf
4589 c na3 : numero noarcf du 3-eme sommet du triangle
4591 c mosoar : nombre maximal d'entiers par arete et
4592 c indice dans nosoar de l'arete suivante dans le hachage
4593 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
4594 c attention: mxsoar>3*mxsomm obligatoire!
4595 c moartr : nombre maximal d'entiers par arete du tableau noartr
4596 c mxarcf : nombre maximal d'aretes declarables dans noarcf, n1arcf
4600 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
4601 c chainage des vides suivant en 3 et precedant en 2 de nosoar
4602 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4603 c chainage des aretes frontalieres, chainage du hachage des aretes
4604 c hachage des aretes = nosoar(1)+nosoar(2)*2
4605 c avec mxsoar>=3*mxsomm
4606 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
4607 c nosoar(2,arete vide)=l'arete vide qui precede
4608 c nosoar(3,arete vide)=l'arete vide qui suit
4610 c n1artr : numero du premier triangle vide dans le tableau noartr
4611 c le chainage des triangles vides se fait sur noartr(2,.)
4612 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4613 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
4614 c noarst : noarst(i) numero d'une arete de sommet i
4616 c n1arcf : numero d'une arete de chaque contour ferme
4617 c noarcf : numero du sommet , numero de l'arete suivante
4618 c numero de l'arete dans le tableau nosoar
4619 c attention : chainage circulaire des aretes
4623 c nbcf : nombre actuel de cf apres ajout du triangle
4624 c nt : numero du triangle ajoute dans noartr
4625 c 0 si saturation du tableau nosoar ou noartr ou noarcf ou n1arcf
4626 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4627 c auteur : alain perronnet analyse numerique paris upmc mars 1997
4628 c2345x7..............................................................012
4629 integer nosoar(mosoar,*),
4635 c combien y a t il d'aretes nbascf sur le cf ?
4636 c ============================================
4637 c la premiere arete est elle sur le cf?
4638 if( noarcf(2,na1) .eq. na2 ) then
4639 c la 1-ere arete est sur le cf
4642 c la 1-ere arete n'est pas sur le cf
4646 c la seconde arete est elle sur le cf?
4647 if( noarcf(2,na2) .eq. na3 ) then
4648 c la 2-eme arete est sur le cf
4654 c la troisieme arete est elle sur le cf?
4655 if( noarcf(2,na3) .eq. na1 ) then
4656 c la 3-eme arete est sur le cf
4662 c le nombre d'aretes sur le cf
4663 nbascf = na1cf + na2cf + na3cf
4665 c traitement selon le nombre d'aretes sur le cf
4666 c =============================================
4667 if( nbascf .eq. 3 ) then
4669 c le contour ferme se reduit a un triangle avec 3 aretes sur le cf
4670 c ----------------------------------------------------------------
4671 c ajout dans noartr de ce nouveau triangle
4672 call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
4673 % noarcf(3,na1), noarcf(3,na2), noarcf(3,na3),
4675 % moartr, n1artr, noartr,
4677 if( nt .le. 0 ) return
4679 c le cf est supprime et chaine vide
4680 noarcf(2,na3) = n1arcf(0)
4683 c ce cf a ete traite => un cf de moins a traiter
4686 else if( nbascf .eq. 2 ) then
4688 c le triangle a 2 aretes sur le contour
4689 c -------------------------------------
4690 c les 2 aretes sont la 1-ere et 2-eme du triangle
4691 if( na1cf .eq. 0 ) then
4692 c l'arete 1 n'est pas sur le cf
4694 else if( na2cf .eq. 0 ) then
4695 c l'arete 2 n'est pas sur le cf
4698 c l'arete 3 n'est pas sur le cf
4701 c le triangle oppose a l'arete 3 est inconnu
4702 c modification du contour apres integration du
4703 c triangle ayant ses 2-eres aretes sur le cf
4704 call trcf2a( nbcf, naa1, naor3,
4705 % mosoar, mxsoar, n1soar, nosoar,
4706 % moartr, n1artr, noartr, noarst,
4707 % n1arcf, noarcf, nt )
4709 else if( nbascf .eq. 1 ) then
4711 c le triangle a 1 arete sur le contour
4712 c ------------------------------------
4713 c cette arete est la seconde du triangle
4714 if( na3cf .ne. 0 ) then
4715 c l'arete 3 est sur le cf
4719 else if( na1cf .ne. 0 ) then
4720 c l'arete 1 est sur le cf
4725 c l'arete 2 est sur le cf
4730 c le triangle oppose a l'arete 1 et 3 est inconnu
4731 c modification du contour apres integration du
4732 c triangle ayant 1 arete sur le cf avec creation
4733 c d'un nouveau contour ferme
4734 call trcf1a( nbcf, naa01, naa1, naa2, naor1, naor3,
4735 % mosoar, mxsoar, n1soar, nosoar,
4736 % moartr, n1artr, noartr, noarst,
4737 % mxarcf, n1arcf, noarcf, nt )
4741 c le triangle a 0 arete sur le contour
4742 c ------------------------------------
4743 c modification du contour apres integration du
4744 c triangle ayant 0 arete sur le cf avec creation
4745 c de 2 nouveaux contours fermes
4746 call trcf0a( nbcf, na01, na1, na2, na3,
4747 % naa1, naa2, naa01,
4748 % mosoar, mxsoar, n1soar, nosoar,
4749 % moartr, n1artr, noartr, noarst,
4750 % mxarcf, n1arcf, noarcf, nt )
4755 subroutine tridcf( nbcf0, nbstpe, nostpe, pxyd, noarst,
4756 % mosoar, mxsoar, n1soar, nosoar,
4757 % moartr, n1artr, noartr,
4758 % mxarcf, n1arcf, noarcf, larmin,
4759 % nbtrcf, notrcf, ierr )
4760 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4761 c but : triangulation directe de nbcf0 contours fermes (cf)
4762 c ----- definis par la liste circulaire de leurs aretes peripheriques
4763 c avec integration de nbstpe sommets isoles a l'un des cf initiaux
4767 c nbcf0 : nombre initial de cf a trianguler
4768 c nbstpe : nombre de sommets isoles a l'interieur des cf et
4769 c a devenir sommets de la triangulation
4770 c nostpe : numero dans pxyd des nbstpe sommets isoles
4771 c pxyd : tableau des coordonnees 2d des points
4772 c par point : x y distance_souhaitee
4773 c mosoar : nombre maximal d'entiers par arete et
4774 c indice dans nosoar de l'arete suivante dans le hachage
4775 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
4776 c attention: mxsoar>3*mxsomm obligatoire!
4777 c moartr : nombre maximal d'entiers par arete du tableau noartr
4778 c mxarcf : nombre maximal d'aretes declarables dans noarcf, n1arcf, larmin, not
4782 c noarst : noarst(i) numero d'une arete de sommet i
4783 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
4784 c chainage des vides suivant en 3 et precedant en 2 de nosoar
4785 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4786 c chainage des aretes frontalieres, chainage du hachage des aretes
4787 c hachage des aretes = nosoar(1)+nosoar(2)*2
4788 c avec mxsoar>=3*mxsomm
4789 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
4790 c nosoar(2,arete vide)=l'arete vide qui precede
4791 c nosoar(3,arete vide)=l'arete vide qui suit
4793 c n1artr : numero du premier triangle vide dans le tableau noartr
4794 c le chainage des triangles vides se fait sur noartr(2,.)
4795 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4796 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
4798 c n1arcf : numero de la premiere arete de chacun des nbcf0 cf
4799 c n1arcf(0) no de la premiere arete vide du tableau noarcf
4800 c noarcf(2,i) no de l'arete suivante
4801 c noarcf : numero du sommet , numero de l'arete suivante du cf
4802 c numero de l'arete dans le tableau nosoar
4806 c larmin : tableau (mxarcf) auxiliaire
4807 c stocker la liste des numeros des meilleures aretes
4808 c lors de la selection du meilleur sommet du cf a trianguler
4813 c nbtrcf : nombre de triangles des nbcf0 cf
4814 c notrcf : numero des triangles des nbcf0 cf dans le tableau noartr
4815 c ierr : 0 si pas d'erreur
4816 c 2 saturation de l'un des des tableaux nosoar, noartr, ...
4817 c 3 si contour ferme reduit a moins de 3 aretes
4818 c 4 saturation du tableau notrcf
4819 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4820 c auteur : alain perronnet analyse numerique paris upmc mars 1997
4821 c modifs : alain perronnet laboratoire jl lions upmc paris octobre 2006
4822 c....................................................................012
4823 common / unites / lecteu, imprim, nunite(30)
4824 double precision pxyd(3,*)
4825 integer nostpe(nbstpe),
4827 % nosoar(mosoar,mxsoar),
4835 double precision d, diptdr, surtd2, dmin, s
4837 c depart avec nbcf0 cf a trianguler
4840 c le nombre de triangles formes dans l'ensemble des cf
4843 c le nombre restant de sommets isoles a integrer au cf
4846 1 if( nbstp .le. 0 ) goto 10
4848 c il existe au moins un sommet isole
4849 c recherche d'un cf dont la premiere arete forme un triangle
4850 c d'aire>0 avec un sommet isole et recherche du sommet isole
4851 c le plus proche de cette arete
4852 c ==========================================================
4856 c le cf en haut de pile a pour arete avant la premiere arete
4859 c recherche de l'arete qui precede la premiere arete
4860 2 if( noarcf( 2, na2 ) .ne. na1 ) then
4861 na2 = noarcf( 2, na2 )
4864 c l'arete na0 dans noarcf qui precede n1arcf( ncf )
4866 c la premiere arete du cf
4867 na1 = noarcf( 2, na0 )
4868 c son numero dans nosoar
4869 noar1 = noarcf( 3, na1 )
4871 na2 = noarcf( 2, na1 )
4872 c le no pxyd des 2 sommets de l'arete na1
4873 ns1 = noarcf( 1, na1 )
4874 ns2 = noarcf( 1, na2 )
4876 c le sommet isole ns3
4878 if( ns3 .le. 0 ) goto 3
4879 c aire du triangle arete na1 et sommet ns3
4880 d = surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
4881 if( d .gt. 0d0 ) then
4882 c distance de ce sommet ns3 a l'arete na1
4883 d = diptdr( pxyd(1,ns3), pxyd(1,ns1), pxyd(1,ns2) )
4884 if( d .lt. dmin ) then
4890 if( imin .gt. 0 ) then
4891 c le sommet imin de nostpe est a distance minimale de
4892 c la premiere arete du cf de numero ncf
4893 c la formation de l'arete ns2-ns3 dans le tableau nosoar
4894 call fasoar( ns2, ns3, -1, -1, 0,
4895 % mosoar, mxsoar, n1soar, nosoar, noarst,
4897 if( ierr .ne. 0 ) goto 9900
4898 c la formation de l'arete ns3-ns1 dans le tableau nosoar
4899 call fasoar( ns3, ns1, -1, -1, 0,
4900 % mosoar, mxsoar, n1soar, nosoar, noarst,
4902 if( ierr .ne. 0 ) goto 9900
4904 c ajout dans noartr du triangle de sommets ns1 ns2 ns3
4905 c et d'aretes na1, noar2, noar3 dans nosoar
4906 call trcf3a( ns1, ns2, ns3,
4907 % noar1, noar2, noar3,
4909 % moartr, n1artr, noartr,
4911 s = surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
4913 write(imprim,*)'tridcf: trcf3a produit tr',nt,' st',
4915 write(imprim,*)'tridcf: triangle AIRE<0'
4917 if( nt .le. 0 ) then
4921 if( nbtrcf .ge. mxarcf ) then
4922 write(imprim,*) 'saturation du tableau notrcf'
4927 notrcf( nbtrcf ) = nt
4929 c modification du cf. creation d'une arete dans noarcf
4931 if( na12 .le. 0 ) then
4932 write(imprim,*) 'saturation du tableau noarcf'
4936 c la 1-ere arete vide de noarcf est mise a jour
4937 n1arcf(0) = noarcf( 2, na12 )
4939 c l'arete suivante de na0
4940 noarcf( 1, na1 ) = ns1
4941 noarcf( 2, na1 ) = na12
4942 noarcf( 3, na1 ) = noar3
4943 c l'arete suivante de na1
4944 noarcf( 1, na12 ) = ns3
4945 noarcf( 2, na12 ) = na2
4946 noarcf( 3, na12 ) = noar2
4948 c un sommet isole traite
4950 nostpe( imin ) = - nostpe( imin )
4956 if( imin .eq. 0 ) then
4957 write(imprim,*) 'tridcf: il reste',nbstp,
4958 % ' sommets isoles non triangules'
4959 write(imprim,*) 'ameliorer l''algorithme'
4965 c tant qu'il existe un cf a trianguler faire
4966 c la triangulation directe du cf
4967 c ==========================================
4968 10 if( nbcf .gt. 0 ) then
4970 c le cf en haut de pile a pour premiere arete
4971 na01 = n1arcf( nbcf )
4972 na1 = noarcf( 2, na01 )
4974 c choix du sommet du cf a relier a l'arete na1
4975 c --------------------------------------------
4976 call trchtd( pxyd, na01, na1, noarcf,
4977 % na03, na3, larmin )
4978 if( na3 .eq. 0 ) then
4983 c l'arete suivante de na1
4985 na2 = noarcf( 2, na1 )
4987 c formation du triangle arete na1 - sommet noarcf(1,na3)
4988 c ------------------------------------------------------
4989 call trcf3s( nbcf, na01, na1, na02, na2, na03, na3,
4990 % mosoar, mxsoar, n1soar, nosoar,
4991 % moartr, n1artr, noartr, noarst,
4992 % mxarcf, n1arcf, noarcf, nt )
4993 if( nt .le. 0 ) then
4994 c saturation du tableau noartr ou noarcf ou n1arcf
4998 call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr)
4999 s = surtd2( pxyd(1,nosotr(1)),
5000 % pxyd(1,nosotr(2)),
5001 % pxyd(1,nosotr(3)) )
5003 write(imprim,*)'tridcf: trcf3s produit tr',nt,' st',nosotr
5004 write(imprim,*)'tridcf: triangle AIRE<0'
5007 c ajout du triangle cree a sa pile
5008 if( nbtrcf .ge. mxarcf ) then
5009 write(imprim,*) 'saturation du tableau notrcf'
5014 notrcf( nbtrcf ) = nt
5018 c mise a jour du chainage des triangles des aretes
5019 c ================================================
5020 do 30 ntp0 = 1, nbtrcf
5022 c le numero du triangle ajoute dans le tableau noartr
5023 nt0 = notrcf( ntp0 )
5025 c boucle sur les 3 aretes du triangle nt0
5028 c le numero de l'arete i du triangle dans le tableau nosoar
5029 noar = abs( noartr(i,nt0) )
5031 c ce triangle est il deja chaine dans cette arete?
5032 nt1 = nosoar(4,noar)
5033 nt2 = nosoar(5,noar)
5034 if( nt1 .eq. nt0 .or. nt2 .eq. nt0 ) goto 20
5036 c ajout de ce triangle nt0 a l'arete noar
5037 if( nt1 .le. 0 ) then
5038 c le triangle est ajoute a l'arete
5039 nosoar( 4, noar ) = nt0
5040 else if( nt2 .le. 0 ) then
5041 c le triangle est ajoute a l'arete
5042 nosoar( 5, noar ) = nt0
5044 c l'arete appartient a 2 triangles differents de nt0
5045 c anomalie. chainage des triangles des aretes defectueux
5047 write(imprim,*) 'tridcf: erreur 1 arete dans 3 triangles'
5048 write(imprim,*) 'tridcf: arete nosoar(',noar,')=',
5049 % (nosoar(k,noar),k=1,mosoar)
5050 call nusotr( nt0, mosoar, nosoar, moartr, noartr, nosotr)
5051 write(imprim,*) 'tridcf: triangle nt0=',nt0,' st:',
5053 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr)
5054 write(imprim,*) 'tridcf: triangle nt1=',nt1,' st:',
5056 call nusotr( nt2, mosoar, nosoar, moartr, noartr, nosotr)
5057 write(imprim,*) 'tridcf: triangle nt2=',nt2,' st:',
5069 c erreur tableau nosoar sature
5070 9900 write(imprim,*) 'saturation du tableau nosoar'
5075 subroutine te1stm( nsasup, nbarpi, pxyd, noarst,
5076 % mosoar, mxsoar, n1soar, nosoar,
5077 % moartr, mxartr, n1artr, noartr,
5078 % mxarcf, n1arcf, noarcf, larmin, notrcf, liarcf,
5080 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5081 c but : supprimer de la triangulation le sommet nsasup qui doit
5082 c ----- etre un sommet interne ("centre" d'une boule de triangles)
5084 c attention: le chainage lchain de nosoar devient celui des cf
5088 c nsasup : numero dans le tableau pxyd du sommet a supprimer
5089 c nbarpi : numero du dernier sommet frontalier ou interne impose
5090 c pxyd : tableau des coordonnees 2d des points
5091 c par point : x y distance_souhaitee
5092 c mosoar : nombre maximal d'entiers par arete et
5093 c indice dans nosoar de l'arete suivante dans le hachage
5094 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5095 c attention: mxsoar>3*mxsomm obligatoire!
5096 c moartr : nombre maximal d'entiers par arete du tableau noartr
5097 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
5101 c noarst : noarst(i) numero d'une arete de sommet i
5102 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
5103 c chainage des vides suivant en 3 et precedant en 2 de nosoar
5104 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
5105 c chainage des aretes frontalieres, chainage du hachage des aretes
5106 c hachage des aretes = nosoar(1)+nosoar(2)*2
5107 c avec mxsoar>=3*mxsomm
5108 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
5109 c nosoar(2,arete vide)=l'arete vide qui precede
5110 c nosoar(3,arete vide)=l'arete vide qui suit
5111 c n1artr : numero du premier triangle vide dans le tableau noartr
5112 c le chainage des triangles vides se fait sur noartr(2,.)
5113 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5114 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5119 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
5120 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
5121 c larmin : tableau ( mxarcf ) auxiliaire d'entiers
5122 c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
5123 c liarcf : tableau ( mxarcf ) auxiliaire d'entiers
5127 c ierr : =0 si pas d'erreur
5128 c -1 le sommet a supprimer n'est pas le centre d'une boule
5129 c de triangles. il est suppose externe
5130 c ou bien le sommet est centre d'un cf dont toutes les
5131 c aretes sont frontalieres
5132 c dans les 2 cas => retour sans modifs
5133 c >0 si une erreur est survenue
5134 c =11 algorithme defaillant
5135 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5136 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5137 c....................................................................012
5138 parameter ( lchain=6, mxstpe=512)
5139 common / unites / lecteu,imprim,intera,nunite(29)
5140 double precision pxyd(3,*), s0, s1, surtd2, s
5141 integer nosoar(mosoar,mxsoar),
5142 % noartr(moartr,mxartr),
5152 if( nsasup .le. nbarpi ) then
5153 c sommet frontalier non destructible
5159 c nsasup est il un sommet interne, "centre" d'une boule de triangles?
5160 c => le sommet nsasup peut etre supprime
5161 c ===================================================================
5162 c formation du cf de ''centre'' le sommet nsasup
5163 call trp1st( nsasup, noarst, mosoar, nosoar,
5164 % moartr, mxartr, noartr,
5165 % mxarcf, nbtrcf, notrcf )
5167 if( nbtrcf .le. 2 ) then
5168 c erreur: impossible de trouver tous les triangles de sommet nsasup
5169 c ou pas assez de triangles de sommet nsasup
5170 c le sommet nsasup n'est pas supprime de la triangulation
5175 if( nbtrcf*3 .gt. mxarcf ) then
5176 write(imprim,*) 'saturation du tableau noarcf'
5181 c si toutes les aretes du cf sont frontalieres, alors il est
5182 c interdit de detruire le sommet "centre" du cf
5183 c calcul du nombre nbarfr des aretes simples des nbtrcf triangles
5184 call trfrcf( nsasup, mosoar, nosoar, moartr, noartr,
5185 % nbtrcf, notrcf, nbarfr )
5186 if( nbarfr .ge. nbtrcf ) then
5187 c toutes les aretes simples sont frontalieres
5188 c le sommet nsasup ("centre" de la cavite) n'est pas supprime
5193 c calcul des surfaces avant suppression du point
5197 c les numeros des 3 sommets du triangle nt
5198 call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
5199 s = surtd2( pxyd(1,nosotr(1)),
5200 % pxyd(1,nosotr(2)),
5201 % pxyd(1,nosotr(3)) )
5205 c formation du contour ferme (liste chainee des aretes simples)
5206 c forme a partir des aretes des triangles de l'etoile du sommet nsasup
5207 c les aretes doubles sont detruites
5208 c les triangles du cf sont detruits
5209 call focftr( nbtrcf, notrcf, nbarpi, pxyd, noarst,
5210 % mosoar, mxsoar, n1soar, nosoar,
5211 % moartr, n1artr, noartr,
5212 % nbarcf, n1arcf, noarcf, nbstpe, nostpe,
5214 if( ierr .ne. 0 ) then
5215 c modification de ierr pour continuer le calcul
5220 c ici le sommet nsasup n'appartient plus a aucune arete
5221 noarst( nsasup ) = 0
5223 c chainage des aretes vides dans le tableau noarcf
5224 n1arcf(0) = nbarcf+1
5225 mmarcf = min(8*nbarcf,mxarcf)
5226 do 40 i=nbarcf+1,mmarcf
5229 noarcf(2,mmarcf) = 0
5231 c sauvegarde du chainage des aretes peripheriques
5232 c pour la mise en delaunay du maillage
5235 c le numero de l'arete dans le tableau nosoar
5236 liarcf( i ) = noarcf( 3, nbcf )
5237 c l'arete suivante dans le cf
5238 nbcf = noarcf( 2, nbcf )
5241 c triangulation directe du contour ferme sans le sommet nsasup
5242 c ============================================================
5244 call tridcf( nbcf, nbstpe, nostpe, pxyd, noarst,
5245 % mosoar, mxsoar, n1soar, nosoar,
5246 % moartr, n1artr, noartr,
5247 % mxarcf, n1arcf, noarcf, larmin,
5248 % nbtrcf, notrcf, ierr )
5249 if( ierr .ne. 0 ) return
5250 c calcul des surfaces apres suppression du point
5254 c les numeros des 3 sommets du triangle nt
5255 call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
5256 s = surtd2( pxyd(1,nosotr(1)),
5257 % pxyd(1,nosotr(2)),
5258 % pxyd(1,nosotr(3)) )
5260 write(imprim,*)'te1stm: apres tridcf le triangle',nt,
5261 % ' st',nosotr,' AIRE<0'
5266 if( abs(s0-s1) .gt. 1d-10*s0 ) then
5268 write(imprim,*)'te1stm: difference des aires lors suppression st',
5270 write(imprim,10055) s0, s1
5271 10055 format('aire0=',d25.16,' aire1=',d25.16)
5274 c transformation des triangles du cf en triangles delaunay
5275 c ========================================================
5276 c construction du chainage lchain dans nosoar
5277 c des aretes peripheriques du cf a partir de la sauvegarde liarcf
5280 c le numero de l'arete peripherique du cf dans nosoar
5282 if( nosoar(3,noar) .le. 0 ) then
5283 c arete interne => elle est chainee a partir de la precedente
5284 nosoar( lchain, noar0 ) = noar
5288 c la derniere arete peripherique n'a pas de suivante
5289 nosoar(lchain,noar0) = 0
5291 c mise en delaunay des aretes chainees
5292 call tedela( pxyd, noarst,
5293 % mosoar, mxsoar, n1soar, nosoar, liarcf(1),
5294 % moartr, mxartr, n1artr, noartr, modifs )
5299 subroutine tr3str( np, nt,
5300 % mosoar, mxsoar, n1soar, nosoar,
5301 % moartr, mxartr, n1artr, noartr,
5302 % noarst, nutr, ierr )
5303 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5304 c but : former les 3 sous-triangles du triangle nt a partir
5305 c ----- du point interne np
5309 c np : numero dans le tableau pxyd du point
5310 c nt : numero dans le tableau noartr du triangle a trianguler
5311 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
5312 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5313 c moartr : nombre maximal d'entiers par arete du tableau noartr
5314 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
5318 c n1soar : numero de la premiere arete vide dans le tableau nosoar
5319 c une arete i de nosoar est vide <=> nosoar(1,i)=0
5320 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages
5321 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
5322 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
5323 c n1artr : numero du premier triangle vide dans le tableau noartr
5324 c le chainage des triangles vides se fait sur noartr(2,.)
5325 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5326 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5327 c noarst : noarst(i) numero d'une arete de sommet i
5331 c nutr : le numero des 3 sous-triangles du triangle nt
5332 c nt : en sortie le triangle initial n'est plus actif dans noartr
5333 c c'est en fait le premier triangle vide de noartr
5334 c ierr : =0 si pas d'erreur
5335 c =1 si le tableau nosoar est sature
5336 c =2 si le tableau noartr est sature
5337 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5338 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5339 c....................................................................012
5340 integer nosoar(mosoar,mxsoar),
5341 % noartr(moartr,mxartr),
5345 integer nosotr(3), nu2sar(2), nuarco(3)
5347 c reservation des 3 nouveaux triangles dans le tableau noartr
5348 c ===========================================================
5350 c le numero du sous-triangle i dans le tableau noartr
5351 if( n1artr .le. 0 ) then
5352 c tableau noartr sature
5357 c le nouveau premier triangle libre dans noartr
5358 n1artr = noartr(2,n1artr)
5361 c les numeros des 3 sommets du triangle nt
5362 call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
5364 c formation des 3 aretes nosotr(i)-np dans le tableau nosoar
5365 c ==========================================================
5369 c le triangle a creer
5372 c les 2 sommets du cote i du triangle nosotr
5373 nu2sar(1) = nosotr(i)
5375 call hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar, noar )
5376 c en sortie: noar>0 => no arete retrouvee
5377 c <0 => no arete ajoutee
5378 c =0 => saturation du tableau nosoar
5380 if( noar .eq. 0 ) then
5381 c saturation du tableau nosoar
5384 else if( noar .lt. 0 ) then
5385 c l'arete a ete ajoutee. initialisation des autres informations
5387 c le numero des 2 sommets a ete initialise par hasoar
5388 c et (nosoar(1,noar)<nosoar(2,noar))
5389 c le numero de la ligne de l'arete: ici arete interne
5392 c l'arete a ete retrouvee
5393 c le numero des 2 sommets a ete retrouve par hasoar
5394 c et (nosoar(1,noar)<nosoar(2,noar))
5395 c le numero de ligne reste inchange
5398 c le triangle 1 de l'arete noar => le triangle nt0
5399 nosoar(4,noar) = nt0
5400 c le triangle 2 de l'arete noar => le triangle nti
5401 nosoar(5,noar) = nti
5403 c le sommet nosotr(i) appartient a l'arete noar
5404 noarst( nosotr(i) ) = noar
5406 c le numero d'arete nosotr(i)-np
5409 c le triangle qui precede le suivant
5413 c le numero d'une arete du point np
5416 c les 3 sous-triangles du triangle nt sont formes dans le tableau noartr
5417 c ======================================================================
5420 c le numero suivant i => i mod 3 + 1
5427 c le numero dans noartr du sous-triangle a ajouter
5430 c le numero de l'arete i du triangle initial nt
5431 c est l'arete 1 du sous-triangle i
5433 noartr( 1, nti ) = noar
5435 c mise a jour du numero de triangle de cette arete
5437 if( nosoar(4,noar) .eq. nt ) then
5438 c le sous-triangle nti remplace le triangle nt
5439 nosoar(4,noar) = nti
5441 c le sous-triangle nti remplace le triangle nt
5442 nosoar(5,noar) = nti
5445 c l'arete 2 du sous-triangle i est l'arete i1 ajoutee
5446 if( nosotr(i1) .eq. nosoar(1,nuarco(i1)) ) then
5447 c l'arete ns i1-np dans nosoar est dans le sens direct
5448 noartr( 2, nti ) = nuarco(i1)
5450 c l'arete ns i1-np dans nosoar est dans le sens indirect
5451 noartr( 2, nti ) = -nuarco(i1)
5454 c l'arete 3 du sous-triangle i est l'arete i ajoutee
5455 if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
5456 c l'arete ns i1-np dans nosoar est dans le sens indirect
5457 noartr( 3, nti ) = -nuarco(i)
5459 c l'arete ns i1-np dans nosoar est dans le sens direct
5460 noartr( 3, nti ) = nuarco(i)
5464 c le triangle nt est rendu libre
5465 c ==============================
5466 c il devient n1artr le premier triangle libre
5468 noartr( 2, nt ) = n1artr
5473 subroutine mt4sqa( na, moartr, noartr, mosoar, nosoar,
5474 % ns1, ns2, ns3, ns4)
5475 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5476 c but : calcul du numero des 4 sommets de l'arete na de nosoar
5477 c ----- formant un quadrangle
5481 c na : numero de l'arete dans nosoar a traiter
5482 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5483 c arete1=0 si triangle vide => arete2=triangle vide suivant
5484 c mosoar : nombre maximal d'entiers par arete
5485 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
5486 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
5490 c ns1,ns2,ns3 : les 3 numeros des sommets du triangle t1 en sens direct
5491 c ns1,ns4,ns2 : les 3 numeros des sommets du triangle t2 en sens direct
5493 c si erreur rencontree => ns4 = 0
5494 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5495 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5496 c2345x7..............................................................012
5497 common / unites / lecteu, imprim, nunite(30)
5498 integer noartr(moartr,*), nosoar(mosoar,*)
5500 c le numero de triangle est il correct ?
5501 c a supprimer apres mise au point
5502 if( na .le. 0 ) then
5504 c write(kerr(mxlger)(1:6),'(i6)') na
5505 c kerr(1) = kerr(mxlger)(1:6) //
5506 c % ' no incorrect arete dans nosoar'
5508 write(imprim,*) na, ' no incorrect arete dans nosoar'
5513 if( nosoar(1,na) .le. 0 ) then
5515 c write(kerr(mxlger)(1:6),'(i6)') na
5516 c kerr(1) = kerr(mxlger)(1:6) //
5517 c % ' arete non active dans nosoar'
5519 write(imprim,*) na, ' arete non active dans nosoar'
5524 c recherche de l'arete na dans le premier triangle
5526 if( nt .le. 0 ) then
5528 c write(kerr(mxlger)(1:6),'(i6)') na
5529 c kerr(1) = 'triangle 1 incorrect pour l''arete ' //
5530 c % kerr(mxlger)(1:6)
5532 write(imprim,*) 'triangle 1 incorrect pour l''arete ', na
5538 if( abs( noartr(i,nt) ) .eq. na ) goto 8
5540 c si arrivee ici => bogue avant
5541 write(imprim,*) 'mt4sqa: arete',na,' non dans le triangle',nt
5545 c les 2 sommets de l'arete na
5546 8 if( noartr(i,nt) .gt. 0 ) then
5553 ns1 = nosoar(ns1,na)
5554 ns2 = nosoar(ns2,na)
5562 naa = abs( noartr(i,nt) )
5564 c le sommet ns3 du triangle 123
5566 if( ns3 .eq. ns1 .or. ns3 .eq. ns2 ) then
5570 c le triangle de l'autre cote de l'arete na
5571 c =========================================
5573 if( nt .le. 0 ) then
5575 c write(kerr(mxlger)(1:6),'(i6)') na
5576 c kerr(1) = 'triangle 2 incorrect pour l''arete ' //
5577 c % kerr(mxlger)(1:6)
5579 write(imprim,*) 'triangle 2 incorrect pour l''arete ',na
5584 c le numero de l'arete naa du triangle nt
5585 naa = abs( noartr(1,nt) )
5586 if( naa .eq. na ) naa = abs( noartr(2,nt) )
5588 if( ns4 .eq. ns1 .or. ns4 .eq. ns2 ) then
5594 subroutine te2t2t( noaret, mosoar, n1soar, nosoar, noarst,
5595 % moartr, noartr, noar34 )
5596 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5597 c but : echanger la diagonale des 2 triangles ayant en commun
5598 c ----- l'arete noaret du tableau nosoar si c'est possible
5602 c noaret : numero de l'arete a echanger entre les 2 triangles
5603 c mosoar : nombre maximal d'entiers par arete
5604 c moartr : nombre maximal d'entiers par triangle
5608 c n1soar : numero de la premiere arete vide dans le tableau nosoar
5609 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
5610 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
5611 c noarst : noarst(i) numero d'une arete de sommet i
5612 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5613 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5617 c noar34 : numero nosoar de la nouvelle arete diagonale
5618 c 0 si pas d'echange des aretes diagonales
5619 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5620 c auteur : alain perronnet analyse numerique paris upmc avril 1997
5621 c....................................................................012
5622 common / unites / lecteu,imprim,intera,nunite(29)
5623 integer nosoar(mosoar,*),
5627 c une arete frontaliere ne peut etre echangee
5629 if( nosoar(3,noaret) .gt. 0 ) return
5631 c les 4 sommets des 2 triangles ayant l'arete noaret en commun
5632 call mt4sqa( noaret, moartr, noartr, mosoar, nosoar,
5633 % ns1, ns2, ns3, ns4)
5634 c ns1,ns2,ns3 : les 3 numeros des sommets du triangle nt1 en sens direct
5635 c ns1,ns4,ns2 : les 3 numeros des sommets du triangle nt2 en sens direct
5637 c recherche du numero de l'arete noaret dans le triangle nt1
5638 nt1 = nosoar(4,noaret)
5640 if( abs(noartr(n1,nt1)) .eq. noaret ) goto 15
5642 c impossible d'arriver ici sans bogue!
5643 write(imprim,*) 'anomalie dans te2t2t 1'
5645 c l'arete de sommets 2 et 3
5646 15 if( n1 .lt. 3 ) then
5651 na23 = noartr(n2,nt1)
5653 c l'arete de sommets 3 et 1
5654 if( n2 .lt. 3 ) then
5659 na31 = noartr(n3,nt1)
5661 c recherche du numero de l'arete noaret dans le triangle nt2
5662 nt2 = nosoar(5,noaret)
5664 if( abs(noartr(n1,nt2)) .eq. noaret ) goto 25
5666 c impossible d'arriver ici sans bogue!
5667 write(imprim,*) 'Anomalie dans te2t2t 2'
5669 c l'arete de sommets 1 et 4
5670 25 if( n1 .lt. 3 ) then
5675 na14 = noartr(n2,nt2)
5677 c l'arete de sommets 4 et 2
5678 if( n2 .lt. 3 ) then
5683 na42 = noartr(n3,nt2)
5685 c les triangles 123 142 deviennent 143 234
5686 c ========================================
5687 c ajout de l'arete ns3-ns4
5688 c on evite l'affichage de l'erreur
5690 call fasoar( ns3, ns4, nt1, nt2, 0,
5691 % mosoar, mxsoar, n1soar, nosoar, noarst,
5693 if( ierr .gt. 0 ) then
5694 c ierr=1 si le tableau nosoar est sature
5695 c =2 si arete a creer et appartenant a 2 triangles distincts
5696 c des triangles nt1 et nt2
5697 c =3 si arete appartenant a 2 triangles distincts
5698 c differents des triangles nt1 et nt2
5699 c =4 si arete appartenant a 2 triangles distincts
5700 c dont le second n'est pas le triangle nt2
5706 c suppression de l'arete noaret
5707 call sasoar( noaret, mosoar, mxsoar, n1soar, nosoar, noarst )
5709 c nt1 = triangle 143
5710 noartr(1,nt1) = na14
5711 c sens de stockage de l'arete ns3-ns4 dans nosoar?
5712 if( nosoar(1,noar34) .eq. ns3 ) then
5717 noartr(2,nt1) = noar34 * n1
5718 noartr(3,nt1) = na31
5720 c nt2 = triangle 234
5721 noartr(1,nt2) = na23
5722 noartr(2,nt2) = -noar34 * n1
5723 noartr(3,nt2) = na42
5725 c echange nt1 -> nt2 pour l'arete na23
5727 if( nosoar(4,na23) .eq. nt1 ) then
5732 nosoar(n1,na23) = nt2
5734 c echange nt2 -> nt1 pour l'arete na14
5736 if( nosoar(4,na14) .eq. nt2 ) then
5741 nosoar(n1,na14) = nt1
5743 c numero d'une arete de chacun des 4 sommets
5746 noarst(ns3) = noar34
5747 noarst(ns4) = noar34
5751 subroutine f0trte( letree, pxyd,
5752 % mosoar, mxsoar, n1soar, nosoar,
5753 % moartr, mxartr, n1artr, noartr,
5755 % nbtr, nutr, ierr )
5756 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5757 c but : former le ou les triangles du triangle equilateral letree
5758 c ----- les points internes au te deviennent des sommets des
5759 c sous-triangles du te
5763 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
5764 c si letree(0)>0 alors
5765 c letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
5767 c letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
5769 c ( le te est une feuille de l'arbre )
5770 c letree(4) : no letree du sur-triangle du triangle j
5771 c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
5772 c letree(6:8) : no pxyd des 3 sommets du triangle j
5773 c pxyd : tableau des x y distance_souhaitee de chaque sommet
5774 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
5775 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5776 c moartr : nombre maximal d'entiers par arete du tableau noartr
5777 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
5781 c n1soar : numero de la premiere arete vide dans le tableau nosoar
5782 c une arete i de nosoar est vide <=> nosoar(1,i)=0
5783 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
5784 c chainage des aretes frontalieres, chainage du hachage des aretes
5785 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
5786 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
5787 c n1artr : numero du premier triangle vide dans le tableau noartr
5788 c le chainage des triangles vides se fait sur noartr(2,.)
5789 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5790 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5791 c noarst : noarst(i) numero d'une arete de sommet i
5795 c nbtr : nombre de sous-triangles du te, triangulation du te
5796 c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
5797 c ierr : =0 si pas d'erreur
5798 c =1 si le tableau nosoar est sature
5799 c =2 si le tableau noartr est sature
5800 c =3 si aucun des triangles ne contient l'un des points internes au te
5801 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5802 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5803 c....................................................................012
5804 common / unites / lecteu, imprim, nunite(30)
5805 double precision pxyd(3,*)
5806 integer letree(0:8),
5807 % nosoar(mosoar,mxsoar),
5808 % noartr(moartr,mxartr),
5813 c le numero nt du triangle dans le tableau noartr
5814 if( n1artr .le. 0 ) then
5815 c tableau noartr sature
5816 write(imprim,*) 'f0trte: tableau noartr sature'
5821 c le numero du nouveau premier triangle libre dans noartr
5822 n1artr = noartr( 2, n1artr )
5824 c formation du triangle = le triangle equilateral letree
5831 c ajout eventuel de l'arete si si+1 dans le tableau nosoar
5832 call fasoar( letree(5+i), letree(5+i1), nt, -1, 0,
5833 % mosoar, mxsoar, n1soar, nosoar, noarst,
5835 if( ierr .ne. 0 ) return
5838 c le triangle nt est forme dans le tableau noartr
5840 c letree(5+i) est le numero du sommet 1 de l'arete i du te
5841 if( letree(5+i) .eq. nosoar(1,nuarco(i)) ) then
5846 c l'arete ns1-ns2 dans nosoar est celle du cote du te
5847 noartr( i, nt ) = lesign * nuarco(i)
5850 c triangulation du te=triangle nt par ajout des points internes du te
5853 call trpite( letree, pxyd,
5854 % mosoar, mxsoar, n1soar, nosoar,
5855 % moartr, mxartr, n1artr, noartr, noarst,
5856 % nbtr, nutr, ierr )
5860 subroutine f1trte( letree, pxyd, milieu,
5861 % mosoar, mxsoar, n1soar, nosoar,
5862 % moartr, mxartr, n1artr, noartr,
5864 % nbtr, nutr, ierr )
5865 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5866 c but : former les triangles du triangle equilateral letree
5867 c ----- a partir de l'un des 3 milieux des cotes du te
5868 c et des points internes au te
5869 c ils deviennent tous des sommets des sous-triangles du te
5873 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
5874 c si letree(0)>0 alors
5875 c letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
5877 c letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
5879 c ( le te est une feuille de l'arbre )
5880 c letree(4) : no letree du sur-triangle du triangle j
5881 c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
5882 c letree(6:8) : no pxyd des 3 sommets du triangle j
5883 c pxyd : tableau des x y distance_souhaitee de chaque sommet
5884 c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
5885 c 0 si pas de milieu du cote i a ajouter
5886 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
5887 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5888 c moartr : nombre maximal d'entiers par arete du tableau noartr
5889 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
5893 c n1soar : numero de la premiere arete vide dans le tableau nosoar
5894 c une arete i de nosoar est vide <=> nosoar(1,i)=0
5895 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
5896 c chainage des aretes frontalieres, chainage du hachage des aretes
5897 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
5898 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
5899 c n1artr : numero du premier triangle vide dans le tableau noartr
5900 c le chainage des triangles vides se fait sur noartr(2,.)
5901 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5902 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5903 c noarst : noarst(np) numero d'une arete du sommet np
5907 c nbtr : nombre de sous-triangles du te, triangulation du te
5908 c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
5909 c ierr : =0 si pas d'erreur
5910 c =1 si le tableau nosoar est sature
5911 c =2 si le tableau noartr est sature
5912 c =3 si aucun des triangles ne contient l'un des points internes au te
5913 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5914 c auteur : alain perronnet analyse numerique paris upmc mars 1997
5915 c....................................................................012
5916 double precision pxyd(3,*)
5917 integer letree(0:8),
5919 % nosoar(mosoar,mxsoar),
5920 % noartr(moartr,mxartr),
5924 integer nosotr(3), nuarco(5)
5926 c le numero des 2 triangles (=2 demi te) a creer dans le tableau noartr
5928 if( n1artr .le. 0 ) then
5929 c tableau noartr sature
5934 c le nouveau premier triangle libre dans noartr
5935 n1artr = noartr(2,n1artr)
5939 c recherche du milieu a creer
5941 if( milieu(i) .ne. 0 ) goto 9
5943 c le numero pxyd du point milieu du cote i
5946 c on se ramene au seul cas i=3 c-a-d le milieu est sur le cote 3
5948 c milieu sur le cote 1
5949 nosotr(1) = letree(7)
5950 nosotr(2) = letree(8)
5951 nosotr(3) = letree(6)
5952 else if( i .eq. 2 ) then
5953 c milieu sur le cote 2
5954 nosotr(1) = letree(8)
5955 nosotr(2) = letree(6)
5956 nosotr(3) = letree(7)
5958 c milieu sur le cote 3
5959 nosotr(1) = letree(6)
5960 nosotr(2) = letree(7)
5961 nosotr(3) = letree(8)
5964 c formation des 2 aretes s1 s2 et s2 s3
5971 c ajout eventuel de l'arete dans nosoar
5972 call fasoar( nosotr(i), nosotr(i1), nutr(i), -1, 0,
5973 % mosoar, mxsoar, n1soar, nosoar, noarst,
5975 if( ierr .ne. 0 ) return
5978 c ajout eventuel de l'arete s3 milieu dans nosoar
5979 call fasoar( nosotr(3), nm, nutr(2), -1, 0,
5980 % mosoar, mxsoar, n1soar, nosoar, noarst,
5982 if( ierr .ne. 0 ) return
5984 c ajout eventuel de l'arete milieu s1 dans nosoar
5985 call fasoar( nosotr(1), nm, nutr(1), -1, 0,
5986 % mosoar, mxsoar, n1soar, nosoar, noarst,
5988 if( ierr .ne. 0 ) return
5990 c ajout eventuel de l'arete milieu s2 dans nosoar
5991 call fasoar( nosotr(2), nm, nutr(1), nutr(2), 0,
5992 % mosoar, mxsoar, n1soar, nosoar, noarst,
5994 if( ierr .ne. 0 ) return
5996 c les aretes s1 s2 et s2 s3 dans le tableau noartr
5998 c nosotr(i) est le numero du sommet 1 de l'arete i du te
5999 if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
6004 c l'arete ns1-ns2 dans nosoar est celle du cote du te
6005 noartr( 1, nutr(i) ) = lesign * nuarco(i)
6008 c l'arete mediane s2 milieu
6009 if( nm .eq. nosoar(1,nuarco(5)) ) then
6014 noartr( 2, nutr(1) ) = lesign * nuarco(5)
6015 noartr( 3, nutr(2) ) = -lesign * nuarco(5)
6018 if( nm .eq. nosoar(1,nuarco(4)) ) then
6023 noartr( 3, nutr(1) ) = lesign * nuarco(4)
6026 if( nm .eq. nosoar(1,nuarco(3)) ) then
6031 noartr( 2, nutr(2) ) = lesign * nuarco(3)
6033 c triangulation des 2 demi te par ajout des points internes du te
6034 call trpite( letree, pxyd,
6035 % mosoar, mxsoar, n1soar, nosoar,
6036 % moartr, mxartr, n1artr, noartr, noarst,
6037 % nbtr, nutr, ierr )
6041 subroutine f2trte( letree, pxyd, milieu,
6042 % mosoar, mxsoar, n1soar, nosoar,
6043 % moartr, mxartr, n1artr, noartr,
6045 % nbtr, nutr, ierr )
6046 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6047 c but : former les triangles du triangle equilateral letree
6048 c ----- a partir de 2 milieux des cotes du te
6049 c et des points internes au te
6050 c ils deviennent tous des sommets des sous-triangles du te
6054 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
6055 c si letree(0)>0 alors
6056 c letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
6058 c letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
6060 c ( le te est une feuille de l'arbre )
6061 c letree(4) : no letree du sur-triangle du triangle j
6062 c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
6063 c letree(6:8) : no pxyd des 3 sommets du triangle j
6064 c pxyd : tableau des x y distance_souhaitee de chaque sommet
6065 c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
6066 c 0 si pas de milieu du cote i a ajouter
6067 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
6068 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6069 c moartr : nombre maximal d'entiers par arete du tableau noartr
6070 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
6074 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6075 c une arete i de nosoar est vide <=> nosoar(1,i)=0
6076 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6077 c chainage des aretes frontalieres, chainage du hachage des aretes
6078 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
6079 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6080 c n1artr : numero du premier triangle vide dans le tableau noartr
6081 c le chainage des triangles vides se fait sur noartr(2,.)
6082 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6083 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
6084 c noarst : noarst(np) numero d'une arete du sommet np
6088 c nbtr : nombre de sous-triangles du te, triangulation du te
6089 c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
6090 c ierr : =0 si pas d'erreur
6091 c =1 si le tableau nosoar est sature
6092 c =2 si le tableau noartr est sature
6093 c =3 si aucun des triangles ne contient l'un des points internes au te
6094 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6095 c auteur : alain perronnet analyse numerique paris upmc mars 1997
6096 c....................................................................012
6097 common / unites / lecteu, imprim, nunite(30)
6098 double precision pxyd(3,*)
6099 integer letree(0:8),
6101 % nosoar(mosoar,mxsoar),
6102 % noartr(moartr,mxartr),
6106 integer nosotr(3), nuarco(7)
6108 c le numero des 3 triangles a creer dans le tableau noartr
6110 if( n1artr .le. 0 ) then
6111 c tableau noartr sature
6116 c le nouveau premier triangle libre dans noartr
6117 n1artr = noartr(2,n1artr)
6121 c recherche du premier milieu a creer
6123 if( milieu(i) .ne. 0 ) goto 9
6126 c on se ramene au seul cas i=2 c-a-d le cote 1 n'a pas de milieu
6127 9 if( i .eq. 2 ) then
6128 c pas de milieu sur le cote 1
6129 nosotr(1) = letree(6)
6130 nosotr(2) = letree(7)
6131 nosotr(3) = letree(8)
6132 c le numero pxyd du milieu du cote 2
6134 c le numero pxyd du milieu du cote 3
6136 else if( milieu(2) .ne. 0 ) then
6137 c pas de milieu sur le cote 3
6138 nosotr(1) = letree(8)
6139 nosotr(2) = letree(6)
6140 nosotr(3) = letree(7)
6141 c le numero pxyd du milieu du cote 2
6143 c le numero pxyd du milieu du cote 3
6146 c pas de milieu sur le cote 2
6147 nosotr(1) = letree(7)
6148 nosotr(2) = letree(8)
6149 nosotr(3) = letree(6)
6150 c le numero pxyd du milieu du cote 2
6152 c le numero pxyd du milieu du cote 3
6156 c ici seul le cote 1 n'a pas de milieu
6157 c nm2 est le milieu du cote 2
6158 c nm3 est le milieu du cote 3
6160 c ajout eventuel de l'arete s1 s2 dans nosoar
6161 call fasoar( nosotr(1), nosotr(2), nutr(1), -1, 0,
6162 % mosoar, mxsoar, n1soar, nosoar, noarst,
6164 if( ierr .ne. 0 ) return
6166 c ajout eventuel de l'arete s1 s2 dans nosoar
6167 call fasoar( nosotr(2), nm2, nutr(1), -1, 0,
6168 % mosoar, mxsoar, n1soar, nosoar, noarst,
6170 if( ierr .ne. 0 ) return
6172 c ajout eventuel de l'arete s1 nm2 dans nosoar
6173 call fasoar( nosotr(1), nm2, nutr(1), nutr(2), 0,
6174 % mosoar, mxsoar, n1soar, nosoar, noarst,
6176 if( ierr .ne. 0 ) return
6178 c ajout eventuel de l'arete nm2 nm3 dans nosoar
6179 call fasoar( nm3, nm2, nutr(2), nutr(3), 0,
6180 % mosoar, mxsoar, n1soar, nosoar, noarst,
6182 if( ierr .ne. 0 ) return
6184 c ajout eventuel de l'arete s1 nm3 dans nosoar
6185 call fasoar( nosotr(1), nm3, nutr(2), -1, 0,
6186 % mosoar, mxsoar, n1soar, nosoar, noarst,
6188 if( ierr .ne. 0 ) return
6190 c ajout eventuel de l'arete nm2 s3 dans nosoar
6191 call fasoar( nm2, nosotr(3), nutr(3), -1, 0,
6192 % mosoar, mxsoar, n1soar, nosoar, noarst,
6195 c ajout eventuel de l'arete nm3 s3 dans nosoar
6196 call fasoar( nosotr(3), nm3, nutr(3), -1, 0,
6197 % mosoar, mxsoar, n1soar, nosoar, noarst,
6199 if( ierr .ne. 0 ) return
6201 c le triangle s1 s2 nm2 ou arete1 arete2 arete3
6203 c nosotr(i) est le numero du sommet 1 de l'arete i du te
6204 if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
6209 c l'arete ns1-ns2 dans nosoar est celle du cote du te
6210 noartr( i, nutr(1) ) = lesign * nuarco(i)
6212 if( nm2 .eq. nosoar(1,nuarco(3)) ) then
6217 noartr( 3, nutr(1) ) = lesign * nuarco(3)
6219 c le triangle s1 nm2 nm3
6220 noartr( 1, nutr(2) ) = -lesign * nuarco(3)
6221 if( nm2 .eq. nosoar(1,nuarco(4)) ) then
6226 noartr( 2, nutr(2) ) = lesign * nuarco(4)
6227 noartr( 1, nutr(3) ) = -lesign * nuarco(4)
6228 if( nm3 .eq. nosoar(1,nuarco(5)) ) then
6233 noartr( 3, nutr(2) ) = lesign * nuarco(5)
6235 c le triangle nm2 nm3 s3
6236 if( nm2 .eq. nosoar(1,nuarco(6)) ) then
6241 noartr( 2, nutr(3) ) = lesign * nuarco(6)
6242 if( nm3 .eq. nosoar(1,nuarco(7)) ) then
6247 noartr( 3, nutr(3) ) = lesign * nuarco(7)
6249 c triangulation des 3 sous-te par ajout des points internes du te
6250 call trpite( letree, pxyd,
6251 % mosoar, mxsoar, n1soar, nosoar,
6252 % moartr, mxartr, n1artr, noartr, noarst,
6253 % nbtr, nutr, ierr )
6257 subroutine f3trte( letree, pxyd, milieu,
6258 % mosoar, mxsoar, n1soar, nosoar,
6259 % moartr, mxartr, n1artr, noartr,
6261 % nbtr, nutr, ierr )
6262 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6263 c but : former les triangles du triangle equilateral letree
6264 c ----- a partir de 3 milieux des cotes du te
6265 c et des points internes au te
6266 c ils deviennent tous des sommets des sous-triangles du te
6270 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
6271 c si letree(0)>0 alors
6272 c letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
6274 c letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
6276 c ( le te est une feuille de l'arbre )
6277 c letree(4) : no letree du sur-triangle du triangle j
6278 c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
6279 c letree(6:8) : no pxyd des 3 sommets du triangle j
6280 c pxyd : tableau des x y distance_souhaitee de chaque sommet
6281 c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
6282 c 0 si pas de milieu du cote i a ajouter
6283 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
6284 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6285 c moartr : nombre maximal d'entiers par arete du tableau noartr
6286 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
6290 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6291 c une arete i de nosoar est vide <=> nosoar(1,i)=0
6292 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6293 c chainage des aretes frontalieres, chainage du hachage des aretes
6294 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
6295 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6296 c n1artr : numero du premier triangle vide dans le tableau noartr
6297 c le chainage des triangles vides se fait sur noartr(2,.)
6298 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6299 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
6300 c noarst : noarst(np) numero d'une arete du sommet np
6304 c nbtr : nombre de sous-triangles du te, triangulation du te
6305 c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
6306 c ierr : =0 si pas d'erreur
6307 c =1 si le tableau nosoar est sature
6308 c =2 si le tableau noartr est sature
6309 c =3 si aucun des triangles ne contient l'un des points internes au te
6310 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6311 c auteur : alain perronnet analyse numerique paris upmc mars 1997
6312 c....................................................................012
6313 double precision pxyd(3,*)
6314 integer letree(0:8),
6316 % nosoar(mosoar,mxsoar),
6317 % noartr(moartr,mxartr),
6323 c le numero des 4 triangles a creer dans le tableau noartr
6325 if( n1artr .le. 0 ) then
6326 c tableau noartr sature
6331 c le nouveau premier triangle libre dans noartr
6332 n1artr = noartr(2,n1artr)
6343 c le sommet precedant
6351 c ajout eventuel de l'arete si mi dans nosoar
6352 call fasoar( letree(5+i), milieu(i), nutr(i), -1, 0,
6353 % mosoar, mxsoar, n1soar, nosoar, noarst,
6354 % nuarco(i3-2), ierr )
6355 if( ierr .ne. 0 ) return
6357 c ajout eventuel de l'arete mi mi-1 dans nosoar
6358 call fasoar( milieu(i), milieu(i0), nutr(i), nutr(4), 0,
6359 % mosoar, mxsoar, n1soar, nosoar, noarst,
6360 % nuarco(i3-1), ierr )
6361 if( ierr .ne. 0 ) return
6363 c ajout eventuel de l'arete m i-1 si dans nosoar
6364 call fasoar( milieu(i0), letree(5+i), nutr(i), -1, 0,
6365 % mosoar, mxsoar, n1soar, nosoar, noarst,
6366 % nuarco(i3), ierr )
6367 if( ierr .ne. 0 ) return
6371 c les 3 sous-triangles pres des sommets
6379 c le sommet precedant
6387 c ajout du triangle arete3i-2 arete3i-1 arete3i
6388 if( letree(5+i) .eq. nosoar(1,nuarco(i3-2)) ) then
6393 noartr( 1, nutr(i) ) = lesign * nuarco(i3-2)
6395 if( milieu(i) .eq. nosoar(1,nuarco(i3-1)) ) then
6400 noartr( 2, nutr(i) ) = lesign * nuarco(i3-1)
6402 if( milieu(i0) .eq. nosoar(1,nuarco(i3)) ) then
6407 noartr( 3, nutr(i) ) = lesign * nuarco(i3)
6411 c le sous triangle central
6415 if( milieu(i) .eq. nosoar(1,nuarco(i3)) ) then
6420 noartr( i, nutr(4) ) = lesign * nuarco(i3)
6423 c triangulation des 3 sous-te par ajout des points internes du te
6424 call trpite( letree, pxyd,
6425 % mosoar, mxsoar, n1soar, nosoar,
6426 % moartr, mxartr, n1artr, noartr, noarst,
6427 % nbtr, nutr, ierr )
6432 subroutine hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar,
6434 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6435 c but : rechercher le numero des 2 sommets d'une arete parmi
6436 c ----- les numeros des 2 sommets des aretes du tableau nosoar
6437 c s ils n y sont pas stockes les y ajouter
6438 c dans tous les cas retourner le numero de l'arete dans nosoar
6440 c la methode employee ici est celle du hachage
6441 c avec pour fonction d'adressage h(ns1,ns2)=min(ns1,ns2)
6443 c remarque: h(ns1,ns2)=ns1 + 2*ns2
6444 c ne marche pas si des aretes sont detruites
6445 c et ajoutees aux aretes vides
6446 c le chainage est commun a plusieurs hachages!
6447 c d'ou ce choix du minimum pour le hachage
6451 c mosoar : nombre maximal d'entiers par arete et
6452 c indice dans nosoar de l'arete suivante dans le hachage
6453 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6454 c attention: mxsoar>3*mxsomm obligatoire!
6458 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6459 c une arete i de nosoar est vide <=> nosoar(1,i)=0
6460 c chainage des aretes vides amont et aval
6461 c l'arete vide qui precede=nosoar(4,i)
6462 c l'arete vide qui suit =nosoar(5,i)
6463 c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
6464 c chainage momentan'e d'aretes, chainage du hachage des aretes
6465 c hachage des aretes = min( nosoar(1), nosoar(2) )
6466 c nu2sar : en entree les 2 numeros des sommets de l'arete
6467 c en sortie nu2sar(1)<nu2sar(2) numeros des 2 sommets de l'arete
6471 c noar : numero dans nosoar de l'arete apres hachage
6472 c =0 si saturation du tableau nosoar
6473 c >0 si le tableau nu2sar est l'arete noar retrouvee
6474 c dans le tableau nosoar
6475 c <0 si le tableau nu2sar a ete ajoute et forme l'arete
6476 c -noar du tableau nosoar avec nosoar(1,noar)<nosoar(2,noar)
6477 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6478 c auteur : alain perronnet analyse numerique upmc paris mars 1997
6479 c ...................................................................012
6480 integer nu2sar(2), nosoar(mosoar,mxsoar)
6482 if( nu2sar(1) .gt. nu2sar(2) ) then
6484 c permutation des numeros des 2 sommets pour
6485 c amener le plus petit dans nu2sar(1)
6487 nu2sar(1) = nu2sar(2)
6491 c la fonction d'adressage du hachage des aretes : h(ns1,ns2)=min(ns1,ns2)
6492 c ===============================================
6495 c la recherche de l'arete dans le chainage du hachage
6496 c ---------------------------------------------------
6497 10 if( nu2sar(1) .eq. nosoar(1,noar) ) then
6498 if( nu2sar(2) .eq. nosoar(2,noar) ) then
6500 c l'arete est retrouvee
6501 c .....................
6506 c l'arete suivante parmi celles ayant meme fonction d'adressage
6507 i = nosoar( mosoar, noar )
6513 c noar est ici la derniere arete (sans suivante) du chainage
6514 c a partir de l'adressage du hachage
6516 c l'arete non retrouvee doit etre ajoutee
6517 c .......................................
6518 if( nosoar( 1, nu2sar(1) ) .eq. 0 ) then
6520 c l'adresse de hachage est libre => elle devient la nouvelle arete
6521 c retouche des chainages de cette arete noar qui ne sera plus vide
6523 c l'eventuel chainage du hachage n'est pas modifie
6527 c la premiere arete dans l'adressage du hachage n'est pas libre
6528 c => choix quelconque d'une arete vide pour ajouter cette arete
6529 if( n1soar .le. 0 ) then
6531 c le tableau nosoar est sature avec pour temoin d'erreur
6537 c l'arete n1soar est vide => c'est la nouvelle arete
6538 c mise a jour du chainage de la derniere arete noar du chainage
6539 c sa suivante est la nouvelle arete n1soar
6540 nosoar( mosoar, noar ) = n1soar
6542 c l'arete ajoutee est n1soar
6545 c la nouvelle premiere arete vide
6546 n1soar = nosoar( 5, n1soar )
6548 c la premiere arete vide n1soar n'a pas d'arete vide precedente
6549 nosoar( 4, n1soar ) = 0
6551 c noar la nouvelle arete est la derniere du chainage du hachage
6552 nosoar( mosoar, noar ) = 0
6558 c les 2 sommets de la nouvelle arete noar
6559 nosoar( 1, noar ) = nu2sar(1)
6560 nosoar( 2, noar ) = nu2sar(2)
6562 c le tableau nu2sar a ete ajoute avec l'indice -noar
6567 subroutine mt3str( nt, moartr, noartr, mosoar, nosoar,
6569 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6570 c but : calcul du numero des 3 sommets du triangle nt du tableau noartr
6575 c nt : numero du triangle de noartr a traiter
6576 c moartr : nombre maximal d'entiers par triangle
6577 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6578 c arete1=0 si triangle vide => arete2=triangle vide suivant
6579 c mosoar : nombre maximal d'entiers par arete
6580 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
6581 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6585 c ns1,ns2,ns3 : les 3 numeros des sommets du triangle en sens direct
6587 c si erreur rencontree => ns1 = 0
6588 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6589 c auteur : alain perronnet analyse numerique paris upmc juillet 1995
6590 c2345x7..............................................................012
6591 common / unites / lecteu, imprim, nunite(30)
6592 integer noartr(moartr,*), nosoar(mosoar,*)
6594 c le numero de triangle est il correct ?
6595 c a supprimer apres mise au point
6596 if( nt .le. 0 ) then
6598 c write(kerr(mxlger)(1:6),'(i6)') nt
6599 c kerr(1) = kerr(mxlger)(1:6) //
6600 c % ' no triangle dans noartr incorrect'
6602 write(imprim,*) nt,' no triangle dans noartr incorrect'
6608 if( na .gt. 0 ) then
6609 c arete dans le sens direct
6613 c arete dans le sens indirect
6619 if( na .gt. 0 ) then
6620 c arete dans le sens direct => ns3 est le second sommet de l'arete
6623 c arete dans le sens indirect => ns3 est le premier sommet de l'arete
6628 subroutine trpite( letree, pxyd,
6629 % mosoar, mxsoar, n1soar, nosoar,
6630 % moartr, mxartr, n1artr, noartr,
6632 % nbtr, nutr, ierr )
6633 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6634 c but : former le ou les sous-triangles des nbtr triangles nutr
6635 c ----- qui forment le triangle equilateral letree par ajout
6636 c des points internes au te qui deviennent des sommets des
6637 c sous-triangles des nbtr triangles
6641 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
6642 c letree(0:3):-no pxyd des 1 a 4 points internes au triangle j
6644 c ( le te est ici une feuille de l'arbre )
6645 c letree(4) : no letree du sur-triangle du triangle j
6646 c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
6647 c letree(6:8) : no pxyd des 3 sommets du triangle j
6648 c pxyd : tableau des x y distance_souhaitee de chaque sommet
6649 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
6650 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6651 c moartr : nombre maximal d'entiers par arete du tableau noartr
6652 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
6656 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6657 c une arete i de nosoar est vide <=> nosoar(1,i)=0
6658 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6659 c chainage des aretes frontalieres, chainage du hachage des aretes
6660 c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
6661 c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6662 c n1artr : numero du premier triangle vide dans le tableau noartr
6663 c le chainage des triangles vides se fait sur noartr(2,.)
6664 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6665 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
6666 c noarst : noarst(i) numero d'une arete de sommet i
6670 c nbtr : nombre de sous-triangles du te
6671 c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
6672 c ierr : =0 si pas d'erreur
6673 c =1 si le tableau nosoar est sature
6674 c =2 si le tableau noartr est sature
6675 c =3 si aucun des triangles ne contient l'un des points internes au te
6676 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6677 c auteur : alain perronnet analyse numerique paris upmc mars 1997
6678 c....................................................................012
6679 common / unites / lecteu, imprim, nunite(30)
6680 double precision pxyd(3,*)
6681 integer letree(0:8),
6682 % nosoar(mosoar,mxsoar),
6683 % noartr(moartr,mxartr),
6691 c si pas de point interne alors retour
6692 if( letree(0) .eq. 0 ) goto 150
6694 c il existe au moins un point interne a trianguler
6695 c dans les nbtr triangles
6698 c le numero du point
6700 if( np .eq. 0 ) goto 150
6702 c le point np dans pxyd est a traiter
6705 c les numeros des 3 sommets du triangle nt=nutr(n)
6707 call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
6709 c le triangle nt contient il le point np?
6710 call ptdatr( pxyd(1,np), pxyd, nosotr, nsigne )
6711 c nsigne>0 si le point est dans le triangle ou sur une des 3 aretes
6712 c =0 si triangle degenere ou indirect ou ne contient pas le poin
6714 if( nsigne .gt. 0 ) then
6716 c le triangle nt est triangule en 3 sous-triangles
6717 call tr3str( np, nt,
6718 % mosoar, mxsoar, n1soar, nosoar,
6719 % moartr, mxartr, n1artr, noartr,
6721 % nutr(nbtr+1), ierr )
6722 if( ierr .ne. 0 ) return
6724 c reamenagement des 3 triangles crees dans nutr
6725 c en supprimant le triangle nt
6726 nutr( n ) = nutr( nbtr + 3 )
6728 c le point np est triangule
6734 c erreur: le point np n'est pas dans l'un des nbtr triangles
6735 write(imprim,10010) np
6740 10010 format(' erreur trpite: pas de triangle contenant le point',i7)
6746 subroutine sasoar( noar, mosoar, mxsoar, n1soar, nosoar, noarst )
6747 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6748 c but : supprimer l'arete noar du tableau nosoar
6749 c ----- si celle ci n'est pas une arete des lignes de la fontiere
6751 c la methode employee ici est celle du hachage
6752 c avec pour fonction d'adressage h = min( nu2sar(1), nu2sar(2) )
6754 c attention: il faut mettre a jour le no d'arete des 2 sommets
6755 c de l'arete supprimee dans le tableau noarst!
6759 c noar : numero de l'arete de nosoar a supprimer
6760 c mosoar : nombre maximal d'entiers par arete et
6761 c indice dans nosoar de l'arete suivante dans le hachage h
6762 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6763 c attention: mxsoar>3*mxsomm obligatoire!
6767 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
6768 c chainage des vides suivant en 3 et precedant en 2 de nosoar
6769 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6770 c chainage des aretes frontalieres, chainage du hachage des aretes
6771 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
6772 c nosoar(4,arete vide)=l'arete vide qui precede
6773 c nosoar(5,arete vide)=l'arete vide qui suit
6774 c noarst : numero d'une arete de nosoar pour chaque sommet
6775 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6776 c auteur : alain perronnet analyse numerique upmc paris mars 1997
6777 c modifs : alain perronnet laboratoire jl lions upmc paris octobre 2006
6778 c ...................................................................012
6779 common / unites / lecteu, imprim, nunite(30)
6780 integer nosoar(mosoar,mxsoar), noarst(*), ns(2)
6783 c mise a jour de noarst pour les 2 sommets de l'arete a supprimer
6784 c necessaire uniquement pour les sommets frontaliers et internes imposes
6785 c le numero des 2 sommets de l'arete noar a supprimer
6786 ns(1) = nosoar(1,noar)
6787 ns(2) = nosoar(2,noar)
6789 if( noarst(ns(k)) .eq. noar ) then
6790 c il faut remettre a jour le pointeur sur une arete
6791 if(nosoar(1,ns(k)).eq.ns(k) .and. nosoar(2,ns(k)).gt.0
6792 % .and. nosoar(4,ns(k)) .gt. 0 ) then
6793 c arete active de sommet ns(k)
6794 noarst( ns(k) ) = ns(k)
6797 if( nosoar(1,i).gt.0 .and. nosoar(4,i).gt.0 ) then
6799 if( nosoar(2,i).eq.ns(k) .or.
6800 % (nosoar(1,i).eq.ns(k).and.nosoar(2,i).gt.0))then
6801 c arete active de sommet ns(k)
6812 if( nosoar(3,noar) .le. 0 ) then
6814 c l'arete n'est pas frontaliere => elle devient une arete vide
6816 c recherche de l'arete qui precede dans le chainage du hachage
6817 noar1 = nosoar(1,noar)
6819 c parcours du chainage du hachage jusqu'a retrouver l'arete noar
6820 10 if( noar1 .ne. noar ) then
6822 c l'arete suivante parmi celles ayant meme fonction d'adressage
6824 noar1 = nosoar( mosoar, noar1 )
6825 if( noar1 .gt. 0 ) goto 10
6827 c l'arete noar n'a pas ete retrouvee dans le chainage => erreur
6828 write(imprim,*) 'erreur sasoar:arete non dans le chainage '
6830 write(imprim,*) 'arete de st1=',nosoar(1,noar),
6831 % ' st2=',nosoar(2,noar),' ligne=',nosoar(3,noar),
6832 % ' tr1=',nosoar(4,noar),' tr2=',nosoar(5,noar)
6833 write(imprim,*) 'chainages=',(nosoar(i,noar),i=6,mosoar)
6835 c l'arete n'est pas detruite
6840 if( noar .ne. nosoar(1,noar) ) then
6842 c saut de l'arete noar dans le chainage du hachage
6843 c noar0 initialisee est ici l'arete qui precede noar dans ce chainage
6844 nosoar( mosoar, noar0 ) = nosoar( mosoar, noar )
6846 c le chainage du hachage n'existe plus pour noar
6847 c pas utile car mise a zero faite dans le sp hasoar
6848 ccc nosoar( mosoar, noar ) = 0
6850 c noar devient la nouvelle premiere arete du chainage des vides
6851 nosoar( 4, noar ) = 0
6852 nosoar( 5, noar ) = n1soar
6853 c la nouvelle precede l'ancienne premiere
6854 nosoar( 4, n1soar ) = noar
6859 c noar est la premiere arete du chainage du hachage h
6860 c cette arete ne peut etre consideree dans le chainage des vides
6861 c car le chainage du hachage doit etre conserve (sinon perte...)
6865 c le temoin d'arete vide
6866 nosoar( 1, noar ) = 0
6871 subroutine caetoi( noar, mosoar, mxsoar, n1soar, nosoar, noarst,
6873 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6874 c but : ajouter (ou retirer) l'arete noar de nosoar de l'etoile
6875 c ----- des aretes simples chainees en position lchain de nosoar
6876 c detruire du tableau nosoar les aretes doubles
6878 c attention: le chainage lchain de nosoar devient celui des cf
6882 c noar : numero dans le tableau nosoar de l'arete a traiter
6883 c mosoar : nombre maximal d'entiers par arete et
6884 c indice dans nosoar de l'arete suivante dans le hachage
6885 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6886 c attention: mxsoar>3*mxsomm obligatoire!
6888 c entrees et sorties:
6889 c -------------------
6890 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6891 c une arete i de nosoar est vide <=> nosoar(1,i)=0
6892 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6893 c chainage des aretes frontalieres, chainage du hachage des aretes
6894 c n1aeoc : numero dans nosoar de la premiere arete simple de l'etoile
6898 c nbtrar : 1 si arete ajoutee, 2 si arete double supprimee, 0 si erreur
6899 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6900 c auteur : alain perronnet analyse numerique paris upmc mars 1997
6901 c2345x7..............................................................012
6902 parameter (lchain=6)
6903 common / unites / lecteu, imprim, nunite(30)
6904 integer nosoar(mosoar,mxsoar), noarst(*)
6906 c si l'arete n'appartient pas aux aretes de l'etoile naetoi
6907 c alors elle est ajoutee a l'etoile dans naetoi
6908 c sinon elle est empilee dans npile pour etre detruite ensuite
6909 c elle est supprimee de l'etoile naetoi
6911 if( nosoar( lchain, noar ) .lt. 0 ) then
6913 c arete de l'etoile vue pour la premiere fois
6914 c elle est ajoutee au chainage
6915 nosoar( lchain, noar ) = n1aeoc
6916 c elle devient la premiere du chainage
6923 c arete double de l'etoile. elle est supprimee du chainage
6927 c parcours des aretes chainees jusqu'a trouver l'arete noar
6928 10 if( na .ne. noar ) then
6929 c passage a la suivante
6931 na = nosoar( lchain, na )
6932 if( na .le. 0 ) then
6937 if( nbpass .gt. 512 ) then
6938 write(imprim,*)'Pb dans caetoi: boucle infinie evitee'
6945 c suppression de noar du chainage des aretes simples de l'etoile
6946 if( na0 .gt. 0 ) then
6947 c il existe une arete qui precede
6948 nosoar( lchain, na0 ) = nosoar( lchain, noar )
6950 c noar est en fait n1aeoc la premiere du chainage
6951 n1aeoc = nosoar( lchain, noar )
6953 c noar n'est plus une arete simple de l'etoile
6954 nosoar( lchain, noar ) = -1
6956 c destruction du tableau nosoar de l'arete double noar
6957 call sasoar( noar, mosoar, mxsoar, n1soar, nosoar, noarst )
6965 subroutine focftr( nbtrcf, notrcf, nbarpi, pxyd, noarst,
6966 % mosoar, mxsoar, n1soar, nosoar,
6967 % moartr, n1artr, noartr,
6968 % nbarcf, n1arcf, noarcf, nbstpe, nostpe,
6970 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6971 c but : former un contour ferme (cf) avec les aretes simples des
6972 c ----- nbtrcf triangles du tableau notrcf
6973 c destruction des nbtrcf triangles du tableau noartr
6974 c destruction des aretes doubles du tableau nosoar
6976 c attention: le chainage lchain de nosoar devient celui des cf
6980 c nbtrcf : nombre de triangles du cf a former
6981 c notrcf : numero des triangles dans le tableau noartr
6982 c nbarpi : numero du dernier sommet frontalier ou interne impose
6983 c pxyd : tableau des coordonnees 2d des points
6984 c par point : x y distance_souhaitee
6986 c mosoar : nombre maximal d'entiers par arete et
6987 c indice dans nosoar de l'arete suivante dans le hachage
6988 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6989 c attention: mxsoar>3*mxsomm obligatoire!
6990 c moartr : nombre maximal d'entiers par arete du tableau noartr
6992 c entrees et sorties :
6993 c --------------------
6994 c noarst : noarst(i) numero d'une arete de sommet i
6995 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6996 c une arete i de nosoar est vide <=> nosoar(1,i)=0
6997 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6998 c chainage des aretes frontalieres, chainage du hachage des aretes
6999 c hachage des aretes = nosoar(1)+nosoar(2)*2
7000 c n1artr : numero du premier triangle vide dans le tableau noartr
7001 c le chainage des triangles vides se fait sur noartr(2,.)
7002 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
7003 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
7007 c nbarcf : nombre d'aretes du cf
7008 c n1arcf : numero d'une arete de chaque contour
7009 c noarcf : numero des aretes de la ligne du contour ferme
7010 c attention: chainage circulaire des aretes
7011 c les aretes vides pointes par n1arcf(0) ne sont pas chainees
7012 c nbstpe : nombre de sommets perdus dans la suppression des triangles
7013 c nostpe : numero des sommets perdus dans la suppression des triangles
7014 c ierr : 0 si pas d'erreur
7015 c 14 si les lignes fermees se coupent => donnees a revoir
7016 c 15 si une seule arete simple frontaliere
7017 c 16 si boucle infinie car toutes les aretes simples
7018 c de la boule sont frontalieres!
7019 c 17 si boucle infinie dans caetoi
7020 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7021 c auteur : alain perronnet analyse numerique upmc paris mars 1997
7022 c modifs : alain perronnet laboratoire jl lions upmc paris octobre 2006
7023 c....................................................................012
7024 parameter (lchain=6, mxstpe=512)
7025 common / unites / lecteu, imprim, nunite(30)
7026 double precision pxyd(3,*)
7027 integer notrcf(1:nbtrcf)
7028 integer nosoar(mosoar,mxsoar),
7036 c formation des aretes simples du cf autour de l'arete ns1-ns2
7037 c attention: le chainage lchain du tableau nosoar devient actif
7038 c ============================================================
7039 c ici toutes les aretes du tableau nosoar verifient nosoar(lchain,i) = -1
7040 c ce qui equivaut a dire que l'etoile des aretes simples est vide
7041 c (initialisation dans le sp insoar puis remise a -1 dans la suite!)
7046 c nombre de sommets des triangles a supprimer sans repetition
7050 c ajout a l'etoile des aretes simples des 3 aretes des triangles a supprimer
7051 c suppression des triangles de l'etoile pour les aretes simples de l'etoile
7054 c ajout ou retrait des 3 aretes du triangle notrcf(i) de l'etoile
7057 c 13/10/2006 ...............................................
7058 call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
7060 c ajout des numeros de sommets non encore vus dans l'etoile
7063 if( nosotr(k) .eq. nostpe(j) ) goto 3
7067 nostpe( nbst ) = nosotr(k)
7069 c 13/10/2006 ................................................
7072 c l'arete de nosoar a traiter
7073 noar = abs( noartr(j,nt) )
7074 call caetoi( noar, mosoar, mxsoar, n1soar, nosoar, noarst,
7076 if( nbtrar .le. 0 ) then
7077 write(imprim,*)'focftr: erreur dans caetoi noar=',noar
7081 c si arete simple alors suppression du numero de triangle
7083 if( nbtrar .eq. 1 ) then
7084 if( nosoar(4,noar) .eq. nt ) then
7085 nosoar(4,noar) = nosoar(5,noar)
7086 else if( nosoar(5,noar) .eq. nt ) then
7089 write(imprim,*)'focftr: anomalie arete',noar,
7090 % ' sans triangle',nt
7091 write(imprim,*)'focftr: nosoar(',noar,')=',
7092 % (nosoar(kk,noar),kk=1,mosoar)
7096 c l'arete appartient a aucun triangle => elle est vide
7097 c les positions 4 et 5 servent maintenant aux chainages des vides
7102 c les aretes simples de l'etoile sont reordonnees pour former une
7103 c ligne fermee = un contour ferme peripherique de l'etoile encore dit 1 cf
7104 c ========================================================================
7107 c la premiere arete du contour ferme
7111 c l'arete est-elle dans le sens direct?
7112 c recherche de l'arete du triangle exterieur nt d'arete na1
7114 if( nt .le. 0 ) nt = nosoar(5,na1)
7116 c attention au cas de l'arete initiale frontaliere de no de triangles 0 et -
7117 if( nt .le. 0 ) then
7118 c permutation circulaire des aretes simples chainees
7119 c la premiere arete doit devenir la derniere du chainage,
7120 c la 2=>1, la 3=>2, ... , la derniere=>l'avant derniere, 1=>derniere
7121 n1aeoc = nosoar( lchain, n1aeoc )
7122 if( n1aeoc .eq. n1ae00 ) then
7123 c attention: boucle infinie si toutes les aretes simples
7124 c de la boule sont frontalieres!... arretee par ce test
7126 write(imprim,*)'focftr: boucle dans les aretes de l etoile'
7131 14 if( noar .gt. 0 ) then
7132 c la sauvegarde de l'arete et l'arete suivante
7134 noar = nosoar(lchain,noar)
7137 if( na0 .le. 0 ) then
7138 c une seule arete simple frontaliere
7140 write(imprim,*)'focftr: 1 arete seule pour l etoile'
7143 c le suivant de l'ancien dernier est l'ancien premier
7144 nosoar(lchain,na0) = na1
7145 c le nouveau dernier est l'ancien premier
7146 nosoar(lchain,na1) = 0
7150 c ici l'arete na1 est l'une des aretes du triangle nt
7152 if( abs(noartr(i,nt)) .eq. na1 ) then
7154 if( noartr(i,nt) .gt. 0 ) then
7155 c elle est parcourue dans le sens indirect de l'etoile
7156 c (car c'est en fait le triangle exterieur a la boule)
7164 c le 1-er sommet ou arete du contour ferme
7166 c le nombre de sommets du contour ferme de l'etoile
7168 c le premier sommet de l'etoile
7169 noarcf( 1, nbarcf ) = ns0
7170 c l'arete suivante du cf
7171 noarcf( 2, nbarcf ) = nbarcf + 1
7172 c le numero de cette arete dans le tableau nosoar
7173 noarcf( 3, nbarcf ) = na1
7174 c mise a jour du numero d'arete du sommet ns0
7177 c l'arete suivante a chainer
7178 n1aeoc = nosoar( lchain, na1 )
7179 c l'arete na1 n'est plus dans l'etoile
7180 nosoar( lchain, na1 ) = -1
7182 c boucle sur les aretes simples de l'etoile
7183 20 if( n1aeoc .gt. 0 ) then
7185 c recherche de l'arete de 1-er sommet ns1
7188 25 if( na1 .gt. 0 ) then
7190 c le numero du dernier sommet de l'arete precedente
7191 c est il l'un des 2 sommets de l'arete na1?
7192 if ( ns1 .eq. nosoar(1,na1) ) then
7193 c l'autre sommet de l'arete na1
7195 else if( ns1 .eq. nosoar(2,na1) ) then
7196 c l'autre sommet de l'arete na1
7199 c non: passage a l'arete suivante
7201 na1 = nosoar( lchain, na1 )
7205 c oui: na1 est l'arete peripherique suivante
7206 c na0 est sa precedente dans le chainage
7207 c une arete de plus dans le contour ferme (cf)
7209 c le premier sommet de l'arete nbarcf peripherique
7210 noarcf( 1, nbarcf ) = ns1
7211 c l'arete suivante du cf
7212 noarcf( 2, nbarcf ) = nbarcf + 1
7213 c le numero de cette arete dans le tableau nosoar
7214 noarcf( 3, nbarcf ) = na1
7215 c mise a jour du numero d'arete du sommet ns1
7218 c suppression de l'arete des aretes simples de l'etoile
7219 if( n1aeoc .eq. na1 ) then
7220 n1aeoc = nosoar( lchain, na1 )
7222 nosoar( lchain, na0 ) = nosoar( lchain, na1 )
7224 c l'arete n'est plus une arete simple de l'etoile
7225 nosoar( lchain, na1 ) = -1
7227 c le sommet final de l'arete a rechercher ensuite
7234 if( ns1 .ne. ns0 ) then
7235 c arete non retrouvee : l'etoile ne se referme pas
7236 write(imprim,*)'focftr: revoyez vos donnees du bord'
7237 write(imprim,*)'les lignes fermees doivent etre disjointes'
7238 write(imprim,*)'verifiez si elles ne se coupent pas'
7243 c l'arete suivant la derniere arete du cf est la premiere du cf
7244 c => realisation d'un chainage circulaire des aretes du cf
7245 noarcf( 2, nbarcf ) = 1
7248 c existe t il des sommets perdus?
7249 c -------------------------------
7250 if( nbst .gt. mxstpe ) then
7251 write(imprim,*)'focftr: tableau nostfe(',mxstpe,') a augmenter'
7255 c le nombre de sommets perdus
7256 nbstpe = nbst - nbarcf
7257 if( nbstpe .gt. 0 ) then
7258 c oui: stockage dans nostpe des sommets perdus
7259 c tout sommet des aretes de l'etoile est supprime
7260 c de la liste des sommets
7262 c le numero du sommet de l'arete du cf
7263 ns1 = noarcf( 1, i )
7265 if( ns1 .eq. nostpe(j) ) then
7266 c le sommet peripherique est supprime
7267 c de la liste des sommets perdus
7277 if( nostpe(i) .eq. 0 .or. nostpe(i) .gt. nbarpi ) then
7278 c un sommet de l'etoile ou perdu mais supprimable
7279 c ce qui apporte plus de qualites aux triangles a former
7283 nostpe(i-n) = nostpe(i)
7287 ccc write(imprim,*)'focftr:',nbstpe,' sommets isoles:',(nostpe(k),k=1,nbstpe)
7291 c destruction des triangles de l'etoile du tableau noartr
7292 c -------------------------------------------------------
7294 c le numero du triangle dans noartr
7296 c l'arete 1 de nt0 devient nulle
7297 noartr( 1, nt0 ) = 0
7298 c chainage de nt0 en tete du chainage des triangles vides de noartr
7299 noartr( 2, nt0 ) = n1artr
7305 subroutine int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x0, y0 )
7306 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7307 c but : existence ou non d'une intersection a l'interieur
7308 c ----- des 2 aretes ns1-ns2 et ns3-ns4
7309 c attention les intersections au sommet sont comptees
7313 c ns1,...ns4 : numero pxyd des 4 sommets
7314 c pxyd : les coordonnees des sommets
7318 c linter : -1 si ns3-ns4 parallele a ns1 ns2
7319 c 0 si ns3-ns4 n'intersecte pas ns1-ns2 entre les aretes
7320 c 1 si ns3-ns4 intersecte ns1-ns2 entre les aretes
7321 c 2 si le point d'intersection est ns1 entre ns3-ns4
7322 c 3 si le point d'intersection est ns3 entre ns1-ns2
7323 c 4 si le point d'intersection est ns4 entre ns1-ns2
7324 c x0,y0 : 2 coordonnees du point d'intersection s'il existe(linter>=1)
7325 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7326 c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
7327 c2345x7..............................................................012
7328 parameter ( epsmoi=-0.000001d0, eps=0.001d0,
7329 % unmeps= 0.999d0, unpeps=1.000001d0 )
7330 double precision pxyd(3,*), x0, y0
7331 double precision x1,y1,x21,y21,d21,x43,y43,d43,d,x,y,p21,p43
7335 x21 = pxyd(1,ns2) - x1
7336 y21 = pxyd(2,ns2) - y1
7337 d21 = x21**2 + y21**2
7339 x43 = pxyd(1,ns4) - pxyd(1,ns3)
7340 y43 = pxyd(2,ns4) - pxyd(2,ns3)
7341 d43 = x43**2 + y43**2
7343 c les 2 aretes sont-elles jugees paralleles ?
7344 d = x43 * y21 - y43 * x21
7345 if( d*d .le. 0.000001d0 * d21 * d43 ) then
7346 c cote i parallele a ns1-ns2
7351 c les 2 coordonnees du point d'intersection
7352 x =( x1*x43*y21-pxyd(1,ns3)*x21*y43-(y1-pxyd(2,ns3))*x21*x43)/d
7353 y =(-y1*y43*x21+pxyd(2,ns3)*y21*x43+(x1-pxyd(1,ns3))*y21*y43)/d
7355 c coordonnee barycentrique de x,y dans le repere ns1-ns2
7356 p21 = ( ( x - x1 ) * x21 + ( y - y1 ) * y21 ) / d21
7357 c coordonnee barycentrique de x,y dans le repere ns3-ns4
7358 p43 = ( (x - pxyd(1,ns3))* x43 + (y - pxyd(2,ns3)) * y43 ) / d43
7361 if( epsmoi .le. p21 .and. p21 .le. unpeps ) then
7362 c x,y est entre ns1-ns2
7363 if( (p21 .le. eps) .and.
7364 % (epsmoi .le. p43 .and. p43 .le. unpeps) ) then
7365 c le point x,y est proche de ns1 et interne a ns3-ns4
7370 else if( epsmoi .le. p43 .and. p43 .le. eps ) then
7371 c le point x,y est proche de ns3 et entre ns1-ns2
7376 else if( unmeps .le. p43 .and. p43 .le. unpeps ) then
7377 c le point x,y est proche de ns4 et entre ns1-ns2
7382 else if( eps .le. p43 .and. p43 .le. unmeps ) then
7383 c le point x,y est entre ns3-ns4
7391 c pas d'intersection a l'interieur des aretes
7395 subroutine tefoar( narete, nbarpi, pxyd,
7396 % mosoar, mxsoar, n1soar, nosoar,
7397 % moartr, mxartr, n1artr, noartr, noarst,
7398 % mxarcf, n1arcf, noarcf, larmin, notrcf,
7400 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7401 c but : forcer l'arete narete de nosoar dans la triangulation actuelle
7402 c ----- triangulation frontale pour la reobtenir
7404 c attention: le chainage lchain(=6) de nosoar devient actif
7405 c durant la formation des contours fermes (cf)
7409 c narete : numero nosoar de l'arete frontaliere a forcer
7410 c nbarpi : numero du dernier point interne impose par l'utilisateur
7411 c pxyd : tableau des coordonnees 2d des points
7412 c par point : x y distance_souhaitee
7414 c mosoar : nombre maximal d'entiers par arete et
7415 c indice dans nosoar de l'arete suivante dans le hachage
7416 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
7417 c attention: mxsoar>3*mxsomm obligatoire!
7418 c moartr : nombre maximal d'entiers par arete du tableau noartr
7419 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
7423 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
7424 c chainage des vides suivant en 3 et precedant en 2 de nosoar
7425 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
7426 c chainage des aretes frontalieres, chainage du hachage des aretes
7427 c hachage des aretes = nosoar(1)+nosoar(2)*2
7428 c avec mxsoar>=3*mxsomm
7429 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
7430 c nosoar(2,arete vide)=l'arete vide qui precede
7431 c nosoar(3,arete vide)=l'arete vide qui suit
7432 c n1artr : numero du premier triangle vide dans le tableau noartr
7433 c le chainage des triangles vides se fait sur noartr(2,.)
7434 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
7435 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
7436 c noarst : noarst(i) numero d'une arete de sommet i
7438 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
7440 c tableaux auxiliaires :
7441 c ----------------------
7442 c n1arcf : tableau (0:mxarcf) auxiliaire
7443 c noarcf : tableau (3,mxarcf) auxiliaire
7444 c larmin : tableau (mxarcf) auxiliaire
7445 c notrcf : tableau (1:mxarcf) auxiliaire
7449 c ierr : 0 si pas d'erreur
7450 c 1 saturation des sommets
7451 c 2 ns1 dans aucun triangle
7452 c 9 tableau nosoar de taille insuffisante car trop d'aretes
7454 c 10 un des tableaux n1arcf, noarcf notrcf est sature
7455 c augmenter a l'appel mxarcf
7456 c >11 algorithme defaillant
7457 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7458 c auteur : alain perronnet analyse numerique paris upmc mars 1997
7459 c modifs : alain perronnet laboratoire jl lions upmc paris octobre 2006
7460 c....................................................................012
7461 parameter (mxpitr=32, mxstpe=512)
7462 common / unites / lecteu,imprim,intera,nunite(29)
7463 double precision pxyd(3,*)
7464 integer noartr(moartr,mxartr),
7465 % nosoar(mosoar,mxsoar),
7473 integer lapitr(mxpitr)
7474 double precision x1,y1,x2,y2,d12,d3,d4,x,y,d,dmin
7475 integer nosotr(3), ns(2)
7476 integer nacf(1:2), nacf1, nacf2
7477 equivalence (nacf(1),nacf1), (nacf(2),nacf2)
7481 c traitement de cette arete perdue
7482 ns1 = nosoar( 1, narete )
7483 ns2 = nosoar( 2, narete )
7486 ccc write(imprim,*) 'tefoar reconstruction de l''arete ',ns1,' ', ns2
7487 ccc write(imprim,*) 'sommet',ns1,' x=',pxyd(1,ns1),' y=',pxyd(2,ns1)
7488 ccc write(imprim,*) 'sommet',ns2,' x=',pxyd(1,ns2),' y=',pxyd(2,ns2)
7490 c le sommet ns2 est il correct?
7492 if( na .le. 0 ) then
7493 write(imprim,*) 'tefoar: erreur sommet ',ns2,' sans arete'
7498 if( nosoar(4,na) .le. 0 ) then
7499 write(imprim,*) 'tefoar: erreur sommet ',ns2,
7500 % ' dans aucun triangle'
7506 c le premier passage: recherche dans le sens ns1->ns2
7509 c recherche des triangles intersectes par le segment ns1-ns2
7510 c ==========================================================
7515 d12 = (x2-x1)**2 + (y2-y1)**2
7517 c recherche du triangle voisin dans le sens indirect de rotation
7520 c recherche du no local du sommet ns1 dans l'un de ses triangles
7521 10 na01 = noarst( ns1 )
7522 if( na01 .le. 0 ) then
7523 write(imprim,*) 'tefoar: sommet ',ns1,' sans arete'
7528 nt0 = nosoar(4,na01)
7529 if( nt0 .le. 0 ) then
7530 write(imprim,*) 'tefoar: sommet ',ns1,' dans aucun triangle'
7536 c le numero des 3 sommets du triangle nt0 dans le sens direct
7537 20 call nusotr( nt0, mosoar, nosoar, moartr, noartr, nosotr )
7539 if( nosotr(na00) .eq. ns1 ) goto 26
7542 25 if( ipas .eq. 0 ) then
7543 c le second passage: recherche dans le sens ns2->ns1
7544 c tentative d'inversion des 2 sommets extremites de l'arete a forcer
7551 c les sens ns1->ns2 et ns2->ns1 ne donne pas de solution!
7552 write(imprim,*)'tefoar:arete ',ns1,' - ',ns2,' a imposer'
7553 write(imprim,*)'tefoar:anomalie sommet ',ns1,
7554 % 'non dans le triangle de sommets ',(nosotr(i),i=1,3)
7560 c le numero des aretes suivante et precedente
7561 26 na0 = nosui3( na00 )
7562 na1 = nopre3( na00 )
7566 c point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
7567 c ------------------------------------------------------------
7568 call int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x1, y1 )
7569 if( linter .le. 0 ) then
7571 c pas d'intersection: rotation autour du point ns1
7572 c pour trouver le triangle de l'autre cote de l'arete na01
7573 if( nsens .lt. 0 ) then
7574 c sens indirect de rotation: l'arete de sommet ns1
7575 na01 = abs( noartr(na00,nt0) )
7577 c sens direct de rotation: l'arete de sommet ns1 qui precede
7578 na01 = abs( noartr(na1,nt0) )
7580 c le triangle de l'autre cote de l'arete na01
7581 if( nosoar(4,na01) .eq. nt0 ) then
7582 nt0 = nosoar(5,na01)
7584 nt0 = nosoar(4,na01)
7586 if( nt0 .gt. 0 ) goto 20
7588 c le parcours sort du domaine
7589 c il faut tourner dans l'autre sens autour de ns1
7590 if( nsens .lt. 0 ) then
7595 c dans les 2 sens, pas d'intersection => impossible
7596 c essai avec l'arete inversee ns1 <-> ns2
7597 if( ipas .eq. 0 ) goto 25
7598 write(imprim,*) 'tefoar: arete ',ns1,' ',ns2,
7599 % ' sans intersection avec les triangles actuels'
7600 write(imprim,*) 'revoyez les lignes du contour'
7606 c il existe une intersection avec l'arete opposee au sommet ns1
7607 c =============================================================
7608 c nbtrcf : nombre de triangles du cf
7612 c le triangle oppose a l'arete na0 de nt0
7613 30 noar = abs( noartr(na0,nt0) )
7614 if( nosoar(4,noar) .eq. nt0 ) then
7615 nt1 = nosoar(5,noar)
7617 nt1 = nosoar(4,noar)
7619 if( nt1 .le. 0 ) then
7620 write(imprim,*) 'erreur dans tefoar nt1=',nt1
7624 c le numero des 3 sommets du triangle nt1 dans le sens direct
7625 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
7627 c le triangle nt1 contient il ns2 ?
7629 if( nosotr(j) .eq. ns2 ) goto 70
7632 c recherche de l'arete noar, na1 dans nt1 qui est l'arete na0 de nt0
7634 if( abs( noartr(na1,nt1) ) .eq. noar ) goto 35
7637 c recherche de l'intersection de ns1-ns2 avec les 2 autres aretes de nt1
7638 c ======================================================================
7644 c les 2 sommets de l'arete na2 de nt1
7645 noar = abs( noartr(na2,nt1) )
7646 ns3 = nosoar( 1, noar )
7647 ns4 = nosoar( 2, noar )
7649 c point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
7650 c ------------------------------------------------------------
7651 call int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x , y )
7652 if( linter .gt. 0 ) then
7654 c les 2 aretes s'intersectent en (x,y)
7655 c distance de (x,y) a ns3 et ns4
7656 d3 = (pxyd(1,ns3)-x)**2 + (pxyd(2,ns3)-y)**2
7657 d4 = (pxyd(1,ns4)-x)**2 + (pxyd(2,ns4)-y)**2
7658 c nsp est le point le plus proche de (x,y)
7659 if( d3 .lt. d4 ) then
7666 if( d .gt. 1d-5*d12 ) goto 60
7668 c ici le sommet nsp est trop proche de l'arete perdue ns1-ns2
7669 if( nsp .le. nbarpi ) then
7670 c point utilisateur ou frontalier donc non supprimable
7671 write(imprim,*) 'tefoar: sommet nsp=',nsp,
7672 %' frontalier trop proche de l''arete perdue ns1=',ns1,'-ns2=',ns2
7673 write(imprim,*)'s',nsp,': x=', pxyd(1,nsp),' y=', pxyd(2,nsp)
7674 write(imprim,*)'s',ns1,': x=', pxyd(1,ns1),' y=', pxyd(2,ns1)
7675 write(imprim,*)'s',ns2,': x=', pxyd(1,ns2),' y=', pxyd(2,ns2)
7676 write(imprim,*)'arete s',ns1,'-s',ns2,
7677 % ' coupe arete s',ns3,'-s',ns4,' en (x,y)'
7678 write(imprim,*) 's',ns3,': x=', pxyd(1,ns3),' y=', pxyd(2,ns3)
7679 write(imprim,*) 's',ns4,': x=', pxyd(1,ns4),' y=', pxyd(2,ns4)
7680 write(imprim,*) 'intersection en: x=', x, ' y=', y
7681 write(imprim,*) 'distance ns1-ns2=', sqrt(d12)
7682 write(imprim,*) 'distance (x,y) au plus proche',ns3,ns4,'=',
7689 c le sommet interne nsp est supprime en mettant tous les triangles
7690 c l'ayant comme sommet dans la pile notrcf des triangles a supprimer
7691 c ------------------------------------------------------------------
7692 ccc write(imprim,*) 'tefoar: le sommet ',nsp,' est supprime'
7693 c construction de la liste des triangles de sommet nsp
7694 call trp1st( nsp, noarst, mosoar, nosoar,
7695 % moartr, mxartr, noartr,
7696 % mxpitr, nbt, lapitr )
7697 if( nbt .le. 0 ) then
7698 c les triangles de sommet nsp ne forme pas une "boule"
7699 c avec ce sommet nsp pour "centre"
7701 % 'tefoar: les triangles autour du sommet ',nsp,
7702 % ' ne forme pas une etoile'
7706 c ajout des triangles de sommet nsp a notrcf
7711 if( nt .eq. notrcf(k) ) goto 38
7715 notrcf( nbtrcf ) = nt
7718 c ce sommet supprime n'appartient plus a aucun triangle
7721 c ns2 est-il un sommet des triangles empiles?
7722 c -------------------------------------------
7723 do 40 nt=nbtrc0+1,nbtrcf
7724 c le triangle a supprimer nt
7726 c le numero des 3 sommets du triangle nt1 dans le sens direct
7727 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr)
7729 c le sommet k de nt1
7730 if( nosotr( k ) .eq. ns2 ) then
7737 c recherche du plus proche point d'intersection de ns1-ns2
7738 c par rapport a ns2 avec les aretes des triangles ajoutes
7741 do 48 nt=nbtrc0+1,nbtrcf
7743 c le numero des 3 sommets du triangle nt1 dans le sens direct
7744 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr)
7746 c les 2 sommets de l'arete k de nt
7748 ns4 = nosotr( nosui3(k) )
7750 c point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
7751 c ------------------------------------------------------------
7752 call int1sd( ns1, ns2, ns3, ns4, pxyd,
7754 if( linter .gt. 0 ) then
7755 c les 2 aretes s'intersectent en (x,y)
7756 d = (x-x2)**2+(y-y2)**2
7757 if( d .lt. dmin ) then
7766 c redemarrage avec le triangle nt0 et l'arete na0
7767 if( nt0 .gt. 0 ) goto 30
7769 write(imprim,*) 'tefoar: algorithme defaillant'
7776 c pas d'intersection differente de l'initiale => sommet sur ns1-ns2
7777 c tentative d'inversion des sommets de l'arete ns1-ns2
7778 if( ipas .eq. 0 ) goto 25
7780 write(imprim,*) 'tefoar 50: revoyez vos donnees'
7781 write(imprim,*) 'les lignes fermees doivent etre disjointes'
7782 write(imprim,*) 'verifiez si elles ne se coupent pas'
7787 c cas sans probleme : intersection differente de celle initiale
7788 c ================= =========================================
7789 60 nbtrcf = nbtrcf + 1
7790 notrcf( nbtrcf ) = nt1
7791 c passage au triangle suivant
7796 c ----------------------------------------------------------
7797 c ici toutes les intersections de ns1-ns2 ont ete parcourues
7798 c tous les triangles intersectes ou etendus forment les
7799 c nbtrcf triangles du tableau notrcf
7800 c ----------------------------------------------------------
7801 70 nbtrcf = nbtrcf + 1
7802 notrcf( nbtrcf ) = nt1
7804 c formation du cf des aretes simples des triangles de notrcf
7805 c et destruction des nbtrcf triangles du tableau noartr
7806 c attention: le chainage lchain du tableau nosoar devient actif
7807 c =============================================================
7808 80 if( nbtrcf*3 .gt. mxarcf ) then
7809 write(imprim,*) 'saturation du tableau noarcf'
7815 call focftr( nbtrcf, notrcf, nbarpi, pxyd, noarst,
7816 % mosoar, mxsoar, n1soar, nosoar,
7817 % moartr, n1artr, noartr,
7818 % nbarcf, n1arcf, noarcf, nbstpe, nostpe,
7820 if( ierr .ne. 0 ) return
7822 c chainage des aretes vides dans le tableau noarcf
7823 c ------------------------------------------------
7824 c decalage de 2 aretes car 2 aretes sont necessaires ensuite pour
7825 c integrer 2 fois l'arete perdue et former ainsi 2 cf
7826 c comme nbtrcf*3 minore mxarcf il existe au moins 2 places vides
7827 c derriere => pas de test de debordement
7828 n1arcf(0) = nbarcf+3
7829 mmarcf = min(8*nbarcf,mxarcf)
7830 do 90 i=nbarcf+3,mmarcf
7833 noarcf(2,mmarcf) = 0
7835 c reperage des sommets ns1 ns2 de l'arete perdue dans le cf
7836 c ---------------------------------------------------------
7837 ns1 = nosoar( 1, narete )
7838 ns2 = nosoar( 2, narete )
7842 c la premiere arete dans noarcf du cf
7844 110 if( noarcf(1,na0) .ne. ns(i) ) then
7845 c passage a l'arete suivante
7846 na0 = noarcf( 2, na0 )
7849 c position dans noarcf du sommet i de l'arete perdue
7853 c formation des 2 cf chacun contenant l'arete ns1-ns2
7854 c ---------------------------------------------------
7855 c sauvegarde de l'arete suivante de celle de sommet ns1
7856 na0 = noarcf( 2, nacf1 )
7857 nt1 = noarcf( 3, nacf1 )
7861 c l'arete suivante dans le premier cf
7862 noarcf( 2, nacf1 ) = nacf2
7863 c cette arete est celle perdue
7864 noarcf( 3, nacf1 ) = narete
7870 c le premier sommet de la premiere arete du second cf
7871 noarcf( 1, n1 ) = ns2
7872 c l'arete suivante dans le second cf
7873 noarcf( 2, n1 ) = n2
7874 c cette arete est celle perdue
7875 noarcf( 3, n1 ) = narete
7876 c la seconde arete du second cf
7877 noarcf( 1, n2 ) = ns1
7878 noarcf( 2, n2 ) = na0
7879 noarcf( 3, n2 ) = nt1
7882 c recherche du precedent de nacf2
7883 130 na1 = noarcf( 2, na0 )
7884 if( na1 .ne. nacf2 ) then
7885 c passage a l'arete suivante
7889 c na0 precede nacf2 => il precede n1
7890 noarcf( 2, na0 ) = n1
7895 c triangulation directe des 2 contours fermes
7896 c l'arete ns1-ns2 devient une arete de la triangulation des 2 cf
7897 c ==============================================================
7898 call tridcf( nbcf, nbstpe, nostpe, pxyd, noarst,
7899 % mosoar, mxsoar, n1soar, nosoar,
7900 % moartr, n1artr, noartr,
7901 % mxarcf, n1arcf, noarcf, larmin,
7902 % nbtrcf, notrcf, ierr )
7908 subroutine te4ste( nbsomm, mxsomm, pxyd, ntrp, letree,
7910 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7911 c but : decouper un te ntrp de letree en 4 sous-triangles
7912 c ----- eliminer les sommets de te trop proches des points
7916 c mxsomm : nombre maximal de points declarables dans pxyd
7917 c ntrp : numero letree du triangle a decouper en 4 sous-triangles
7921 c nbsomm : nombre actuel de points dans pxyd
7922 c pxyd : tableau des coordonnees des points
7923 c par point : x y distance_souhaitee
7924 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
7925 c letree(0,0) : no du 1-er te vide dans letree
7926 c letree(0,1) : maximum du 1-er indice de letree (ici 8)
7927 c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
7928 c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
7929 c si letree(0,.)>0 alors
7930 c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
7932 c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
7934 c ( j est alors une feuille de l'arbre )
7935 c letree(4,j) : no letree du sur-triangle du triangle j
7936 c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
7937 c letree(6:8,j) : no pxyd des 3 sommets du triangle j
7941 c ierr : 0 si pas d'erreur, 51 saturation letree, 52 saturation pxyd
7942 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7943 c auteur : alain perronnet analyse numerique paris upmc juillet 1994
7944 c2345x7..............................................................012
7945 common / unites / lecteu,imprim,nunite(30)
7946 integer letree(0:8,0:*)
7947 double precision pxyd(3,mxsomm)
7948 integer np(0:3),milieu(3)
7950 c debut par l'arete 2 du triangle ntrp
7956 c le milieu de l'arete i1 existe t il deja ?
7957 call n1trva( ntrp, i1, letree, noteva, niveau )
7958 if( noteva .gt. 0 ) then
7959 c il existe un te voisin
7960 c s'il existe 4 sous-triangles le milieu existe deja
7961 if( letree(0,noteva) .gt. 0 ) then
7963 nsot = letree(0,noteva)
7964 milieu(i) = letree( 5+nopre3(i1), nsot )
7969 c le milieu n'existe pas. il est cree
7971 if( nbsomm .gt. mxsomm ) then
7972 c plus assez de place dans pxyd
7973 write(imprim,*) 'te4ste: saturation pxyd'
7978 c le milieu de l'arete i
7981 c ntrp est le triangle de milieux d'arete ces 3 sommets
7982 ns1 = letree( 5+i1, ntrp )
7983 ns2 = letree( 5+i2, ntrp )
7984 pxyd(1,nbsomm) = ( pxyd(1,ns1) + pxyd(1,ns2) ) * 0.5
7985 pxyd(2,nbsomm) = ( pxyd(2,ns1) + pxyd(2,ns2) ) * 0.5
7987 c l'arete et milieu suivant
7994 c le premier triangle vide
7996 if( nsot .le. 0 ) then
7997 c manque de place. saturation letree
7999 write(imprim,*) 'te4ste: saturation letree'
8004 c mise a jour du premier te libre
8005 letree(0,0) = letree(0,nsot)
8007 c nsot est le i-eme sous triangle
8013 c le numero des points et sous triangles dans ntrp
8014 np(i) = -letree(i,ntrp)
8015 letree(i,ntrp) = nsot
8017 c le sommet commun avec le triangle ntrp
8018 letree(5+i,nsot) = letree(5+i,ntrp)
8020 c le sur-triangle et numero de sous-triangle de nsot
8021 c a laisser ici car incorrect sinon pour i=0
8022 letree(4,nsot) = ntrp
8025 c le sous-triangle du triangle
8026 letree(i,ntrp) = nsot
8029 c le numero des nouveaux sommets milieux
8030 nsot = letree(0,ntrp)
8031 letree(6,nsot) = milieu(1)
8032 letree(7,nsot) = milieu(2)
8033 letree(8,nsot) = milieu(3)
8035 nsot = letree(1,ntrp)
8036 letree(7,nsot) = milieu(3)
8037 letree(8,nsot) = milieu(2)
8039 nsot = letree(2,ntrp)
8040 letree(6,nsot) = milieu(3)
8041 letree(8,nsot) = milieu(1)
8043 nsot = letree(3,ntrp)
8044 letree(6,nsot) = milieu(2)
8045 letree(7,nsot) = milieu(1)
8047 c repartition des eventuels 4 points np dans ces 4 sous-triangles
8048 c il y a obligatoirement suffisamment de place
8050 if( np(i) .gt. 0 ) then
8051 nsot = notrpt( pxyd(1,np(i)), pxyd, ntrp, letree )
8054 if( letree(i1,nsot) .eq. 0 ) then
8055 c place libre a occuper
8056 letree(i1,nsot) = -np(i)
8065 subroutine tesuqm( quamal, nbarpi, pxyd, noarst,
8066 % mosoar, mxsoar, n1soar, nosoar,
8067 % moartr, mxartr, n1artr, noartr,
8068 % mxarcf, n1arcf, noarcf,
8069 % larmin, notrcf, liarcf,
8071 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8072 c but : supprimer de la triangulation les triangles de qualite
8073 c ----- inferieure a quamal
8077 c quamal : qualite des triangles au dessous de laquelle supprimer des sommets
8078 c nbarpi : numero du dernier point interne impose par l'utilisateur
8079 c pxyd : tableau des coordonnees 2d des points
8080 c par point : x y distance_souhaitee
8081 c mosoar : nombre maximal d'entiers par arete et
8082 c indice dans nosoar de l'arete suivante dans le hachage
8083 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
8084 c attention: mxsoar>3*mxsomm obligatoire!
8085 c moartr : nombre maximal d'entiers par arete du tableau noartr
8089 c noarst : noarst(i) numero d'une arete de sommet i
8090 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
8091 c chainage des vides suivant en 3 et precedant en 2 de nosoar
8092 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
8093 c chainage des aretes frontalieres, chainage du hachage des aretes
8094 c hachage des aretes = nosoar(1)+nosoar(2)*2
8095 c avec mxsoar>=3*mxsomm
8096 c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
8097 c nosoar(2,arete vide)=l'arete vide qui precede
8098 c nosoar(3,arete vide)=l'arete vide qui suit
8099 c n1artr : numero du premier triangle vide dans le tableau noartr
8100 c le chainage des triangles vides se fait sur noartr(2,.)
8101 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
8102 c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
8106 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
8107 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
8108 c larmin : tableau (mxarcf) auxiliaire d'entiers
8109 c notrcf : tableau (mxarcf) auxiliaire d'entiers
8110 c liarcf : tableau (mxarcf) auxiliaire d'entiers
8114 c quamin : qualite minimale des triangles
8115 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8116 c auteur : alain perronnet Laboratoire JL Lions UPMC Paris Octobre 2006
8117 c....................................................................012
8118 parameter ( lchain=6, mxtrqm=1024 )
8119 common / unites / lecteu,imprim,intera,nunite(29)
8120 double precision pxyd(3,*), quamal, qualit, quamin
8121 integer nosoar(mosoar,mxsoar),
8122 % noartr(moartr,mxartr),
8124 integer nosotr(3), notraj(3)
8125 double precision surtd2, s123, s142, s143, s234,
8127 integer notrqm(mxtrqm)
8128 double precision qutrqm(mxtrqm)
8129 integer n1arcf(0:mxarcf),
8137 c initialisation du chainage des aretes des cf => 0 arete de cf
8138 do 5 narete=1,mxsoar
8139 nosoar( lchain, narete ) = -1
8142 c recherche des triangles de plus basse qualite
8146 if( noartr(1,nt) .eq. 0 ) goto 10
8147 c le numero des 3 sommets du triangle nt
8148 call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
8149 c la qualite du triangle ns1 ns2 ns3
8150 call qutr2d( pxyd(1,nosotr(1)), pxyd(1,nosotr(2)),
8151 % pxyd(1,nosotr(3)), qualit )
8152 if( qualit .lt. quamal ) then
8153 if( nbtrqm .ge. mxtrqm ) goto 10
8156 qutrqm(nbtrqm) = qualit
8160 c tri croissant des qualites minimales des triangles
8161 call tritas( nbtrqm, qutrqm, notrqm )
8163 c le plus mauvais triangle
8169 c no du triangle de mauvaise qualite
8170 ntqmin = notrqm( n )
8172 c le triangle a t il ete traite?
8173 if( noartr(1,ntqmin) .eq. 0 ) goto 100
8176 ccc print *,'tesuqm: triangle',ntqmin,' qualite=',qutrqm(n)
8177 ccc print *,'tesuqm: noartr(',ntqmin,')=',
8178 ccc % (noartr(j,ntqmin),j=1,moartr)
8181 ccc noar = noartr(j,ntqmin)
8182 ccc print*,'arete',noar,' nosoar=',(nosoar(i,abs(noar)),i=1,mosoar)
8185 c le numero des 3 sommets du triangle ntqmin
8186 call nusotr( ntqmin, mosoar, nosoar, moartr, noartr, nosotr )
8190 ccc print *,'sommet',nbt,': x=',pxyd(1,nbt),' y=',pxyd(2,nbt)
8193 c recherche des triangles adjacents par les aretes de ntqmin
8196 c le no de l'arete j dans nosoar
8197 noar = abs( noartr(j,ntqmin) )
8198 c le triangle adjacent a l'arete j de ntqmin
8199 if( nosoar(4,noar) .eq. ntqmin ) then
8200 notraj(j) = nosoar(5,noar)
8202 notraj(j) = nosoar(4,noar)
8204 if( notraj(j) .gt. 0 ) then
8205 c 1 triangle adjacent de plus
8209 c pas de triangle adjacent
8214 if( nbt .eq. 1 ) then
8216 c ntqmin a un seul triangle oppose par l'arete naop
8217 c le triangle a 2 aretes frontalieres est plat
8218 c l'arete commune aux 2 triangles est rendue Delaunay
8219 c ---------------------------------------------------
8220 noar = abs( noartr(naop,ntqmin) )
8221 if( nosoar(3,noar) .ne. 0 ) then
8226 c l'arete appartient a deux triangles actifs
8227 c le numero des 4 sommets du quadrangle des 2 triangles
8228 call mt4sqa( noar, moartr, noartr, mosoar, nosoar,
8229 % ns1, ns2, ns3, ns4 )
8230 if( ns4 .eq. 0 ) goto 100
8232 c carre de la longueur de l'arete ns1 ns2
8233 a12=(pxyd(1,ns2)-pxyd(1,ns1))**2+(pxyd(2,ns2)-pxyd(2,ns1))**2
8235 c comparaison de la somme des aires des 2 triangles
8236 c -------------------------------------------------
8237 c calcul des surfaces des triangles 123 et 142 de cette arete
8238 s123=surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
8239 s142=surtd2( pxyd(1,ns1), pxyd(1,ns4), pxyd(1,ns2) )
8240 ccc print *,'tesuqm: ns4=',ns4,' x=',pxyd(1,ns4),
8241 ccc % ' y=',pxyd(2,ns4)
8242 ccc print *,'tesuqm: s123=',s123,' s142=',s142
8243 s12 = abs( s123 ) + abs( s142 )
8244 if( s12 .le. 0.001*a12 ) goto 100
8246 c calcul des surfaces des triangles 143 et 234 de cette arete
8247 s143=surtd2( pxyd(1,ns1), pxyd(1,ns4), pxyd(1,ns3) )
8248 s234=surtd2( pxyd(1,ns2), pxyd(1,ns3), pxyd(1,ns4) )
8249 ccc print *,'tesuqm: s143=',s143,' s234=',s234
8250 s34 = abs( s234 ) + abs( s143 )
8251 ccc print *,'tesuqm: s12=',s12,' s34=',s34
8253 if( abs(s34-s12) .gt. 1d-14*s34 ) goto 100
8255 c quadrangle convexe
8256 c echange de la diagonale 12 par 34 des 2 triangles
8257 c -------------------------------------------------
8258 call te2t2t( noar, mosoar, n1soar, nosoar, noarst,
8259 % moartr, noartr, noar34 )
8260 ccc print *,'tesuqm: sortie te2t2t avec noar34=',noar34
8263 else if( nbt .eq. 2 ) then
8265 c ntqmin a 2 triangles opposes par l'arete naop
8266 c essai de supprimer le sommet non frontalier
8267 c ---------------------------------------------
8269 if( notraj(j) .eq. 0 ) goto 33
8272 c arete sans triangle adjacent
8273 33 noar = abs( noartr(j,ntqmin) )
8274 ccc print *,'tesuqm: nosoar(',noar,')=',
8275 ccc % (nosoar(j,noar),j=1,mosoar)
8276 if( noar .le. 0 ) goto 100
8279 ns1 = nosoar(1,noar)
8280 ns2 = nosoar(2,noar)
8282 c ns3 l'autre sommet non frontalier
8285 if( ns3 .ne. ns1 .and. ns3 .ne. ns2 ) goto 40
8288 40 if( ns3 .gt. nbarpi ) then
8290 c le sommet ns3 non frontalier va etre supprime
8291 ccc print*,'tesuqm: ntqmin=',ntqmin,
8292 ccc % ' demande la suppression ns3=',ns3
8293 call te1stm( ns3, nbarpi, pxyd, noarst,
8294 % mosoar, mxsoar, n1soar, nosoar,
8295 % moartr, mxartr, n1artr, noartr,
8296 % mxarcf, n1arcf, noarcf,
8297 % larmin, notrcf, liarcf, ierr )
8298 ccc if( ierr .eq. 0 ) then
8299 ccc print *,'tesuqm: st supprime ns3=',ns3
8301 ccc print *,'tesuqm: ST NON SUPPRIME ns3=',ns3,' ierr=',ierr
8313 subroutine tritas( nb, a, noanc )
8314 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8315 c but : tri croissant du tableau a de nb reels par la methode du tas
8316 c ----- methode due a williams et floyd o(n log n )
8317 c version avec un pointeur sur un tableau dont est extrait a
8320 c nb : nombre de termes du tableau a
8321 c a : les nb reels double precision a trier dans a
8322 c noanc : numero ancien position de l'information (souvent noanc(i)=i)
8326 c a : les nb reels croissants dans a
8327 c noanc : numero ancien position de l'information
8328 c noanc(1)=no position pointeur sur a(1), ...
8329 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8330 c auteur : perronnet alain analyse numerique upmc paris fevrier 1991
8331 c ...................................................................012
8333 integer pere,per,fil,fils1,fils2,fin
8334 double precision a(1:nb),aux
8336 c formation du tas sous forme d'un arbre binaire
8339 do 20 pere = nb/2,1,-1
8341 c descendre pere jusqu'a n dans a de facon a respecter
8342 c a(pere)>a(j) pour j fils ou petit fils de pere
8343 c c-a-d pour tout j tel que pere <= e(j/2)<j<nb+1
8347 c protection du pere
8352 if( fils1 .lt. fin ) then
8353 c il existe un fils1
8356 if( fils2 .lt. fin ) then
8357 c il existe 2 fils . selection du plus grand
8358 if( a(fils2) .gt. a(fils1) ) fil = fils2
8361 c ici fil est le plus grand des fils
8362 if( a(per) .lt. a(fil) ) then
8363 c permutation de per et fil
8367 c le pointeur est aussi permute
8369 noanc(per) = noanc(fil)
8371 c le nouveau pere est le fils permute
8378 c a chaque iteration la racine (plus grande valeur actuelle de a)
8379 c est mise a sa place (fin actuelle du tableau) et permutee avec
8380 c la valeur qui occupe cette place, puis descente de cette nouvelle
8381 c racine pour respecter le fait que tout pere est plus grand que tous
8383 c c-a-d pour tout j tel que pere <= e(j/2)<j<nb+1
8387 c la permutation premier dernier
8391 c le pointeur est aussi permute
8393 noanc(fin) = noanc(1)
8396 c descendre a(1) entre 1 et fin
8401 if( fils1 .lt. fin ) then
8402 c il existe un fils1
8405 if( fils2 .lt. fin ) then
8406 c il existe 2 fils . selection du plus grand
8407 if( a(fils2) .gt. a(fils1) ) fil = fils2
8410 c ici fil est le plus grand des fils
8411 if( a(per) .lt. a(fil) ) then
8412 c permutation de per et fil
8416 c le pointeur est aussi permute
8418 noanc(per) = noanc(fil)
8420 c le nouveau pere est le fils permute