+ subroutine qutr2d( p1, p2, p3, qualite )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : calculer la qualite d'un triangle de r**2
+c ----- 2 coordonnees des 3 sommets en double precision
+c
+c entrees :
+c ---------
+c p1,p2,p3 : les 3 coordonnees des 3 sommets du triangle
+c sens direct pour une surface et qualite >0
+c sorties :
+c ---------
+c qualite: valeur de la qualite du triangle entre 0 et 1 (equilateral)
+c 1 etant la qualite optimale
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique upmc paris janvier 1995
+c2345x7..............................................................012
+ parameter ( d2uxr3 = 3.4641016151377544d0 )
+c d2uxr3 = 2 * sqrt(3)
+ double precision p1(2), p2(2), p3(2), qualite, a, b, c, p
+c
+c la longueur des 3 cotes
+ a = sqrt( (p2(1)-p1(1))**2 + (p2(2)-p1(2))**2 )
+ b = sqrt( (p3(1)-p2(1))**2 + (p3(2)-p2(2))**2 )
+ c = sqrt( (p1(1)-p3(1))**2 + (p1(2)-p3(2))**2 )
+c
+c demi perimetre
+ p = (a+b+c) * 0.5d0
+c
+ if ( (a*b*c) .ne. 0d0 ) then
+c critere : 2 racine(3) * rayon_inscrit / plus longue arete
+ qualite = d2uxr3 * sqrt( abs( (p-a) / p * (p-b) * (p-c) ) )
+ % / max(a,b,c)
+ else
+ qualite = 0d0
+ endif
+c
+c
+c autres criteres possibles:
+c critere : 2 * rayon_inscrit / rayon_circonscrit
+c qualite = 8d0 * (p-a) * (p-b) * (p-c) / (a * b * c)
+c
+c critere : 3*sqrt(3.) * ray_inscrit / demi perimetre
+c qualite = 3*sqrt(3.) * sqrt ((p-a)*(p-b)*(p-c) / p**3)
+c
+c critere : 2*sqrt(3.) * ray_inscrit / max( des aretes )
+c qualite = 2*sqrt(3.) * sqrt( (p-a)*(p-b)*(p-c) / p ) / max(a,b,c)
+ end
+
+
+ double precision function surtd2( p1 , p2 , p3 )
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : calcul de la surface d'un triangle defini par 3 points de R**2
+c -----
+c parametres d entree :
+c ---------------------
+c p1 p2 p3 : les 3 fois 2 coordonnees des sommets du triangle
+c
+c parametre resultat :
+c --------------------
+c surtd2 : surface du triangle
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique upmc paris fevrier 1992
+c2345x7..............................................................012
+ double precision p1(2), p2(2), p3(2)
+c
+c la surface du triangle
+ surtd2 = ( ( p2(1)-p1(1) ) * ( p3(2)-p1(2) )
+ % - ( p2(2)-p1(2) ) * ( p3(1)-p1(1) ) ) * 0.5d0
+ end
+
+ integer function nopre3( i )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : numero precedent i dans le sens circulaire 1 2 3 1 ...
+c -----
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
+c2345x7..............................................................012
+ if( i .eq. 1 ) then
+ nopre3 = 3
+ else
+ nopre3 = i - 1
+ endif
+ end
+
+ integer function nosui3( i )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : numero suivant i dans le sens circulaire 1 2 3 1 ...
+c -----
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
+c2345x7..............................................................012
+ if( i .eq. 3 ) then
+ nosui3 = 1
+ else
+ nosui3 = i + 1
+ endif
+ end
+
+ subroutine provec( v1 , v2 , v3 )
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : v3 vecteur = produit vectoriel de 2 vecteurs de r ** 3
+c -----
+c entrees:
+c --------
+c v1, v2 : les 2 vecteurs de 3 composantes
+c
+c sortie :
+c --------
+c v3 : vecteur = v1 produit vectoriel v2
+cc++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : perronnet alain upmc analyse numerique paris mars 1987
+c2345x7..............................................................012
+ double precision v1(3), v2(3), v3(3)
+c
+ v3( 1 ) = v1( 2 ) * v2( 3 ) - v1( 3 ) * v2( 2 )
+ v3( 2 ) = v1( 3 ) * v2( 1 ) - v1( 1 ) * v2( 3 )
+ v3( 3 ) = v1( 1 ) * v2( 2 ) - v1( 2 ) * v2( 1 )
+c
+ return
+ end
+
+ subroutine norme1( n, v, ierr )
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : normalisation euclidienne a 1 d un vecteur v de n composantes
+c -----
+c entrees :
+c ---------
+c n : nombre de composantes du vecteur
+c
+c modifie :
+c ---------
+c v : le vecteur a normaliser a 1
+c
+c sortie :
+c ---------
+c ierr : 1 si la norme de v est egale a 0
+c 0 si pas d'erreur
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris mars 1987
+c ......................................................................
+ double precision v( n ), s, sqrt
+c
+ s = 0.0d0
+ do 10 i=1,n
+ s = s + v( i ) * v( i )
+ 10 continue
+c
+c test de nullite de la norme du vecteur
+c --------------------------------------
+ if( s .le. 0.0d0 ) then
+c norme nulle du vecteur non normalisable a 1
+ ierr = 1
+ return
+ endif
+c
+ s = 1.0d0 / sqrt( s )
+ do 20 i=1,n
+ v( i ) = v ( i ) * s
+ 20 continue
+c
+ ierr = 0
+ end
+
+
+ subroutine insoar( mxsomm, mosoar, mxsoar, n1soar, nosoar )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : initialiser le tableau nosoar pour le hachage des aretes
+c -----
+c
+c entrees:
+c --------
+c mxsomm : plus grand numero de sommet d'une arete au cours du calcul
+c mosoar : nombre maximal d'entiers par arete du tableau nosoar
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c avec mxsoar>=3*mxsomm
+c
+c sorties:
+c --------
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c une arete i de nosoar est vide <=> nosoar(1,i)=0
+c chainage des aretes vides amont et aval
+c l'arete vide qui precede=nosoar(4,i)
+c l'arete vide qui suit =nosoar(5,i)
+c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
+c chainage momentan'e d'aretes, chainage du hachage des aretes
+c hachage des aretes = min( nosoar(1), nosoar(2) )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c2345x7..............................................................012
+ integer nosoar(mosoar,mxsoar)
+c
+c initialisation des aretes 1 a mxsomm
+ do 10 i=1,mxsomm
+c
+c sommet 1 = 0 <=> temoin d'arete vide pour le hachage
+ nosoar( 1, i ) = 0
+c
+c arete sur aucune ligne
+ nosoar( 3, i ) = 0
+c
+c la position de l'arete interne ou frontaliere est inconnue
+ nosoar( 6, i ) = -2
+c
+c fin de chainage du hachage pas d'arete suivante
+ nosoar( mosoar, i ) = 0
+c
+ 10 continue
+c
+c la premiere arete vide chainee est la mxsomm+1 du tableau
+c car ces aretes ne sont pas atteignables par le hachage direct
+ n1soar = mxsomm + 1
+c
+c initialisation des aretes vides et des chainages
+ do 20 i = n1soar, mxsoar
+c
+c sommet 1 = 0 <=> temoin d'arete vide pour le hachage
+ nosoar( 1, i ) = 0
+c
+c arete sur aucune ligne
+ nosoar( 3, i ) = 0
+c
+c chainage sur l'arete vide qui precede
+c (si arete occupee cela deviendra le no du triangle 1 de l'arete)
+ nosoar( 4, i ) = i-1
+c
+c chainage sur l'arete vide qui suit
+c (si arete occupee cela deviendra le no du triangle 2 de l'arete)
+ nosoar( 5, i ) = i+1
+c
+c chainages des aretes frontalieres ou internes ou ...
+ nosoar( 6, i ) = -2
+c
+c fin de chainage du hachage
+ nosoar( mosoar, i ) = 0
+c
+ 20 continue
+c
+c la premiere arete vide n'a pas de precedent
+ nosoar( 4, n1soar ) = 0
+c
+c la derniere arete vide est mxsoar sans arete vide suivante
+ nosoar( 5, mxsoar ) = 0
+ end
+
+
+ subroutine azeroi ( l , ntab )
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : initialisation a zero d un tableau ntab de l variables entieres
+c -----
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique upmc paris septembre 1988
+c23456---------------------------------------------------------------012
+ integer ntab(l)
+ do 1 i = 1 , l
+ ntab( i ) = 0
+ 1 continue
+ end
+
+
+ subroutine fasoar( ns1, ns2, nt1, nt2, nolign,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % noar, ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : former l'arete de sommet ns1-ns2 dans le hachage du tableau
+c ----- nosoar des aretes de la triangulation
+c
+c entrees:
+c --------
+c ns1 ns2: numero pxyd des 2 sommets de l'arete
+c nt1 : numero du triangle auquel appartient l'arete
+c nt1=-1 si numero inconnu
+c nt2 : numero de l'eventuel second triangle de l'arete si connu
+c nt2=-1 si numero inconnu
+c nolign : numero de la ligne de l'arete dans ladefi(wulftr-1+nolign)
+c =0 si l'arete n'est une arete de ligne
+c ce numero est ajoute seulement si l'arete est creee
+c mosoar : nombre maximal d'entiers par arete du tableau nosoar
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c
+c modifies:
+c ---------
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c une arete i de nosoar est vide <=> nosoar(1,i)=0
+c chainage des aretes vides amont et aval
+c l'arete vide qui precede=nosoar(4,i)
+c l'arete vide qui suit =nosoar(5,i)
+c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
+c chainage momentan'e d'aretes, chainage du hachage des aretes
+c hachage des aretes = min( nosoar(1), nosoar(2) )
+c noarst : noarst(np) numero d'une arete du sommet np
+c
+c ierr : si < 0 en entree pas d'affichage en cas d'erreur du type
+c "arete appartenant a plus de 2 triangles et a creer!"
+c si >=0 en entree affichage de ce type d'erreur
+c
+c sorties:
+c --------
+c noar : >0 numero de l'arete retrouvee ou ajoutee
+c ierr : =0 si pas d'erreur
+c =1 si le tableau nosoar est sature
+c =2 si arete a creer et appartenant a 2 triangles distincts
+c des triangles nt1 et nt2
+c =3 si arete appartenant a 2 triangles distincts
+c differents des triangles nt1 et nt2
+c =4 si arete appartenant a 2 triangles distincts
+c dont le second n'est pas le triangle nt2
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c2345x7..............................................................012
+ common / unites / lecteu, imprim, nunite(30)
+ integer nosoar(mosoar,mxsoar), noarst(*)
+ integer nu2sar(2)
+c
+c ajout eventuel de l'arete s1 s2 dans nosoar
+ nu2sar(1) = ns1
+ nu2sar(2) = ns2
+c
+c hachage de l'arete de sommets nu2sar
+ call hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar, noar )
+c en sortie: noar>0 => no arete retrouvee
+c <0 => no arete ajoutee
+c =0 => saturation du tableau nosoar
+c
+ if( noar .eq. 0 ) then
+c
+c saturation du tableau nosoar
+ write(imprim,*) 'fasoar: tableau nosoar sature'
+ ierr = 1
+ return
+c
+ else if( noar .lt. 0 ) then
+c
+c l'arete a ete ajoutee. initialisation des autres informations
+ noar = -noar
+c le numero de la ligne de l'arete
+ nosoar(3,noar) = nolign
+c le triangle 1 de l'arete => le triangle nt1
+ nosoar(4,noar) = nt1
+c le triangle 2 de l'arete => le triangle nt2
+ nosoar(5,noar) = nt2
+c
+c le sommet appartient a l'arete noar
+ noarst( nu2sar(1) ) = noar
+ noarst( nu2sar(2) ) = noar
+c
+ else
+c
+c l'arete a ete retrouvee.
+c si elle appartient a 2 triangles differents de nt1 et nt2
+c alors il y a une erreur
+ if( nosoar(4,noar) .gt. 0 .and.
+ % nosoar(5,noar) .gt. 0 ) then
+ if( nosoar(4,noar) .ne. nt1 .and.
+ % nosoar(4,noar) .ne. nt2 .or.
+ % nosoar(5,noar) .ne. nt1 .and.
+ % nosoar(5,noar) .ne. nt2 ) then
+c arete appartenant a plus de 2 triangles => erreur
+ if( ierr .ge. 0 ) then
+ write(imprim,*) 'erreur fasoar: arete ',noar,
+ % ' dans 2 triangles et a creer!'
+ endif
+ ierr = 2
+ return
+ endif
+ endif
+c
+c mise a jour du numero des triangles de l'arete noar
+c le triangle 2 de l'arete => le triangle nt1
+ if( nosoar(4,noar) .lt. 0 ) then
+c pas de triangle connu pour cette arete
+ n = 4
+ else
+c deja un triangle connu. ce nouveau est le second
+ if( nosoar(5,noar) .gt. 0 .and. nt1 .gt. 0 .and.
+ % nosoar(5,noar) .ne. nt1 ) then
+c arete appartenant a plus de 2 triangles => erreur
+ write(imprim,*) 'erreur fasoar: arete ',noar,
+ % ' dans plus de 2 triangles'
+ ierr = 3
+ return
+ endif
+ n = 5
+ endif
+ nosoar(n,noar) = nt1
+c
+c cas de l'arete frontaliere retrouvee comme diagonale d'un quadrangle
+ if( nt2 .gt. 0 ) then
+c l'arete appartient a 2 triangles
+ if( nosoar(5,noar) .gt. 0 .and.
+ % nosoar(5,noar) .ne. nt2 ) then
+c arete appartenant a plus de 2 triangles => erreur
+ write(imprim,*) 'erreur fasoar: arete ',noar,
+ % ' dans plus de 2 triangles'
+ ierr = 4
+ return
+ endif
+ nosoar(5,noar) = nt2
+ endif
+c
+ endif
+c
+c pas d'erreur
+ ierr = 0
+ end
+
+ subroutine fq1inv( x, y, s, xc, yc, ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : calcul des 2 coordonnees (xc,yc) dans le carre (0,1)
+c ----- image par f:carre unite-->quadrangle appartenant a q1**2
+c par une resolution directe due a nicolas thenault
+c
+c entrees:
+c --------
+c x,y : coordonnees du point image dans le quadrangle de sommets s
+c s : les 2 coordonnees des 4 sommets du quadrangle
+c
+c sorties:
+c --------
+c xc,yc : coordonnees dans le carre dont l'image par f vaut (x,y)
+c ierr : 0 si calcul sans erreur, 1 si quadrangle degenere
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteurs: thenault tulenew analyse numerique paris janvier 1998
+c modifs : perronnet alain analyse numerique paris janvier 1998
+c234567..............................................................012
+ real s(1:2,1:4), dist(2)
+ double precision a,b,c,d,alpha,beta,gamma,delta,x0,y0,t(2),u,v,w
+c
+ a = s(1,1)
+ b = s(1,2) - s(1,1)
+ c = s(1,4) - s(1,1)
+ d = s(1,1) - s(1,2) + s(1,3) - s(1,4)
+c
+ alpha = s(2,1)
+ beta = s(2,2) - s(2,1)
+ gamma = s(2,4) - s(2,1)
+ delta = s(2,1) - s(2,2) + s(2,3) - s(2,4)
+c
+ u = beta * c - b * gamma
+ if( u .eq. 0 ) then
+c quadrangle degenere
+ ierr = 1
+ return
+ endif
+ v = delta * c - d * gamma
+ w = b * delta - beta * d
+c
+ x0 = c * (y-alpha) - gamma * (x-a)
+ y0 = b * (y-alpha) - beta * (x-a)
+c
+ a = v * w
+ b = u * u - w * x0 - v * y0
+ c = x0 * y0
+c
+ if( a .ne. 0 ) then
+c
+ delta = sqrt( b*b-4*a*c )
+ if( b .ge. 0.0 ) then
+ t(2) = -b - delta
+ else
+ t(2) = -b + delta
+ endif
+c la racine de plus grande valeur absolue
+c (elle donne le plus souvent le point exterieur au carre unite
+c donc a tester en second pour reduire les calculs)
+ t(2) = t(2) / ( 2 * a )
+c calcul de la seconde racine a partir de la somme => plus stable
+ t(1) = - b/a - t(2)
+c
+ do 10 i=1,2
+c
+c la solution i donne t elle un point interne au carre unite?
+ xc = ( x0 - v * t(i) ) / u
+ yc = ( w * t(i) - y0 ) / u
+ if( 0.0 .le. xc .and. xc .le. 1.0 ) then
+ if( 0.0 .le. yc .and. yc .le. 1.0 ) goto 9000
+ endif
+c
+c le point (xc,yc) n'est pas dans le carre unite
+c cela peut etre du aux erreurs d'arrondi
+c => choix par le minimum de la distance aux bords du carre
+ dist(i) = max( 0.0, -xc, xc-1.0, -yc, yc-1.0 )
+c
+ 10 continue
+c
+ if( dist(1) .gt. dist(2) ) then
+c f(xc,yc) pour la racine 2 est plus proche de x,y
+c xc yc sont deja calcules
+ goto 9000
+ endif
+c
+ else if ( b .ne. 0 ) then
+ t(1) = - c / b
+ else
+ t(1) = 0
+ endif
+c
+c les 2 coordonnees du point dans le carre unite
+ xc = ( x0 - v * t(1) ) / u
+ yc = ( w * t(1) - y0 ) / u
+c
+ 9000 ierr = 0
+ return
+ end
+
+
+ subroutine ptdatr( point, pxyd, nosotr, nsigne )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : le point est il dans le triangle de sommets nosotr
+c -----
+c
+c entrees:
+c --------
+c point : les 2 coordonnees du point
+c pxyd : les 2 coordonnees et distance souhaitee des points du maillage
+c nosotr : le numero des 3 sommets du triangle
+c
+c sorties:
+c --------
+c nsigne : >0 si le point est dans le triangle ou sur une des 3 aretes
+c =0 si le triangle est degenere ou indirect ou ne contient pas le poin
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+ integer nosotr(3)
+ double precision point(2), pxyd(3,*)
+ double precision xp,yp, x1,x2,x3, y1,y2,y3, d,dd, cb1,cb2,cb3
+c
+ xp = point( 1 )
+ yp = point( 2 )
+c
+ n1 = nosotr( 1 )
+ x1 = pxyd( 1 , n1 )
+ y1 = pxyd( 2 , n1 )
+c
+ n2 = nosotr( 2 )
+ x2 = pxyd( 1 , n2 )
+ y2 = pxyd( 2 , n2 )
+c
+ n3 = nosotr( 3 )
+ x3 = pxyd( 1 , n3 )
+ y3 = pxyd( 2 , n3 )
+c
+c 2 fois la surface du triangle = determinant de la matrice
+c de calcul des coordonnees barycentriques du point p
+ d = ( x2 - x1 ) * ( y3 - y1 ) - ( x3 - x1 ) * ( y2 - y1 )
+c
+ if( d .gt. 0 ) then
+c
+c triangle non degenere
+c =====================
+c calcul des 3 coordonnees barycentriques du
+c point xp yp dans le triangle
+ cb1 = ( ( x2-xp ) * ( y3-yp ) - ( x3-xp ) * ( y2-yp ) ) / d
+ cb2 = ( ( x3-xp ) * ( y1-yp ) - ( x1-xp ) * ( y3-yp ) ) / d
+ cb3 = 1d0 - cb1 -cb2
+ccc cb3 = ( ( x1-xp ) * ( y2-yp ) - ( x2-xp ) * ( y1-yp ) ) / d
+c
+ccc if( cb1 .ge. -0.00005d0 .and. cb1 .le. 1.00005d0 .and.
+ if( cb1 .ge. 0d0 .and. cb1 .le. 1d0 .and.
+ % cb2 .ge. 0d0 .and. cb2 .le. 1d0 .and.
+ % cb3 .ge. 0d0 .and. cb3 .le. 1d0 ) then
+c
+c le triangle nosotr contient le point
+ nsigne = 1
+ else
+ nsigne = 0
+ endif
+c
+ else
+c
+c triangle degenere
+c =================
+c le point est il du meme cote que le sommet oppose de chaque arete?
+ nsigne = 0
+ do 10 i=1,3
+c le sinus de l'angle p1 p2-p1 point
+ x1 = pxyd(1,n1)
+ y1 = pxyd(2,n1)
+ d = ( pxyd(1,n2) - x1 ) * ( point(2) - y1 )
+ % - ( pxyd(2,n2) - y1 ) * ( point(1) - x1 )
+ dd = ( pxyd(1,n2) - x1 ) * ( pxyd(2,n3) - y1 )
+ % - ( pxyd(2,n2) - y1 ) * ( pxyd(1,n3) - x1 )
+ cb1 = ( pxyd(1,n2) - x1 ) ** 2
+ % + ( pxyd(2,n2) - y1 ) ** 2
+ cb2 = ( point(1) - x1 ) ** 2
+ % + ( point(2) - y1 ) ** 2
+ cb3 = ( pxyd(1,n3) - x1 ) ** 2
+ % + ( pxyd(2,n3) - y1 ) ** 2
+ if( abs( dd ) .le. 1e-4 * sqrt( cb1 * cb3 ) ) then
+c le point 3 est sur l'arete 1-2
+c le point doit y etre aussi
+ if( abs( d ) .le. 1e-4 * sqrt( cb1 * cb2 ) ) then
+c point sur l'arete
+ nsigne = nsigne + 1
+ endif
+ else
+c le point 3 n'est pas sur l'arete . test des signes
+ if( d * dd .ge. 0 ) then
+ nsigne = nsigne + 1
+ endif
+ endif
+c permutation circulaire des 3 sommets et aretes
+ n = n1
+ n1 = n2
+ n2 = n3
+ n3 = n
+ 10 continue
+ if( nsigne .ne. 3 ) nsigne = 0
+ endif
+ end
+
+ integer function nosstr( p, pxyd, nt, letree )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : calculer le numero 0 a 3 du sous-triangle te contenant
+c ----- le point p
+c
+c entrees:
+c --------
+c p : point de r**2 contenu dans le te nt de letree
+c pxyd : x y distance des points
+c nt : numero letree du te de te voisin a calculer
+c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
+c letree(0,0) no du 1-er te vide dans letree
+c letree(0,1) : maximum du 1-er indice de letree (ici 8)
+c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
+c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
+c si letree(0,.)>0 alors
+c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
+c sinon
+c letree(0:3,j) :-no pxyd des 1 \85a 4 points internes au triangle j
+c 0 si pas de point
+c ( j est alors une feuille de l'arbre )
+c letree(4,j) : no letree du sur-triangle du triangle j
+c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
+c letree(6:8,j) : no pxyd des 3 sommets du triangle j
+c
+c sorties :
+c ---------
+c nosstr : 0 si le sous-triangle central contient p
+c i =1,2,3 numero du sous-triangle contenant p
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
+c2345x7..............................................................012
+ integer letree(0:8,0:*)
+ double precision pxyd(3,*), p(2),
+ % x1, y1, x21, y21, x31, y31, d, xe, ye
+c
+c le numero des 3 sommets du triangle
+ ns1 = letree( 6, nt )
+ ns2 = letree( 7, nt )
+ ns3 = letree( 8, nt )
+c
+c les coordonnees entre 0 et 1 du point p
+ x1 = pxyd(1,ns1)
+ y1 = pxyd(2,ns1)
+c
+ x21 = pxyd(1,ns2) - x1
+ y21 = pxyd(2,ns2) - y1
+c
+ x31 = pxyd(1,ns3) - x1
+ y31 = pxyd(2,ns3) - y1
+c
+ d = 1.0 / ( x21 * y31 - x31 * y21 )
+c
+ xe = ( ( p(1) - x1 ) * y31 - ( p(2) - y1 ) * x31 ) * d
+ ye = ( ( p(2) - y1 ) * x21 - ( p(1) - x1 ) * y21 ) * d
+c
+ if( xe .gt. 0.5d0 ) then
+c sous-triangle droit
+ nosstr = 2
+ else if( ye .gt. 0.5d0 ) then
+c sous-triangle haut
+ nosstr = 3
+ else if( xe+ye .lt. 0.5d0 ) then
+c sous-triangle gauche
+ nosstr = 1
+ else
+c sous-triangle central
+ nosstr = 0
+ endif
+ end
+
+
+ integer function notrpt( p, pxyd, notrde, letree )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : calculer le numero letree du sous-triangle feuille contenant
+c ----- le point p a partir du te notrde de letree
+c
+c entrees:
+c --------
+c p : point de r**2 contenu dans le te nt de letree
+c pxyd : x y distance des points
+c notrde : numero letree du triangle depart de recherche (1=>racine)
+c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
+c letree(0,0) no du 1-er te vide dans letree
+c letree(0,1) : maximum du 1-er indice de letree (ici 8)
+c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
+c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
+c si letree(0,.)>0 alors
+c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
+c sinon
+c letree(0:3,j) :-no pxyd des 1 \85 4 points internes au triangle j
+c 0 si pas de point
+c ( j est alors une feuille de l'arbre )
+c letree(4,j) : no letree du sur-triangle du triangle j
+c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
+c letree(6:8,j) : no pxyd des 3 sommets du triangle j
+c
+c sorties :
+c ---------
+c notrpt : numero letree du triangle contenant le point p
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
+c2345x7..............................................................012
+ integer letree(0:8,0:*)
+ double precision pxyd(1:3,*), p(2)
+c
+c la racine depart de la recherche
+ notrpt = notrde
+c
+c tant que la feuille n'est pas atteinte descendre l'arbre
+ 10 if( letree(0,notrpt) .gt. 0 ) then
+c
+c recherche du sous-triangle contenant p
+ nsot = nosstr( p, pxyd, notrpt, letree )
+c
+c le numero letree du sous-triangle
+ notrpt = letree( nsot, notrpt )
+ goto 10
+c
+ endif
+ end
+
+
+ subroutine teajpt( ns, nbsomm, mxsomm, pxyd, letree,
+ & ntrp, ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : ajout du point ns de pxyd dans letree
+c -----
+c
+c entrees:
+c --------
+c ns : numero du point a ajouter dans letree
+c mxsomm : nombre maximal de points declarables dans pxyd
+c pxyd : tableau des coordonnees des points
+c par point : x y distance_souhaitee
+c
+c modifies :
+c ----------
+c nbsomm : nombre actuel de points dans pxyd
+c
+c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
+c letree(0,0) : no du 1-er te vide dans letree
+c letree(0,1) : maximum du 1-er indice de letree (ici 8)
+c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
+c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
+c si letree(0,.)>0 alors
+c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
+c sinon
+c letree(0:3,j) :-no pxyd des 1 \85a 4 points internes au triangle j
+c 0 si pas de point
+c ( j est alors une feuille de l'arbre )
+c letree(4,j) : no letree du sur-triangle du triangle j
+c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
+c letree(6:8,j) : no pxyd des 3 sommets du triangle j
+c
+c sorties :
+c ---------
+c ntrp : numero letree du triangle te ou a ete ajoute le point
+c ierr : 0 si pas d'erreur, 51 saturation letree, 52 saturation pxyd
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
+c2345x7..............................................................012
+ integer letree(0:8,0:*)
+ double precision pxyd(3,mxsomm)
+c
+c depart de la racine
+ ntrp = 1
+c
+c recherche du triangle contenant le point pxyd(ns)
+ 1 ntrp = notrpt( pxyd(1,ns), pxyd, ntrp, letree )
+c
+c existe t il un point libre
+ do 10 i=0,3
+ if( letree(i,ntrp) .eq. 0 ) then
+c la place i est libre
+ letree(i,ntrp) = -ns
+ return
+ endif
+ 10 continue
+c
+c pas de place libre => 4 sous-triangles sont crees
+c a partir des 3 milieux des aretes
+ call te4ste( nbsomm, mxsomm, pxyd, ntrp, letree, ierr )
+ if( ierr .ne. 0 ) return
+c
+c ajout du point ns
+ goto 1
+ end
+
+ subroutine n1trva( nt, lar, letree, notrva, lhpile )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : calculer le numero letree du triangle voisin du te nt
+c ----- par l'arete lar (1 a 3 ) de nt
+c attention : notrva n'est pas forcement minimal
+c
+c entrees:
+c --------
+c nt : numero letree du te de te voisin a calculer
+c lar : numero 1 a 3 de l'arete du triangle nt
+c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
+c letree(0,0) no du 1-er te vide dans letree
+c letree(0,1) : maximum du 1-er indice de letree (ici 8)
+c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
+c letree(0:8,1) : racine de l'arbre (triangle sans sur-triangle)
+c si letree(0,.)>0 alors
+c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
+c sinon
+c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
+c 0 si pas de point
+c ( j est alors une feuille de l'arbre )
+c letree(4,j) : no letree du sur-triangle du triangle j
+c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
+c letree(6:8,j) : no pxyd des 3 sommets du triangle j
+c
+c sorties :
+c ---------
+c notrva : >0 numero letree du te voisin par l'arete lar
+c =0 si pas de te voisin (racine , ... )
+c lhpile : =0 si nt et notrva ont meme taille
+c >0 nt est 4**lhpile fois plus petit que notrva
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
+c2345x7..............................................................012
+ integer letree(0:8,0:*)
+ integer lapile(1:64)
+c
+c initialisation de la pile
+c le triangle est empile
+ lapile(1) = nt
+ lhpile = 1
+c
+c tant qu'il existe un sur-triangle
+ 10 ntr = lapile( lhpile )
+ if( ntr .eq. 1 ) then
+c racine atteinte => pas de triangle voisin
+ notrva = 0
+ lhpile = lhpile - 1
+ return
+ endif
+c
+c le type du triangle ntr
+ nty = letree( 5, ntr )
+c l'eventuel sur-triangle
+ nsut = letree( 4, ntr )
+c
+ if( nty .eq. 0 ) then
+c
+c triangle de type 0 => triangle voisin de type precedent(lar)
+c dans le sur-triangle de ntr
+c ce triangle remplace ntr dans lapile
+ lapile( lhpile ) = letree( nopre3(lar), nsut )
+ goto 20
+ endif
+c
+c triangle ntr de type nty>0
+ if( nosui3(nty) .eq. lar ) then
+c
+c le triangle voisin par lar est le triangle 0
+ lapile( lhpile ) = letree( 0, nsut )
+ goto 20
+ endif
+c
+c triangle sans voisin direct => passage par le sur-triangle
+ if( nsut .eq. 0 ) then
+c
+c ntr est la racine => pas de triangle voisin par cette arete
+ notrva = 0
+ return
+ else
+c
+c le sur-triangle est empile
+ lhpile = lhpile + 1
+ lapile(lhpile) = nsut
+ goto 10
+ endif
+c
+c descente aux sous-triangles selon la meme arete
+ 20 notrva = lapile( lhpile )
+c
+ 30 lhpile = lhpile - 1
+ if( letree(0,notrva) .le. 0 ) then
+c le triangle est une feuille de l'arbre 0 sous-triangle
+c lhpile = nombre de differences de niveaux dans l'arbre
+ return
+ else
+c le triangle a 4 sous-triangles
+ if( lhpile .gt. 0 ) then
+c
+c bas de pile non atteint
+ nty = letree( 5, lapile(lhpile) )
+ if( nty .eq. lar ) then
+c l'oppose est suivant(nty) de notrva
+ notrva = letree( nosui3(nty) , notrva )
+ else
+c l'oppose est precedent(nty) de notrva
+ notrva = letree( nopre3(nty) , notrva )
+ endif
+ goto 30
+ endif
+ endif
+c
+c meme niveau dans l'arbre lhpile = 0
+ end
+
+
+ subroutine cenced( xy1, xy2, xy3, cetria, ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : calcul des coordonnees du centre du cercle circonscrit
+c ----- du triangle defini par ses 3 sommets de coordonnees
+c xy1 xy2 xy3 ainsi que le carre du rayon de ce cercle
+c
+c entrees :
+c ---------
+c xy1 xy2 xy3 : les 2 coordonnees des 3 sommets du triangle
+c ierr : <0 => pas d'affichage si triangle degenere
+c >=0 => affichage si triangle degenere
+c
+c sortie :
+c --------
+c cetria : cetria(1)=abcisse du centre
+c cetria(2)=ordonnee du centre
+c cetria(3)=carre du rayon 1d28 si triangle degenere
+c ierr : 0 si triangle non degenere
+c 1 si triangle degenere
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : perronnet alain upmc analyse numerique paris juin 1995
+c2345x7..............................................................012
+ parameter (epsurf=1d-7)
+ common / unites / lecteu,imprim,nunite(30)
+ double precision x1,y1,x21,y21,x31,y31,
+ % aire2,xc,yc,rot,
+ % xy1(2),xy2(2),xy3(2),cetria(3)
+c
+c le calcul de 2 fois l'aire du triangle
+c attention l'ordre des 3 sommets est direct ou non
+ x1 = xy1(1)
+ x21 = xy2(1) - x1
+ x31 = xy3(1) - x1
+c
+ y1 = xy1(2)
+ y21 = xy2(2) - y1
+ y31 = xy3(2) - y1
+c
+ aire2 = x21 * y31 - x31 * y21
+c
+c recherche d'un test relatif peu couteux
+c pour reperer la degenerescence du triangle
+ if( abs(aire2) .le.
+ % epsurf*(abs(x21)+abs(x31))*(abs(y21)+abs(y31)) ) then
+c triangle de qualite trop faible
+ if( ierr .ge. 0 ) then
+c nblgrc(nrerr) = 1
+c kerr(1) = 'erreur cenced: triangle degenere'
+c call lereur
+ write(imprim,*) 'erreur cenced: triangle degenere'
+ write(imprim,10000) xy1,xy2,xy3,aire2
+ endif
+10000 format( 3(' x=',g24.16,' y=',g24.16/),' aire*2=',g24.16)
+ cetria(1) = 0d0
+ cetria(2) = 0d0
+ cetria(3) = 1d28
+ ierr = 1
+ return
+ endif
+c
+c les 2 coordonnees du centre intersection des 2 mediatrices
+c x = (x1+x2)/2 + lambda * (y2-y1)
+c y = (y1+y2)/2 - lambda * (x2-x1)
+c x = (x1+x3)/2 + rot * (y3-y1)
+c y = (y1+y3)/2 - rot * (x3-x1)
+c ==========================================================
+ rot = ((xy2(1)-xy3(1))*x21 + (xy2(2)-xy3(2))*y21) / (2 * aire2)
+c
+ xc = ( x1 + xy3(1) ) * 0.5d0 + rot * y31
+ yc = ( y1 + xy3(2) ) * 0.5d0 - rot * x31
+c
+ cetria(1) = xc
+ cetria(2) = yc
+c
+c le carre du rayon
+ cetria(3) = (x1-xc) ** 2 + (y1-yc) ** 2
+c
+c pas d'erreur rencontree
+ ierr = 0
+ end
+
+
+ double precision function angled( p1, p2, p3 )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : calculer l'angle (p1p2,p1p3) en radians
+c -----
+c
+c entrees :
+c ---------
+c p1,p2,p3 : les 2 coordonnees des 3 sommets de l'angle
+c sens direct pour une surface >0
+c sorties :
+c ---------
+c angled : angle (p1p2,p1p3) en radians entre [0 et 2pi]
+c 0 si p1=p2 ou p1=p3
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique upmc paris fevrier 1992
+c2345x7..............................................................012
+ double precision p1(2),p2(2),p3(2),x21,y21,x31,y31,a1,a2,d,c
+c
+c les cotes
+ x21 = p2(1) - p1(1)
+ y21 = p2(2) - p1(2)
+ x31 = p3(1) - p1(1)
+ y31 = p3(2) - p1(2)
+c
+c longueur des cotes
+ a1 = x21 * x21 + y21 * y21
+ a2 = x31 * x31 + y31 * y31
+ d = sqrt( a1 * a2 )
+ if( d .eq. 0 ) then
+ angled = 0
+ return
+ endif
+c
+c cosinus de l'angle
+ c = ( x21 * x31 + y21 * y31 ) / d
+ if( c .le. -1.d0 ) then
+c tilt sur apollo si acos( -1 -eps )
+ angled = atan( 1.d0 ) * 4.d0
+ return
+ else if( c .ge. 1.d0 ) then
+c tilt sur apollo si acos( 1 + eps )
+ angled = 0
+ return
+ endif
+c
+ angled = acos( c )
+ if( x21 * y31 - x31 * y21 .lt. 0 ) then
+c demi plan inferieur
+ angled = 8.d0 * atan( 1.d0 ) - angled
+ endif
+ end
+
+
+ subroutine teajte( mxsomm, nbsomm, pxyd, comxmi,
+ % aretmx, mxtree, letree,
+ % ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : initialisation des tableaux letree
+c ----- ajout des sommets 1 a nbsomm (valeur en entree) dans letree
+c
+c entrees:
+c --------
+c mxsomm : nombre maximal de sommets permis pour la triangulation
+c mxtree : nombre maximal de triangles equilateraux (te) declarables
+c aretmx : longueur maximale des aretes des triangles equilateraux
+c
+c entrees et sorties :
+c --------------------
+c nbsomm : nombre de sommets apres identification
+c pxyd : tableau des coordonnees 2d des points
+c par point : x y distance_souhaitee
+c tableau reel(3,mxsomm)
+c
+c sorties:
+c --------
+c comxmi : coordonnees minimales et maximales des points frontaliers
+c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
+c letree(0,0) : no du 1-er te vide dans letree
+c letree(0,1) : maximum du 1-er indice de letree (ici 8)
+c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
+c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
+c si letree(0,.)>0 alors
+c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
+c sinon
+c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
+c 0 si pas de point
+c ( j est alors une feuille de l'arbre )
+c letree(4,j) : no letree du sur-triangle du triangle j
+c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
+c letree(6:8,j) : no pxyd des 3 sommets du triangle j
+c
+c ierr : 0 si pas d'erreur
+c 51 saturation letree
+c 52 saturation pxyd
+c 7 tous les points sont alignes
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc juillet 1994
+c....................................................................012
+ integer letree(0:8,0:mxtree)
+ double precision pxyd(3,mxsomm)
+ double precision comxmi(3,2)
+ double precision a(2),s,aretmx,rac3
+c
+c protection du nombre de sommets avant d'ajouter ceux de tetree
+ nbsofr = nbsomm
+ do 1 i = 1, nbsomm
+ comxmi(1,1) = min( comxmi(1,1), pxyd(1,i) )
+ comxmi(1,2) = max( comxmi(1,2), pxyd(1,i) )
+ comxmi(2,1) = min( comxmi(2,1), pxyd(2,i) )
+ comxmi(2,2) = max( comxmi(2,2), pxyd(2,i) )
+ 1 continue
+c
+c creation de l'arbre tee
+c =======================
+c la premiere colonne vide de letree
+ letree(0,0) = 2
+c chainage des te vides
+ do 4 i = 2 , mxtree
+ letree(0,i) = i+1
+ 4 continue
+ letree(0,mxtree) = 0
+c les maxima des 2 indices de letree
+ letree(1,0) = 8
+ letree(2,0) = mxtree
+c
+c la racine
+c aucun point interne au triangle equilateral (te) 1
+ letree(0,1) = 0
+ letree(1,1) = 0
+ letree(2,1) = 0
+ letree(3,1) = 0
+c pas de sur-triangle
+ letree(4,1) = 0
+ letree(5,1) = 0
+c le numero pxyd des 3 sommets du te 1
+ letree(6,1) = nbsomm + 1
+ letree(7,1) = nbsomm + 2
+ letree(8,1) = nbsomm + 3
+c
+c calcul de la largeur et hauteur du rectangle englobant
+c ======================================================
+ a(1) = comxmi(1,2) - comxmi(1,1)
+ a(2) = comxmi(2,2) - comxmi(2,1)
+c la longueur de la diagonale
+ s = sqrt( a(1)**2 + a(2)**2 )
+ do 60 k=1,2
+ if( a(k) .lt. 1e-4 * s ) then
+c nblgrc(nrerr) = 1
+ write(imprim,*) 'tous les points sont alignes'
+c call lereur
+ ierr = 7
+ return
+ endif
+ 60 continue
+c
+c le maximum des ecarts
+ s = s + s
+c
+c le triangle equilateral englobant
+c =================================
+c ecart du rectangle au triangle equilateral
+ rac3 = sqrt( 3.0d0 )
+ arete = a(1) + 2 * aretmx + 2 * ( a(2) + aretmx ) / rac3
+c
+c le point nbsomm + 1 en bas a gauche
+ nbsomm = nbsomm + 1
+ pxyd(1,nbsomm) = (comxmi(1,1)+comxmi(1,2))*0.5d0 - arete*0.5d0
+ pxyd(2,nbsomm) = comxmi(2,1) - aretmx
+ pxyd(3,nbsomm) = s
+c
+c le point nbsomm + 2 en bas a droite
+ nbsomm = nbsomm + 1
+ pxyd(1,nbsomm) = pxyd(1,nbsomm-1) + arete
+ pxyd(2,nbsomm) = pxyd(2,nbsomm-1)
+ pxyd(3,nbsomm) = s
+c
+c le point nbsomm + 3 sommet au dessus
+ nbsomm = nbsomm + 1
+ pxyd(1,nbsomm) = pxyd(1,nbsomm-2) + arete * 0.5d0
+ pxyd(2,nbsomm) = pxyd(2,nbsomm-2) + arete * 0.5d0 * rac3
+ pxyd(3,nbsomm) = s
+c
+c ajout des sommets des lignes pour former letree
+c ===============================================
+ do 150 i=1,nbsofr
+c ajout du point i de pxyd a letree
+ call teajpt( i, nbsomm, mxsomm, pxyd, letree,
+ & nt, ierr )
+ if( ierr .ne. 0 ) return
+ 150 continue
+c
+ return
+ end
+
+
+ subroutine tetaid( nutysu, dx, dy, longai, ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : calculer la longueur de l'arete ideale en dx,dy
+c -----
+c
+c entrees:
+c --------
+c nutysu : numero de traitement de areteideale() selon le type de surface
+c 0 pas d'emploi de la fonction areteideale() => aretmx active
+c 1 il existe une fonction areteideale(xyz,xyzdir)
+c ... autres options a definir ...
+c dx, dy : abscisse et ordonnee dans le plan du point (reel2!)
+c
+c sorties:
+c --------
+c longai : longueur de l'areteideale(xyz,xyzdir) autour du point xyz
+c ierr : 0 si pas d'erreur, <>0 sinon
+c 1 calcul incorrect de areteideale(xyz,xyzdir)
+c 2 longueur calculee nulle
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c2345x7..............................................................012
+ common / unites / lecteu, imprim, nunite(30)
+c
+ double precision areteideale
+ double precision dx, dy, longai
+ double precision xyz(3), xyzd(3), d0
+c
+ ierr = 0
+ if( nutysu .gt. 0 ) then
+ d0 = longai
+c le point ou se calcule la longueur
+ xyz(1) = dx
+ xyz(2) = dy
+c z pour le calcul de la longueur (inactif ici!)
+ xyz(3) = 0d0
+c la direction pour le calcul de la longueur (inactif ici!)
+ xyzd(1) = 0d0
+ xyzd(2) = 0d0
+ xyzd(3) = 0d0
+
+ longai = areteideale(xyz,xyzd)
+ if( longai .lt. 0d0 ) then
+ write(imprim,10000) xyz
+10000 format('attention: longueur de areteideale(',
+ % g14.6,',',g14.6,',',g14.6,')<=0! => rendue >0' )
+ longai = -longai
+ endif
+ if( longai .eq. 0d0 ) then
+ write(imprim,10001) xyz
+10001 format('erreur: longueur de areteideale(',
+ % g14.6,',',g14.6,',',g14.6,')=0!' )
+ ierr = 2
+ longai = d0
+ endif
+ endif
+ end
+
+
+ subroutine tehote( nutysu,
+ % nbarpi, mxsomm, nbsomm, pxyd,
+ % comxmi, aretmx,
+ % letree, mxqueu, laqueu,
+ % ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : homogeneisation de l'arbre des te a un saut de taille au plus
+c ----- prise en compte des distances souhaitees autour des sommets initiaux
+c
+c entrees:
+c --------
+c nutysu : numero de traitement de areteideale() selon le type de surface
+c 0 pas d'emploi de la fonction areteideale() => aretmx active
+c 1 il existe une fonction areteideale()
+c dont seules les 2 premieres composantes de uv sont actives
+c autres options a definir...
+c nbarpi : nombre de sommets de la frontiere + nombre de points internes
+c imposes par l'utilisateur
+c mxsomm : nombre maximal de sommets permis pour la triangulation et te
+c mxqueu : nombre d'entiers utilisables dans laqueu
+c comxmi : minimum et maximum des coordonnees de l'objet
+c aretmx : longueur maximale des aretes des triangles equilateraux
+c permtr : perimetre de la ligne enveloppe dans le plan
+c avant mise a l'echelle a 2**20
+c
+c modifies :
+c ----------
+c nbsomm : nombre de sommets apres identification
+c pxyd : tableau des coordonnees 2d des points
+c par point : x y distance_souhaitee
+c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
+c letree(0,0) : no du 1-er te vide dans letree
+c letree(1,0) : maximum du 1-er indice de letree (ici 8)
+c letree(2,0) : maximum declare du 2-eme indice de letree (ici mxtree)
+c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
+c si letree(0,.)>0 alors
+c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
+c sinon
+c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
+c 0 si pas de point
+c ( j est alors une feuille de l'arbre )
+c letree(4,j) : no letree du sur-triangle du triangle j
+c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
+c letree(6:8,j) : no pxyd des 3 sommets du triangle j
+c
+c auxiliaire :
+c ------------
+c laqueu : mxqueu entiers servant de queue pour le parcours de letree
+c
+c sorties:
+c --------
+c ierr : 0 si pas d'erreur
+c 51 si saturation letree dans te4ste
+c 52 si saturation pxyd dans te4ste
+c >0 si autre erreur
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc avril 1997
+c2345x7..............................................................012
+ double precision ampli
+ parameter (ampli=1.34d0)
+ common / unites / lecteu, imprim, intera, nunite(29)
+c
+ double precision pxyd(3,mxsomm), d2, aretm2
+ double precision comxmi(3,2),aretmx,a,s,xrmin,xrmax,yrmin,yrmax
+ double precision dmin, dmax
+ integer letree(0:8,0:*)
+c
+ integer laqueu(1:mxqueu),lequeu
+c lequeu : entree dans la queue
+c lhqueu : longueur de la queue
+c gestion circulaire
+c
+ integer nuste(3)
+ equivalence (nuste(1),ns1),(nuste(2),ns2),(nuste(3),ns3)
+c
+c existence ou non de la fonction 'taille_ideale' des aretes
+c autour du point. ici la carte est supposee isotrope
+c ==========================================================
+c attention: si la fonction taille_ideale existe
+c alors pxyd(3,*) est la taille_ideale dans l'espace initial
+c sinon pxyd(3,*) est la distance calculee dans le plan par
+c propagation a partir des tailles des aretes de la frontiere
+c
+ if( nutysu .gt. 0 ) then
+c
+c la fonction taille_ideale(x,y,z) existe
+c ---------------------------------------
+c initialisation de la distance souhaitee autour des points 1 a nbsomm
+ do 1 i=1,nbsomm
+c calcul de pxyzd(3,i)
+ call tetaid( nutysu, pxyd(1,i), pxyd(2,i),
+ % pxyd(3,i), ierr )
+ if( ierr .ne. 0 ) goto 9999
+ 1 continue
+c
+ else
+c
+c la fonction taille_ideale(x,y,z) n'existe pas
+c ---------------------------------------------
+c prise en compte des distances souhaitees dans le plan
+c autour des points frontaliers et des points internes imposes
+c toutes les autres distances souhaitees ont ete mis a aretmx
+c lors de l'execution du sp teqini
+ do 3 i=1,nbarpi
+c le sommet i n'est pas un sommet de letree => sommet frontalier
+c recherche du sous-triangle minimal feuille contenant le point i
+ nte = 1
+ 2 nte = notrpt( pxyd(1,i), pxyd, nte, letree )
+c la distance au sommet le plus eloigne est elle inferieure
+c a la distance souhaitee?
+ ns1 = letree(6,nte)
+ ns2 = letree(7,nte)
+ ns3 = letree(8,nte)
+ d2 = max( ( pxyd(1,i)-pxyd(1,ns1) )**2 +
+ % ( pxyd(2,i)-pxyd(2,ns1) )**2
+ % , ( pxyd(1,i)-pxyd(1,ns2) )**2 +
+ % ( pxyd(2,i)-pxyd(2,ns2) )**2
+ % , ( pxyd(1,i)-pxyd(1,ns3) )**2 +
+ % ( pxyd(2,i)-pxyd(2,ns3) )**2 )
+ if( d2 .gt. pxyd(3,i)**2 ) then
+c le triangle nte trop grand doit etre subdivise en 4 sous-triangle
+ call te4ste( nbsomm, mxsomm, pxyd, nte, letree,
+ & ierr )
+ if( ierr .ne. 0 ) return
+ goto 2
+ endif
+ 3 continue
+ endif
+c
+c le sous-triangle central de la racine est decoupe systematiquement
+c ==================================================================
+ nte = 2
+ if( letree(0,2) .le. 0 ) then
+c le sous-triangle central de la racine n'est pas subdivise
+c il est donc decoupe en 4 soustriangles
+ nbsom0 = nbsomm
+ call te4ste( nbsomm, mxsomm, pxyd, nte, letree,
+ % ierr )
+ if( ierr .ne. 0 ) return
+ do 4 i=nbsom0+1,nbsomm
+c mise a jour de taille_ideale des nouveaux sommets de te
+ call tetaid( nutysu, pxyd(1,i), pxyd(2,i), pxyd(3,i), ierr )
+ if( ierr .ne. 0 ) goto 9999
+ 4 continue
+ endif
+c
+c le carre de la longueur de l'arete de triangles equilateraux
+c souhaitee pour le fond de la triangulation
+ aretm2 = (aretmx*ampli) ** 2
+c
+c tout te contenu dans le rectangle englobant doit avoir un
+c cote < aretmx et etre de meme taille que les te voisins
+c s'il contient un point; sinon un seul saut de taille est permis
+c ===============================================================
+c le rectangle englobant pour selectionner les te "internes"
+c le numero des 3 sommets du te englobant racine de l'arbre des te
+ ns1 = letree(6,1)
+ ns2 = letree(7,1)
+ ns3 = letree(8,1)
+ a = aretmx * 0.01d0
+c abscisse du milieu de l'arete gauche du te 1
+ s = ( pxyd(1,ns1) + pxyd(1,ns3) ) / 2
+ xrmin = min( s, comxmi(1,1) - aretmx ) - a
+c abscisse du milieu de l'arete droite du te 1
+ s = ( pxyd(1,ns2) + pxyd(1,ns3) ) / 2
+ xrmax = max( s, comxmi(1,2) + aretmx ) + a
+ yrmin = comxmi(2,1) - aretmx
+c ordonnee de la droite passant par les milieus des 2 aretes
+c droite gauche du te 1
+ s = ( pxyd(2,ns1) + pxyd(2,ns3) ) / 2
+ yrmax = max( s, comxmi(2,2) + aretmx ) + a
+c
+c cas particulier de 3 ou 4 ou peu d'aretes frontalieres
+ if( nbarpi .le. 8 ) then
+c tout le triangle englobant (racine) est a prendre en compte
+ xrmin = pxyd(1,ns1) - a
+ xrmax = pxyd(1,ns2) + a
+ yrmin = pxyd(2,ns1) - a
+ yrmax = pxyd(2,ns3) + a
+ endif
+c
+ nbs0 = nbsomm
+ nbiter = -1
+c
+c initialisation de la queue
+ 5 nbiter = nbiter + 1
+ lequeu = 1
+ lhqueu = 0
+c la racine de letree initialise la queue
+ laqueu(1) = 1
+c
+c tant que la longueur de la queue est >=0 traiter le debut de queue
+ 10 if( lhqueu .ge. 0 ) then
+c
+c le triangle te a traiter
+ i = lequeu - lhqueu
+ if( i .le. 0 ) i = mxqueu + i
+ nte = laqueu( i )
+c la longueur de la queue est reduite
+ lhqueu = lhqueu - 1
+c
+c nte est il un sous-triangle feuille minimal ?
+ 15 if( letree(0,nte) .gt. 0 ) then
+c
+c non les 4 sous-triangles sont mis dans la queue
+ if( lhqueu + 4 .ge. mxqueu ) then
+ write(imprim,*) 'tehote: saturation de la queue'
+ ierr = 7
+ return
+ endif
+ do 20 i=3,0,-1
+c ajout du sous-triangle i
+ lhqueu = lhqueu + 1
+ lequeu = lequeu + 1
+ if( lequeu .gt. mxqueu ) lequeu = lequeu - mxqueu
+ laqueu( lequeu ) = letree( i, nte )
+ 20 continue
+ goto 10
+c
+ endif
+c
+c ici nte est un triangle minimal non subdivise
+c ---------------------------------------------
+c le te est il dans le cadre englobant de l'objet ?
+ ns1 = letree(6,nte)
+ ns2 = letree(7,nte)
+ ns3 = letree(8,nte)
+ if( pxyd(1,ns1) .gt. pxyd(1,ns2) ) then
+ dmin = pxyd(1,ns2)
+ dmax = pxyd(1,ns1)
+ else
+ dmin = pxyd(1,ns1)
+ dmax = pxyd(1,ns2)
+ endif
+ if( (xrmin .le. dmin .and. dmin .le. xrmax) .or.
+ % (xrmin .le. dmax .and. dmax .le. xrmax) ) then
+ if( pxyd(2,ns1) .gt. pxyd(2,ns3) ) then
+ dmin = pxyd(2,ns3)
+ dmax = pxyd(2,ns1)
+ else
+ dmin = pxyd(2,ns1)
+ dmax = pxyd(2,ns3)
+ endif
+ if( (yrmin .le. dmin .and. dmin .le. yrmax) .or.
+ % (yrmin .le. dmax .and. dmax .le. yrmax) ) then
+c
+c nte est un te feuille et interne au rectangle englobant
+c =======================================================
+c le carre de la longueur de l'arete du te de numero nte
+ d2 = (pxyd(1,ns1)-pxyd(1,ns2)) ** 2 +
+ % (pxyd(2,ns1)-pxyd(2,ns2)) ** 2
+c
+ if( nutysu .eq. 0 ) then
+c
+c il n'existe pas de fonction 'taille_ideale'
+c -------------------------------------------
+c si la taille effective de l'arete du te est superieure a aretmx
+c alors le te est decoupe
+ if( d2 .gt. aretm2 ) then
+c le triangle nte trop grand doit etre subdivise
+c en 4 sous-triangles
+ call te4ste( nbsomm,mxsomm, pxyd,
+ % nte, letree, ierr )
+ if( ierr .ne. 0 ) return
+ goto 15
+ endif
+c
+ else
+c
+c il existe ici une fonction 'taille_ideale'
+c ------------------------------------------
+c si la taille effective de l'arete du te est superieure au mini
+c des 3 tailles_ideales aux sommets alors le te est decoupe
+ do 28 i=1,3
+ if( d2 .gt. (pxyd(3,nuste(i))*ampli)**2 ) then
+c le triangle nte trop grand doit etre subdivise
+c en 4 sous-triangles
+ nbsom0 = nbsomm
+ call te4ste( nbsomm, mxsomm, pxyd,
+ & nte, letree, ierr )
+ if( ierr .ne. 0 ) return
+ do 27 j=nbsom0+1,nbsomm
+c mise a jour de taille_ideale des nouveaux sommets de
+ call tetaid( nutysu, pxyd(1,j), pxyd(2,j),
+ % pxyd(3,j), ierr )
+ if( ierr .ne. 0 ) goto 9999
+ 27 continue
+ goto 15
+ endif
+ 28 continue
+ endif
+c
+c recherche du nombre de niveaux entre nte et les te voisins par se
+c si la difference de subdivisions excede 1 alors le plus grand des
+c =================================================================
+ 29 do 30 i=1,3
+c
+c noteva triangle voisin de nte par l'arete i
+ call n1trva( nte, i, letree, noteva, niveau )
+ if( noteva .le. 0 ) goto 30
+c il existe un te voisin
+ if( niveau .gt. 0 ) goto 30
+c nte a un te voisin plus petit ou egal
+ if( letree(0,noteva) .le. 0 ) goto 30
+c nte a un te voisin noteva subdivise au moins une fois
+c
+ if( nbiter .gt. 0 ) then
+c les 2 sous triangles voisins sont-ils subdivises?
+ ns2 = letree(i,noteva)
+ if( letree(0,ns2) .le. 0 ) then
+c ns2 n'est pas subdivise
+ ns2 = letree(nosui3(i),noteva)
+ if( letree(0,ns2) .le. 0 ) then
+c les 2 sous-triangles ne sont pas subdivises
+ goto 30
+ endif
+ endif
+ endif
+c
+c saut>1 => le triangle nte doit etre subdivise en 4 sous-triang
+c --------------------------------------------------------------
+ nbsom0 = nbsomm
+ call te4ste( nbsomm,mxsomm, pxyd, nte, letree,
+ & ierr )
+ if( ierr .ne. 0 ) return
+ if( nutysu .gt. 0 ) then
+ do 32 j=nbsom0+1,nbsomm
+c mise a jour de taille_ideale des nouveaux sommets de te
+ call tetaid( nutysu, pxyd(1,j), pxyd(2,j),
+ % pxyd(3,j), ierr )
+ if( ierr .ne. 0 ) goto 9999
+ 32 continue
+ endif
+ goto 15
+c
+ 30 continue
+ endif
+ endif
+ goto 10
+ endif
+ if( nbs0 .lt. nbsomm ) then
+ nbs0 = nbsomm
+ goto 5
+ endif
+ return
+c
+c pb dans le calcul de la fonction taille_ideale
+
+ 9999 write(imprim,*) 'pb dans le calcul de taille_ideale'
+c nblgrc(nrerr) = 1
+c kerr(1) = 'pb dans le calcul de taille_ideale'
+c call lereur
+ return
+ end
+
+
+ subroutine tetrte( comxmi, aretmx, nbarpi, mxsomm, pxyd,
+ % mxqueu, laqueu, letree,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr, noarst,
+ % ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : trianguler les triangles equilateraux feuilles et
+c ----- les points de la frontiere et les points internes imposes
+c
+c attention: la triangulation finale n'est pas de type delaunay!
+c
+c entrees:
+c --------
+c comxmi : minimum et maximum des coordonnees de l'objet
+c aretmx : longueur maximale des aretes des triangles equilateraux
+c nbarpi : nombre de sommets de la frontiere + nombre de points internes
+c imposes par l'utilisateur
+c mxsomm : nombre maximal de sommets declarables dans pxyd
+c pxyd : tableau des coordonnees 2d des points
+c par point : x y distance_souhaitee
+c
+c mxqueu : nombre d'entiers utilisables dans laqueu
+c mosoar : nombre maximal d'entiers par arete du tableau nosoar
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxartr : nombre maximal de triangles stockables dans le tableau noartr
+c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
+c letree(0,0) : no du 1-er te vide dans letree
+c letree(0,1) : maximum du 1-er indice de letree (ici 8)
+c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
+c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
+c si letree(0,.)>0 alors
+c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
+c sinon
+c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
+c 0 si pas de point
+c ( j est alors une feuille de l'arbre )
+c letree(4,j) : no letree du sur-triangle du triangle j
+c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
+c letree(6:8,j) : no pxyd des 3 sommets du triangle j
+c
+c modifies:
+c ---------
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c une arete i de nosoar est vide <=> nosoar(1,i)=0
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = nosoar(1)+nosoar(2)*2
+c noarst : noarst(i) numero d'une arete de sommet i
+c
+c auxiliaire :
+c ------------
+c laqueu : mxqueu entiers servant de queue pour le parcours de letree
+c
+c sorties:
+c --------
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c ierr : =0 si pas d'erreur
+c =1 si le tableau nosoar est sature
+c =2 si le tableau noartr est sature
+c =3 si aucun des triangles ne contient l'un des points internes d'un t
+c =5 si saturation de la queue de parcours de l'arbre des te
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c2345x7..............................................................012
+ common / unites / lecteu, imprim, intera, nunite(29)
+c
+ double precision pxyd(3,mxsomm)
+ double precision comxmi(3,2),aretmx,a,s,xrmin,xrmax,yrmin,yrmax
+ double precision dmin, dmax
+c
+ integer nosoar(mosoar,mxsoar),
+ % noartr(moartr,mxartr),
+ % noarst(mxsomm)
+c
+ integer letree(0:8,0:*)
+ integer laqueu(1:mxqueu)
+c lequeu:entree dans la queue en gestion circulaire
+c lhqueu:longueur de la queue en gestion circulaire
+c
+ integer milieu(3), nutr(1:13)
+c
+c le rectangle englobant pour selectionner les te "internes"
+c le numero des 3 sommets du te englobant racine de l'arbre des te
+ ns1 = letree(6,1)
+ ns2 = letree(7,1)
+ ns3 = letree(8,1)
+ a = aretmx * 0.01d0
+c abscisse du milieu de l'arete gauche du te 1
+ s = ( pxyd(1,ns1) + pxyd(1,ns3) ) / 2
+ xrmin = min( s, comxmi(1,1) - aretmx ) - a
+c abscisse du milieu de l'arete droite du te 1
+ s = ( pxyd(1,ns2) + pxyd(1,ns3) ) / 2
+ xrmax = max( s, comxmi(1,2) + aretmx ) + a
+ yrmin = comxmi(2,1) - aretmx
+c ordonnee de la droite passant par les milieus des 2 aretes
+c droite gauche du te 1
+ s = ( pxyd(2,ns1) + pxyd(2,ns3) ) / 2
+ yrmax = max( s, comxmi(2,2) + aretmx ) + a
+c
+c cas particulier de 3 ou 4 ou peu d'aretes frontalieres
+ if( nbarpi .le. 8 ) then
+c tout le triangle englobant (racine) est a prendre en compte
+ xrmin = pxyd(1,ns1) - a
+ xrmax = pxyd(1,ns2) + a
+ yrmin = pxyd(2,ns1) - a
+ yrmax = pxyd(2,ns3) + a
+ endif
+c
+c initialisation du tableau noartr
+ do 5 i=1,mxartr
+c le numero de l'arete est inconnu
+ noartr(1,i) = 0
+c le chainage sur le triangle vide suivant
+ noartr(2,i) = i+1
+ 5 continue
+ noartr(2,mxartr) = 0
+ n1artr = 1
+c
+c parcours des te jusqu'a trianguler toutes les feuilles (triangles eq)
+c =====================================================================
+c initialisation de la queue sur les te
+ ierr = 0
+ lequeu = 1
+ lhqueu = 0
+c la racine de letree initialise la queue
+ laqueu(1) = 1
+c
+c tant que la longueur de la queue est >=0 traiter le debut de queue
+ 10 if( lhqueu .ge. 0 ) then
+c
+c le triangle te a traiter
+ i = lequeu - lhqueu
+ if( i .le. 0 ) i = mxqueu + i
+ nte = laqueu( i )
+c la longueur est reduite
+ lhqueu = lhqueu - 1
+c
+c nte est il un sous-triangle feuille (minimal) ?
+ 15 if( letree(0,nte) .gt. 0 ) then
+c non les 4 sous-triangles sont mis dans la queue
+ if( lhqueu + 4 .ge. mxqueu ) then
+ write(imprim,*) 'tetrte: saturation de la queue'
+ ierr = 5
+ return
+ endif
+ do 20 i=3,0,-1
+c ajout du sous-triangle i
+ lhqueu = lhqueu + 1
+ lequeu = lequeu + 1
+ if( lequeu .gt. mxqueu ) lequeu = lequeu - mxqueu
+ laqueu( lequeu ) = letree( i, nte )
+ 20 continue
+ goto 10
+ endif
+c
+c ici nte est un triangle minimal non subdivise
+c ---------------------------------------------
+c le te est il dans le cadre englobant de l'objet ?
+ ns1 = letree(6,nte)
+ ns2 = letree(7,nte)
+ ns3 = letree(8,nte)
+ if( pxyd(1,ns1) .gt. pxyd(1,ns2) ) then
+ dmin = pxyd(1,ns2)
+ dmax = pxyd(1,ns1)
+ else
+ dmin = pxyd(1,ns1)
+ dmax = pxyd(1,ns2)
+ endif
+ if( (xrmin .le. dmin .and. dmin .le. xrmax) .or.
+ % (xrmin .le. dmax .and. dmax .le. xrmax) ) then
+ if( pxyd(2,ns1) .gt. pxyd(2,ns3) ) then
+ dmin = pxyd(2,ns3)
+ dmax = pxyd(2,ns1)
+ else
+ dmin = pxyd(2,ns1)
+ dmax = pxyd(2,ns3)
+ endif
+ if( (yrmin .le. dmin .and. dmin .le. yrmax) .or.
+ % (yrmin .le. dmax .and. dmax .le. yrmax) ) then
+c
+c te minimal et interne au rectangle englobant
+c --------------------------------------------
+c recherche du nombre de niveaux entre nte et les te voisins
+c par ses aretes
+ nbmili = 0
+ do 30 i=1,3
+c
+c a priori pas de milieu de l'arete i du te nte
+ milieu(i) = 0
+c
+c recherche de noteva te voisin de nte par l'arete i
+ call n1trva( nte, i, letree, noteva, niveau )
+c noteva : >0 numero letree du te voisin par l'arete i
+c =0 si pas de te voisin (racine , ... )
+c niveau : =0 si nte et noteva ont meme taille
+c >0 nte est 4**niveau fois plus petit que noteva
+ if( noteva .gt. 0 ) then
+c il existe un te voisin
+ if( letree(0,noteva) .gt. 0 ) then
+c noteva est plus petit que nte
+c => recherche du numero du milieu du cote=sommet du te no
+c le sous-te 0 du te noteva
+ nsot = letree(0,noteva)
+c le numero dans pxyd du milieu de l'arete i de nte
+ milieu( i ) = letree( 5+nopre3(i), nsot )
+ nbmili = nbmili + 1
+ endif
+ endif
+c
+ 30 continue
+c
+c triangulation du te nte en fonction du nombre de ses milieux
+ goto( 50, 100, 200, 300 ) , nbmili + 1
+c
+c 0 milieu => 1 triangle = le te nte
+c ----------------------------------
+ 50 call f0trte( letree(0,nte), pxyd,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % noarst,
+ % nbtr, nutr, ierr )
+ if( ierr .ne. 0 ) return
+ goto 10
+c
+c 1 milieu => 2 triangles = 2 demi te
+c -----------------------------------
+ 100 call f1trte( letree(0,nte), pxyd, milieu,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % noarst,
+ % nbtr, nutr, ierr )
+ if( ierr .ne. 0 ) return
+ goto 10
+c
+c 2 milieux => 3 triangles
+c -----------------------------------
+ 200 call f2trte( letree(0,nte), pxyd, milieu,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % noarst,
+ % nbtr, nutr, ierr )
+ if( ierr .ne. 0 ) return
+ goto 10
+c
+c 3 milieux => 4 triangles = 4 quart te
+c -------------------------------------
+ 300 call f3trte( letree(0,nte), pxyd, milieu,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % noarst,
+ % nbtr, nutr, ierr )
+ if( ierr .ne. 0 ) return
+ goto 10
+ endif
+ endif
+ goto 10
+ endif
+ end
+
+
+ subroutine aisoar( mosoar, mxsoar, nosoar, na1 )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : chainer en colonne lchain les aretes non vides et
+c ----- non frontalieres du tableau nosoar
+c
+c entrees:
+c --------
+c mosoar : nombre maximal d'entiers par arete dans le tableau nosoar
+c mxsoar : nombre maximal d'aretes frontalieres declarables
+c
+c modifies :
+c ----------
+c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
+c nosoar(lchain,i)=arete interne suivante
+c
+c sortie :
+c --------
+c na1 : numero dans nosoar de la premiere arete interne
+c les suivantes sont nosoar(lchain,na1), ...
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+ parameter (lchain=6)
+ integer nosoar(mosoar,mxsoar)
+c
+c formation du chainage des aretes internes a echanger eventuellement
+c recherche de la premiere arete non vide et non frontaliere
+ do 10 na1=1,mxsoar
+ if( nosoar(1,na1) .gt. 0 .and. nosoar(3,na1) .le. 0 ) goto 15
+ 10 continue
+c
+c protection de la premiere arete non vide et non frontaliere
+ 15 na0 = na1
+ do 20 na=na1+1,mxsoar
+ if( nosoar(1,na) .gt. 0 .and. nosoar(3,na) .le. 0 ) then
+c arete interne => elle est chainee a partir de la precedente
+ nosoar(lchain,na0) = na
+ na0 = na
+ endif
+ 20 continue
+c
+c la derniere arete interne n'a pas de suivante
+ nosoar(lchain,na0) = 0
+ end
+
+
+ subroutine tedela( pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar, n1ardv,
+ % moartr, mxartr, n1artr, noartr, modifs )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : pour toutes les aretes chainees dans nosoar(lchain,*)
+c ----- du tableau nosoar
+c echanger la diagonale des 2 triangles si le sommet oppose
+c a un triangle ayant en commun une arete appartient au cercle
+c circonscrit de l'autre (violation boule vide delaunay)
+c
+c entrees:
+c --------
+c pxyd : tableau des x y distance_souhaitee de chaque sommet
+c
+c modifies :
+c ----------
+c noarst : noarst(i) numero d'une arete de sommet i
+c mosoar : nombre maximal d'entiers par arete dans le tableau nosoar
+c mxsoar : nombre maximal d'aretes frontalieres declarables
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
+c n1ardv : numero dans nosoar de la premiere arete du chainage
+c des aretes a rendre delaunay
+c
+c moartr : nombre d'entiers par triangle dans le tableau noartr
+c mxartr : nombre maximal de triangles declarables dans noartr
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c modifs : nombre d'echanges de diagonales pour maximiser la qualite
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+ parameter (lchain=6)
+ common / unites / lecteu, imprim, nunite(30)
+ double precision pxyd(3,*), surtd2, s123, s142, s143, s234,
+ % s12, s34, a12, cetria(3), r0
+ integer nosoar(mosoar,mxsoar),
+ % noartr(moartr,mxartr),
+ % noarst(*)
+c
+c le nombre d'echanges de diagonales pour minimiser l'aire
+ modifs = 0
+ r0 = 0
+c
+c la premiere arete du chainage des aretes a rendre delaunay
+ na0 = n1ardv
+c
+c tant que la pile des aretes a echanger eventuellement est non vide
+c ==================================================================
+ 20 if( na0 .gt. 0 ) then
+c
+c l'arete a traiter
+ na = na0
+c la prochaine arete a traiter
+ na0 = nosoar(lchain,na0)
+c
+c l'arete est marquee traitee avec le numero -1
+ nosoar(lchain,na) = -1
+c
+c l'arete est elle active?
+ if( nosoar(1,na) .eq. 0 ) goto 20
+c
+c si arete frontaliere pas d'echange possible
+ if( nosoar(3,na) .gt. 0 ) goto 20
+c
+c existe-t-il 2 triangles ayant cette arete commune?
+ if( nosoar(4,na) .le. 0 .or. nosoar(5,na) .le. 0 ) goto 20
+c
+c aucun des 2 triangles est-il desactive?
+ if( noartr(1,nosoar(4,na)) .eq. 0 .or.
+ % noartr(1,nosoar(5,na)) .eq. 0 ) goto 20
+c
+c l'arete appartient a deux triangles actifs
+c le numero des 4 sommets du quadrangle des 2 triangles
+ call mt4sqa( na, moartr, noartr, mosoar, nosoar,
+ % ns1, ns2, ns3, ns4 )
+ if( ns4 .eq. 0 ) goto 20
+c
+c carre de la longueur de l'arete ns1 ns2
+ a12 = (pxyd(1,ns2)-pxyd(1,ns1))**2+(pxyd(2,ns2)-pxyd(2,ns1))**2
+c
+c comparaison de la somme des aires des 2 triangles
+c -------------------------------------------------
+c calcul des surfaces des triangles 123 et 142 de cette arete
+ s123=surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
+ s142=surtd2( pxyd(1,ns1), pxyd(1,ns4), pxyd(1,ns2) )
+ s12 = abs( s123 ) + abs( s142 )
+ if( s12 .le. 0.001*a12 ) goto 20
+c
+c calcul des surfaces des triangles 143 et 234 de cette arete
+ s143=surtd2( pxyd(1,ns1), pxyd(1,ns4), pxyd(1,ns3) )
+ s234=surtd2( pxyd(1,ns2), pxyd(1,ns3), pxyd(1,ns4) )
+ s34 = abs( s234 ) + abs( s143 )
+c
+ if( abs(s34-s12) .gt. 1d-15*s34 ) goto 20
+c
+c quadrangle convexe : le critere de delaunay intervient
+c ------------------ ---------------------------------
+c calcul du centre et rayon de la boule circonscrite a 123
+c pas d'affichage si le triangle est degenere
+ ierr = -1
+ call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), cetria,
+ % ierr )
+ if( ierr .gt. 0 ) then
+c ierr=1 si triangle degenere => abandon
+ goto 20
+ endif
+c
+ if( (cetria(1)-pxyd(1,ns4))**2+(cetria(2)-pxyd(2,ns4))**2
+ % .lt. cetria(3) ) then
+c
+c protection contre une boucle infinie sur le meme cercle
+ if( r0 .eq. cetria(3) ) goto 20
+c
+c oui: ns4 est dans le cercle circonscrit a ns1 ns2 ns3
+c => ns3 est aussi dans le cercle circonscrit de ns1 ns2 ns4
+c
+cccc les 2 triangles d'arete na sont effaces
+ccc do 25 j=4,5
+ccc nt = nosoar(j,na)
+cccc trace du triangle nt
+ccc call mttrtr( pxyd, nt, moartr, noartr, mosoar, nosoar,
+ccc % ncnoir, ncjaun )
+ccc 25 continue
+c
+c echange de la diagonale 12 par 34 des 2 triangles
+ call te2t2t( na, mosoar, n1soar, nosoar, noarst,
+ % moartr, noartr, na34 )
+ if( na34 .eq. 0 ) goto 20
+ r0 = cetria(3)
+c
+c l'arete na34 est marquee traitee
+ nosoar(lchain,na34) = -1
+ modifs = modifs + 1
+c
+c les aretes internes peripheriques des 2 triangles sont enchainees
+ do 60 j=4,5
+ nt = nosoar(j,na34)
+cccc trace du triangle nt
+ccc call mttrtr( pxyd, nt, moartr, noartr, mosoar, nosoar,
+ccc % ncoran, ncgric )
+ do 50 i=1,3
+ n = abs( noartr(i,nt) )
+ if( n .ne. na34 ) then
+ if( nosoar(3,n) .eq. 0 .and.
+ % nosoar(lchain,n) .eq. -1 ) then
+c cette arete marquee est chainee pour etre traitee
+ nosoar(lchain,n) = na0
+ na0 = n
+ endif
+ endif
+ 50 continue
+ 60 continue
+ goto 20
+ endif
+c
+c retour en haut de la pile des aretes a traiter
+ goto 20
+ endif
+ end
+
+
+ subroutine terefr( nbarpi, pxyd,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr, noarst,
+ % mxarcf, n1arcf, noarcf, larmin, notrcf,
+ % nbarpe, ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : recherche des aretes de la frontiere non dans la triangulation
+c ----- triangulation frontale pour les reobtenir
+c
+c attention: le chainage lchain de nosoar devient celui des cf
+c
+c entrees:
+c --------
+c le tableau nosoar
+c nbarpi : numero du dernier point interne impose par l'utilisateur
+c pxyd : tableau des coordonnees 2d des points
+c par point : x y distance_souhaitee
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c attention: mxsoar>3*mxsomm obligatoire!
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
+c
+c modifies:
+c ---------
+c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
+c chainage des vides suivant en 3 et precedant en 2 de nosoar
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = nosoar(1)+nosoar(2)*2
+c avec mxsoar>=3*mxsomm
+c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
+c nosoar(2,arete vide)=l'arete vide qui precede
+c nosoar(3,arete vide)=l'arete vide qui suit
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c noarst : noarst(i) numero d'une arete de sommet i
+c
+c
+c auxiliaires :
+c -------------
+c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
+c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
+c larmin : tableau (mxarcf) auxiliaire d'entiers
+c notrcf : tableau (mxarcf) auxiliaire d'entiers
+c
+c sortie :
+c --------
+c nbarpe : nombre d'aretes perdues puis retrouvees
+c ierr : =0 si pas d'erreur
+c >0 si une erreur est survenue
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+ parameter (lchain=6)
+ common / unites / lecteu,imprim,intera,nunite(29)
+ double precision pxyd(3,*)
+ integer nosoar(mosoar,mxsoar),
+ % noartr(moartr,*),
+ % noarst(*),
+ % n1arcf(0:mxarcf),
+ % noarcf(3,mxarcf),
+ % larmin(mxarcf),
+ % notrcf(mxarcf)
+c
+c le nombre d'aretes de la frontiere non arete de la triangulation
+ nbarpe = 0
+c
+c initialisation du chainage des aretes des cf => 0 arete de cf
+ do 10 narete=1,mxsoar
+ nosoar( lchain, narete) = -1
+ 10 continue
+c
+c boucle sur l'ensemble des aretes actuelles
+c ==========================================
+ do 30 narete=1,mxsoar
+c
+ if( nosoar(3,narete) .gt. 0 ) then
+c arete appartenant a une ligne => frontaliere
+c
+ if(nosoar(4,narete) .le. 0 .or. nosoar(5,narete) .le. 0)then
+c l'arete narete frontaliere n'appartient pas a 2 triangles
+c => elle est perdue
+ nbarpe = nbarpe + 1
+c
+c le numero des 2 sommets de l'arete frontaliere perdue
+ ns1 = nosoar( 1, narete )
+ ns2 = nosoar( 2, narete )
+c write(imprim,10000) ns1,(pxyd(j,ns1),j=1,2),
+c % ns2,(pxyd(j,ns2),j=1,2)
+10000 format(' arete perdue a forcer',
+ % (t24,'sommet=',i6,' x=',g13.5,' y=',g13.5))
+c
+c traitement de cette arete perdue ns1-ns2
+ call tefoar( narete, nbarpi, pxyd,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr, noarst,
+ % mxarcf, n1arcf, noarcf, larmin, notrcf,
+ % ierr )
+ if( ierr .ne. 0 ) return
+c
+c fin du traitement de cette arete perdue et retrouvee
+ endif
+ endif
+c
+ 30 continue
+ end
+
+
+ subroutine tesuex( nblftr, nulftr,
+ % ndtri0, nbsomm, pxyd, nslign,
+ % mosoar, mxsoar, nosoar,
+ % moartr, mxartr, n1artr, noartr, noarst,
+ % nbtria, letrsu, ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : supprimer du tableau noartr les triangles externes au domaine
+c ----- en annulant le numero de leur 1-ere arete dans noartr
+c et en les chainant comme triangles vides
+c
+c entrees:
+c --------
+c nblftr : nombre de lignes fermees definissant la surface
+c nulftr : numero des lignes fermees definissant la surface
+c ndtri0 : plus grand numero dans noartr d'un triangle
+c pxyd : tableau des coordonnees 2d des points
+c par point : x y distance_souhaitee
+c nslign : tableau du numero de sommet dans sa ligne pour chaque
+c sommet frontalier
+c numero du point dans le lexique point si interne impose
+c 0 si le point est interne non impose par l'utilisateur
+c -1 si le sommet est externe au domaine
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c attention: mxsoar>3*mxsomm obligatoire!
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = nosoar(1)+nosoar(2)*2
+c avec mxsoar>=3*mxsomm
+c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
+c nosoar(2,arete vide)=l'arete vide qui precede
+c nosoar(3,arete vide)=l'arete vide qui suit
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxartr : nombre maximal de triangles declarables
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c noarst : noarst(i) numero nosoar d'une arete de sommet i
+c
+c sorties:
+c --------
+c nbtria : nombre de triangles internes au domaine
+c letrsu : letrsu(nt)=numero du triangle interne, 0 sinon
+c noarst : noarst(i) numero nosoar d'une arete du sommet i (modifi'e)
+c ierr : 0 si pas d'erreur, >0 sinon
+cc++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mai 1999
+c2345x7..............................................................012
+ double precision pxyd(3,*)
+ integer nulftr(nblftr),nslign(nbsomm),
+ % nosoar(mosoar,mxsoar),
+ % noartr(moartr,mxartr),
+ % noarst(*)
+ integer letrsu(1:ndtri0)
+ double precision dmin
+c
+c les triangles sont a priori non marques
+ do 5 nt=1,ndtri0
+ letrsu(nt) = 0
+ 5 continue
+c
+c les aretes sont marquees non chainees
+ do 10 noar1=1,mxsoar
+ nosoar(6,noar1) = -2
+ 10 continue
+c
+c recherche du sommet de la triangulation de plus petite abscisse
+c ===============================================================
+ ntmin = 0
+ dmin = 1d38
+ do 20 i=1,nbsomm
+ if( pxyd(1,i) .lt. dmin ) then
+c le nouveau minimum
+ noar1 = noarst(i)
+ if( noar1 .gt. 0 ) then
+c le sommet appartient a une arete de triangle
+ if( nosoar(4,noar1) .gt. 0 ) then
+c le nouveau minimum
+ dmin = pxyd(1,i)
+ ntmin = i
+ endif
+ endif
+ endif
+ 20 continue
+c
+c une arete de sommet ntmin
+ noar1 = noarst( ntmin )
+c un triangle d'arete noar1
+ ntmin = nosoar( 4, noar1 )
+ if( ntmin .le. 0 ) then
+c nblgrc(nrerr) = 1
+c kerr(1) = 'pas de triangle d''abscisse minimale'
+c call lereur
+ write(imprim,*) 'pas de triangle d''abscisse minimale'
+ ierr = 2
+ goto 9990
+ endif
+c
+c chainage des 3 aretes du triangle ntmin
+c =======================================
+c la premiere arete du chainage des aretes traitees
+ noar1 = abs( noartr(1,ntmin) )
+ na0 = abs( noartr(2,ntmin) )
+c elle est chainee sur la seconde arete du triangle ntmin
+ nosoar(6,noar1) = na0
+c les 2 autres aretes du triangle ntmin sont chainees
+ na1 = abs( noartr(3,ntmin) )
+c la seconde est chainee sur la troisieme arete
+ nosoar(6,na0) = na1
+c la troisieme n'a pas de suivante
+ nosoar(6,na1) = 0
+c
+c le triangle ntmin est a l'exterieur du domaine
+c tous les triangles externes sont marques -123 456 789
+c les triangles de l'autre cote d'une arete sur une ligne
+c sont marques: no de la ligne de l'arete * signe oppose
+c =======================================================
+ ligne0 = 0
+ ligne = -123 456 789
+c
+ 40 if( noar1 .ne. 0 ) then
+c
+c l'arete noar1 du tableau nosoar est a traiter
+c ---------------------------------------------
+ noar = noar1
+c l'arete suivante devient la premiere a traiter ensuite
+ noar1 = nosoar(6,noar1)
+c l'arete noar est traitee
+ nosoar(6,noar) = -3
+c
+ do 60 i=4,5
+c
+c l'un des 2 triangles de l'arete
+ nt = nosoar(i,noar)
+ if( nt .gt. 0 ) then
+c
+c triangle deja traite pour une ligne anterieure?
+ if( letrsu(nt) .ne. 0 .and.
+ % abs(letrsu(nt)) .ne. ligne ) goto 60
+c
+cccc trace du triangle nt en couleur ligne0
+ccc call mttrtr( pxyd, nt, moartr, noartr, mosoar, nosoar,
+ccc % ligne0, ncnoir )
+c
+c le triangle est marque avec la valeur de ligne
+ letrsu(nt) = ligne
+c
+c chainage eventuel des autres aretes de ce triangle
+c si ce n'est pas encore fait
+ do 50 j=1,3
+c
+c le numero na de l'arete j du triangle nt dans nosoar
+ na = abs( noartr(j,nt) )
+ if( nosoar(6,na) .ne. -2 ) goto 50
+c
+c le numero de 1 a nblftr dans nulftr de la ligne de l'arete
+ nl = nosoar(3,na)
+c
+c si l'arete est sur une ligne fermee differente de celle envelo
+c et non marquee alors examen du triangle oppose
+ if( nl .gt. 0 ) then
+c
+ if( nl .eq. ligne0 ) goto 50
+c
+c arete frontaliere de ligne non traitee
+c => passage de l'autre cote de la ligne
+c le triangle de l'autre cote de la ligne est recherche
+ if( nt .eq. abs( nosoar(4,na) ) ) then
+ nt2 = 5
+ else
+ nt2 = 4
+ endif
+ nt2 = abs( nosoar(nt2,na) )
+ if( nt2 .gt. 0 ) then
+c
+c le triangle nt2 de l'autre cote est marque avec le
+c avec le signe oppose de celui de ligne
+ if( ligne .ge. 0 ) then
+ lsigne = -1
+ else
+ lsigne = 1
+ endif
+ letrsu(nt2) = lsigne * nl
+c
+c temoin de ligne a traiter ensuite dans nulftr
+ nulftr(nl) = -abs( nulftr(nl) )
+c
+cccc trace du triangle nt2 en jaune borde de magenta
+ccc call mttrtr( pxyd,nt2,
+ccc % moartr,noartr,mosoar,nosoar,
+ccc % ncjaun, ncmage )
+c
+c l'arete est traitee
+ nosoar(6,na) = -3
+c
+ endif
+c
+c l'arete est traitee
+ goto 50
+c
+ endif
+c
+c arete non traitee => elle est chainee
+ nosoar(6,na) = noar1
+ noar1 = na
+c
+ 50 continue
+c
+ endif
+ 60 continue
+c
+ goto 40
+ endif
+c les triangles de la ligne fermee ont tous ete marques
+c plus d'arete chainee
+c
+c recherche d'une nouvelle ligne fermee a traiter
+c ===============================================
+ 65 do 70 nl=1,nblftr
+ if( nulftr(nl) .lt. 0 ) goto 80
+ 70 continue
+c plus de ligne fermee a traiter
+ goto 110
+c
+c tous les triangles de cette composante connexe
+c entre ligne et ligne0 vont etre marques
+c ==============================================
+c remise en etat du numero de ligne
+c nl est le numero de la ligne dans nulftr a traiter
+ 80 nulftr(nl) = -nulftr(nl)
+ do 90 nt2=1,ndtri0
+ if( abs(letrsu(nt2)) .eq. nl ) goto 92
+ 90 continue
+c
+c recherche de l'arete j du triangle nt2 avec ce numero de ligne nl
+ 92 do 95 j=1,3
+c
+c le numero de l'arete j du triangle dans nosoar
+ noar1 = 0
+ na0 = abs( noartr(j,nt2) )
+ if( nl .eq. nosoar(3,na0) ) then
+c
+c na0 est l'arete de ligne nl
+c l'arete suivante du triangle nt2
+ i = mod(j,3) + 1
+c le numero dans nosoar de l'arete i de nt2
+ na1 = abs( noartr(i,nt2) )
+ if( nosoar(6,na1) .eq. -2 ) then
+c arete non traitee => elle est la premiere du chainage
+ noar1 = na1
+c pas de suivante dans ce chainage
+ nosoar(6,na1) = 0
+ else
+ na1 = 0
+ endif
+c
+c l'eventuelle seconde arete suivante
+ i = mod(i,3) + 1
+ na = abs( noartr(i,nt2) )
+ if( nosoar(6,na) .eq. -2 ) then
+ if( na1 .eq. 0 ) then
+c 1 arete non traitee et seule a chainer
+ noar1 = na
+ nosoar(6,na) = 0
+ else
+c 2 aretes a chainer
+ noar1 = na
+ nosoar(6,na) = na1
+ endif
+ endif
+c
+ if( noar1 .gt. 0 ) then
+c
+c il existe au moins une arete a visiter pour ligne
+c marquage des triangles internes a la ligne nl
+ ligne = letrsu(nt2)
+ ligne0 = nl
+ goto 40
+c
+ else
+c
+c nt2 est le seul triangle de la ligne fermee
+ goto 65
+c
+ endif
+ endif
+ 95 continue
+c
+c reperage des sommets internes ou externes dans nslign
+c nslign(sommet externe au domaine)=-1
+c nslign(sommet interne au domaine)= 0
+c =====================================================
+ 110 do 170 ns1=1,nbsomm
+c tout sommet non sur la frontiere ou interne impose
+c est suppose externe
+ if( nslign(ns1) .eq. 0 ) nslign(ns1) = -1
+ 170 continue
+c
+c les triangles externes sont marques vides dans le tableau noartr
+c ================================================================
+ nbtria = 0
+ do 200 nt=1,ndtri0
+c
+ if( letrsu(nt) .le. 0 ) then
+c
+c triangle nt externe
+ if( noartr(1,nt) .ne. 0 ) then
+c la premiere arete est annulee
+ noartr(1,nt) = 0
+c le triangle nt est considere comme etant vide
+ noartr(2,nt) = n1artr
+ n1artr = nt
+ endif
+c
+ else
+c
+c triangle nt interne
+ nbtria = nbtria + 1
+ letrsu(nt) = nbtria
+c
+c marquage des 3 sommets du triangle nt
+ do 190 i=1,3
+c le numero nosoar de l'arete i du triangle nt
+ noar = abs( noartr(i,nt) )
+c le numero des 2 sommets
+ ns1 = nosoar(1,noar)
+ ns2 = nosoar(2,noar)
+c mise a jour du numero d'une arete des 2 sommets de l'arete
+ noarst( ns1 ) = noar
+ noarst( ns2 ) = noar
+c ns1 et ns2 sont des sommets de la triangulation du domaine
+ if( nslign(ns1) .lt. 0 ) nslign(ns1)=0
+ if( nslign(ns2) .lt. 0 ) nslign(ns2)=0
+ 190 continue
+c
+ endif
+c
+ 200 continue
+c ici tout sommet externe ns verifie nslign(ns)=-1
+c
+c les triangles externes sont mis a zero dans nosoar
+c ==================================================
+ do 300 noar=1,mxsoar
+c
+ if( nosoar(1,noar) .gt. 0 ) then
+c
+c le second triangle de l'arete noar
+ nt = nosoar(5,noar)
+ if( nt .gt. 0 ) then
+c si le triangle nt est externe
+c alors il est supprime pour l'arete noar
+ if( letrsu(nt) .le. 0 ) nosoar(5,noar)=0
+ endif
+c
+c le premier triangle de l'arete noar
+ nt = nosoar(4,noar)
+ if( nt .gt. 0 ) then
+ if( letrsu(nt) .le. 0 ) then
+c si le triangle nt est externe
+c alors il est supprime pour l'arete noar
+c et l'eventuel triangle oppose prend sa place
+c en position 4 de nosoar
+ if( nosoar(5,noar) .gt. 0 ) then
+ nosoar(4,noar)=nosoar(5,noar)
+ nosoar(5,noar)=0
+ else
+ nosoar(4,noar)=0
+ endif
+ endif
+ endif
+ endif
+c
+ 300 continue
+c
+c remise en etat pour eviter les modifications de ladefi
+ 9990 do 9991 nl=1,nblftr
+ if( nulftr(nl) .lt. 0 ) nulftr(nl)=-nulftr(nl)
+ 9991 continue
+ return
+ end
+
+
+
+ subroutine trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
+ % mxpile, lhpile, lapile )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : recherche des triangles de noartr partageant le sommet ns
+c -----
+c limite: un camembert de centre ns entame 2 fois
+c ne donne que l'une des parties
+c
+c entrees:
+c --------
+c ns : numero du sommet
+c noarst : noarst(i) numero d'une arete de sommet i
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c mxpile : nombre maximal de triangles empilables
+c
+c sorties :
+c --------
+c lhpile : >0 nombre de triangles empiles
+c =0 si impossible de tourner autour du point
+c =-lhpile si apres butee sur la frontiere il y a a nouveau
+c butee sur la frontiere . a ce stade on ne peut dire si tous
+c les triangles ayant ce sommet ont ete recenses
+c ce cas arrive seulement si le sommet est sur la frontiere
+c lapile : numero dans noartr des triangles de sommet ns
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+ common / unites / lecteu, imprim, nunite(30)
+ integer noartr(moartr,*),
+ % nosoar(mosoar,*),
+ % noarst(*)
+ integer lapile(1:mxpile)
+ integer nosotr(3)
+c
+c la premiere arete de sommet ns
+ nar = noarst( ns )
+ if( nar .le. 0 ) then
+ write(imprim,*) 'trp1st: sommet',ns,' sans arete'
+ goto 9999
+ endif
+c
+c l'arete nar est elle active?
+ if( nosoar(1,nar) .le. 0 ) then
+ccc write(imprim,*) 'trp1st: arete vide',nar,
+ccc % ' st1:', nosoar(1,nar),' st2:',nosoar(2,nar)
+ goto 9999
+ endif
+c
+c le premier triangle de sommet ns
+ nt0 = abs( nosoar(4,nar) )
+ if( nt0 .le. 0 ) then
+ write(imprim,*) 'trp1st: sommet',ns,' dans aucun triangle'
+ goto 9999
+ endif
+c
+c le triangle est il interne?
+ if( noartr(1,nt0) .eq. 0 ) goto 9999
+c
+c le numero des 3 sommets du triangle nt0 dans le sens direct
+ call nusotr( nt0, mosoar, nosoar, moartr, noartr, nosotr )
+c
+c reperage du sommet ns dans le triangle nt0
+ do 5 nar=1,3
+ if( nosotr(nar) .eq. ns ) goto 10
+ 5 continue
+ nta = nt0
+ goto 9995
+c
+c ns retrouve : le triangle nt0 est empile
+ 10 lhpile = 1
+ lapile(1) = nt0
+ nta = nt0
+c
+c recherche dans le sens des aiguilles d'une montre
+c (sens indirect) du triangle nt1 de l'autre cote de l'arete
+c nar du triangle et en tournant autour du sommet ns
+c ==========================================================
+ noar = abs( noartr(nar,nt0) )
+c le triangle nt1 oppose du triangle nt0 par l'arete noar
+ if( nosoar(4,noar) .eq. nt0 ) then
+ nt1 = nosoar(5,noar)
+ else
+ nt1 = nosoar(4,noar)
+ endif
+c
+c la boucle sur les triangles nt1 de sommet ns dans le sens indirect
+c ==================================================================
+ if( nt1 .gt. 0 ) then
+c
+ if( noartr(1,nt1) .eq. 0 ) goto 30
+c
+c le triangle nt1 n'a pas ete detruit. il est actif
+c le triangle oppose par l'arete noar existe
+c le numero des 3 sommets du triangle nt1 dans le sens direct
+ 15 call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
+c
+c reperage du sommet ns dans nt1
+ do 20 nar=1,3
+ if( nosotr(nar) .eq. ns ) goto 25
+ 20 continue
+ nta = nt1
+ goto 9995
+c
+c nt1 est empile
+ 25 if( lhpile .ge. mxpile ) goto 9990
+ lhpile = lhpile + 1
+ lapile(lhpile) = nt1
+c
+c le triangle nt1 de l'autre cote de l'arete de sommet ns
+c sauvegarde du precedent triangle dans nta
+ nta = nt1
+ noar = abs( noartr(nar,nt1) )
+ if( nosoar(4,noar) .eq. nt1 ) then
+ nt1 = nosoar(5,noar)
+ else
+ nt1 = nosoar(4,noar)
+ endif
+ if( nt1 .le. 0 ) goto 30
+c le triangle suivant est a l'exterieur
+ if( nt1 .ne. nt0 ) goto 15
+c
+c recherche terminee par arrivee sur nt0
+c les triangles forment un "cercle" de "centre" ns
+ return
+c
+ endif
+c
+c pas de triangle voisin a nt1
+c ============================
+c le parcours passe par 1 des triangles exterieurs
+c le parcours est inverse par l'arete de gauche
+c le triangle nta est le premier triangle empile
+ 30 lhpile = 1
+ lapile(lhpile) = nta
+c
+c le numero des 3 sommets du triangle nta dans le sens direct
+ call nusotr( nta, mosoar, nosoar, moartr, noartr, nosotr )
+ do 32 nar=1,3
+ if( nosotr(nar) .eq. ns ) goto 33
+ 32 continue
+ goto 9995
+c
+c l'arete qui precede (rotation / ns dans le sens direct)
+ 33 if( nar .eq. 1 ) then
+ nar = 3
+ else
+ nar = nar - 1
+ endif
+c
+c le triangle voisin de nta dans le sens direct
+ noar = abs( noartr(nar,nta) )
+ if( nosoar(4,noar) .eq. nta ) then
+ nt1 = nosoar(5,noar)
+ else
+ nt1 = nosoar(4,noar)
+ endif
+ if( nt1 .le. 0 ) then
+c un seul triangle contient ns
+ goto 70
+ endif
+c
+c boucle sur les triangles de sommet ns dans le sens direct
+c ==========================================================
+ 40 if( noartr(1,nt1) .eq. 0 ) goto 70
+c
+c le triangle nt1 n'a pas ete detruit. il est actif
+c le numero des 3 sommets du triangle nt1 dans le sens direct
+ call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
+c
+c reperage du sommet ns dans nt1
+ do 50 nar=1,3
+ if( nosotr(nar) .eq. ns ) goto 60
+ 50 continue
+ nta = nt1
+ goto 9995
+c
+c nt1 est empile
+ 60 if( lhpile .ge. mxpile ) goto 9990
+ lhpile = lhpile + 1
+ lapile(lhpile) = nt1
+c
+c l'arete qui precede dans le sens direct
+ if( nar .eq. 1 ) then
+ nar = 3
+ else
+ nar = nar - 1
+ endif
+c
+c l'arete de sommet ns dans nosoar
+ noar = abs( noartr(nar,nt1) )
+c
+c le triangle voisin de nta dans le sens direct
+ nta = nt1
+ if( nosoar(4,noar) .eq. nt1 ) then
+ nt1 = nosoar(5,noar)
+ else
+ nt1 = nosoar(4,noar)
+ endif
+ nta = nt1
+ if( nt1 .gt. 0 ) goto 40
+c
+c butee sur le trou => fin des triangles de sommet ns
+c ----------------------------------------------------
+ 70 lhpile = -lhpile
+c impossible ici de trouver les autres triangles de sommet ns
+c les triangles de sommet ns ne forment pas une boule de centre ns
+ return
+c
+c saturation de la pile des triangles
+c -----------------------------------
+ 9990 write(imprim,*) 'trp1st:saturation pile des triangles autour ',
+ %'sommet',ns
+ goto 9999
+c
+c erreur triangle ne contenant pas le sommet ns
+c ----------------------------------------------
+ 9995 write(imprim,*) 'trp1st:triangle ',nta,' st=',
+ % (nosotr(nar),nar=1,3),' sans le sommet' ,ns
+c
+ 9999 lhpile = 0
+ return
+ end
+
+
+
+ subroutine nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : calcul du numero des 3 sommets du triangle nt de noartr
+c ----- dans le sens direct (aire>0 si non degenere)
+c
+c entrees:
+c --------
+c nt : numero du triangle dans le tableau noartr
+c mosoar : nombre maximal d'entiers par arete
+c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
+c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1=0 si triangle vide => arete2=triangle vide suivant
+c
+c sorties:
+c --------
+c nosotr : numero (dans le tableau pxyd) des 3 sommets du triangle
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c2345x7..............................................................012
+ integer nosoar(mosoar,*), noartr(moartr,*), nosotr(3)
+c
+c les 2 sommets de l'arete 1 du triangle nt dans le sens direct
+ na = noartr( 1, nt )
+ if( na .gt. 0 ) then
+ nosotr(1) = 1
+ nosotr(2) = 2
+ else
+ nosotr(1) = 2
+ nosotr(2) = 1
+ na = -na
+ endif
+ nosotr(1) = nosoar( nosotr(1), na )
+ nosotr(2) = nosoar( nosotr(2), na )
+c
+c l'arete suivante
+ na = abs( noartr(2,nt) )
+c
+c le sommet nosotr(3 du triangle 123
+ nosotr(3) = nosoar( 1, na )
+ if( nosotr(3) .eq. nosotr(1) .or. nosotr(3) .eq. nosotr(2) ) then
+ nosotr(3) = nosoar(2,na)
+ endif
+ end
+
+
+ subroutine tesusp( nbarpi, pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % mxarcf, n1arcf, noarcf, larmin, notrcf, liarcf,
+ % nbstsu, ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : supprimer de la triangulation les sommets de te trop proches
+c ----- soit d'un sommet frontalier ou point interne impose
+c soit d'une arete frontaliere
+c
+c attention: le chainage lchain de nosoar devient celui des cf
+c
+c entrees:
+c --------
+c nbarpi : numero du dernier point interne impose par l'utilisateur
+c pxyd : tableau des coordonnees 2d des points
+c par point : x y distance_souhaitee
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c attention: mxsoar>3*mxsomm obligatoire!
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
+c
+c modifies:
+c ---------
+c noarst : noarst(i) numero d'une arete de sommet i
+c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
+c chainage des vides suivant en 3 et precedant en 2 de nosoar
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = nosoar(1)+nosoar(2)*2
+c avec mxsoar>=3*mxsomm
+c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
+c nosoar(2,arete vide)=l'arete vide qui precede
+c nosoar(3,arete vide)=l'arete vide qui suit
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c
+c
+c auxiliaires :
+c -------------
+c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
+c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
+c larmin : tableau ( mxarcf ) auxiliaire d'entiers
+c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
+c liarcf : tableau ( mxarcf ) auxiliaire d'entiers
+c
+c sortie :
+c --------
+c nbstsu : nombre de sommets de te supprimes
+c ierr : =0 si pas d'erreur
+c >0 si une erreur est survenue
+c 11 algorithme defaillant
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+c parameter ( quamal=0.3 ) => ok
+c parameter ( quamal=0.4 ) => pb pour le test ocean
+c parameter ( quamal=0.5 ) => pb pour le test ocean
+c
+ parameter ( quamal=0.333, lchain=6 )
+ common / unites / lecteu,imprim,intera,nunite(29)
+ double precision pxyd(3,*), qualit
+ integer nosoar(mosoar,mxsoar),
+ % noartr(moartr,*),
+ % noarst(*),
+ % n1arcf(0:mxarcf),
+ % noarcf(3,mxarcf),
+ % larmin(mxarcf),
+ % notrcf(mxarcf),
+ % liarcf(mxarcf)
+c
+ integer nosotr(3)
+ equivalence (nosotr(1),ns1), (nosotr(2),ns2),
+ % (nosotr(3),ns3)
+c
+c le nombre de sommets de te supprimes
+ nbstsu = 0
+c
+c initialisation du chainage des aretes des cf => 0 arete de cf
+ do 10 narete=1,mxsoar
+ nosoar( lchain, narete ) = -1
+ 10 continue
+c
+c boucle sur l'ensemble des sommets frontaliers ou points internes
+c ================================================================
+ do 100 ns = 1, nbarpi
+c
+cccc le nombre de sommets supprimes pour ce sommet ns
+ccc nbsuns = 0
+c
+c la qualite minimale au dessous de laquelle le point proche
+c interne est supprime
+ quaopt = quamal
+c
+c une arete de sommet ns
+ 15 narete = noarst( ns )
+ if( narete .le. 0 ) then
+c erreur: le point appartient a aucune arete
+ write(imprim,*) 'sommet ',ns,' dans aucune arete'
+ pause
+ ierr = 11
+ return
+ endif
+c
+c recherche des triangles de sommet ns
+c ils doivent former un contour ferme de type etoile
+ call trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
+ % mxarcf, nbtrcf, notrcf )
+ if( nbtrcf .le. 0 ) then
+c erreur: impossible de trouver tous les triangles de sommet ns
+c seule une partie est a priori retrouvee
+ nbtrcf = -nbtrcf
+ endif
+c
+c boucle sur les triangles de l'etoile du sommet ns
+ quamin = 2.0
+ do 20 i=1,nbtrcf
+c
+c le numero des 3 sommets du triangle nt
+ nt = notrcf(i)
+ call nusotr( nt, mosoar, nosoar, moartr, noartr,
+ % nosotr )
+c nosotr(1:3) est en equivalence avec ns1, ns2, ns3
+c
+c la qualite du triangle ns1 ns2 ns3
+ call qutr2d( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), qualit )
+ if( qualit .lt. quamin ) then
+ quamin = qualit
+ ntqmin = nt
+ endif
+ 20 continue
+c
+c bilan sur la qualite des triangles de sommet ns
+ if( quamin .lt. quaopt ) then
+c
+c recherche du sommet de ntqmin le plus proche et non frontalier
+c ==============================================================
+c le numero des 3 sommets du triangle nt
+ call nusotr( ntqmin, mosoar, nosoar, moartr, noartr,
+ % nosotr )
+ nste = 0
+ quamin = 1e28
+ do 30 j=1,3
+ if( nosotr(j) .ne. ns .and. nosotr(j) .gt. nbarpi ) then
+ d = (pxyd(1,nosotr(j))-pxyd(1,ns))**2
+ % + (pxyd(2,nosotr(j))-pxyd(2,ns))**2
+ if( d .lt. quamin ) then
+ quamin = d
+ nste = j
+ endif
+ endif
+ 30 continue
+c
+ if( nste .gt. 0 ) then
+c
+c nste est le sommet le plus proche de ns de ce
+c triangle de mauvaise qualite et sommet non encore traite
+ nste = nosotr( nste )
+c
+c nste est un sommet de triangle equilateral
+c => le sommet nste va etre supprime
+c ==========================================
+ call te1stm( nste, pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % mxarcf, n1arcf, noarcf,
+ % larmin, notrcf, liarcf, ierr )
+ if( ierr .eq. 0 ) then
+c un sommet de te supprime de plus
+ nbstsu = nbstsu + 1
+ else if( ierr .lt. 0 ) then
+c le sommet nste est externe donc non supprime
+c ou bien le sommet nste est le centre d'un cf dont toutes
+c les aretes simples sont frontalieres
+c dans les 2 cas le sommet n'est pas supprime
+ ierr = 0
+ goto 100
+ else
+c erreur motivant un arret de la triangulation
+ return
+ endif
+c
+c boucle jusqu'a obtenir une qualite suffisante
+c si triangulation tres irreguliere =>
+c destruction de beaucoup de points internes
+c les 2 variables suivantes brident ces destructions massives
+ccc nbsuns = nbsuns + 1
+ quaopt = quaopt * 0.8
+ccc if( nbsuns .le. 5 ) goto 15
+ goto 15
+ endif
+ endif
+c
+ 100 continue
+ end
+
+
+ subroutine teamqa( nutysu,
+ % noarst, mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % mxtrcf, notrcf, nostbo,
+ % n1arcf, noarcf, larmin,
+ % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
+ % ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but: si la taille de l'arete moyenne est >ampli*taille souhaitee
+c ---- alors ajout d'un sommet barycentre du plus grand triangle
+c de sommet ns
+c si la taille de l'arete moyenne est <ampli/2*taille souhaitee
+c alors suppression du sommet ns
+c sinon le sommet ns devient le barycentre pondere de ses voisins
+c
+c remarque: ampli est defini dans $mefisto/mail/tehote.f
+c et doit avoir la meme valeur pour eviter trop de modifications
+c
+c entrees:
+c --------
+c nutysu : numero de traitement de areteideale() selon le type de surface
+c 0 pas d'emploi de la fonction areteideale() => aretmx active
+c 1 il existe une fonction areteideale()
+c dont seules les 2 premieres composantes de uv sont actives
+c autres options a definir...
+c noarst : noarst(i) numero d'une arete de sommet i
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes frontalieres declarables
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxartr : nombre maximal de triangles declarables dans noartr
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c mxtrcf : nombre maximal de triangles empilables
+c nbarpi : numero du dernier sommet frontalier ou interne impose
+c nslign : tableau du numero de sommet dans sa ligne pour chaque
+c sommet frontalier
+c numero du point dans le lexique point si interne impose
+c 0 si le point est interne non impose par l'utilisateur
+c -1 si le sommet est externe au domaine
+c comxmi : min et max des coordonneees des sommets du maillage
+c
+c modifies :
+c ----------
+c nbsomm : nombre actuel de sommets de la triangulation
+c (certains sommets internes ont ete desactives ou ajoutes)
+c pxyd : tableau des coordonnees 2d des points
+c
+c auxiliaires:
+c ------------
+c notrcf : tableau ( mxtrcf ) auxiliaire d'entiers
+c numero dans noartr des triangles de sommet ns
+c nostbo : tableau ( mxtrcf ) auxiliaire d'entiers
+c numero dans pxyd des sommets des aretes simples de la boule
+c n1arcf : tableau (0:mxtrcf) auxiliaire d'entiers
+c noarcf : tableau (3,mxtrcf) auxiliaire d'entiers
+c larmin : tableau ( mxtrcf ) auxiliaire d'entiers
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc juin 1997
+c....................................................................012
+ double precision ampli,ampli2
+ parameter (ampli=1.34d0,ampli2=ampli/2d0)
+ parameter (lchain=6)
+ common / unites / lecteu, imprim, nunite(30)
+ double precision pxyd(3,*)
+ double precision ponder, ponde1, xbar, ybar, x, y, surtd2
+ double precision d, dmoy
+ double precision d2d3(3,3)
+ real origin(3), xyz(3)
+ integer noartr(moartr,*),
+ % nosoar(mosoar,*),
+ % noarst(*),
+ % notrcf(mxtrcf),
+ % nslign(*),
+ % nostbo(*),
+ % n1arcf(0:mxtrcf),
+ % noarcf(3,mxtrcf),
+ % larmin(mxtrcf)
+ double precision comxmi(3,2)
+ integer nosotr(3)
+c
+c le nombre d'iterations pour ameliorer la qualite
+ nbitaq = 4
+ ier = 0
+c
+c initialisation du parcours
+ nbs1 = nbsomm
+ nbs2 = nbarpi + 1
+ nbs3 = -1
+c
+ do 5000 iter=1,nbitaq
+c
+c le nombre de sommets supprimes
+ nbstsu = 0
+ nbbaaj = 0
+c
+c coefficient de ponderation croissant avec les iterations
+ ponder = min( 1d0, ( 50 + (50*iter)/nbitaq ) * 0.01d0 )
+ ponde1 = 1d0 - ponder
+c
+c l'ordre du parcours dans le sens croissant ou decroissant
+ nt = nbs1
+ nbs1 = nbs2
+ nbs2 = nt
+c alternance du parcours
+ nbs3 = -nbs3
+c
+ do 1000 ns = nbs1, nbs2, nbs3
+c
+c le sommet est il interne au domaine?
+ if( nslign(ns) .ne. 0 ) goto 1000
+c
+c existe-t-il une arete de sommet ns ?
+ 10 noar = noarst( ns )
+ if( noar .le. 0 ) goto 1000
+c
+c le 1-er triangle de l'arete noar
+ nt = nosoar( 4, noar )
+ if( nt .le. 0 ) goto 1000
+c
+c recherche des triangles de sommet ns
+c ils doivent former un contour ferme de type etoile
+ call trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
+ % mxtrcf, nbtrcf, notrcf )
+ if( nbtrcf .le. 0 ) goto 1000
+c
+c mise a jour de la distance souhaitee
+ if( nutysu .gt. 0 ) then
+c la fonction taille_ideale(x,y,z) existe
+c calcul de pxyzd(3,ns) dans le repere initial => xyz(1:3)
+ call tetaid( nutysu, pxyd(1,ns), pxyd(2,ns),
+ % pxyd(3,ns), ier )
+ endif
+c
+c boucle sur les triangles qui forment une boule autour du sommet ns
+ nbstbo = 0
+c chainage des aretes simples de la boule a rendre delaunay
+ noar0 = 0
+ do 40 i=1,nbtrcf
+c
+c le numero de l'arete du triangle nt ne contenant pas le sommet ns
+ nt = notrcf(i)
+ do 20 na=1,3
+c le numero de l'arete na dans le tableau nosoar
+ noar = abs( noartr(na,nt) )
+ if( nosoar(1,noar) .ne. ns .and.
+ % nosoar(2,noar) .ne. ns ) goto 25
+ 20 continue
+c
+c construction de la liste des sommets des aretes simples
+c de la boule des triangles de sommet ns
+c -------------------------------------------------------
+ 25 do 35 na=1,2
+ ns1 = nosoar(na,noar)
+ do 30 j=nbstbo,1,-1
+ if( ns1 .eq. nostbo(j) ) goto 35
+ 30 continue
+c ns1 est un nouveau sommet a ajouter
+ nbstbo = nbstbo + 1
+ nostbo(nbstbo) = ns1
+ 35 continue
+c
+c noar est une arete potentielle a rendre delaunay
+ if( nosoar(3,noar) .eq. 0 ) then
+c arete non frontaliere
+ nosoar(lchain,noar) = noar0
+ noar0 = noar
+ endif
+c
+ 40 continue
+c
+c calcul des 2 coordonnees du barycentre de la boule du sommet ns
+c calcul de la longueur moyenne des aretes issues du sommet ns
+c ---------------------------------------------------------------
+ xbar = 0d0
+ ybar = 0d0
+ dmoy = 0d0
+ do 50 i=1,nbstbo
+ x = pxyd(1,nostbo(i))
+ y = pxyd(2,nostbo(i))
+ xbar = xbar + x
+ ybar = ybar + y
+ dmoy = dmoy + sqrt( (x-pxyd(1,ns))**2+(y-pxyd(2,ns))**2 )
+ 50 continue
+ dmoy = dmoy / nbstbo
+c
+c pas de modification de la topologie lors de la derniere iteration
+c =================================================================
+ if( iter .eq. nbitaq ) goto 200
+c
+c si la taille de l'arete moyenne est >ampli*taille souhaitee
+c alors ajout d'un sommet barycentre du plus grand triangle
+c de sommet ns
+c ===========================================================
+ if( dmoy .gt. ampli*pxyd(3,ns) ) then
+c
+ dmoy = 0d0
+ do 150 i=1,nbtrcf
+c recherche du plus grand triangle en surface
+ call nusotr( notrcf(i), mosoar, nosoar,
+ % moartr, noartr, nosotr )
+ d = surtd2( pxyd(1,nosotr(1)),
+ % pxyd(1,nosotr(2)),
+ % pxyd(1,nosotr(3)) )
+ if( d .gt. dmoy ) then
+ dmoy = d
+ imax = i
+ endif
+ 150 continue
+c
+c ajout du barycentre du triangle notrcf(imax)
+ nt = notrcf( imax )
+ call nusotr( nt, mosoar, nosoar,
+ % moartr, noartr, nosotr )
+ if( nbsomm .ge. mxsomm ) then
+ write(imprim,*) 'saturation du tableau pxyd'
+c abandon de l'amelioration du sommet ns
+ goto 9999
+ endif
+ nbsomm = nbsomm + 1
+ do 160 i=1,3
+ pxyd(i,nbsomm) = ( pxyd(i,nosotr(1))
+ % + pxyd(i,nosotr(2))
+ % + pxyd(i,nosotr(3)) ) / 3d0
+ 160 continue
+c
+ if( nutysu .gt. 0 ) then
+c la fonction taille_ideale(x,y,z) existe
+c calcul de pxyzd(3,nbsomm) dans le repere initial => xyz(1:3)
+ call tetaid( nutysu, pxyd(1,nbsomm), pxyd(2,nbsomm),
+ % pxyd(3,nbsomm), ier )
+ endif
+c
+c sommet interne a la triangulation
+ nslign(nbsomm) = 0
+c
+c les 3 aretes du triangle nt sont a rendre delaunay
+ do 170 i=1,3
+ noar = abs( noartr(i,nt) )
+ if( nosoar(3,noar) .eq. 0 ) then
+c arete non frontaliere
+ if( nosoar(lchain,noar) .lt. 0 ) then
+c arete non encore chainee
+ nosoar(lchain,noar) = noar0
+ noar0 = noar
+ endif
+ endif
+ 170 continue
+c
+c triangulation du triangle de barycentre nbsomm
+c protection a ne pas modifier sinon erreur!
+ call tr3str( nbsomm, nt,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % noarst,
+ % nosotr, ierr )
+ if( ierr .ne. 0 ) goto 9999
+c
+c un barycentre ajoute de plus
+ nbbaaj = nbbaaj + 1
+c
+c les aretes chainees de la boule sont rendues delaunay
+ goto 900
+c
+ endif
+c
+c si la taille de l'arete moyenne est <ampli/2*taille souhaitee
+c alors suppression du sommet ns
+c =============================================================
+ if( dmoy .lt. ampli2*pxyd(3,ns) ) then
+c remise a -1 du chainage des aretes peripheriques de la boule ns
+ noar = noar0
+ 90 if( noar .gt. 0 ) then
+c protection du no de l'arete suivante
+ na = nosoar(lchain,noar)
+c l'arete interne est remise a -1
+ nosoar(lchain,noar) = -1
+c l'arete suivante
+ noar = na
+ goto 90
+ endif
+ call te1stm( ns, pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % mxtrcf, n1arcf, noarcf,
+ % larmin, notrcf, nostbo,
+ % ierr )
+ if( ierr .lt. 0 ) then
+c le sommet ns est externe donc non supprime
+c ou bien le sommet ns est le centre d'un cf dont toutes
+c les aretes simples sont frontalieres
+c dans les 2 cas le sommet ns n'est pas supprime
+ ierr = 0
+ goto 200
+ else if( ierr .gt. 0 ) then
+c erreur irrecuperable
+ goto 9999
+ endif
+ nbstsu = nbstsu + 1
+ goto 1000
+c
+ endif
+c
+c les 2 coordonnees du barycentre des sommets des aretes
+c simples de la boule du sommet ns
+c ======================================================
+ 200 xbar = xbar / nbstbo
+ ybar = ybar / nbstbo
+c
+c ponderation pour eviter les degenerescenses
+ pxyd(1,ns) = ponde1 * pxyd(1,ns) + ponder * xbar
+ pxyd(2,ns) = ponde1 * pxyd(2,ns) + ponder * ybar
+c
+ if( nutysu .gt. 0 ) then
+c la fonction taille_ideale(x,y,z) existe
+c calcul de pxyzd(3,ns) dans le repere initial => xyz(1:3)
+ call tetaid( nutysu, pxyd(1,ns), pxyd(2,ns),
+ % pxyd(3,ns), ier )
+ endif
+c
+c les aretes chainees de la boule sont rendues delaunay
+ 900 call tedela( pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar, noar0,
+ % moartr, mxartr, n1artr, noartr, modifs )
+c
+ 1000 continue
+c
+ccc write(imprim,11000) nbstsu, nbbaaj
+ccc11000 format( i6,' sommets supprimes ' ,
+ccc % i6,' barycentres ajoutes' )
+c
+c mise a jour pour ne pas oublier les nouveaux sommets
+ if( nbs1 .gt. nbs2 ) then
+ nbs1 = nbsomm
+ else
+ nbs2 = nbsomm
+ endif
+c
+ 5000 continue
+c
+ 9999 return
+ end
+
+
+ subroutine teamsf( nutysu,
+ % noarst, mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % mxtrcf, notrcf, nostbo,
+ % n1arcf, noarcf, larmin,
+ % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
+ % ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : modification de la topologie des triangles autour des
+c ----- sommets frontaliers et mise en triangulation delaunay locale
+c
+c entrees:
+c --------
+c nutysu : numero de traitement de areteideale() selon le type de surface
+c 0 pas d'emploi de la fonction areteideale() => aretmx active
+c 1 il existe une fonction areteideale()
+c dont seules les 2 premieres composantes de uv sont actives
+c autres options a definir...
+c noarst : noarst(i) numero d'une arete de sommet i
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes frontalieres declarables
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxartr : nombre maximal de triangles declarables dans noartr
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c mxtrcf : nombre maximal de triangles empilables
+c nbarpi : numero du dernier sommet frontalier ou interne impose
+c nslign : >0 => ns numero du point dans le lexique point si interne impose
+c ou => 1 000 000 * n + ns1
+c ou n est le numero (1 a nblftr) de la ligne de ce point
+c ns1 est le numero du point dans sa ligne
+c = 0 si le point est interne non impose par l'utilisateur
+c =-1 si le sommet est externe au domaine
+c comxmi : min et max des coordonneees des sommets du maillage
+c
+c modifies :
+c ----------
+c nbsomm : nombre actuel de sommets de la triangulation
+c (certains sommets internes ont ete desactives ou ajoutes)
+c pxyd : tableau des coordonnees 2d des points
+c
+c auxiliaires:
+c ------------
+c notrcf : tableau ( mxtrcf ) auxiliaire d'entiers
+c numero dans noartr des triangles de sommet ns
+c nostbo : tableau ( mxtrcf ) auxiliaire d'entiers
+c numero dans pxyd des sommets des aretes simples de la boule
+c n1arcf : tableau (0:mxtrcf) auxiliaire d'entiers
+c noarcf : tableau (3,mxtrcf) auxiliaire d'entiers
+c larmin : tableau ( mxtrcf ) auxiliaire d'entiers
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc janvier 1998
+c....................................................................012
+ parameter (lchain=6)
+ common / unites / lecteu, imprim, nunite(30)
+ double precision pxyd(3,*)
+ double precision a, angle, angled, pi, deuxpi, pis3
+ double precision d2d3(3,3)
+ real origin(3), xyz(3)
+ integer noartr(moartr,*),
+ % nosoar(mosoar,*),
+ % noarst(*),
+ % notrcf(mxtrcf),
+ % nslign(*),
+ % nostbo(*),
+ % n1arcf(0:mxtrcf),
+ % noarcf(3,mxtrcf),
+ % larmin(mxtrcf),
+ % nosotr(3)
+ double precision comxmi(3,2)
+c
+c le nombre d'iterations pour ameliorer la qualite
+ nbitaq = 2
+ ier = 0
+c
+c pi / 3
+ pi = atan(1d0) * 4d0
+ pis3 = pi / 3d0
+ deuxpi = 2d0 * pi
+c
+c initialisation du parcours
+ modifs = 0
+ nbs1 = nbarpi
+ nbs2 = 1
+c => pas de traitement sur les points des lignes de la frontiere
+ nbs3 = -1
+c
+ do 5000 iter=1,nbitaq
+c
+c le nombre de sommets supprimes
+ nbstsu = 0
+c
+c l'ordre du parcours dans le sens croissant ou decroissant
+ nt = nbs1
+ nbs1 = nbs2
+ nbs2 = nt
+c alternance du parcours
+ nbs3 = -nbs3
+c
+ do 1000 ns = nbs1, nbs2, nbs3
+c
+c le sommet est il sur une ligne de la frontiere?
+c if( nslign(ns) .lt. 1 000 000 ) goto 1000
+c
+c traitement d'un sommet d'une ligne de la frontiere
+c ==================================================
+c existe-t-il une arete de sommet ns ?
+ noar = noarst( ns )
+ if( noar .le. 0 ) goto 1000
+c
+c le 1-er triangle de l'arete noar
+ nt = nosoar( 4, noar )
+ if( nt .le. 0 ) goto 1000
+c
+c recherche des triangles de sommet ns
+c ils doivent former un contour ferme de type camembert
+ call trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
+ % mxtrcf, nbtrcf, notrcf )
+ if( nbtrcf .ge. -1 ) goto 1000
+c
+c boucle sur les triangles qui forment un camembert autour du sommet n
+ nbtrcf = -nbtrcf
+c
+c angle interne au camembert autour du sommet ns
+ angle = 0d0
+ do 540 i=1,nbtrcf
+c
+c le numero de l'arete du triangle nt ne contenant pas le sommet ns
+ nt = notrcf(i)
+ do 520 na=1,3
+c le numero de l'arete na dans le tableau nosoar
+ noar = abs( noartr(na,nt) )
+ if( nosoar(1,noar) .ne. ns .and.
+ % nosoar(2,noar) .ne. ns ) goto 525
+ 520 continue
+c
+c calcul de l'angle (ns-st1 arete, ns-st2 arete)
+ 525 ns1 = nosoar(1,noar)
+ ns2 = nosoar(2,noar)
+ a = angled( pxyd(1,ns), pxyd(1,ns1), pxyd(1,ns2) )
+ if( a .gt. pi ) a = deuxpi - a
+ angle = angle + a
+c
+ 540 continue
+c
+c nombre ideal de triangles autour du sommet ns
+ n = nint( angle / pis3 )
+ if( n .le. 1 ) goto 1000
+ i = 1
+ if( nbtrcf .gt. n ) then
+c
+c ajout du barycentre du triangle "milieu"
+ nt = notrcf( (n+1)/2 )
+ call nusotr( nt, mosoar, nosoar,
+ % moartr, noartr, nosotr )
+ if( nbsomm .ge. mxsomm ) then
+ write(imprim,*) 'saturation du tableau pxyd'
+c abandon de l'amelioration du sommet ns
+ goto 1000
+ endif
+ nbsomm = nbsomm + 1
+ do 560 i=1,3
+ pxyd(i,nbsomm) = ( pxyd(i,nosotr(1))
+ % + pxyd(i,nosotr(2))
+ % + pxyd(i,nosotr(3)) ) / 3d0
+ 560 continue
+c
+ if( nutysu .gt. 0 ) then
+c la fonction taille_ideale(x,y,z) existe
+c calcul de pxyzd(3,nbsomm) dans le repere initial => xyz(1:3)
+ call tetaid( nutysu, pxyd(1,nbsomm), pxyd(2,nbsomm),
+ % pxyd(3,nbsomm), ier )
+ endif
+c
+c sommet interne a la triangulation
+ nslign(nbsomm) = 0
+c
+c les 3 aretes du triangle nt sont a rendre delaunay
+ noar0 = 0
+ do 570 i=1,3
+ noar = abs( noartr(i,nt) )
+ if( nosoar(3,noar) .eq. 0 ) then
+c arete non frontaliere
+ if( nosoar(lchain,noar) .lt. 0 ) then
+c arete non encore chainee
+ nosoar(lchain,noar) = noar0
+ noar0 = noar
+ endif
+ endif
+ 570 continue
+c
+c triangulation du triangle de barycentre nbsomm
+c protection a ne pas modifier sinon erreur!
+ call tr3str( nbsomm, nt,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % noarst,
+ % nosotr, ierr )
+ if( ierr .ne. 0 ) goto 9999
+c
+c les aretes chainees de la boule sont rendues delaunay
+ call tedela( pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar, noar0,
+ % moartr, mxartr, n1artr, noartr, modifs )
+ endif
+c
+ 1000 continue
+c
+ 5000 continue
+c
+ 9999 return
+ end
+
+
+ subroutine teamqs( nutysu,
+ % noarst, mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % mxtrcf, notrcf, nostbo,
+ % n1arcf, noarcf, larmin,
+ % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
+ % ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : une iteration de barycentrage des points internes
+c ----- modification de la topologie pour avoir 4 ou 5 ou 6 triangles
+c pour chaque sommet de la triangulation
+c mise en triangulation delaunay
+c
+c entrees:
+c --------
+c nutysu : numero de traitement de areteideale() selon le type de surface
+c 0 pas d'emploi de la fonction areteideale() => aretmx active
+c 1 il existe une fonction areteideale()
+c dont seules les 2 premieres composantes de uv sont actives
+c autres options a definir...
+c noarst : noarst(i) numero d'une arete de sommet i
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes frontalieres declarables
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxartr : nombre maximal de triangles declarables dans noartr
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c mxtrcf : nombre maximal de triangles empilables
+c nbarpi : numero du dernier sommet frontalier ou interne impose
+c nslign : >0 => ns numero du point dans le lexique point si interne impose
+c ou => 1 000 000 * n + ns1
+c ou n est le numero (1 a nblftr) de la ligne de ce point
+c ns1 est le numero du point dans sa ligne
+c = 0 si le point est interne non impose par l'utilisateur
+c =-1 si le sommet est externe au domaine
+c comxmi : min et max des coordonneees des sommets du maillage
+c
+c modifies :
+c ----------
+c nbsomm : nombre actuel de sommets de la triangulation
+c (certains sommets internes ont ete desactives ou ajoutes)
+c pxyd : tableau des coordonnees 2d des points
+c
+c auxiliaires:
+c ------------
+c notrcf : tableau ( mxtrcf ) auxiliaire d'entiers
+c numero dans noartr des triangles de sommet ns
+c nostbo : tableau ( mxtrcf ) auxiliaire d'entiers
+c numero dans pxyd des sommets des aretes simples de la boule
+c n1arcf : tableau (0:mxtrcf) auxiliaire d'entiers
+c noarcf : tableau (3,mxtrcf) auxiliaire d'entiers
+c larmin : tableau ( mxtrcf ) auxiliaire d'entiers
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mai 1997
+c....................................................................012
+ parameter (lchain=6)
+ common / unites / lecteu, imprim, nunite(30)
+ double precision pxyd(3,*)
+ double precision ponder, ponde1, xbar, ybar, x, y, d, dmin, dmax
+ double precision d2d3(3,3)
+ real origin(3), xyz(3)
+ integer noartr(moartr,*),
+ % nosoar(mosoar,*),
+ % noarst(*),
+ % notrcf(mxtrcf),
+ % nslign(*),
+ % nostbo(*),
+ % n1arcf(0:mxtrcf),
+ % noarcf(3,mxtrcf),
+ % larmin(mxtrcf)
+ integer nosotr(3,2)
+ double precision comxmi(3,2)
+c
+c le nombre d'iterations pour ameliorer la qualite
+ nbitaq = 6
+ ier = 0
+c
+c initialisation du parcours
+ nbs1 = nbsomm
+ nbs2 = nbarpi + 1
+c => pas de traitement sur les points des lignes de la frontiere
+ nbs3 = -1
+c
+ do 5000 iter=1,nbitaq
+c
+c le nombre de sommets supprimes
+ nbstsu = 0
+c
+c les compteurs de passage sur les differents cas
+ nbst4 = 0
+ nbst5 = 0
+ nbst8 = 0
+c
+c coefficient de ponderation croissant avec les iterations
+ ponder = min( 1d0, ( 50 + (50*iter)/nbitaq ) * 0.01d0 )
+ ponde1 = 1d0 - ponder
+c
+c l'ordre du parcours dans le sens croissant ou decroissant
+ nt = nbs1
+ nbs1 = nbs2
+ nbs2 = nt
+c alternance du parcours
+ nbs3 = -nbs3
+c
+ do 1000 ns = nbs1, nbs2, nbs3
+c
+c le sommet est il interne au domaine?
+ if( nslign(ns) .ne. 0 ) goto 1000
+c
+c traitement d'un sommet interne non impose par l'utilisateur
+c ===========================================================
+c existe-t-il une arete de sommet ns ?
+ 10 noar = noarst( ns )
+ if( noar .le. 0 ) goto 1000
+c
+c le 1-er triangle de l'arete noar
+ nt = nosoar( 4, noar )
+ if( nt .le. 0 ) goto 1000
+c
+c recherche des triangles de sommet ns
+c ils doivent former un contour ferme de type etoile
+ call trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
+ % mxtrcf, nbtrcf, notrcf )
+ if( nbtrcf .le. 0 ) goto 1000
+c
+c boucle sur les triangles qui forment une boule autour du sommet ns
+ nbstbo = 0
+c chainage des aretes simples de la boule a rendre delaunay
+ noar0 = 0
+ do 40 i=1,nbtrcf
+c
+c le numero de l'arete du triangle nt ne contenant pas le sommet ns
+ nt = notrcf(i)
+ do 20 na=1,3
+c le numero de l'arete na dans le tableau nosoar
+ noar = abs( noartr(na,nt) )
+ if( nosoar(1,noar) .ne. ns .and.
+ % nosoar(2,noar) .ne. ns ) goto 25
+ 20 continue
+c
+c construction de la liste des sommets des aretes simples
+c de la boule des triangles de sommet ns
+c -------------------------------------------------------
+ 25 do 35 na=1,2
+ ns1 = nosoar(na,noar)
+ do 30 j=nbstbo,1,-1
+ if( ns1 .eq. nostbo(j) ) goto 35
+ 30 continue
+c ns1 est un nouveau sommet a ajouter
+ nbstbo = nbstbo + 1
+ nostbo(nbstbo) = ns1
+ 35 continue
+c
+c noar est une arete potentielle a rendre delaunay
+ if( nosoar(3,noar) .eq. 0 ) then
+c arete non frontaliere
+ nosoar(lchain,noar) = noar0
+ noar0 = noar
+ endif
+c
+ 40 continue
+c
+c calcul des 2 coordonnees du barycentre de la boule du sommet ns
+c calcul de l'arete de taille maximale et minimale issue de ns
+c ---------------------------------------------------------------
+ xbar = 0d0
+ ybar = 0d0
+ dmin = 1d28
+ dmax = 0d0
+ do 50 i=1,nbstbo
+ x = pxyd(1,nostbo(i))
+ y = pxyd(2,nostbo(i))
+ xbar = xbar + x
+ ybar = ybar + y
+ d = (x-pxyd(1,ns)) ** 2 + (y-pxyd(2,ns)) ** 2
+ if( d .gt. dmax ) then
+ dmax = d
+ imax = i
+ endif
+ if( d .lt. dmin ) then
+ dmin = d
+ imin = i
+ endif
+ 50 continue
+c
+c pas de modification de la topologie lors de la derniere iteration
+c =================================================================
+ if( iter .ge. nbitaq ) goto 200
+c
+c si la boule de ns contient 3 ou 4 triangles le sommet ns est detruit
+c ====================================================================
+ if( nbtrcf .le. 4 ) then
+c
+c remise a -1 du chainage des aretes peripheriques de la boule ns
+ noar = noar0
+ 60 if( noar .gt. 0 ) then
+c protection du no de l'arete suivante
+ na = nosoar(lchain,noar)
+c l'arete interne est remise a -1
+ nosoar(lchain,noar) = -1
+c l'arete suivante
+ noar = na
+ goto 60
+ endif
+ call te1stm( ns, pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % mxtrcf, n1arcf, noarcf,
+ % larmin, notrcf, nostbo,
+ % ierr )
+ if( ierr .lt. 0 ) then
+c le sommet ns est externe donc non supprime
+c ou bien le sommet ns est le centre d'un cf dont toutes
+c les aretes simples sont frontalieres
+c dans les 2 cas le sommet ns n'est pas supprime
+ ierr = 0
+ goto 200
+ else if( ierr .eq. 0 ) then
+ nbst4 = nbst4 + 1
+ nbstsu = nbstsu + 1
+ else
+c erreur irrecuperable
+ goto 9999
+ endif
+ goto 1000
+c
+ endif
+c
+c si la boule de ns contient 5 triangles et a un sommet voisin
+c sommet de 5 triangles alors l'arete joignant ces 2 sommets
+c est transformee en un seul sommet de 6 triangles
+c ============================================================
+ if( nbtrcf .eq. 5 ) then
+c
+ do 80 i=1,5
+c le numero du sommet de l'arete i et different de ns
+ ns1 = nostbo(i)
+c la liste des triangles de sommet ns1
+ call trp1st( ns1, noarst,
+ % mosoar, nosoar, moartr, noartr,
+ % mxtrcf-5, nbtrc1, notrcf(6) )
+ if( nbtrc1 .eq. 5 ) then
+c
+c l'arete de sommets ns-ns1 devient un point
+c par suppression du sommet ns
+c
+c remise a -1 du chainage des aretes peripheriques de la boul
+ noar = noar0
+ 70 if( noar .gt. 0 ) then
+c protection du no de l'arete suivante
+ na = nosoar(lchain,noar)
+c l'arete interne est remise a -1
+ nosoar(lchain,noar) = -1
+c l'arete suivante
+ noar = na
+ goto 70
+ endif
+c
+c le point ns1 devient le milieu de l'arete ns-ns1
+ do 75 j=1,3
+ pxyd(j,ns1) = (pxyd(j,ns) + pxyd(j,ns1)) * 0.5d0
+ 75 continue
+c
+ if( nutysu .gt. 0 ) then
+c la fonction taille_ideale(x,y,z) existe
+c calcul de pxyzd(3,ns1) dans le repere initial => xyz(1:3
+ call tetaid( nutysu,pxyd(1,ns1),pxyd(2,ns1),
+ % pxyd(3,ns1), ier )
+ endif
+c
+c suppression du point ns et mise en delaunay
+ call te1stm( ns, pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % mxtrcf, n1arcf, noarcf,
+ % larmin, notrcf, nostbo,
+ % ierr )
+ if( ierr .lt. 0 ) then
+c le sommet ns est externe donc non supprime
+c ou bien le sommet ns est le centre d'un cf dont toutes
+c les aretes simples sont frontalieres
+c dans les 2 cas le sommet ns n'est pas supprime
+ ierr = 0
+ goto 200
+ else if( ierr .eq. 0 ) then
+ nbstsu = nbstsu + 1
+ nbst5 = nbst5 + 1
+ goto 1000
+ else
+c erreur irrecuperable
+ goto 9999
+ endif
+ endif
+ 80 continue
+ endif
+c
+c si la boule de ns contient au moins 8 triangles
+c alors un triangle interne est ajoute + 3 triangles (1 par arete)
+c ================================================================
+ if( nbtrcf .ge. 8 ) then
+c
+c modification des coordonnees du sommet ns
+c il devient le barycentre du triangle notrcf(1)
+ call nusotr( notrcf(1), mosoar, nosoar,
+ % moartr, noartr, nosotr )
+ do 110 i=1,3
+ pxyd(i,ns) = ( pxyd(i,nosotr(1,1))
+ % + pxyd(i,nosotr(2,1))
+ % + pxyd(i,nosotr(3,1)) ) / 3d0
+ 110 continue
+c
+ if( nutysu .gt. 0 ) then
+c la fonction taille_ideale(x,y,z) existe
+c calcul de pxyzd(3,nbsomm) dans le repere initial => xyz(1:3)
+ call tetaid( nutysu, pxyd(1,ns), pxyd(2,ns),
+ % pxyd(3,ns), ier )
+ endif
+c
+c ajout des 2 autres sommets comme barycentres des triangles
+c notrcf(1+nbtrcf/3) et notrcf(1+2*nbtrcf/3)
+ nbt1 = ( nbtrcf + 1 ) / 3
+ do 140 n=1,2
+c
+c le triangle traite
+ nt = notrcf(1 + n * nbt1 )
+c
+c le numero pxyd de ses 3 sommets
+ call nusotr( nt, mosoar, nosoar,
+ % moartr, noartr, nosotr )
+c
+c ajout du nouveau barycentre
+ if( nbsomm .ge. mxsomm ) then
+ write(imprim,*) 'saturation du tableau pxyd'
+c abandon de l'amelioration
+ goto 1100
+ endif
+ nbsomm = nbsomm + 1
+ do 120 i=1,3
+ pxyd(i,nbsomm) = ( pxyd(i,nosotr(1,1))
+ % + pxyd(i,nosotr(2,1))
+ % + pxyd(i,nosotr(3,1)) ) / 3d0
+ 120 continue
+c
+ if( nutysu .gt. 0 ) then
+c la fonction taille_ideale(x,y,z) existe
+c calcul de pxyzd(3,nbsomm) dans le repere initial => xyz(1:3
+ call tetaid( nutysu, pxyd(1,nbsomm),pxyd(2,nbsomm),
+ % pxyd(3,nbsomm), ier )
+ endif
+c
+c sommet interne a la triangulation
+ nslign(nbsomm) = 0
+c
+c les 3 aretes du triangle nt sont a rendre delaunay
+ do 130 i=1,3
+ noar = abs( noartr(i,nt) )
+ if( nosoar(3,noar) .eq. 0 ) then
+c arete non frontaliere
+ if( nosoar(lchain,noar) .lt. 0 ) then
+c arete non encore chainee
+ nosoar(lchain,noar) = noar0
+ noar0 = noar
+ endif
+ endif
+ 130 continue
+c
+c triangulation du triangle de barycentre nbsomm
+c protection a ne pas modifier sinon erreur!
+ call tr3str( nbsomm, nt,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % noarst,
+ % nosotr, ierr )
+ if( ierr .ne. 0 ) goto 9999
+ 140 continue
+c
+ nbst8 = nbst8 + 1
+c
+c les aretes chainees de la boule sont rendues delaunay
+ goto 300
+c
+ endif
+c
+c nbtrcf est compris entre 5 et 7 => barycentrage simple
+c ======================================================
+c les 2 coordonnees du barycentre des sommets des aretes
+c simples de la boule du sommet ns
+ 200 xbar = xbar / nbstbo
+ ybar = ybar / nbstbo
+c
+c ponderation pour eviter les degenerescenses
+ pxyd(1,ns) = ponde1 * pxyd(1,ns) + ponder * xbar
+ pxyd(2,ns) = ponde1 * pxyd(2,ns) + ponder * ybar
+c
+c les aretes chainees de la boule sont rendues delaunay
+ 300 call tedela( pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar, noar0,
+ % moartr, mxartr, n1artr, noartr, modifs )
+c
+ 1000 continue
+c
+c trace de la triangulation actuelle et calcul de la qualite
+ 1100 continue
+c
+ccc write(imprim,11000) nbst4, nbst5, nbst8
+ccc11000 format( i7,' sommets de 4t',
+ccc % i7,' sommets 5t+5t',
+ccc % i7,' sommets >7t' )
+c
+c mise a jour pour ne pas oublier les nouveaux sommets
+ if( nbs1 .gt. nbs2 ) then
+ nbs1 = nbsomm
+ nbs2 = nbarpi + 1
+ else
+ nbs1 = nbarpi + 1
+ nbs2 = nbsomm
+ endif
+c
+ 5000 continue
+c
+ 9999 return
+ end
+
+
+ subroutine teamqt( nutysu,
+ % noarst, mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % mxarcf, notrcf, nostbo,
+ % n1arcf, noarcf, larmin,
+ % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
+ % ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : amelioration de la qualite de la triangulation issue de teabr4
+c -----
+c
+c entrees:
+c --------
+c nutysu : numero de traitement de areteideale() selon le type de surface
+c 0 pas d'emploi de la fonction areteideale() => aretmx active
+c 1 il existe une fonction areteideale()
+c dont seules les 2 premieres composantes de uv sont actives
+c autres options a definir...
+c noarst : noarst(i) numero d'une arete de sommet i
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes frontalieres declarables
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxartr : nombre maximal de triangles declarables dans noartr
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c mxarcf : nombre maximal de triangles empilables
+c nbarpi : numero du dernier sommet frontalier ou interne impose
+c nslign : tableau du numero de sommet dans sa ligne pour chaque
+c sommet frontalier
+c numero du point dans le lexique point si interne impose
+c 0 si le point est interne non impose par l'utilisateur
+c -1 si le sommet est externe au domaine
+c comxmi : min et max des coordonneees des sommets du maillage
+c
+c modifies :
+c ----------
+c nbsomm : nombre actuel de sommets de la triangulation
+c (certains sommets internes ont ete desactives ou ajoutes)
+c pxyd : tableau des coordonnees 2d des points
+c
+c auxiliaires:
+c ------------
+c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
+c numero dans noartr des triangles de sommet ns
+c nostbo : tableau ( mxarcf ) auxiliaire d'entiers
+c numero dans pxyd des sommets des aretes simples de la boule
+c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
+c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
+c larmin : tableau ( mxarcf ) auxiliaire d'entiers
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc juin 1997
+c....................................................................012
+ common / unites / lecteu, imprim, nunite(30)
+ double precision pxyd(3,*), d2d3(3,3)
+ integer noartr(moartr,*),
+ % nosoar(mosoar,*),
+ % noarst(*),
+ % notrcf(mxarcf),
+ % nslign(*),
+ % nostbo(mxarcf),
+ % n1arcf(0:mxarcf),
+ % noarcf(3,mxarcf),
+ % larmin(mxarcf)
+ double precision comxmi(3,2)
+c
+c suppression des sommets de triangles equilateraux trop proches
+c d'un sommet frontalier ou d'un point interne impose par
+c triangulation frontale de l'etoile et mise en delaunay
+c ==============================================================
+ call tesusp( nbarpi, pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % mxarcf, n1arcf, noarcf, larmin, notrcf, nostbo,
+ % nbstsu, ierr )
+ if( ierr .ne. 0 ) goto 9999
+c write(imprim,*) 'retrait de',nbstsu,
+c % ' sommets de te trop proches de la frontiere'
+c
+c ajustage des tailles moyennes des aretes avec ampli=1.34d0 entre
+c ampli/2 x taille_souhaitee et ampli x taille_souhaitee
+c + barycentrage des sommets et mise en triangulation delaunay
+c ================================================================
+ call teamqa( nutysu,
+ % noarst, mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % mxarcf, notrcf, nostbo,
+ % n1arcf, noarcf, larmin,
+ % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
+ % ierr )
+ if( ierr .ne. 0 ) goto 9999
+c
+c modification de la topologie autour des sommets frontaliers
+c pour avoir un nombre de triangles egal a l'angle/60 degres
+c et mise en triangulation delaunay locale
+c ===========================================================
+ call teamsf( nutysu,
+ % noarst, mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % mxarcf, notrcf, nostbo,
+ % n1arcf, noarcf, larmin,
+ % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
+ % ierr )
+ if( ierr .ne. 0 ) goto 9999
+c
+c quelques iterations de barycentrage des points internes
+c modification de la topologie pour avoir 4 ou 5 ou 6 triangles
+c pour chaque sommet de la triangulation
+c et mise en triangulation delaunay
+c =============================================================
+ call teamqs( nutysu,
+ % noarst, mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % mxarcf, notrcf, nostbo,
+ % n1arcf, noarcf, larmin,
+ % comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
+ % ierr )
+c
+ 9999 return
+ end
+
+ subroutine trfrcf( nscent, mosoar, nosoar, moartr, noartr,
+ % nbtrcf, notrcf, nbarfr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : calculer le nombre d'aretes simples du contour ferme des
+c ----- nbtrcf triangles de numeros stockes dans le tableau notrcf
+c ayant tous le sommet nscent
+c
+c entrees:
+c --------
+c nscent : numero du sommet appartenant a tous les triangles notrcf
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c nbtrcf : >0 nombre de triangles empiles
+c =0 si impossible de tourner autour du point
+c =-nbtrcf si apres butee sur la frontiere il y a a nouveau
+c butee sur la frontiere . a ce stade on ne peut dire si tous
+c les triangles ayant ce sommet ont ete recenses
+c ce cas arrive seulement si le sommet est sur la frontiere
+c notrcf : numero dans noartr des triangles de sommet ns
+c
+c sortie :
+c --------
+c nbarfr : nombre d'aretes simples frontalieres
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc juin 1997
+c....................................................................012
+ integer noartr(moartr,*),
+ % nosoar(mosoar,*),
+ % notrcf(1:nbtrcf)
+c
+ nbarfr = 0
+ do 50 n=1,nbtrcf
+c le numero du triangle n dans le tableau noartr
+ nt = notrcf( n )
+c parcours des 3 aretes du triangle nt
+ do 40 i=1,3
+c le numero de l'arete i dans le tableau nosoar
+ noar = abs( noartr( i, nt ) )
+ do 30 j=1,2
+c le numero du sommet j de l'arete noar
+ ns = nosoar( j, noar )
+ if( ns .eq. nscent ) goto 40
+ 30 continue
+c l'arete noar (sans sommet nscent) est elle frontaliere?
+ if( nosoar( 5, noar ) .le. 0 ) then
+c l'arete appartient au plus a un triangle
+c une arete simple frontaliere de plus
+ nbarfr = nbarfr + 1
+ endif
+c le triangle a au plus une arete sans sommet nscent
+ goto 50
+ 40 continue
+ 50 continue
+ end
+
+ subroutine int2ar( p1, p2, p3, p4, oui )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : les 2 aretes de r**2 p1-p2 p3-p4 s'intersectent elles
+c ----- entre leurs sommets?
+c
+c entrees:
+c --------
+c p1,p2,p3,p4 : les 2 coordonnees reelles des sommets des 2 aretes
+c
+c sortie :
+c --------
+c oui : .true. si intersection, .false. sinon
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc octobre 1991
+c2345x7..............................................................012
+ double precision p1(2),p2(2),p3(2),p4(2)
+ double precision x21,y21,d21,x43,y43,d43,d,x,y,xx
+ logical oui
+c
+c longueur des aretes
+ x21 = p2(1)-p1(1)
+ y21 = p2(2)-p1(2)
+ d21 = x21**2 + y21**2
+c
+ x43 = p4(1)-p3(1)
+ y43 = p4(2)-p3(2)
+ d43 = x43**2 + y43**2
+c
+c les 2 aretes sont-elles jugees paralleles ?
+ d = x43 * y21 - y43 * x21
+ if( abs(d) .le. 0.001 * sqrt(d21 * d43) ) then
+c aretes paralleles . pas d'intersection
+ oui = .false.
+ return
+ endif
+c
+c les 2 coordonnees du point d'intersection
+ x = ( p1(1)*x43*y21 - p3(1)*x21*y43 - (p1(2)-p3(2))*x21*x43 ) / d
+ y =-( p1(2)*y43*x21 - p3(2)*y21*x43 - (p1(1)-p3(1))*y21*y43 ) / d
+c
+c coordonnees de x,y dans le repere ns1-ns2
+ xx = ( x - p1(1) ) * x21 + ( y - p1(2) ) * y21
+c le point est il entre p1 et p2 ?
+ oui = -0.00001d0*d21 .le. xx .and. xx .le. 1.00001d0*d21
+c
+c coordonnees de x,y dans le repere ns3-ns4
+ xx = ( x - p3(1) ) * x43 + ( y - p3(2) ) * y43
+c le point est il entre p3 et p4 ?
+ oui = oui .and. -0.00001d0*d43 .le. xx .and. xx .le. 1.00001d0*d43
+ end
+
+
+ subroutine trchtd( pxyd, nar00, nar0, noarcf,
+ % namin0, namin, larmin )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : recherche dans le contour ferme du sommet qui joint a la plus
+c ----- courte arete nar00 donne le triangle sans intersection
+c avec le contour ferme de meilleure qualite
+c
+c entrees:
+c --------
+c pxyd : tableau des coordonnees des sommets et distance_souhaitee
+c
+c entrees et sorties:
+c -------------------
+c nar00 : numero dans noarcf de l'arete avant nar0
+c nar0 : numero dans noarcf de la plus petite arete du contour ferme
+c a joindre a noarcf(1,namin) pour former le triangle ideal
+c noarcf : numero du sommet , numero de l'arete suivante
+c numero du triangle exterieur a l'etoile
+c
+c sortie :
+c --------
+c namin0 : numero dans noarcf de l'arete avant namin
+c namin : numero dans noarcf du sommet choisi
+c 0 si contour ferme reduit a moins de 3 aretes
+c larmin : tableau auxiliaire pour stocker la liste des numeros des
+c aretes de meilleure qualite pour faire le choix final
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
+c2345x7..............................................................012
+ double precision dmaxim, precision
+ parameter (dmaxim=1.7d+308, precision=1d-16)
+c ATTENTION:variables a ajuster selon la machine!
+c ATTENTION:dmaxim : le plus grand reel machine
+c ATTENTION:sur dec-alpha la precision est de 10**-14 seulement
+
+ common / unites / lecteu,imprim,nunite(30)
+ double precision pxyd(1:3,1:*)
+ integer noarcf(1:3,1:*),
+ % larmin(1:*)
+ double precision q, dd, dmima,
+ % unpeps, rayon, surtd2
+ logical oui
+ double precision centre(3)
+c
+c initialisations
+c dmaxim : le plus grand reel machine
+ unpeps = 1d0 + 100d0 * precision
+c
+c recherche de la plus courte arete du contour ferme
+ nbmin = 0
+ na00 = nar00
+ dmima = dmaxim
+ nbar = 0
+c
+ 2 na0 = noarcf( 2, na00 )
+ na1 = noarcf( 2, na0 )
+ nbar = nbar + 1
+c les 2 sommets de l'arete na0 du cf
+ ns1 = noarcf( 1, na0 )
+ ns2 = noarcf( 1, na1 )
+ dd = (pxyd(1,ns2)-pxyd(1,ns1))**2 + (pxyd(2,ns2)-pxyd(2,ns1))**2
+ if( dd .lt. dmima ) then
+ dmima = dd
+ larmin(1) = na00
+ endif
+ na00 = na0
+ if( na00 .ne. nar00 ) then
+c derniere arete non atteinte
+ goto 2
+ endif
+c
+ if( nbar .eq. 3 ) then
+c
+c contour ferme reduit a un triangle
+c ----------------------------------
+ namin = nar00
+ nar0 = noarcf( 2, nar00 )
+ namin0 = noarcf( 2, nar0 )
+ return
+c
+ else if( nbar .le. 2 ) then
+ write(imprim,*) 'erreur trchtd: cf<3 aretes'
+ pause
+ namin = 0
+ namin0 = 0
+ return
+ endif
+c
+c cf non reduit a un triangle
+c la plus petite arete est nar0 dans noarcf
+ nar00 = larmin( 1 )
+ nar0 = noarcf( 2, nar00 )
+ nar = noarcf( 2, nar0 )
+c
+ ns1 = noarcf( 1, nar0 )
+ ns2 = noarcf( 1, nar )
+c
+c recherche dans cette etoile du sommet offrant la meilleure qualite
+c du triangle ns1-ns2 ns3 sans intersection avec le contour ferme
+c ==================================================================
+ nar3 = nar
+ qmima = -1
+c
+c parcours des sommets possibles ns3
+ 10 nar3 = noarcf( 2, nar3 )
+ if( nar3 .ne. nar0 ) then
+c
+c il existe un sommet ns3 different de ns1 et ns2
+ ns3 = noarcf( 1, nar3 )
+c
+c les aretes ns1-ns3 et ns2-ns3 intersectent-elles une arete
+c du contour ferme ?
+c ----------------------------------------------------------
+c intersection de l'arete ns2-ns3 et des aretes du cf
+c jusqu'au sommet ns3
+ nar1 = noarcf( 2, nar )
+c
+ 15 if( nar1 .ne. nar3 .and. noarcf( 2, nar1 ) .ne. nar3 ) then
+c l'arete suivante
+ nar2 = noarcf( 2, nar1 )
+c le numero des 2 sommets de l'arete
+ np1 = noarcf( 1, nar1 )
+ np2 = noarcf( 1, nar2 )
+ call int2ar( pxyd(1,ns2), pxyd(1,ns3),
+ % pxyd(1,np1), pxyd(1,np2), oui )
+ if( oui ) goto 10
+c les 2 aretes ne s'intersectent pas entre leurs sommets
+ nar1 = nar2
+ goto 15
+ endif
+c
+c intersection de l'arete ns3-ns1 et des aretes du cf
+c jusqu'au sommet de l'arete nar0
+ nar1 = noarcf( 2, nar3 )
+c
+ 18 if( nar1 .ne. nar0 .and. noarcf( 2, nar1 ) .ne. nar0 ) then
+c l'arete suivante
+ nar2 = noarcf( 2, nar1 )
+c le numero des 2 sommets de l'arete
+ np1 = noarcf( 1, nar1 )
+ np2 = noarcf( 1, nar2 )
+ call int2ar( pxyd(1,ns1), pxyd(1,ns3),
+ % pxyd(1,np1), pxyd(1,np2), oui )
+ if( oui ) goto 10
+c les 2 aretes ne s'intersectent pas entre leurs sommets
+ nar1 = nar2
+ goto 18
+ endif
+c
+c le triangle ns1-ns2-ns3 n'intersecte pas une arete du contour ferme
+c le calcul de la surface du triangle
+ dd = surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
+ if( dd .le. 0d0 ) then
+c surface negative => triangle a rejeter
+ q = 0
+ else
+c calcul de la qualite du triangle ns1-ns2-ns3
+ call qutr2d( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), q )
+ endif
+c
+ if( q .ge. qmima*1.00001 ) then
+c q est un vrai maximum de la qualite
+ qmima = q
+ nbmin = 1
+ larmin(1) = nar3
+ else if( q .ge. qmima*0.999998 ) then
+c q est voisin de qmima
+c il est empile
+ nbmin = nbmin + 1
+ larmin( nbmin ) = nar3
+ endif
+ goto 10
+ endif
+c
+c bilan : existe t il plusieurs sommets de meme qualite?
+c ======================================================
+ if( nbmin .gt. 1 ) then
+c
+c oui:recherche de ceux de cercle ne contenant pas d'autres sommets
+ do 80 i=1,nbmin
+c le sommet
+ nar = larmin( i )
+ if( nar .le. 0 ) goto 80
+ ns3 = noarcf(1,nar)
+c les coordonnees du centre du cercle circonscrit
+c et son rayon
+ ier = -1
+ call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3),
+ % centre, ier )
+ if( ier .ne. 0 ) then
+c le sommet ns3 ne convient pas
+ larmin( i ) = 0
+ goto 80
+ endif
+ rayon = centre(3) * unpeps
+ do 70 j=1,nbmin
+ if( j .ne. i ) then
+c l'autre sommet
+ nar1 = larmin(j)
+ if( nar1 .le. 0 ) goto 70
+ ns4 = noarcf(1,nar1)
+c appartient t il au cercle ns1 ns2 ns3 ?
+ dd = (centre(1)-pxyd(1,ns4))**2 +
+ % (centre(2)-pxyd(2,ns4))**2
+ if( dd .le. rayon ) then
+c ns4 est dans le cercle circonscrit ns1 ns2 ns3
+c le sommet ns3 ne convient pas
+ larmin( i ) = 0
+ goto 80
+ endif
+ endif
+ 70 continue
+ 80 continue
+c
+c existe t il plusieurs sommets ?
+ j = 0
+ do 90 i=1,nbmin
+ if( larmin( i ) .gt. 0 ) then
+c compactage des min
+ j = j + 1
+ larmin(j) = larmin(i)
+ endif
+ 90 continue
+c
+ if( j .gt. 1 ) then
+c oui : choix du plus petit rayon de cercle circonscrit
+ dmima = dmaxim
+ do 120 i=1,nbmin
+ ns3 = noarcf(1,larmin(i))
+c
+c les coordonnees du centre de cercle circonscrit
+c au triangle nt et son rayon
+ ier = -1
+ call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3),
+ % centre, ier )
+ if( ier .ne. 0 ) then
+c le sommet ns3 ne convient pas
+ goto 120
+ endif
+ rayon = sqrt( centre(3) )
+ if( rayon .lt. dmima ) then
+ dmima = rayon
+ larmin(1) = larmin(i)
+ endif
+ 120 continue
+ endif
+ endif
+c
+c le choix final
+c ==============
+ namin = larmin(1)
+c
+c recherche de l'arete avant namin ( nar0 <> namin )
+c ==================================================
+ nar1 = nar0
+ 200 if( nar1 .ne. namin ) then
+ namin0 = nar1
+ nar1 = noarcf( 2, nar1 )
+ goto 200
+ endif
+ end
+
+ subroutine trcf0a( nbcf, na01, na1, na2, na3,
+ % noar1, noar2, noar3,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr, noarst,
+ % mxarcf, n1arcf, noarcf, nt )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : modification de la triangulation du contour ferme nbcf
+c ----- par ajout d'un triangle ayant 0 arete sur le contour
+c creation des 3 aretes dans le tableau nosoar
+c modification du contour par ajout de la 3-eme arete
+c creation d'un contour ferme a partir de la seconde arete
+c
+c entrees:
+c --------
+c nbcf : numero dans n1arcf du cf traite ici
+c na01 : numero noarcf de l'arete precedent l'arete na1 de noarcf
+c na1 : numero noarcf du 1-er sommet du triangle
+c implicitement l'arete na1 n'est pas une arete du triangle
+c na2 : numero noarcf du 2-eme sommet du triangle
+c implicitement l'arete na1 n'est pas une arete du triangle
+c na3 : numero noarcf du 3-eme sommet du triangle
+c implicitement l'arete na1 n'est pas une arete du triangle
+c
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c attention: mxsoar>3*mxsomm obligatoire!
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c
+c entrees et sorties :
+c --------------------
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c une arete i de nosoar est vide <=> nosoar(1,i)=0
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = nosoar(1)+nosoar(2)*2
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c
+c noarst : noarst(i) numero d'une arete de sommet i
+c n1arcf : numero d'une arete de chaque contour
+c noarcf : numero des aretes de la ligne du contour ferme
+c attention : chainage circulaire des aretes
+c
+c sortie :
+c --------
+c noar1 : numero dans le tableau nosoar de l'arete 1 du triangle
+c noar2 : numero dans le tableau nosoar de l'arete 2 du triangle
+c noar3 : numero dans le tableau nosoar de l'arete 3 du triangle
+c nt : numero du triangle ajoute dans noartr
+c 0 si saturation du tableau noartr ou noarcf ou n1arcf
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c2345x7..............................................................012
+ common / unites / lecteu, imprim, nunite(30)
+ integer nosoar(mosoar,*),
+ % noartr(moartr,*),
+ % noarst(*),
+ % n1arcf(0:*),
+ % noarcf(3,*)
+c
+ ierr = 0
+c
+c 2 contours fermes peuvent ils etre ajoutes ?
+ if( nbcf+2 .gt. mxarcf ) goto 9100
+c
+c creation des 3 aretes du triangle dans le tableau nosoar
+c ========================================================
+c la formation de l'arete sommet1-sommet2 dans le tableau nosoar
+ call fasoar( noarcf(1,na1), noarcf(1,na2), -1, -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % noar1, ierr )
+ if( ierr .ne. 0 ) goto 9900
+c
+c la formation de l'arete sommet2-sommet3 dans le tableau nosoar
+ call fasoar( noarcf(1,na2), noarcf(1,na3), -1, -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % noar2, ierr )
+ if( ierr .ne. 0 ) goto 9900
+c
+c la formation de l'arete sommet3-sommet1 dans le tableau nosoar
+ call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % noar3, ierr )
+ if( ierr .ne. 0 ) goto 9900
+c
+c ajout dans noartr de ce triangle nt
+c ===================================
+ call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
+ % noar1, noar2, noar3,
+ % mosoar, nosoar,
+ % moartr, n1artr, noartr,
+ % nt )
+ if( nt .le. 0 ) return
+c
+c modification du contour nbcf existant
+c chainage de l'arete na2 vers l'arete na1
+c ========================================
+c modification du cf en pointant na2 sur na1
+ na2s = noarcf( 2, na2 )
+ noarcf( 2, na2 ) = na1
+c le numero de l'arete dans le tableau nosoar
+ noar2s = noarcf( 3, na2 )
+c le numero de l'arete dans le tableau nosoar
+ noarcf( 3, na2 ) = noar1
+c debut du cf
+ n1arcf( nbcf ) = na2
+c
+c creation d'un nouveau contour ferme na2 - na3
+c =============================================
+ nbcf = nbcf + 1
+c recherche d'une arete de cf vide
+ nav = n1arcf(0)
+ if( nav .le. 0 ) goto 9100
+c la 1-ere arete vide est mise a jour
+ n1arcf(0) = noarcf( 2, nav )
+c
+c ajout de l'arete nav pointant sur na2s
+c le numero du sommet
+ noarcf( 1, nav ) = noarcf( 1, na2 )
+c l'arete suivante
+ noarcf( 2, nav ) = na2s
+c le numero nosoar de cette arete
+ noarcf( 3, nav ) = noar2s
+c
+c l'arete na3 se referme sur nav
+ na3s = noarcf( 2, na3 )
+ noarcf( 2, na3 ) = nav
+c le numero de l'arete dans le tableau nosoar
+ noar3s = noarcf( 3, na3 )
+ noarcf( 3, na3 ) = noar2
+c debut du cf+1
+ n1arcf( nbcf ) = na3
+c
+c creation d'un nouveau contour ferme na3 - na1
+c =============================================
+ nbcf = nbcf + 1
+c recherche d'une arete de cf vide
+ nav = n1arcf(0)
+ if( nav .le. 0 ) goto 9100
+c la 1-ere arete vide est mise a jour
+ n1arcf(0) = noarcf( 2, nav )
+c
+c ajout de l'arete nav pointant sur na3s
+c le numero du sommet
+ noarcf( 1, nav ) = noarcf( 1, na3 )
+c l'arete suivante
+ noarcf( 2, nav ) = na3s
+c le numero de l'arete dans le tableau nosoar
+ noarcf( 3, nav ) = noar3s
+c
+c recherche d'une arete de cf vide
+ nav1 = n1arcf(0)
+ if( nav1 .le. 0 ) goto 9100
+c la 1-ere arete vide est mise a jour
+ n1arcf(0) = noarcf( 2, nav1 )
+c
+c l'arete precedente na01 de na1 pointe sur la nouvelle nav1
+ noarcf( 2, na01 ) = nav1
+c
+c ajout de l'arete nav1 pointant sur nav
+c le numero du sommet
+ noarcf( 1, nav1 ) = noarcf( 1, na1 )
+c l'arete suivante
+ noarcf( 2, nav1 ) = nav
+c le numero de l'arete dans le tableau nosoar
+ noarcf( 3, nav1 ) = noar3
+c
+c debut du cf+2
+ n1arcf( nbcf ) = nav1
+ return
+c
+c erreur
+ 9100 write(imprim,*) 'saturation du tableau mxarcf'
+ nt = 0
+ return
+c
+c erreur tableau nosoar sature
+ 9900 write(imprim,*) 'saturation du tableau nosoar'
+ nt = 0
+ return
+ end
+
+
+ subroutine trcf1a( nbcf, na01, na1, na2, noar1, noar3,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr, noarst,
+ % mxarcf, n1arcf, noarcf, nt )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : modification de la triangulation du contour ferme nbcf
+c ----- par ajout d'un triangle ayant 1 arete sur le contour
+c modification du contour par ajout de la 3-eme arete
+c creation d'un contour ferme a partir de la seconde arete
+c
+c entrees:
+c --------
+c nbcf : numero dans n1arcf du cf traite ici
+c na01 : numero noarcf de l'arete precedant l'arete na1 de noarcf
+c na1 : numero noarcf du 1-er sommet du triangle
+c implicitement l'arete na1 n'est pas une arete du triangle
+c na2 : numero noarcf du 2-eme sommet du triangle
+c cette arete est l'arete 2 du triangle a ajouter
+c son arete suivante dans noarcf n'est pas sur le contour
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c attention: mxsoar>3*mxsomm obligatoire!
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c
+c entrees et sorties :
+c --------------------
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c une arete i de nosoar est vide <=> nosoar(1,i)=0
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = nosoar(1)+nosoar(2)*2
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c
+c noarst : noarst(i) numero d'une arete de sommet i
+c n1arcf : numero d'une arete de chaque contour
+c noarcf : numero des aretes de la ligne du contour ferme
+c attention : chainage circulaire des aretes
+c
+c sortie :
+c --------
+c noar1 : numero nosoar de l'arete 1 du triangle cree
+c noar3 : numero nosoar de l'arete 3 du triangle cree
+c nt : numero du triangle ajoute dans notria
+c 0 si saturation du tableau notria ou noarcf ou n1arcf
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c2345x7..............................................................012
+ common / unites / lecteu, imprim, nunite(30)
+ integer nosoar(mosoar,mxsoar),
+ % noartr(moartr,*),
+ % noarst(*),
+ % n1arcf(0:*),
+ % noarcf(3,*)
+c
+c un cf supplementaire peut il etre ajoute ?
+ if( nbcf .ge. mxarcf ) then
+ write(imprim,*) 'saturation du tableau noarcf'
+ nt = 0
+ return
+ endif
+c
+ ierr = 0
+c
+c l' arete suivante du triangle non sur le cf
+ na3 = noarcf( 2, na2 )
+c
+c creation des 2 nouvelles aretes du triangle dans le tableau nosoar
+c ==================================================================
+c la formation de l'arete sommet1-sommet2 dans le tableau nosoar
+ call fasoar( noarcf(1,na1), noarcf(1,na2), -1, -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % noar1, ierr )
+ if( ierr .ne. 0 ) goto 9900
+c
+c la formation de l'arete sommet1-sommet3 dans le tableau nosoar
+ call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % noar3, ierr )
+ if( ierr .ne. 0 ) goto 9900
+c
+c le triangle nt de noartr a l'arete 2 comme arete du contour na2
+c ===============================================================
+ call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
+ % noar1, noarcf(3,na2), noar3,
+ % mosoar, nosoar,
+ % moartr, n1artr, noartr,
+ % nt )
+ if( nt .le. 0 ) return
+c
+c modification du contour ferme existant
+c suppression de l'arete na2 du cf
+c ======================================
+c modification du cf en pointant na2 sur na1
+ noarcf( 2, na2 ) = na1
+ noarcf( 3, na2 ) = noar1
+c debut du cf
+ n1arcf( nbcf ) = na2
+c
+c creation d'un nouveau contour ferme na3 - na1
+c =============================================
+ nbcf = nbcf + 1
+c
+c recherche d'une arete de cf vide
+ nav = n1arcf(0)
+ if( nav .le. 0 ) then
+ write(imprim,*) 'saturation du tableau noarcf'
+ nt = 0
+ return
+ endif
+c
+c la 1-ere arete vide est mise a jour
+ n1arcf(0) = noarcf( 2, nav )
+c
+c ajout de l'arete nav pointant sur na3
+c le numero du sommet
+ noarcf( 1, nav ) = noarcf( 1, na1 )
+c l'arete suivante
+ noarcf( 2, nav ) = na3
+c le numero de l'arete dans le tableau nosoar
+ noarcf( 3, nav ) = noar3
+c
+c l'arete precedente na01 de na1 pointe sur la nouvelle nav
+ noarcf( 2, na01 ) = nav
+c
+c debut du cf
+ n1arcf( nbcf ) = nav
+ return
+c
+c erreur tableau nosoar sature
+ 9900 write(imprim,*) 'saturation du tableau nosoar'
+ nt = 0
+ return
+ end
+
+
+ subroutine trcf2a( nbcf, na1, noar3,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr, noarst,
+ % n1arcf, noarcf, nt )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : modification de la triangulation du contour ferme nbcf
+c ----- par ajout d'un triangle ayant 2 aretes sur le contour
+c creation d'une arete dans nosoar (sommet3-sommet1)
+c et modification du contour par ajout de la 3-eme arete
+c
+c entrees:
+c --------
+c nbcf : numero dans n1arcf du cf traite ici
+c na1 : numero noarcf de la premiere arete sur le contour
+c implicitement sa suivante est sur le contour
+c la suivante de la suivante n'est pas sur le contour
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c attention: mxsoar>3*mxsomm obligatoire!
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c
+c entrees et sorties :
+c --------------------
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c une arete i de nosoar est vide <=> nosoar(1,i)=0
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = nosoar(1)+nosoar(2)*2
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c
+c noarst : noarst(i) numero d'une arete de sommet i
+c n1arcf : numero d'une arete de chaque contour
+c noarcf : numero des aretes de la ligne du contour ferme
+c attention : chainage circulaire des aretes
+c
+c sortie :
+c --------
+c noar3 : numero de l'arete 3 dans le tableau nosoar
+c nt : numero du triangle ajoute dans noartr
+c 0 si saturation du tableau noartr ou nosoar
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c2345x7..............................................................012
+ common / unites / lecteu, imprim, nunite(30)
+ integer nosoar(mosoar,*),
+ % noartr(moartr,*),
+ % noarst(*)
+ integer n1arcf(0:*),
+ % noarcf(3,*)
+c
+ ierr = 0
+c
+c l'arete suivante de l'arete na1 dans noarcf
+ na2 = noarcf( 2, na1 )
+c l'arete suivante de l'arete na2 dans noarcf
+ na3 = noarcf( 2, na2 )
+c
+c la formation de l'arete sommet3-sommet1 dans le tableau nosoar
+ call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % noar3, ierr )
+ if( ierr .ne. 0 ) then
+ if( ierr .eq. 1 ) then
+ write(imprim,*) 'saturation des aretes (tableau nosoar)'
+ endif
+ nt = 0
+ return
+ endif
+c
+c le triangle a ses 2 aretes na1 na2 sur le contour ferme
+c ajout dans noartr de ce triangle nt
+ call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
+ % noarcf(3,na1), noarcf(3,na2), noar3,
+ % mosoar, nosoar,
+ % moartr, n1artr, noartr,
+ % nt )
+ if( nt .le. 0 ) return
+c
+c suppression des 2 aretes (na1 na2) du cf
+c ces 2 aretes se suivent dans le chainage du cf
+c ajout de la 3-eme arete (noar3) dans le cf
+c l'arete suivante de na1 devient la suivante de na2
+ noarcf(2,na1) = na3
+ noarcf(3,na1) = noar3
+c
+c l'arete na2 devient vide dans noarcf
+ noarcf(2,na2) = n1arcf( 0 )
+ n1arcf( 0 ) = na2
+c
+c la premiere pointee dans noarcf est na1
+c chainage circulaire => ce peut etre n'importe laquelle
+ n1arcf(nbcf) = na1
+ end
+
+
+ subroutine trcf3a( ns1, ns2, ns3,
+ % noar1, noar2, noar3,
+ % mosoar, nosoar,
+ % moartr, n1artr, noartr,
+ % nt )
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : ajouter dans le tableau noartr le triangle
+c ----- de sommets ns1 ns2 ns3
+c d'aretes noar1 noar2 noar3 deja existantes
+c dans le tableau nosoar des aretes
+c
+c entrees:
+c --------
+c ns1, ns2, ns3 : le numero dans pxyd des 3 sommets du triangle
+c noar1,noar2,noar3 : le numero dans nosoar des 3 aretes du triangle
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c attention: mxsoar>3*mxsomm obligatoire!
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxartr : nombre maximal de triangles stockables dans le tableau noartr
+c
+c modifies :
+c ----------
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = nosoar(1)+nosoar(2)*2
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c
+c sorties:
+c --------
+c nt : numero dans noartr du triangle ajoute
+c =0 si le tableau noartr est sature
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+ common / unites / lecteu,imprim,nunite(30)
+ integer nosoar(mosoar,*),
+ % noartr(moartr,*)
+c
+c recherche d'un triangle libre dans le tableau noartr
+ if( n1artr .le. 0 ) then
+ write(imprim,*) 'saturation du tableau noartr des aretes'
+ nt = 0
+ return
+ endif
+c
+c le numero dans noartr du nouveau triangle
+ nt = n1artr
+c
+c le nouveau premier triangle vide dans le tableau noartr
+ n1artr = noartr(2,n1artr)
+c
+c arete 1 du triangle nt
+c ======================
+c orientation des 3 aretes du triangle pour qu'il soit direct
+ if( ns1 .eq. nosoar(1,noar1) ) then
+ n = 1
+ else
+ n = -1
+ endif
+c le numero de l'arete 1 du triangle nt
+ noartr(1,nt) = n * noar1
+c
+c le numero du triangle nt pour l'arete
+ if( nosoar(4,noar1) .le. 0 ) then
+ n = 4
+ else
+ n = 5
+ endif
+ nosoar(n,noar1) = nt
+c
+c arete 2 du triangle nt
+c ======================
+c orientation des 3 aretes du triangle pour qu'il soit direct
+ if( ns2 .eq. nosoar(1,noar2) ) then
+ n = 1
+ else
+ n = -1
+ endif
+c le numero de l'arete 2 du triangle nt
+ noartr(2,nt) = n * noar2
+c
+c le numero du triangle nt pour l'arete
+ if( nosoar(4,noar2) .le. 0 ) then
+ n = 4
+ else
+ n = 5
+ endif
+ nosoar(n,noar2) = nt
+c
+c arete 3 du triangle nt
+c ======================
+c orientation des 3 aretes du triangle pour qu'il soit direct
+ if( ns3 .eq. nosoar(1,noar3) ) then
+ n = 1
+ else
+ n = -1
+ endif
+c le numero de l'arete 3 du triangle nt
+ noartr(3,nt) = n * noar3
+c
+c le numero du triangle nt pour l'arete
+ if( nosoar(4,noar3) .le. 0 ) then
+ n = 4
+ else
+ n = 5
+ endif
+ nosoar(n,noar3) = nt
+ end
+
+
+
+ subroutine trcf3s( nbcf, na01, na1, na02, na2, na03, na3,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr, noarst,
+ % mxarcf, n1arcf, noarcf, nt )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : ajout d'un triangle d'aretes na1 2 3 du tableau noarcf
+c ----- a la triangulation d'un contour ferme (cf)
+c
+c entrees:
+c --------
+c nbcf : numero dans n1arcf du cf traite ici
+c mais aussi nombre actuel de cf avant ajout du triangle
+c na01 : numero noarcf de l'arete precedent l'arete na1 de noarcf
+c na1 : numero noarcf du 1-er sommet du triangle
+c na02 : numero noarcf de l'arete precedent l'arete na2 de noarcf
+c na2 : numero noarcf du 2-eme sommet du triangle
+c na03 : numero noarcf de l'arete precedent l'arete na3 de noarcf
+c na3 : numero noarcf du 3-eme sommet du triangle
+c
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c attention: mxsoar>3*mxsomm obligatoire!
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxarcf : nombre maximal d'aretes declarables dans noarcf, n1arcf
+c
+c modifies:
+c ---------
+c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
+c chainage des vides suivant en 3 et precedant en 2 de nosoar
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = nosoar(1)+nosoar(2)*2
+c avec mxsoar>=3*mxsomm
+c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
+c nosoar(2,arete vide)=l'arete vide qui precede
+c nosoar(3,arete vide)=l'arete vide qui suit
+c
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c noarst : noarst(i) numero d'une arete de sommet i
+c
+c n1arcf : numero d'une arete de chaque contour ferme
+c noarcf : numero du sommet , numero de l'arete suivante
+c numero de l'arete dans le tableau nosoar
+c attention : chainage circulaire des aretes
+c
+c sortie :
+c --------
+c nbcf : nombre actuel de cf apres ajout du triangle
+c nt : numero du triangle ajoute dans noartr
+c 0 si saturation du tableau nosoar ou noartr ou noarcf ou n1arcf
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c2345x7..............................................................012
+ integer nosoar(mosoar,*),
+ % noartr(moartr,*),
+ % noarst(*),
+ % n1arcf(0:mxarcf),
+ % noarcf(3,mxarcf)
+c
+c combien y a t il d'aretes nbascf sur le cf ?
+c ============================================
+c la premiere arete est elle sur le cf?
+ if( noarcf(2,na1) .eq. na2 ) then
+c la 1-ere arete est sur le cf
+ na1cf = 1
+ else
+c la 1-ere arete n'est pas sur le cf
+ na1cf = 0
+ endif
+c
+c la seconde arete est elle sur le cf?
+ if( noarcf(2,na2) .eq. na3 ) then
+c la 2-eme arete est sur le cf
+ na2cf = 1
+ else
+ na2cf = 0
+ endif
+c
+c la troisieme arete est elle sur le cf?
+ if( noarcf(2,na3) .eq. na1 ) then
+c la 3-eme arete est sur le cf
+ na3cf = 1
+ else
+ na3cf = 0
+ endif
+c
+c le nombre d'aretes sur le cf
+ nbascf = na1cf + na2cf + na3cf
+c
+c traitement selon le nombre d'aretes sur le cf
+c =============================================
+ if( nbascf .eq. 3 ) then
+c
+c le contour ferme se reduit a un triangle avec 3 aretes sur le cf
+c ----------------------------------------------------------------
+c ajout dans noartr de ce nouveau triangle
+ call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
+ % noarcf(3,na1), noarcf(3,na2), noarcf(3,na3),
+ % mosoar, nosoar,
+ % moartr, n1artr, noartr,
+ % nt )
+ if( nt .le. 0 ) return
+c
+c le cf est supprime et chaine vide
+ noarcf(2,na3) = n1arcf(0)
+ n1arcf( 0 ) = na1
+c
+c ce cf a ete traite => un cf de moins a traiter
+ nbcf = nbcf - 1
+c
+ else if( nbascf .eq. 2 ) then
+c
+c le triangle a 2 aretes sur le contour
+c -------------------------------------
+c les 2 aretes sont la 1-ere et 2-eme du triangle
+ if( na1cf .eq. 0 ) then
+c l'arete 1 n'est pas sur le cf
+ naa1 = na2
+ else if( na2cf .eq. 0 ) then
+c l'arete 2 n'est pas sur le cf
+ naa1 = na3
+ else
+c l'arete 3 n'est pas sur le cf
+ naa1 = na1
+ endif
+c le triangle oppose a l'arete 3 est inconnu
+c modification du contour apres integration du
+c triangle ayant ses 2-eres aretes sur le cf
+ call trcf2a( nbcf, naa1, naor3,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr, noarst,
+ % n1arcf, noarcf, nt )
+c
+ else if( nbascf .eq. 1 ) then
+c
+c le triangle a 1 arete sur le contour
+c ------------------------------------
+c cette arete est la seconde du triangle
+ if( na3cf .ne. 0 ) then
+c l'arete 3 est sur le cf
+ naa01 = na02
+ naa1 = na2
+ naa2 = na3
+ else if( na1cf .ne. 0 ) then
+c l'arete 1 est sur le cf
+ naa01 = na03
+ naa1 = na3
+ naa2 = na1
+ else
+c l'arete 2 est sur le cf
+ naa01 = na01
+ naa1 = na1
+ naa2 = na2
+ endif
+c le triangle oppose a l'arete 1 et 3 est inconnu
+c modification du contour apres integration du
+c triangle ayant 1 arete sur le cf avec creation
+c d'un nouveau contour ferme
+ call trcf1a( nbcf, naa01, naa1, naa2, naor1, naor3,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr, noarst,
+ % mxarcf, n1arcf, noarcf, nt )
+c
+ else
+c
+c le triangle a 0 arete sur le contour
+c ------------------------------------
+c modification du contour apres integration du
+c triangle ayant 0 arete sur le cf avec creation
+c de 2 nouveaux contours fermes
+ call trcf0a( nbcf, na01, na1, na2, na3,
+ % naa1, naa2, naa01,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr, noarst,
+ % mxarcf, n1arcf, noarcf, nt )
+ endif
+ end
+
+
+ subroutine tridcf( nbcf0, pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr,
+ % mxarcf, n1arcf, noarcf, larmin,
+ % nbtrcf, notrcf, ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : triangulation directe de nbcf0 contours fermes (cf)
+c ----- definis par la liste circulaire de leurs aretes peripheriques
+c
+c entrees:
+c --------
+c nbcf0 : nombre initial de cf a trianguler
+c pxyd : tableau des coordonnees 2d des points
+c par point : x y distance_souhaitee
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c attention: mxsoar>3*mxsomm obligatoire!
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxarcf : nombre maximal d'aretes declarables dans noarcf, n1arcf, larmin, not
+c
+c modifies:
+c ---------
+c noarst : noarst(i) numero d'une arete de sommet i
+c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
+c chainage des vides suivant en 3 et precedant en 2 de nosoar
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = nosoar(1)+nosoar(2)*2
+c avec mxsoar>=3*mxsomm
+c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
+c nosoar(2,arete vide)=l'arete vide qui precede
+c nosoar(3,arete vide)=l'arete vide qui suit
+c
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c
+c n1arcf : numero de la premiere arete de chacun des nbcf0 cf
+c n1arcf(0) no de la premiere arete vide du tableau noarcf
+c noarcf(2,i) no de l'arete suivante
+c noarcf : numero du sommet , numero de l'arete suivante du cf
+c numero de l'arete dans le tableau nosoar
+c
+c auxiliaires :
+c -------------
+c larmin : tableau (mxarcf) auxiliaire
+c stocker la liste des numeros des meilleures aretes
+c lors de la selection du meilleur sommet du cf a trianguler
+c cf le sp trchtd
+c
+c sortie :
+c --------
+c nbtrcf : nombre de triangles des nbcf0 cf
+c notrcf : numero des triangles des nbcf0 cf dans le tableau noartr
+c ierr : 0 si pas d'erreur
+c 2 saturation de l'un des des tableaux nosoar, noartr, ...
+c 3 si contour ferme reduit a moins de 3 aretes
+c 4 saturation du tableau notrcf
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+ common / unites / lecteu, imprim, nunite(30)
+ double precision pxyd(3,*)
+ integer noartr(moartr,*),
+ % nosoar(mosoar,mxsoar),
+ % noarst(*),
+ % n1arcf(0:mxarcf),
+ % noarcf(3,mxarcf),
+ % larmin(mxarcf),
+ % notrcf(mxarcf)
+c
+ccc integer nosotr(3)
+ccc double precision d, surtd2
+c
+c depart avec nbcf0 cf a trianguler
+ nbcf = nbcf0
+c
+c le nombre de triangles formes dans l'ensemble des cf
+ nbtrcf = 0
+c
+c tant qu'il existe un cf a trianguler faire
+c la triangulation directe du cf
+c ==========================================
+ 10 if( nbcf .gt. 0 ) then
+c
+c le cf en haut de pile a pour premiere arete
+ na01 = n1arcf( nbcf )
+ na1 = noarcf( 2, na01 )
+c
+c choix du sommet du cf a relier a l'arete na1
+c --------------------------------------------
+ call trchtd( pxyd, na01, na1, noarcf,
+ % na03, na3, larmin )
+ if( na3 .eq. 0 ) then
+ ierr = 3
+ return
+ endif
+c
+c l'arete suivante de na1
+ na02 = na1
+ na2 = noarcf( 2, na1 )
+c
+c formation du triangle arete na1 - sommet noarcf(1,na3)
+c ------------------------------------------------------
+ call trcf3s( nbcf, na01, na1, na02, na2, na03, na3,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr, noarst,
+ % mxarcf, n1arcf, noarcf, nt )
+ if( nt .le. 0 ) then
+c saturation du tableau noartr ou noarcf ou n1arcf
+ ierr = 2
+ return
+ endif
+c
+c ajout du triangle cree a sa pile
+ if( nbtrcf .ge. mxarcf ) then
+ write(imprim,*) 'saturation du tableau notrcf'
+ ierr = 4
+ return
+ endif
+ nbtrcf = nbtrcf + 1
+ notrcf( nbtrcf ) = nt
+ goto 10
+ endif
+c
+c mise a jour du chainage des triangles des aretes
+c ================================================
+ do 30 ntp0 = 1, nbtrcf
+c
+c le numero du triangle ajoute dans le tableau noartr
+ nt0 = notrcf( ntp0 )
+c
+cccc aire signee du triangle nt0
+cccc le numero des 3 sommets du triangle nt
+ccc call nusotr( nt0, mosoar, nosoar, moartr, noartr,
+ccc % nosotr )
+ccc d = surtd2( pxyd(1,nosotr(1)), pxyd(1,nosotr(2)),
+ccc % pxyd(1,nosotr(3)) )
+ccc if( d .le. 0 ) then
+cccc
+cccc un triangle d'aire negative de plus
+ccc write(imprim,*) 'triangle ',nt0,' st:',nosotr,
+ccc % ' d aire ',d,'<=0'
+ccc pause
+ccc endif
+c
+cccc trace du triangle nt0
+ccc call mttrtr( pxyd, nt0, moartr, noartr, mosoar, nosoar,
+ccc % ncturq, ncblan )
+c
+c boucle sur les 3 aretes du triangle
+ do 20 i=1,3
+c
+c le numero de l'arete i du triangle dans le tableau nosoar
+ noar = abs( noartr(i,nt0) )
+c
+c ce triangle est il deja chaine dans cette arete?
+ nt1 = nosoar(4,noar)
+ nt2 = nosoar(5,noar)
+ if( nt1 .eq. nt0 .or. nt2 .eq. nt0 ) goto 20
+c
+c ajout de ce triangle nt0 a l'arete noar
+ if( nt1 .le. 0 ) then
+c le triangle est ajoute a l'arete
+ nosoar( 4, noar ) = nt0
+ else if( nt2 .le. 0 ) then
+c le triangle est ajoute a l'arete
+ nosoar( 5, noar ) = nt0
+ else
+c l'arete appartient a 2 triangles differents de nt0
+c anomalie. chainage des triangles des aretes defectueux
+c a corriger
+ write(imprim,*) 'pause dans tridcf'
+ pause
+ ierr = 5
+ return
+ endif
+c
+ 20 continue
+c
+ 30 continue
+ end
+
+
+ subroutine te1stm( nsasup, pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % mxarcf, n1arcf, noarcf, larmin, notrcf, liarcf,
+ % ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : supprimer de la triangulation le sommet nsasup qui doit
+c ----- etre un sommet interne ("centre" d'une boule de triangles)
+c
+c attention: le chainage lchain de nosoar devient celui des cf
+c
+c entrees:
+c --------
+c nsasup : numero dans le tableau pxyd du sommet a supprimer
+c pxyd : tableau des coordonnees 2d des points
+c par point : x y distance_souhaitee
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c attention: mxsoar>3*mxsomm obligatoire!
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
+c
+c modifies:
+c ---------
+c noarst : noarst(i) numero d'une arete de sommet i
+c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
+c chainage des vides suivant en 3 et precedant en 2 de nosoar
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = nosoar(1)+nosoar(2)*2
+c avec mxsoar>=3*mxsomm
+c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
+c nosoar(2,arete vide)=l'arete vide qui precede
+c nosoar(3,arete vide)=l'arete vide qui suit
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c
+c
+c auxiliaires :
+c -------------
+c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
+c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
+c larmin : tableau ( mxarcf ) auxiliaire d'entiers
+c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
+c liarcf : tableau ( mxarcf ) auxiliaire d'entiers
+c
+c sortie :
+c --------
+c ierr : =0 si pas d'erreur
+c -1 le sommet a supprimer n'est pas le centre d'une boule
+c de triangles. il est suppose externe
+c ou bien le sommet est centre d'un cf dont toutes les
+c aretes sont frontalieres
+c dans les 2 cas => retour sans modifs
+c >0 si une erreur est survenue
+c =11 algorithme defaillant
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+ parameter ( lchain=6, quamal=0.3)
+ common / unites / lecteu,imprim,intera,nunite(29)
+ double precision pxyd(3,*)
+ integer nosoar(mosoar,mxsoar),
+ % noartr(moartr,*),
+ % noarst(*),
+ % n1arcf(0:mxarcf),
+ % noarcf(3,mxarcf),
+ % larmin(mxarcf),
+ % notrcf(mxarcf),
+ % liarcf(mxarcf)
+c
+c nsasup est il un sommet interne, "centre" d'une boule de triangles?
+c => le sommet nsasup peut etre supprime
+c ===================================================================
+c formation du cf de ''centre'' le sommet nsasup
+ call trp1st( nsasup, noarst, mosoar, nosoar,
+ % moartr, noartr,
+ % mxarcf, nbtrcf, notrcf )
+ if( nbtrcf .le. 0 ) then
+c erreur: impossible de trouver tous les triangles de sommet nsasup
+c le sommet nsasup n'est pas supprime de la triangulation
+ ierr = -1
+ return
+ else if( nbtrcf .le. 2 ) then
+c le sommet nsasup n'est pas supprime
+ ierr = -1
+ return
+ endif
+ if( nbtrcf*3 .gt. mxarcf ) then
+ write(imprim,*) 'saturation du tableau noarcf'
+ ierr = 10
+ return
+ endif
+c
+ccc trace des triangles de l'etoile du sommet nsasup
+ccc call trpltr( nbtrcf, notrcf, pxyd,
+ccc % moartr, noartr, mosoar, nosoar,
+ccc % ncroug, ncblan )
+c
+c si toutes les aretes du cf sont frontalieres, alors il est
+c interdit de detruire le sommet "centre" du cf
+c calcul du nombre nbarfr des aretes simples des nbtrcf triangles
+ call trfrcf( nsasup, mosoar, nosoar, moartr, noartr,
+ % nbtrcf, notrcf, nbarfr )
+ if( nbarfr .ge. nbtrcf ) then
+c toutes les aretes simples sont frontalieres
+c le sommet nsasup ("centre" de la cavite) n'est pas supprime
+ ierr = -1
+ return
+ endif
+c
+c formation du contour ferme (liste chainee des aretes simples)
+c forme a partir des aretes des triangles de l'etoile du sommet nsasup
+ call focftr( nbtrcf, notrcf, pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr,
+ % nbarcf, n1arcf, noarcf,
+ % ierr )
+ if( ierr .ne. 0 ) return
+c
+c ici le sommet nsasup appartient a aucune arete
+ noarst( nsasup ) = 0
+c
+c chainage des aretes vides dans le tableau noarcf
+ n1arcf(0) = nbarcf+1
+ mmarcf = min(8*nbarcf,mxarcf)
+ do 40 i=nbarcf+1,mmarcf
+ noarcf(2,i) = i+1
+ 40 continue
+ noarcf(2,mmarcf) = 0
+c
+c sauvegarde du chainage des aretes peripheriques
+c pour la mise en delaunay du maillage
+ nbcf = n1arcf(1)
+ do 50 i=1,nbarcf
+c le numero de l'arete dans le tableau nosoar
+ liarcf( i ) = noarcf( 3, nbcf )
+c l'arete suivante dans le cf
+ nbcf = noarcf( 2, nbcf )
+ 50 continue
+c
+c triangulation directe du contour ferme sans le sommet nsasup
+c ============================================================
+ nbcf = 1
+ call tridcf( nbcf, pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr,
+ % mxarcf, n1arcf, noarcf, larmin,
+ % nbtrcf, notrcf, ierr )
+ if( ierr .ne. 0 ) return
+c
+c transformation des triangles du cf en triangles delaunay
+c ========================================================
+c construction du chainage lchain dans nosoar
+c des aretes peripheriques du cf a partir de la sauvegarde liarcf
+ noar0 = liarcf(1)
+ do 60 i=2,nbarcf
+c le numero de l'arete peripherique du cf dans nosoar
+ noar = liarcf( i )
+ if( nosoar(3,noar) .le. 0 ) then
+c arete interne => elle est chainee a partir de la precedente
+ nosoar( lchain, noar0 ) = noar
+ noar0 = noar
+ endif
+ 60 continue
+c la derniere arete peripherique n'a pas de suivante
+ nosoar(lchain,noar0) = 0
+c
+c mise en delaunay des aretes chainees
+ call tedela( pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar, liarcf(1),
+ % moartr, mxartr, n1artr, noartr, modifs )
+ccc write(imprim,*) 'nombre echanges diagonales =',modifs
+ return
+ end
+
+
+ subroutine tr3str( np, nt,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % noarst,
+ % nutr, ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : former les 3 sous-triangles du triangle nt a partir
+c ----- du point interne np
+c
+c entrees:
+c --------
+c np : numero dans le tableau pxyd du point
+c nt : numero dans le tableau noartr du triangle a trianguler
+c mosoar : nombre maximal d'entiers par arete du tableau nosoar
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxartr : nombre maximal de triangles stockables dans le tableau noartr
+c
+c modifies:
+c ---------
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c une arete i de nosoar est vide <=> nosoar(1,i)=0
+c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages
+c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
+c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c noarst : noarst(i) numero d'une arete de sommet i
+c
+c sorties:
+c --------
+c nutr : le numero des 3 sous-triangles du triangle nt
+c nt : en sortie le triangle initial n'est plus actif dans noartr
+c c'est en fait le premier triangle vide de noartr
+c ierr : =0 si pas d'erreur
+c =1 si le tableau nosoar est sature
+c =2 si le tableau noartr est sature
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+ integer nosoar(mosoar,mxsoar),
+ % noartr(moartr,mxartr),
+ % noarst(*),
+ % nutr(3)
+c
+ integer nosotr(3), nu2sar(2), nuarco(3)
+c
+c reservation des 3 nouveaux triangles dans le tableau noartr
+c ===========================================================
+ do 10 i=1,3
+c le numero du sous-triangle i dans le tableau noartr
+ if( n1artr .le. 0 ) then
+c tableau noartr sature
+ ierr = 2
+ return
+ endif
+ nutr(i) = n1artr
+c le nouveau premier triangle libre dans noartr
+ n1artr = noartr(2,n1artr)
+ 10 continue
+c
+c les numeros des 3 sommets du triangle nt
+ call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
+c
+c formation des 3 aretes nosotr(i)-np dans le tableau nosoar
+c ==========================================================
+ nt0 = nutr(3)
+ do 20 i=1,3
+c
+c le triangle a creer
+ nti = nutr(i)
+c
+c les 2 sommets du cote i du triangle nosotr
+ nu2sar(1) = nosotr(i)
+ nu2sar(2) = np
+ call hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar, noar )
+c en sortie: noar>0 => no arete retrouvee
+c <0 => no arete ajoutee
+c =0 => saturation du tableau nosoar
+c
+ if( noar .eq. 0 ) then
+c saturation du tableau nosoar
+ ierr = 1
+ return
+ else if( noar .lt. 0 ) then
+c l'arete a ete ajoutee. initialisation des autres informations
+ noar = -noar
+c le numero des 2 sommets a ete initialise par hasoar
+c et (nosoar(1,noar)<nosoar(2,noar))
+c le numero de la ligne de l'arete: ici arete interne
+ nosoar(3,noar) = 0
+c else
+c l'arete a ete retrouvee
+c le numero des 2 sommets a ete retrouve par hasoar
+c et (nosoar(1,noar)<nosoar(2,noar))
+c le numero de ligne reste inchange
+ endif
+c
+c le triangle 1 de l'arete noar => le triangle nt0
+ nosoar(4,noar) = nt0
+c le triangle 2 de l'arete noar => le triangle nti
+ nosoar(5,noar) = nti
+c
+c le sommet nosotr(i) appartient a l'arete noar
+ noarst( nosotr(i) ) = noar
+c
+c le numero d'arete nosotr(i)-np
+ nuarco(i) = noar
+c
+c le triangle qui precede le suivant
+ nt0 = nti
+ 20 continue
+c
+c le numero d'une arete du point np
+ noarst( np ) = noar
+c
+c les 3 sous-triangles du triangle nt sont formes dans le tableau noartr
+c ======================================================================
+ do 30 i=1,3
+c
+c le numero suivant i => i mod 3 + 1
+ if( i .ne. 3 ) then
+ i1 = i + 1
+ else
+ i1 = 1
+ endif
+c
+c le numero dans noartr du sous-triangle a ajouter
+ nti = nutr( i )
+c
+c le numero de l'arete i du triangle initial nt
+c est l'arete 1 du sous-triangle i
+ noar = noartr(i,nt)
+ noartr( 1, nti ) = noar
+c
+c mise a jour du numero de triangle de cette arete
+ noar = abs( noar )
+ if( nosoar(4,noar) .eq. nt ) then
+c le sous-triangle nti remplace le triangle nt
+ nosoar(4,noar) = nti
+ else
+c le sous-triangle nti remplace le triangle nt
+ nosoar(5,noar) = nti
+ endif
+c
+c l'arete 2 du sous-triangle i est l'arete i1 ajoutee
+ if( nosotr(i1) .eq. nosoar(1,nuarco(i1)) ) then
+c l'arete ns i1-np dans nosoar est dans le sens direct
+ noartr( 2, nti ) = nuarco(i1)
+ else
+c l'arete ns i1-np dans nosoar est dans le sens indirect
+ noartr( 2, nti ) = -nuarco(i1)
+ endif
+c
+c l'arete 3 du sous-triangle i est l'arete i ajoutee
+ if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
+c l'arete ns i1-np dans nosoar est dans le sens indirect
+ noartr( 3, nti ) = -nuarco(i)
+ else
+c l'arete ns i1-np dans nosoar est dans le sens direct
+ noartr( 3, nti ) = nuarco(i)
+ endif
+ 30 continue
+c
+c le triangle nt est rendu libre
+c ==============================
+c il devient n1artr le premier triangle libre
+ noartr( 1, nt ) = 0
+ noartr( 2, nt ) = n1artr
+ n1artr = nt
+ end
+
+
+ subroutine mt4sqa( na, moartr, noartr, mosoar, nosoar,
+ % ns1, ns2, ns3, ns4)
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : calcul du numero des 4 sommets de l'arete na de nosoar
+c ----- formant un quadrangle
+c
+c entrees:
+c --------
+c na : numero de l'arete dans nosoar a traiter
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1=0 si triangle vide => arete2=triangle vide suivant
+c mosoar : nombre maximal d'entiers par arete
+c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
+c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
+c
+c sorties:
+c --------
+c ns1,ns2,ns3 : les 3 numeros des sommets du triangle t1 en sens direct
+c ns1,ns4,ns2 : les 3 numeros des sommets du triangle t2 en sens direct
+c
+c si erreur rencontree => ns4 = 0
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c2345x7..............................................................012
+ common / unites / lecteu, imprim, nunite(30)
+ integer noartr(moartr,*), nosoar(mosoar,*)
+c
+c le numero de triangle est il correct ?
+c a supprimer apres mise au point
+ if( na .le. 0 ) then
+c nblgrc(nrerr) = 1
+c write(kerr(mxlger)(1:6),'(i6)') na
+c kerr(1) = kerr(mxlger)(1:6) //
+c % ' no incorrect arete dans nosoar'
+c call lereur
+ write(imprim,*) na, ' no incorrect arete dans nosoar'
+ ns4 = 0
+ return
+ endif
+c
+ if( nosoar(1,na) .le. 0 ) then
+c nblgrc(nrerr) = 1
+c write(kerr(mxlger)(1:6),'(i6)') na
+c kerr(1) = kerr(mxlger)(1:6) //
+c % ' arete non active dans nosoar'
+c call lereur
+ write(imprim,*) na, ' arete non active dans nosoar'
+ ns4 = 0
+ return
+ endif
+c
+c recherche de l'arete na dans le premier triangle
+ nt = nosoar(4,na)
+ if( nt .le. 0 ) then
+c nblgrc(nrerr) = 1
+c write(kerr(mxlger)(1:6),'(i6)') na
+c kerr(1) = 'triangle 1 incorrect pour l''arete ' //
+c % kerr(mxlger)(1:6)
+c call lereur
+ write(imprim,*) 'triangle 1 incorrect pour l''arete ', na
+ ns4 = 0
+ return
+ endif
+c
+ do 5 i=1,3
+ if( abs( noartr(i,nt) ) .eq. na ) goto 8
+ 5 continue
+c si arrivee ici => bogue avant
+ write(imprim,*) 'mt4sqa: arete',na,' non dans le triangle',nt
+ ns4 = 0
+ return
+c
+c les 2 sommets de l'arete na
+ 8 if( noartr(i,nt) .gt. 0 ) then
+ ns1 = 1
+ ns2 = 2
+ else
+ ns1 = 2
+ ns2 = 1
+ endif
+ ns1 = nosoar(ns1,na)
+ ns2 = nosoar(ns2,na)
+c
+c l'arete suivante
+ if( i .lt. 3 ) then
+ i = i + 1
+ else
+ i = 1
+ endif
+ naa = abs( noartr(i,nt) )
+c
+c le sommet ns3 du triangle 123
+ ns3 = nosoar(1,naa)
+ if( ns3 .eq. ns1 .or. ns3 .eq. ns2 ) then
+ ns3 = nosoar(2,naa)
+ endif
+c
+c le triangle de l'autre cote de l'arete na
+c =========================================
+ nt = nosoar(5,na)
+ if( nt .le. 0 ) then
+c nblgrc(nrerr) = 1
+c write(kerr(mxlger)(1:6),'(i6)') na
+c kerr(1) = 'triangle 2 incorrect pour l''arete ' //
+c % kerr(mxlger)(1:6)
+c call lereur
+ write(imprim,*) 'triangle 2 incorrect pour l''arete ',na
+ ns4 = 0
+ return
+ endif
+c
+c le numero de l'arete naa du triangle nt
+ naa = abs( noartr(1,nt) )
+ if( naa .eq. na ) naa = abs( noartr(2,nt) )
+ ns4 = nosoar(1,naa)
+ if( ns4 .eq. ns1 .or. ns4 .eq. ns2 ) then
+ ns4 = nosoar(2,naa)
+ endif
+ end
+
+
+ subroutine te2t2t( noaret, mosoar, n1soar, nosoar, noarst,
+ % moartr, noartr, noar34 )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : echanger la diagonale des 2 triangles ayant en commun
+c ----- l'arete noaret du tableau nosoar si c'est possible
+c
+c entrees:
+c --------
+c noaret : numero de l'arete a echanger entre les 2 triangles
+c mosoar : nombre maximal d'entiers par arete
+c moartr : nombre maximal d'entiers par triangle
+c
+c modifies :
+c ----------
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
+c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
+c noarst : noarst(i) numero d'une arete de sommet i
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c
+c sortie :
+c --------
+c noar34 : numero nosoar de la nouvelle arete diagonale
+c 0 si pas d'echange des aretes diagonales
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc avril 1997
+c....................................................................012
+ integer nosoar(mosoar,*),
+ % noartr(moartr,*),
+ % noarst(*)
+c
+c une arete frontaliere ne peut etre echangee
+ noar34 = 0
+ if( nosoar(3,noaret) .gt. 0 ) return
+c
+c les 4 sommets des 2 triangles ayant l'arete noaret en commun
+ call mt4sqa( noaret, moartr, noartr, mosoar, nosoar,
+ % ns1, ns2, ns3, ns4)
+c ns1,ns2,ns3 : les 3 numeros des sommets du triangle nt1 en sens direct
+c ns1,ns4,ns2 : les 3 numeros des sommets du triangle nt2 en sens direct
+c
+c recherche du numero de l'arete noaret dans le triangle nt1
+ nt1 = nosoar(4,noaret)
+ do 10 n1 = 1, 3
+ if( abs(noartr(n1,nt1)) .eq. noaret ) goto 15
+ 10 continue
+c impossible d'arriver ici sans bogue!
+ write(imprim,*) 'pause dans te2t2t 1'
+ pause
+c
+c l'arete de sommets 2 et 3
+ 15 if( n1 .lt. 3 ) then
+ n2 = n1 + 1
+ else
+ n2 = 1
+ endif
+ na23 = noartr(n2,nt1)
+c
+c l'arete de sommets 3 et 1
+ if( n2 .lt. 3 ) then
+ n3 = n2 + 1
+ else
+ n3 = 1
+ endif
+ na31 = noartr(n3,nt1)
+c
+c recherche du numero de l'arete noaret dans le triangle nt2
+ nt2 = nosoar(5,noaret)
+ do 20 n1 = 1, 3
+ if( abs(noartr(n1,nt2)) .eq. noaret ) goto 25
+ 20 continue
+c impossible d'arriver ici sans bogue!
+ write(imprim,*) 'pause dans te2t2t 2'
+ pause
+c
+c l'arete de sommets 1 et 4
+ 25 if( n1 .lt. 3 ) then
+ n2 = n1 + 1
+ else
+ n2 = 1
+ endif
+ na14 = noartr(n2,nt2)
+c
+c l'arete de sommets 4 et 2
+ if( n2 .lt. 3 ) then
+ n3 = n2 + 1
+ else
+ n3 = 1
+ endif
+ na42 = noartr(n3,nt2)
+c
+c les triangles 123 142 deviennent 143 234
+c ========================================
+c ajout de l'arete ns3-ns4
+c on evite l'affichage de l'erreur
+ ierr = -1
+ call fasoar( ns3, ns4, nt1, nt2, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % noar34, ierr )
+ if( ierr .gt. 0 ) then
+c ierr=1 si le tableau nosoar est sature
+c =2 si arete a creer et appartenant a 2 triangles distincts
+c des triangles nt1 et nt2
+c =3 si arete appartenant a 2 triangles distincts
+c differents des triangles nt1 et nt2
+c =4 si arete appartenant a 2 triangles distincts
+c dont le second n'est pas le triangle nt2
+c => pas d'echange
+ noar34 = 0
+ return
+ endif
+c
+c suppression de l'arete noaret
+ call sasoar( noaret, mosoar, mxsoar, n1soar, nosoar )
+c
+c nt1 = triangle 143
+ noartr(1,nt1) = na14
+c sens de stockage de l'arete ns3-ns4 dans nosoar?
+ if( nosoar(1,noar34) .eq. ns3 ) then
+ n1 = -1
+ else
+ n1 = 1
+ endif
+ noartr(2,nt1) = noar34 * n1
+ noartr(3,nt1) = na31
+c
+c nt2 = triangle 234
+ noartr(1,nt2) = na23
+ noartr(2,nt2) = -noar34 * n1
+ noartr(3,nt2) = na42
+c
+c echange nt1 -> nt2 pour l'arete na23
+ na23 = abs( na23 )
+ if( nosoar(4,na23) .eq. nt1 ) then
+ n1 = 4
+ else
+ n1 = 5
+ endif
+ nosoar(n1,na23) = nt2
+c
+c echange nt2 -> nt1 pour l'arete na14
+ na14 = abs( na14 )
+ if( nosoar(4,na14) .eq. nt2 ) then
+ n1 = 4
+ else
+ n1 = 5
+ endif
+ nosoar(n1,na14) = nt1
+c
+c numero d'une arete de chacun des 4 sommets
+ noarst(ns1) = na14
+ noarst(ns2) = na23
+ noarst(ns3) = noar34
+ noarst(ns4) = noar34
+ end
+
+
+
+ subroutine f0trte( letree, pxyd,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % noarst,
+ % nbtr, nutr, ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : former le ou les triangles du triangle equilateral letree
+c ----- les points internes au te deviennent des sommets des
+c sous-triangles du te
+c
+c entrees:
+c --------
+c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
+c si letree(0)>0 alors
+c letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
+c sinon
+c letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
+c 0 si pas de point
+c ( le te est une feuille de l'arbre )
+c letree(4) : no letree du sur-triangle du triangle j
+c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
+c letree(6:8) : no pxyd des 3 sommets du triangle j
+c pxyd : tableau des x y distance_souhaitee de chaque sommet
+c mosoar : nombre maximal d'entiers par arete du tableau nosoar
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxartr : nombre maximal de triangles stockables dans le tableau noartr
+c
+c modifies:
+c ---------
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c une arete i de nosoar est vide <=> nosoar(1,i)=0
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
+c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c noarst : noarst(i) numero d'une arete de sommet i
+c
+c sorties:
+c --------
+c nbtr : nombre de sous-triangles du te, triangulation du te
+c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
+c ierr : =0 si pas d'erreur
+c =1 si le tableau nosoar est sature
+c =2 si le tableau noartr est sature
+c =3 si aucun des triangles ne contient l'un des points internes au te
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+ common / unites / lecteu, imprim, nunite(30)
+ double precision pxyd(3,*)
+ integer letree(0:8),
+ % nosoar(mosoar,mxsoar),
+ % noartr(moartr,mxartr),
+ % noarst(*),
+ % nutr(1:nbtr)
+ integer nuarco(3)
+c
+c le numero nt du triangle dans le tableau noartr
+ if( n1artr .le. 0 ) then
+c tableau noartr sature
+ write(imprim,*) 'f0trte: tableau noartr sature'
+ ierr = 2
+ return
+ endif
+ nt = n1artr
+c le numero du nouveau premier triangle libre dans noartr
+ n1artr = noartr( 2, n1artr )
+c
+c formation du triangle = le triangle equilateral letree
+ do 10 i=1,3
+ if( i .ne. 3 ) then
+ i1 = i + 1
+ else
+ i1 = 1
+ endif
+c ajout eventuel de l'arete si si+1 dans le tableau nosoar
+ call fasoar( letree(5+i), letree(5+i1), nt, -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % nuarco(i), ierr )
+ if( ierr .ne. 0 ) return
+ 10 continue
+c
+c le triangle nt est forme dans le tableau noartr
+ do 20 i=1,3
+c letree(5+i) est le numero du sommet 1 de l'arete i du te
+ if( letree(5+i) .eq. nosoar(1,nuarco(i)) ) then
+ lesign = 1
+ else
+ lesign = -1
+ endif
+c l'arete ns1-ns2 dans nosoar est celle du cote du te
+ noartr( i, nt ) = lesign * nuarco(i)
+ 20 continue
+c
+c triangulation du te=triangle nt par ajout des points internes du te
+ nbtr = 1
+ nutr(1) = nt
+ call trpite( letree, pxyd,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr, noarst,
+ % nbtr, nutr, ierr )
+ end
+
+
+ subroutine f1trte( letree, pxyd, milieu,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % noarst,
+ % nbtr, nutr, ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : former les triangles du triangle equilateral letree
+c ----- a partir de l'un des 3 milieux des cotes du te
+c et des points internes au te
+c ils deviennent tous des sommets des sous-triangles du te
+c
+c entrees:
+c --------
+c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
+c si letree(0)>0 alors
+c letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
+c sinon
+c letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
+c 0 si pas de point
+c ( le te est une feuille de l'arbre )
+c letree(4) : no letree du sur-triangle du triangle j
+c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
+c letree(6:8) : no pxyd des 3 sommets du triangle j
+c pxyd : tableau des x y distance_souhaitee de chaque sommet
+c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
+c 0 si pas de milieu du cote i a ajouter
+c mosoar : nombre maximal d'entiers par arete du tableau nosoar
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxartr : nombre maximal de triangles stockables dans le tableau noartr
+c
+c modifies:
+c ---------
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c une arete i de nosoar est vide <=> nosoar(1,i)=0
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
+c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c noarst : noarst(np) numero d'une arete du sommet np
+c
+c sorties:
+c --------
+c nbtr : nombre de sous-triangles du te, triangulation du te
+c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
+c ierr : =0 si pas d'erreur
+c =1 si le tableau nosoar est sature
+c =2 si le tableau noartr est sature
+c =3 si aucun des triangles ne contient l'un des points internes au te
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+ double precision pxyd(3,*)
+ integer letree(0:8),
+ % milieu(3),
+ % nosoar(mosoar,mxsoar),
+ % noartr(moartr,mxartr),
+ % noarst(*),
+ % nutr(1:nbtr)
+c
+ integer nosotr(3), nuarco(5)
+c
+c le numero des 2 triangles (=2 demi te) a creer dans le tableau noartr
+ do 5 nbtr=1,2
+ if( n1artr .le. 0 ) then
+c tableau noartr sature
+ ierr = 2
+ return
+ endif
+ nutr(nbtr) = n1artr
+c le nouveau premier triangle libre dans noartr
+ n1artr = noartr(2,n1artr)
+ 5 continue
+ nbtr = 2
+c
+c recherche du milieu a creer
+ do 7 i=1,3
+ if( milieu(i) .ne. 0 ) goto 9
+ 7 continue
+c le numero pxyd du point milieu du cote i
+ 9 nm = milieu( i )
+c
+c on se ramene au seul cas i=3 c-a-d le milieu est sur le cote 3
+ if( i .eq. 1 ) then
+c milieu sur le cote 1
+ nosotr(1) = letree(7)
+ nosotr(2) = letree(8)
+ nosotr(3) = letree(6)
+ else if( i .eq. 2 ) then
+c milieu sur le cote 2
+ nosotr(1) = letree(8)
+ nosotr(2) = letree(6)
+ nosotr(3) = letree(7)
+ else
+c milieu sur le cote 3
+ nosotr(1) = letree(6)
+ nosotr(2) = letree(7)
+ nosotr(3) = letree(8)
+ endif
+c
+c formation des 2 aretes s1 s2 et s2 s3
+ do 10 i=1,2
+ if( i .ne. 3 ) then
+ i1 = i + 1
+ else
+ i1 = 1
+ endif
+c ajout eventuel de l'arete dans nosoar
+ call fasoar( nosotr(i), nosotr(i1), nutr(i), -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % nuarco(i), ierr )
+ if( ierr .ne. 0 ) return
+ 10 continue
+c
+c ajout eventuel de l'arete s3 milieu dans nosoar
+ call fasoar( nosotr(3), nm, nutr(2), -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % nuarco(3), ierr )
+ if( ierr .ne. 0 ) return
+c
+c ajout eventuel de l'arete milieu s1 dans nosoar
+ call fasoar( nosotr(1), nm, nutr(1), -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % nuarco(4), ierr )
+ if( ierr .ne. 0 ) return
+c
+c ajout eventuel de l'arete milieu s2 dans nosoar
+ call fasoar( nosotr(2), nm, nutr(1), nutr(2), 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % nuarco(5), ierr )
+ if( ierr .ne. 0 ) return
+c
+c les aretes s1 s2 et s2 s3 dans le tableau noartr
+ do 20 i=1,2
+c nosotr(i) est le numero du sommet 1 de l'arete i du te
+ if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
+ lesign = 1
+ else
+ lesign = -1
+ endif
+c l'arete ns1-ns2 dans nosoar est celle du cote du te
+ noartr( 1, nutr(i) ) = lesign * nuarco(i)
+ 20 continue
+c
+c l'arete mediane s2 milieu
+ if( nm .eq. nosoar(1,nuarco(5)) ) then
+ lesign = -1
+ else
+ lesign = 1
+ endif
+ noartr( 2, nutr(1) ) = lesign * nuarco(5)
+ noartr( 3, nutr(2) ) = -lesign * nuarco(5)
+c
+c l'arete s1 milieu
+ if( nm .eq. nosoar(1,nuarco(4)) ) then
+ lesign = 1
+ else
+ lesign = -1
+ endif
+ noartr( 3, nutr(1) ) = lesign * nuarco(4)
+c
+c l'arete s3 milieu
+ if( nm .eq. nosoar(1,nuarco(3)) ) then
+ lesign = -1
+ else
+ lesign = 1
+ endif
+ noartr( 2, nutr(2) ) = lesign * nuarco(3)
+c
+c triangulation des 2 demi te par ajout des points internes du te
+ call trpite( letree, pxyd,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr, noarst,
+ % nbtr, nutr, ierr )
+ end
+
+
+ subroutine f2trte( letree, pxyd, milieu,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % noarst,
+ % nbtr, nutr, ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : former les triangles du triangle equilateral letree
+c ----- a partir de 2 milieux des cotes du te
+c et des points internes au te
+c ils deviennent tous des sommets des sous-triangles du te
+c
+c entrees:
+c --------
+c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
+c si letree(0)>0 alors
+c letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
+c sinon
+c letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
+c 0 si pas de point
+c ( le te est une feuille de l'arbre )
+c letree(4) : no letree du sur-triangle du triangle j
+c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
+c letree(6:8) : no pxyd des 3 sommets du triangle j
+c pxyd : tableau des x y distance_souhaitee de chaque sommet
+c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
+c 0 si pas de milieu du cote i a ajouter
+c mosoar : nombre maximal d'entiers par arete du tableau nosoar
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxartr : nombre maximal de triangles stockables dans le tableau noartr
+c
+c modifies:
+c ---------
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c une arete i de nosoar est vide <=> nosoar(1,i)=0
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
+c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c noarst : noarst(np) numero d'une arete du sommet np
+c
+c sorties:
+c --------
+c nbtr : nombre de sous-triangles du te, triangulation du te
+c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
+c ierr : =0 si pas d'erreur
+c =1 si le tableau nosoar est sature
+c =2 si le tableau noartr est sature
+c =3 si aucun des triangles ne contient l'un des points internes au te
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+ common / unites / lecteu, imprim, nunite(30)
+ double precision pxyd(3,*)
+ integer letree(0:8),
+ % milieu(3),
+ % nosoar(mosoar,mxsoar),
+ % noartr(moartr,mxartr),
+ % noarst(*),
+ % nutr(1:nbtr)
+c
+ integer nosotr(3), nuarco(7)
+c
+c le numero des 3 triangles a creer dans le tableau noartr
+ do 5 nbtr=1,3
+ if( n1artr .le. 0 ) then
+c tableau noartr sature
+ ierr = 2
+ return
+ endif
+ nutr(nbtr) = n1artr
+c le nouveau premier triangle libre dans noartr
+ n1artr = noartr(2,n1artr)
+ 5 continue
+ nbtr = 3
+c
+c recherche du premier milieu a creer
+ do 7 i=1,3
+ if( milieu(i) .ne. 0 ) goto 9
+ 7 continue
+c
+c on se ramene au seul cas i=2 c-a-d le cote 1 n'a pas de milieu
+ 9 if( i .eq. 2 ) then
+c pas de milieu sur le cote 1
+ nosotr(1) = letree(6)
+ nosotr(2) = letree(7)
+ nosotr(3) = letree(8)
+c le numero pxyd du milieu du cote 2
+ nm2 = milieu( 2 )
+c le numero pxyd du milieu du cote 3
+ nm3 = milieu( 3 )
+ else if( milieu(2) .ne. 0 ) then
+c pas de milieu sur le cote 3
+ nosotr(1) = letree(8)
+ nosotr(2) = letree(6)
+ nosotr(3) = letree(7)
+c le numero pxyd du milieu du cote 2
+ nm2 = milieu( 1 )
+c le numero pxyd du milieu du cote 3
+ nm3 = milieu( 2 )
+ else
+c pas de milieu sur le cote 2
+ nosotr(1) = letree(7)
+ nosotr(2) = letree(8)
+ nosotr(3) = letree(6)
+c le numero pxyd du milieu du cote 2
+ nm2 = milieu( 3 )
+c le numero pxyd du milieu du cote 3
+ nm3 = milieu( 1 )
+ endif
+c
+c ici seul le cote 1 n'a pas de milieu
+c nm2 est le milieu du cote 2
+c nm3 est le milieu du cote 3
+c
+c ajout eventuel de l'arete s1 s2 dans nosoar
+ call fasoar( nosotr(1), nosotr(2), nutr(1), -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % nuarco(1), ierr )
+ if( ierr .ne. 0 ) return
+c
+c ajout eventuel de l'arete s1 s2 dans nosoar
+ call fasoar( nosotr(2), nm2, nutr(1), -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % nuarco(2), ierr )
+ if( ierr .ne. 0 ) return
+c
+c ajout eventuel de l'arete s1 nm2 dans nosoar
+ call fasoar( nosotr(1), nm2, nutr(1), nutr(2), 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % nuarco(3), ierr )
+ if( ierr .ne. 0 ) return
+c
+c ajout eventuel de l'arete nm2 nm3 dans nosoar
+ call fasoar( nm3, nm2, nutr(2), nutr(3), 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % nuarco(4), ierr )
+ if( ierr .ne. 0 ) return
+c
+c ajout eventuel de l'arete s1 nm3 dans nosoar
+ call fasoar( nosotr(1), nm3, nutr(2), -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % nuarco(5), ierr )
+ if( ierr .ne. 0 ) return
+c
+c ajout eventuel de l'arete nm2 s3 dans nosoar
+ call fasoar( nm2, nosotr(3), nutr(3), -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % nuarco(6), ierr )
+c
+c ajout eventuel de l'arete nm3 s3 dans nosoar
+ call fasoar( nosotr(3), nm3, nutr(3), -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % nuarco(7), ierr )
+ if( ierr .ne. 0 ) return
+c
+c le triangle s1 s2 nm2 ou arete1 arete2 arete3
+ do 20 i=1,2
+c nosotr(i) est le numero du sommet 1 de l'arete i du te
+ if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
+ lesign = 1
+ else
+ lesign = -1
+ endif
+c l'arete ns1-ns2 dans nosoar est celle du cote du te
+ noartr( i, nutr(1) ) = lesign * nuarco(i)
+ 20 continue
+ if( nm2 .eq. nosoar(1,nuarco(3)) ) then
+ lesign = 1
+ else
+ lesign = -1
+ endif
+ noartr( 3, nutr(1) ) = lesign * nuarco(3)
+c
+c le triangle s1 nm2 nm3
+ noartr( 1, nutr(2) ) = -lesign * nuarco(3)
+ if( nm2 .eq. nosoar(1,nuarco(4)) ) then
+ lesign = 1
+ else
+ lesign = -1
+ endif
+ noartr( 2, nutr(2) ) = lesign * nuarco(4)
+ noartr( 1, nutr(3) ) = -lesign * nuarco(4)
+ if( nm3 .eq. nosoar(1,nuarco(5)) ) then
+ lesign = 1
+ else
+ lesign = -1
+ endif
+ noartr( 3, nutr(2) ) = lesign * nuarco(5)
+c
+c le triangle nm2 nm3 s3
+ if( nm2 .eq. nosoar(1,nuarco(6)) ) then
+ lesign = 1
+ else
+ lesign = -1
+ endif
+ noartr( 2, nutr(3) ) = lesign * nuarco(6)
+ if( nm3 .eq. nosoar(1,nuarco(7)) ) then
+ lesign = -1
+ else
+ lesign = 1
+ endif
+ noartr( 3, nutr(3) ) = lesign * nuarco(7)
+c
+c triangulation des 3 sous-te par ajout des points internes du te
+ call trpite( letree, pxyd,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr, noarst,
+ % nbtr, nutr, ierr )
+ end
+
+
+ subroutine f3trte( letree, pxyd, milieu,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % noarst,
+ % nbtr, nutr, ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : former les triangles du triangle equilateral letree
+c ----- a partir de 3 milieux des cotes du te
+c et des points internes au te
+c ils deviennent tous des sommets des sous-triangles du te
+c
+c entrees:
+c --------
+c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
+c si letree(0)>0 alors
+c letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
+c sinon
+c letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
+c 0 si pas de point
+c ( le te est une feuille de l'arbre )
+c letree(4) : no letree du sur-triangle du triangle j
+c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
+c letree(6:8) : no pxyd des 3 sommets du triangle j
+c pxyd : tableau des x y distance_souhaitee de chaque sommet
+c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
+c 0 si pas de milieu du cote i a ajouter
+c mosoar : nombre maximal d'entiers par arete du tableau nosoar
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxartr : nombre maximal de triangles stockables dans le tableau noartr
+c
+c modifies:
+c ---------
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c une arete i de nosoar est vide <=> nosoar(1,i)=0
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
+c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c noarst : noarst(np) numero d'une arete du sommet np
+c
+c sorties:
+c --------
+c nbtr : nombre de sous-triangles du te, triangulation du te
+c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
+c ierr : =0 si pas d'erreur
+c =1 si le tableau nosoar est sature
+c =2 si le tableau noartr est sature
+c =3 si aucun des triangles ne contient l'un des points internes au te
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+ common / unites / lecteu, imprim, nunite(30)
+ double precision pxyd(3,*)
+ integer letree(0:8),
+ % milieu(3),
+ % nosoar(mosoar,mxsoar),
+ % noartr(moartr,mxartr),
+ % noarst(*),
+ % nutr(1:nbtr)
+c
+ integer nuarco(9)
+c
+c le numero des 4 triangles a creer dans le tableau noartr
+ do 5 nbtr=1,4
+ if( n1artr .le. 0 ) then
+c tableau noartr sature
+ ierr = 2
+ return
+ endif
+ nutr(nbtr) = n1artr
+c le nouveau premier triangle libre dans noartr
+ n1artr = noartr(2,n1artr)
+ 5 continue
+ nbtr = 4
+c
+ do 10 i=1,3
+c le sommet suivant
+ if( i .ne. 3 ) then
+ i1 = i + 1
+ else
+ i1 = 1
+ endif
+c le sommet precedant
+ if( i .ne. 1 ) then
+ i0 = i - 1
+ else
+ i0 = 3
+ endif
+ i3 = 3 * i
+c
+c ajout eventuel de l'arete si mi dans nosoar
+ call fasoar( letree(5+i), milieu(i), nutr(i), -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % nuarco(i3-2), ierr )
+ if( ierr .ne. 0 ) return
+c
+c ajout eventuel de l'arete mi mi-1 dans nosoar
+ call fasoar( milieu(i), milieu(i0), nutr(i), nutr(4), 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % nuarco(i3-1), ierr )
+ if( ierr .ne. 0 ) return
+c
+c ajout eventuel de l'arete m i-1 si dans nosoar
+ call fasoar( milieu(i0), letree(5+i), nutr(i), -1, 0,
+ % mosoar, mxsoar, n1soar, nosoar, noarst,
+ % nuarco(i3), ierr )
+ if( ierr .ne. 0 ) return
+c
+ 10 continue
+c
+c les 3 sous-triangles pres des sommets
+ do 20 i=1,3
+c le sommet suivant
+ if( i .ne. 3 ) then
+ i1 = i + 1
+ else
+ i1 = 1
+ endif
+c le sommet precedant
+ if( i .ne. 1 ) then
+ i0 = i - 1
+ else
+ i0 = 3
+ endif
+ i3 = 3 * i
+c
+c ajout du triangle arete3i-2 arete3i-1 arete3i
+ if( letree(5+i) .eq. nosoar(1,nuarco(i3-2)) ) then
+ lesign = 1
+ else
+ lesign = -1
+ endif
+ noartr( 1, nutr(i) ) = lesign * nuarco(i3-2)
+c
+ if( milieu(i) .eq. nosoar(1,nuarco(i3-1)) ) then
+ lesign = 1
+ else
+ lesign = -1
+ endif
+ noartr( 2, nutr(i) ) = lesign * nuarco(i3-1)
+c
+ if( milieu(i0) .eq. nosoar(1,nuarco(i3)) ) then
+ lesign = 1
+ else
+ lesign = -1
+ endif
+ noartr( 3, nutr(i) ) = lesign * nuarco(i3)
+c
+ 20 continue
+c
+c le sous triangle central
+ i3 = -1
+ do 30 i=1,3
+ i3 = i3 + 3
+ if( milieu(i) .eq. nosoar(1,nuarco(i3)) ) then
+ lesign = -1
+ else
+ lesign = 1
+ endif
+ noartr( i, nutr(4) ) = lesign * nuarco(i3)
+ 30 continue
+c
+c triangulation des 3 sous-te par ajout des points internes du te
+ call trpite( letree, pxyd,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr, noarst,
+ % nbtr, nutr, ierr )
+ end
+
+
+
+ subroutine hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar,
+ % noar )
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : rechercher le numero des 2 sommets d'une arete parmi
+c ----- les numeros des 2 sommets des aretes du tableau nosoar
+c s ils n y sont pas stockes les y ajouter
+c dans tous les cas retourner le numero de l'arete dans nosoar
+c
+c la methode employee ici est celle du hachage
+c avec pour fonction d'adressage h(ns1,ns2)=min(ns1,ns2)
+c
+c remarque: h(ns1,ns2)=ns1 + 2*ns2
+c ne marche pas si des aretes sont detruites
+c et ajoutees aux aretes vides
+c le chainage est commun a plusieurs hachages!
+c d'ou ce choix du minimum pour le hachage
+c
+c entrees:
+c --------
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c attention: mxsoar>3*mxsomm obligatoire!
+c
+c modifies:
+c ---------
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c une arete i de nosoar est vide <=> nosoar(1,i)=0
+c chainage des aretes vides amont et aval
+c l'arete vide qui precede=nosoar(4,i)
+c l'arete vide qui suit =nosoar(5,i)
+c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
+c chainage momentan'e d'aretes, chainage du hachage des aretes
+c hachage des aretes = min( nosoar(1), nosoar(2) )
+c nu2sar : en entree les 2 numeros des sommets de l'arete
+c en sortie nu2sar(1)<nu2sar(2) numeros des 2 sommets de l'arete
+c
+c sorties:
+c --------
+c noar : numero dans nosoar de l'arete apres hachage
+c =0 si saturation du tableau nosoar
+c >0 si le tableau nu2sar est l'arete noar retrouvee
+c dans le tableau nosoar
+c <0 si le tableau nu2sar a ete ajoute et forme l'arete
+c -noar du tableau nosoar avec nosoar(1,noar)<nosoar(2,noar)
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique upmc paris mars 1997
+c ...................................................................012
+ integer nu2sar(2), nosoar(mosoar,mxsoar)
+c
+ if( nu2sar(1) .gt. nu2sar(2) ) then
+c
+c permutation des numeros des 2 sommets pour
+c amener le plus petit dans nu2sar(1)
+ i = nu2sar(1)
+ nu2sar(1) = nu2sar(2)
+ nu2sar(2) = i
+ endif
+c
+c la fonction d'adressage du hachage des aretes : h(ns1,ns2)=min(ns1,ns2)
+c ===============================================
+ noar = nu2sar(1)
+c
+c la recherche de l'arete dans le chainage du hachage
+c ---------------------------------------------------
+ 10 if( nu2sar(1) .eq. nosoar(1,noar) ) then
+ if( nu2sar(2) .eq. nosoar(2,noar) ) then
+c
+c l'arete est retrouvee
+c .....................
+ return
+ endif
+ endif
+c
+c l'arete suivante parmi celles ayant meme fonction d'adressage
+ i = nosoar( mosoar, noar )
+ if( i .gt. 0 ) then
+ noar = i
+ goto 10
+ endif
+c
+c noar est ici la derniere arete (sans suivante) du chainage
+c a partir de l'adressage du hachage
+c
+c l'arete non retrouvee doit etre ajoutee
+c .......................................
+ if( nosoar( 1, nu2sar(1) ) .eq. 0 ) then
+c
+c l'adresse de hachage est libre => elle devient la nouvelle arete
+c retouche des chainages de cette arete noar qui ne sera plus vide
+ noar = nu2sar(1)
+c l'eventuel chainage du hachage n'est pas modifie
+c
+ else
+c
+c la premiere arete dans l'adressage du hachage n'est pas libre
+c => choix quelconque d'une arete vide pour ajouter cette arete
+ if( n1soar .le. 0 ) then
+c
+c le tableau nosoar est sature avec pour temoin d'erreur
+ noar = 0
+ return
+c
+ else
+c
+c l'arete n1soar est vide => c'est la nouvelle arete
+c mise a jour du chainage de la derniere arete noar du chainage
+c sa suivante est la nouvelle arete n1soar
+ nosoar( mosoar, noar ) = n1soar
+c
+c l'arete ajoutee est n1soar
+ noar = n1soar
+c
+c la nouvelle premiere arete vide
+ n1soar = nosoar( 5, n1soar )
+c
+c la premiere arete vide n1soar n'a pas d'arete vide precedente
+ nosoar( 4, n1soar ) = 0
+c
+c noar la nouvelle arete est la derniere du chainage du hachage
+ nosoar( mosoar, noar ) = 0
+c
+ endif
+c
+ endif
+c
+c les 2 sommets de la nouvelle arete noar
+ nosoar( 1, noar ) = nu2sar(1)
+ nosoar( 2, noar ) = nu2sar(2)
+c
+c le tableau nu2sar a ete ajoute avec l'indice -noar
+ noar = - noar
+ end
+
+
+ subroutine mt3str( nt, moartr, noartr, mosoar, nosoar,
+ % ns1, ns2, ns3 )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : calcul du numero des 3 sommets du triangle nt du tableau noartr
+c -----
+c
+c entrees:
+c --------
+c nt : numero du triangle de noartr a traiter
+c moartr : nombre maximal d'entiers par triangle
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1=0 si triangle vide => arete2=triangle vide suivant
+c mosoar : nombre maximal d'entiers par arete
+c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
+c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
+c
+c sorties:
+c --------
+c ns1,ns2,ns3 : les 3 numeros des sommets du triangle en sens direct
+c
+c si erreur rencontree => ns1 = 0
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc juillet 1995
+c2345x7..............................................................012
+ integer noartr(moartr,*), nosoar(mosoar,*)
+c
+c le numero de triangle est il correct ?
+c a supprimer apres mise au point
+ if( nt .le. 0 ) then
+c nblgrc(nrerr) = 1
+c write(kerr(mxlger)(1:6),'(i6)') nt
+c kerr(1) = kerr(mxlger)(1:6) //
+c % ' no triangle dans noartr incorrect'
+c call lereur
+ write(imprim,*) nt,' no triangle dans noartr incorrect'
+ ns1 = 0
+ return
+ endif
+c
+ na = noartr(1,nt)
+ if( na .gt. 0 ) then
+c arete dans le sens direct
+ ns1 = nosoar(1,na)
+ ns2 = nosoar(2,na)
+ else
+c arete dans le sens indirect
+ ns1 = nosoar(2,-na)
+ ns2 = nosoar(1,-na)
+ endif
+c
+ na = noartr(2,nt)
+ if( na .gt. 0 ) then
+c arete dans le sens direct => ns3 est le second sommet de l'arete
+ ns3 = nosoar(2,na)
+ else
+c arete dans le sens indirect => ns3 est le premier sommet de l'arete
+ ns3 = nosoar(1,-na)
+ endif
+ end
+ subroutine trpite( letree, pxyd,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % noarst,
+ % nbtr, nutr, ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : former le ou les sous-triangles des nbtr triangles nutr
+c ----- qui forment le triangle equilateral letree par ajout
+c des points internes au te qui deviennent des sommets des
+c sous-triangles des nbtr triangles
+c
+c entrees:
+c --------
+c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
+c letree(0:3):-no pxyd des 1 a 4 points internes au triangle j
+c 0 si pas de point
+c ( le te est ici une feuille de l'arbre )
+c letree(4) : no letree du sur-triangle du triangle j
+c letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
+c letree(6:8) : no pxyd des 3 sommets du triangle j
+c pxyd : tableau des x y distance_souhaitee de chaque sommet
+c mosoar : nombre maximal d'entiers par arete du tableau nosoar
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c mxartr : nombre maximal de triangles stockables dans le tableau noartr
+c
+c modifies:
+c ---------
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c une arete i de nosoar est vide <=> nosoar(1,i)=0
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
+c sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c noarst : noarst(i) numero d'une arete de sommet i
+c
+c sorties:
+c --------
+c nbtr : nombre de sous-triangles du te
+c nutr : numero des nbtr sous-triangles du te dans le tableau noartr
+c ierr : =0 si pas d'erreur
+c =1 si le tableau nosoar est sature
+c =2 si le tableau noartr est sature
+c =3 si aucun des triangles ne contient l'un des points internes au te
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+ logical tratri
+ common / dv2dco / tratri
+c trace ou non des triangles generes dans la triangulation
+ common / unites / lecteu, imprim, nunite(30)
+ double precision pxyd(3,*)
+ integer letree(0:8),
+ % nosoar(mosoar,mxsoar),
+ % noartr(moartr,mxartr),
+ % noarst(*),
+ % nutr(1:nbtr)
+c
+ integer nosotr(3)
+c
+c si pas de point interne alors trace eventuel puis retour
+ if( letree(0) .eq. 0 ) goto 150
+c
+c il existe au moins un point interne a trianguler
+c dans les nbtr triangles
+ do 100 k=0,3
+c
+c le numero du point
+ np = -letree(k)
+ if( np .eq. 0 ) goto 150
+c
+c le point np dans pxyd est a traiter
+ do 10 n = 1, nbtr
+c
+c les numeros des 3 sommets du triangle nt=nutr(n)
+ nt = nutr(n)
+ call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
+c
+c le triangle nt contient il le point np?
+ call ptdatr( pxyd(1,np), pxyd, nosotr, nsigne )
+c nsigne>0 si le point est dans le triangle ou sur une des 3 aretes
+c =0 si triangle degenere ou indirect ou ne contient pas le poin
+c
+ if( nsigne .gt. 0 ) then
+c
+c le triangle nt est triangule en 3 sous-triangles
+ call tr3str( np, nt,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, mxartr, n1artr, noartr,
+ % noarst,
+ % nutr(nbtr+1), ierr )
+ if( ierr .ne. 0 ) return
+c
+c reamenagement des 3 triangles crees dans nutr
+c en supprimant le triangle nt
+ nutr( n ) = nutr( nbtr + 3 )
+ nbtr = nbtr + 2
+c le point np est triangule
+ goto 100
+c
+ endif
+ 10 continue
+c
+c erreur: le point np n'est pas dans l'un des nbtr triangles
+ write(imprim,10010) np
+ pause
+ ierr = 3
+ return
+c
+ 100 continue
+10010 format(' erreur trpite: pas de triangle contenant le point',i7)
+c
+ 150 continue
+
+ccc 150 if( tratri ) then
+cccc les traces sont demandes
+ccc call efface
+cccc le cadre objet global en unites utilisateur
+ccc xx1 = min(pxyd(1,nosotr(1)),pxyd(1,nosotr(2)),pxyd(1,nosotr(3)))
+ccc xx2 = max(pxyd(1,nosotr(1)),pxyd(1,nosotr(2)),pxyd(1,nosotr(3)))
+ccc yy1 = min(pxyd(2,nosotr(1)),pxyd(2,nosotr(2)),pxyd(2,nosotr(3)))
+ccc yy2 = max(pxyd(2,nosotr(1)),pxyd(2,nosotr(2)),pxyd(2,nosotr(3)))
+ccc if( xx1 .ge. xx2 ) xx2 = xx1 + (yy2-yy1)
+ccc if( yy1 .ge. yy2 ) yy2 = yy1 + (xx2-xx1)*0.5
+ccc call isofenetre( xx1-(xx2-xx1), xx2+(xx2-xx1),
+ccc % yy1-(yy2-yy1), yy2+(yy2-yy1) )
+ccc do 200 i=1,nbtr
+cccc trace du triangle nutr(i)
+ccc call mttrtr( pxyd, nutr(i), moartr, noartr, mosoar, nosoar,
+ccc % i, ncblan )
+ccc 200 continue
+ccc endif
+
+ end
+
+
+ subroutine sasoar( noar, mosoar, mxsoar, n1soar, nosoar )
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : supprimer l'arete noar du tableau nosoar
+c ----- si celle ci n'est pas une arete des lignes de la frontiere
+c
+c la methode employee ici est celle du hachage
+c avec pour fonction d'adressage h = min( nu2sar(1), nu2sar(2) )
+c
+c attention: il faut mettre a jour le no d'arete des 2 sommets
+c de l'arete supprimee dans le tableau noarst!
+c
+c entrees:
+c --------
+c noar : numero de l'arete de nosoar a supprimer
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage h
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c attention: mxsoar>3*mxsomm obligatoire!
+c
+c modifies:
+c ---------
+c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
+c chainage des vides suivant en 3 et precedant en 2 de nosoar
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
+c nosoar(4,arete vide)=l'arete vide qui precede
+c nosoar(5,arete vide)=l'arete vide qui suit
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique upmc paris mars 1997
+c ...................................................................012
+ common / unites / lecteu, imprim, nunite(30)
+ integer nosoar(mosoar,mxsoar)
+c
+ if( nosoar(3,noar) .le. 0 ) then
+c
+c l'arete n'est pas frontaliere => elle devient une arete vide
+c
+c recherche de l'arete qui precede dans le chainage du hachage
+ noar1 = nosoar(1,noar)
+c
+c parcours du chainage du hachage jusqu'a retrouver l'arete noar
+ 10 if( noar1 .ne. noar ) then
+c
+c l'arete suivante parmi celles ayant meme fonction d'adressage
+ noar0 = noar1
+ noar1 = nosoar( mosoar, noar1 )
+ if( noar1 .gt. 0 ) goto 10
+c
+c l'arete noar n'a pas ete retrouvee dans le chainage => erreur
+ write(imprim,*) 'erreur sasoar:arete non dans le chainage '
+ % ,noar
+ write(imprim,*) 'arete de st1=',nosoar(1,noar),
+ % ' st2=',nosoar(2,noar),' ligne=',nosoar(3,noar),
+ % ' tr1=',nosoar(4,noar),' tr2=',nosoar(5,noar)
+ write(imprim,*) 'chainages=',(nosoar(i,noar),i=6,mosoar)
+ pause
+c l'arete n'est pas detruite
+ return
+c
+ endif
+c
+ if( noar .ne. nosoar(1,noar) ) then
+c
+c saut de l'arete noar dans le chainage du hachage
+c noar0 initialisee est ici l'arete qui precede noar dans ce chainage
+ nosoar( mosoar, noar0 ) = nosoar( mosoar, noar )
+c
+c le chainage du hachage n'existe plus pour noar
+c pas utile car mise a zero faite dans le sp hasoar
+ccc nosoar( mosoar, noar ) = 0
+c
+c noar devient la nouvelle premiere arete du chainage des vides
+ nosoar( 4, noar ) = 0
+ nosoar( 5, noar ) = n1soar
+c la nouvelle precede l'ancienne premiere
+ nosoar( 4, n1soar ) = noar
+ n1soar = noar
+c
+ccc else
+c
+c noar est la premiere arete du chainage du hachage h
+c cette arete ne peut etre consideree dans le chainage des vides
+c car le chainage du hachage doit etre conserve (sinon perte...)
+c
+ endif
+c
+c le temoin d'arete vide
+ nosoar( 1, noar ) = 0
+ endif
+ end
+
+
+ subroutine caetoi( noar, mosoar, mxsoar, n1soar, nosoar,
+ % n1aeoc, nbtrar )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : ajouter (ou retirer) l'arete noar de nosoar de l'etoile
+c ----- des aretes simples chainees en position lchain de nosoar
+c detruire du tableau nosoar les aretes doubles
+c
+c attention: le chainage lchain de nosoar devient celui des cf
+c
+c entree :
+c --------
+c noar : numero dans le tableau nosoar de l'arete a traiter
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c attention: mxsoar>3*mxsomm obligatoire!
+c
+c entrees et sorties:
+c -------------------
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c une arete i de nosoar est vide <=> nosoar(1,i)=0
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c n1aeoc : numero dans nosoar de la premiere arete simple de l'etoile
+c
+c sortie :
+c --------
+c nbtrar : 1 si arete ajoutee, 2 si arete double supprimee
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c2345x7..............................................................012
+ parameter (lchain=6)
+ integer nosoar(mosoar,mxsoar)
+c
+c si l'arete n'appartient pas aux aretes de l'etoile naetoi
+c alors elle est ajoutee a l'etoile dans naetoi
+c sinon elle est empilee dans npile pour etre detruite ensuite
+c elle est supprimee de l'etoile naetoi
+c
+ if( nosoar( lchain, noar ) .lt. 0 ) then
+c
+c arete de l'etoile vue pour la premiere fois
+c elle est ajoutee au chainage
+ nosoar( lchain, noar ) = n1aeoc
+c elle devient la premiere du chainage
+ n1aeoc = noar
+c arete simple
+ nbtrar = 1
+c
+ else
+c
+c arete double de l'etoile. elle est supprimee du chainage
+ na0 = 0
+ na = n1aeoc
+c parcours des aretes chainees jusqu'a trouver l'arete noar
+ 10 if( na .ne. noar ) then
+c passage a la suivante
+ na0 = na
+ na = nosoar( lchain, na )
+ goto 10
+ endif
+c
+c suppression de noar du chainage des aretes simples de l'etoile
+ if( na0 .gt. 0 ) then
+c il existe une arete qui precede
+ nosoar( lchain, na0 ) = nosoar( lchain, noar )
+ else
+c noar est en fait n1aeoc la premiere du chainage
+ n1aeoc = nosoar( lchain, noar )
+ endif
+c noar n'est plus une arete simple de l'etoile
+ nosoar( lchain, noar ) = -1
+c
+c destruction du tableau nosoar de l'arete double noar
+ call sasoar( noar, mosoar, mxsoar, n1soar, nosoar )
+c
+c arete double
+ nbtrar = 2
+ endif
+ end
+
+
+ subroutine focftr( nbtrcf, notrcf, pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr,
+ % nbarcf, n1arcf, noarcf,
+ % ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : former un contour ferme (cf) avec les aretes simples des
+c ----- nbtrcf triangles du tableau notrcf
+c destruction des nbtrcf triangles du tableau noartr
+c destruction des aretes doubles du tableau nosoar
+c
+c attention: le chainage lchain de nosoar devient celui des cf
+c
+c entrees:
+c --------
+c nbtrcf : nombre de triangles du cf a former
+c notrcf : numero des triangles dans le tableau noartr
+c pxyd : tableau des coordonnees 2d des points
+c par point : x y distance_souhaitee
+c
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c attention: mxsoar>3*mxsomm obligatoire!
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c
+c entrees et sorties :
+c --------------------
+c noarst : noarst(i) numero d'une arete de sommet i
+c n1soar : numero de la premiere arete vide dans le tableau nosoar
+c une arete i de nosoar est vide <=> nosoar(1,i)=0
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = nosoar(1)+nosoar(2)*2
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c
+c sorties:
+c --------
+c nbarcf : nombre d'aretes du cf
+c n1arcf : numero d'une arete de chaque contour
+c noarcf : numero des aretes de la ligne du contour ferme
+c attention: chainage circulaire des aretes
+c les aretes vides pointes par n1arcf(0) ne sont pas chainees
+c ierr : 0 si pas d'erreur
+c 14 si les lignes fermees se coupent => donnees a revoir
+c 15 si une seule arete simple frontaliere
+c 16 si boucle infinie car toutes les aretes simples
+c de la boule sont frontalieres!
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+ parameter (lchain=6)
+ common / unites / lecteu, imprim, nunite(30)
+ double precision pxyd(3,*)
+ integer notrcf(1:nbtrcf)
+ integer nosoar(mosoar,mxsoar),
+ % noartr(moartr,*),
+ % n1arcf(0:*),
+ % noarcf(3,*),
+ % noarst(*)
+c
+c formation des aretes simples du cf autour de l'arete ns1-ns2
+c attention: le chainage lchain du tableau nosoar devient actif
+c ============================================================
+c ici toutes les aretes du tableau nosoar verifient nosoar(lchain,i) = -1
+c ce qui equivaut a dire que l'etoile des aretes simples est vide
+c (initialisation dans le sp insoar puis remise a -1 dans la suite!)
+ n1aeoc = 0
+c
+c ajout a l'etoile des aretes simples des 3 aretes des triangles a supprimer
+c suppression des triangles de l'etoile pour les aretes simples de l'etoile
+ do 10 i=1,nbtrcf
+c ajout ou retrait des 3 aretes du triangle notrcf(i) de l'etoile
+ nt = notrcf( i )
+ do 5 j=1,3
+c l'arete de nosoar a traiter
+ noar = abs( noartr(j,nt) )
+ call caetoi( noar, mosoar, mxsoar, n1soar, nosoar,
+ % n1aeoc, nbtrar )
+c si arete simple alors suppression du numero de triangle pour cette a
+ if( nbtrar .eq. 1 ) then
+ if( nosoar(4,noar) .eq. nt ) then
+ nosoar(4,noar) = nosoar(5,noar)
+ endif
+ nosoar(5,noar) = -1
+c else
+c l'arete appartient a aucun triangle => elle est vide
+c les positions 4 et 5 servent maintenant aux chainages des vides
+ endif
+ 5 continue
+ 10 continue
+c
+c les aretes simples de l'etoile sont reordonnees pour former une
+c ligne fermee = un contour ferme peripherique de l'etoile encore dit 1 cf
+c ========================================================================
+ n1ae00 = n1aeoc
+ 12 na1 = n1aeoc
+c la premiere arete du contour ferme
+ ns0 = nosoar(1,na1)
+ ns1 = nosoar(2,na1)
+c
+c l'arete est-elle dans le sens direct?
+c recherche de l'arete du triangle exterieur nt d'arete na1
+ nt = nosoar(4,na1)
+ if( nt .le. 0 ) nt = nosoar(5,na1)
+c
+c attention au cas de l'arete initiale frontaliere de no de triangles 0 et -
+ if( nt .le. 0 ) then
+c permutation circulaire des aretes simples chainees
+c la premiere arete doit devenir la derniere du chainage,
+c la 2=>1, la 3=>2, ... , la derniere=>l'avant derniere, 1=>derniere
+ n1aeoc = nosoar( lchain, n1aeoc )
+ if( n1aeoc .eq. n1ae00 ) then
+c attention: boucle infinie si toutes les aretes simples
+c de la boule sont frontalieres!... arretee par ce test
+ ierr = 16
+ return
+ endif
+ noar = n1aeoc
+ na0 = 0
+ 14 if( noar .gt. 0 ) then
+c la sauvegarde de l'arete et l'arete suivante
+ na0 = noar
+ noar = nosoar(lchain,noar)
+ goto 14
+ endif
+ if( na0 .le. 0 ) then
+c une seule arete simple frontaliere
+ ierr = 15
+ return
+ endif
+c le suivant de l'ancien dernier est l'ancien premier
+ nosoar(lchain,na0) = na1
+c le nouveau dernier est l'ancien premier
+ nosoar(lchain,na1) = 0
+ goto 12
+ endif
+c
+c ici l'arete na1 est l'une des aretes du triangle nt
+ do 15 i=1,3
+ if( abs(noartr(i,nt)) .eq. na1 ) then
+c c'est l'arete
+ if( noartr(i,nt) .gt. 0 ) then
+c elle est parcourue dans le sens indirect de l'etoile
+c (car c'est en fait le triangle exterieur a la boule)
+ ns0 = nosoar(2,na1)
+ ns1 = nosoar(1,na1)
+ endif
+ goto 17
+ endif
+ 15 continue
+c
+c le 1-er sommet ou arete du contour ferme
+ 17 n1arcf( 1 ) = 1
+c le nombre de sommets du contour ferme de l'etoile
+ nbarcf = 1
+c le premier sommet de l'etoile
+ noarcf( 1, nbarcf ) = ns0
+c l'arete suivante du cf
+ noarcf( 2, nbarcf ) = nbarcf + 1
+c le numero de cette arete dans le tableau nosoar
+ noarcf( 3, nbarcf ) = na1
+c mise a jour du numero d'arete du sommet ns0
+ noarst(ns0) = na1
+c
+cccc trace de l'arete
+ccc call dvtrar( pxyd, ns0, ns1, ncvert, ncblan )
+c
+c l'arete suivante a chainer
+ n1aeoc = nosoar( lchain, na1 )
+c l'arete na1 n'est plus dans l'etoile
+ nosoar( lchain, na1 ) = -1
+c
+c boucle sur les aretes simples de l'etoile
+ 20 if( n1aeoc .gt. 0 ) then
+c
+c recherche de l'arete de 1-er sommet ns1
+ na0 = -1
+ na1 = n1aeoc
+ 25 if( na1 .gt. 0 ) then
+c
+c le numero du dernier sommet de l'arete precedente
+c est il l'un des 2 sommets de l'arete na1?
+ if ( ns1 .eq. nosoar(1,na1) ) then
+c l'autre sommet de l'arete na1
+ ns2 = nosoar(2,na1)
+ else if( ns1 .eq. nosoar(2,na1) ) then
+c l'autre sommet de l'arete na1
+ ns2 = nosoar(1,na1)
+ else
+c non: passage a l'arete suivante
+ na0 = na1
+ na1 = nosoar( lchain, na1 )
+ goto 25
+ endif
+c
+c oui: na1 est l'arete peripherique suivante
+c na0 est sa precedente dans le chainage
+c une arete de plus dans le contour ferme (cf)
+ nbarcf = nbarcf + 1
+c le premier sommet de l'arete nbarcf peripherique
+ noarcf( 1, nbarcf ) = ns1
+c l'arete suivante du cf
+ noarcf( 2, nbarcf ) = nbarcf + 1
+c le numero de cette arete dans le tableau nosoar
+ noarcf( 3, nbarcf ) = na1
+c mise a jour du numero d'arete du sommet ns1
+ noarst(ns1) = na1
+c
+cccc trace de l'arete
+ccc call dvtrar( pxyd, ns1, ns2, ncvert, ncblan )
+c
+c suppression de l'arete des aretes simples de l'etoile
+ if( n1aeoc .eq. na1 ) then
+ n1aeoc = nosoar( lchain, na1 )
+ else
+ nosoar( lchain, na0 ) = nosoar( lchain, na1 )
+ endif
+c l'arete n'est plus une arete simple de l'etoile
+ nosoar( lchain, na1 ) = -1
+c
+c le sommet final de l'arete a rechercher ensuite
+ ns1 = ns2
+ goto 20
+ endif
+ endif
+c
+c verification
+ if( ns1 .ne. ns0 ) then
+c arete non retrouvee : l'etoile ne se referme pas
+c nblgrc(nrerr) = 3
+c kerr(1) = 'focftr: revoyez vos donnees'
+c kerr(2) = 'les lignes fermees doivent etre disjointes'
+c kerr(3) = 'verifiez si elles ne se coupent pas'
+c call lereur
+ write(imprim,*) 'focftr: revoyez vos donnees'
+ write(imprim,*)'les lignes fermees doivent etre disjointes'
+ write(imprim,*)'verifiez si elles ne se coupent pas'
+ ierr = 14
+ return
+ endif
+c
+c l'arete suivant la derniere arete du cf est la premiere du cf
+c => realisation d'un chainage circulaire des aretes du cf
+ noarcf( 2, nbarcf ) = 1
+c
+c destruction des triangles de l'etoile du tableau noartr
+c -------------------------------------------------------
+ do 50 i=1,nbtrcf
+c le numero du triangle dans noartr
+ nt0 = notrcf( i )
+c l'arete 1 de nt0 devient nulle
+ noartr( 1, nt0 ) = 0
+c chainage de nt0 en tete du chainage des triangles vides de noartr
+ noartr( 2, nt0 ) = n1artr
+ n1artr = nt0
+ 50 continue
+ end
+
+
+ subroutine int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x0, y0 )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : existence ou non d'une intersection a l'interieur
+c ----- des 2 aretes ns1-ns2 et ns3-ns4
+c attention les intersections au sommet sont comptees
+c
+c entrees:
+c --------
+c ns1,...ns4 : numero pxyd des 4 sommets
+c pxyd : les coordonnees des sommets
+c
+c sortie :
+c --------
+c linter : -1 si ns3-ns4 parallele a ns1 ns2
+c 0 si ns3-ns4 n'intersecte pas ns1-ns2 entre les aretes
+c 1 si ns3-ns4 intersecte ns1-ns2 entre les aretes
+c 2 si le point d'intersection est ns1 entre ns3-ns4
+c 3 si le point d'intersection est ns3 entre ns1-ns2
+c 4 si le point d'intersection est ns4 entre ns1-ns2
+c x0,y0 : 2 coordonnees du point d'intersection s'il existe(linter>=1)
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc fevrier 1992
+c2345x7..............................................................012
+ parameter ( epsmoi=-0.000001d0, eps=0.001d0,
+ % unmeps= 0.999d0, unpeps=1.000001d0 )
+ double precision pxyd(3,*), x0, y0
+ double precision x1,y1,x21,y21,d21,x43,y43,d43,d,x,y,p21,p43
+c
+ x1 = pxyd(1,ns1)
+ y1 = pxyd(2,ns1)
+ x21 = pxyd(1,ns2) - x1
+ y21 = pxyd(2,ns2) - y1
+ d21 = x21**2 + y21**2
+c
+ x43 = pxyd(1,ns4) - pxyd(1,ns3)
+ y43 = pxyd(2,ns4) - pxyd(2,ns3)
+ d43 = x43**2 + y43**2
+c
+c les 2 aretes sont-elles jugees paralleles ?
+ d = x43 * y21 - y43 * x21
+ if( d*d .le. 0.000001d0 * d21 * d43 ) then
+c cote i parallele a ns1-ns2
+ linter = -1
+ return
+ endif
+c
+c les 2 coordonnees du point d'intersection
+ x =( x1*x43*y21-pxyd(1,ns3)*x21*y43-(y1-pxyd(2,ns3))*x21*x43)/d
+ y =(-y1*y43*x21+pxyd(2,ns3)*y21*x43+(x1-pxyd(1,ns3))*y21*y43)/d
+c
+c coordonnee barycentrique de x,y dans le repere ns1-ns2
+ p21 = ( ( x - x1 ) * x21 + ( y - y1 ) * y21 ) / d21
+c coordonnee barycentrique de x,y dans le repere ns3-ns4
+ p43 = ( (x - pxyd(1,ns3))* x43 + (y - pxyd(2,ns3)) * y43 ) / d43
+c
+c
+ if( epsmoi .le. p21 .and. p21 .le. unpeps ) then
+c x,y est entre ns1-ns2
+ if( (p21 .le. eps) .and.
+ % (epsmoi .le. p43 .and. p43 .le. unpeps) ) then
+c le point x,y est proche de ns1 et interne a ns3-ns4
+ linter = 2
+ x0 = pxyd(1,ns1)
+ y0 = pxyd(2,ns1)
+ return
+ else if( epsmoi .le. p43 .and. p43 .le. eps ) then
+c le point x,y est proche de ns3 et entre ns1-ns2
+ linter = 3
+ x0 = pxyd(1,ns3)
+ y0 = pxyd(2,ns3)
+ return
+ else if( unmeps .le. p43 .and. p43 .le. unpeps ) then
+c le point x,y est proche de ns4 et entre ns1-ns2
+ linter = 4
+ x0 = pxyd(1,ns4)
+ y0 = pxyd(2,ns4)
+ return
+ else if( eps .le. p43 .and. p43 .le. unmeps ) then
+c le point x,y est entre ns3-ns4
+ linter = 1
+ x0 = x
+ y0 = y
+ return
+ endif
+ endif
+c
+c pas d'intersection a l'interieur des aretes
+ linter = 0
+ end
+
+
+ subroutine tefoar( narete, nbarpi, pxyd,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr, noarst,
+ % mxarcf, n1arcf, noarcf, larmin, notrcf,
+ % ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : forcer l'arete narete de nosoar dans la triangulation actuelle
+c ----- triangulation frontale pour la reobtenir
+c
+c attention: le chainage lchain(=6) de nosoar devient actif
+c durant la formation des contours fermes (cf)
+c
+c entrees:
+c --------
+c narete : numero nosoar de l'arete frontaliere a forcer
+c nbarpi : numero du dernier point interne impose par l'utilisateur
+c pxyd : tableau des coordonnees 2d des points
+c par point : x y distance_souhaitee
+c
+c mosoar : nombre maximal d'entiers par arete et
+c indice dans nosoar de l'arete suivante dans le hachage
+c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
+c attention: mxsoar>3*mxsomm obligatoire!
+c moartr : nombre maximal d'entiers par arete du tableau noartr
+c
+c modifies:
+c ---------
+c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
+c chainage des vides suivant en 3 et precedant en 2 de nosoar
+c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
+c chainage des aretes frontalieres, chainage du hachage des aretes
+c hachage des aretes = nosoar(1)+nosoar(2)*2
+c avec mxsoar>=3*mxsomm
+c une arete i de nosoar est vide <=> nosoar(1,i)=0 et
+c nosoar(2,arete vide)=l'arete vide qui precede
+c nosoar(3,arete vide)=l'arete vide qui suit
+c n1artr : numero du premier triangle vide dans le tableau noartr
+c le chainage des triangles vides se fait sur noartr(2,.)
+c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
+c arete1 = 0 si triangle vide => arete2 = triangle vide suivant
+c noarst : noarst(i) numero d'une arete de sommet i
+c
+c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
+c
+c tableaux auxiliaires :
+c ----------------------
+c n1arcf : tableau (0:mxarcf) auxiliaire
+c noarcf : tableau (3,mxarcf) auxiliaire
+c larmin : tableau (mxarcf) auxiliaire
+c notrcf : tableau (1:mxarcf) auxiliaire
+c
+c sortie :
+c --------
+c ierr : 0 si pas d'erreur
+c 1 saturation des sommets
+c 2 ns1 dans aucun triangle
+c 9 tableau nosoar de taille insuffisante car trop d'aretes
+c a probleme
+c 10 un des tableaux n1arcf, noarcf notrcf est sature
+c augmenter a l'appel mxarcf
+c 11 algorithme defaillant
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc mars 1997
+c....................................................................012
+ parameter (mxpitr=32)
+ common / unites / lecteu,imprim,intera,nunite(29)
+ logical tratri
+ common / dv2dco / tratri
+ double precision pxyd(3,*)
+ integer noartr(moartr,*),
+ % nosoar(mosoar,mxsoar),
+ % noarst(*),
+ % n1arcf(0:mxarcf),
+ % noarcf(3,mxarcf),
+ % larmin(mxarcf),
+ % notrcf(mxarcf)
+c
+ integer lapitr(mxpitr)
+ double precision x1,y1,x2,y2,d12,d3,d4,x,y,d,dmin
+ integer nosotr(3), ns(2)
+ integer nacf(1:2), nacf1, nacf2
+ equivalence (nacf(1),nacf1), (nacf(2),nacf2)
+c
+c traitement de cette arete perdue
+ ns1 = nosoar( 1, narete )
+ ns2 = nosoar( 2, narete )
+c
+ if( tratri ) then
+c les traces sont demandes
+c call efface
+c le cadre objet global en unites utilisateur
+ xx1 = min( pxyd(1,ns1), pxyd(1,ns2) )
+ xx2 = max( pxyd(1,ns1), pxyd(1,ns2) )
+ yy1 = min( pxyd(2,ns1), pxyd(2,ns2) )
+ yy2 = max( pxyd(2,ns1), pxyd(2,ns2) )
+ if( xx1 .ge. xx2 ) xx2 = xx1 + (yy2-yy1)
+ if( yy1 .ge. yy2 ) yy2 = yy1 + (xx2-xx1)*0.5
+c call isofenetre( xx1-(xx2-xx1), xx2+(xx2-xx1),
+c % yy1-(yy2-yy1), yy2+(yy2-yy1) )
+ endif
+c
+cccc trace de l'arete perdue
+ccc call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
+c
+c le sommet ns2 est il correct?
+ na = noarst( ns2 )
+ if( na .le. 0 ) then
+ write(imprim,*) 'tefoar: erreur sommet ',ns2,' sans arete'
+ ierr = 8
+ return
+ endif
+ if( nosoar(4,na) .le. 0 ) then
+ write(imprim,*) 'tefoar: erreur sommet ',ns2,
+ % ' dans aucun triangle'
+ ierr = 8
+ return
+ endif
+c
+c recherche du triangle voisin dans le sens indirect de rotation
+ nsens = -1
+c le premier passage: recherche dans le sens ns1->ns2
+ ipas = 0
+c
+c recherche des triangles intersectes par le segment ns1-ns2
+c ==========================================================
+ 3 x1 = pxyd(1,ns1)
+ y1 = pxyd(2,ns1)
+ x2 = pxyd(1,ns2)
+ y2 = pxyd(2,ns2)
+ d12 = (x2-x1)**2 + (y2-y1)**2
+c
+c recherche du no local du sommet ns1 dans l'un de ses triangles
+ na01 = noarst( ns1 )
+ if( na01 .le. 0 ) then
+ write(imprim,*) 'tefoar: sommet ',ns1,' sans arete'
+ ierr = 8
+ return
+ endif
+ nt0 = nosoar(4,na01)
+ if( nt0 .le. 0 ) then
+ write(imprim,*) 'tefoar: sommet ',ns1,' dans aucun triangle'
+ ierr = 8
+ return
+ endif
+c
+c le numero des 3 sommets du triangle nt0 dans le sens direct
+ 20 call nusotr( nt0, mosoar, nosoar, moartr, noartr, nosotr )
+ do 22 na00=1,3
+ if( nosotr(na00) .eq. ns1 ) goto 26
+ 22 continue
+c
+ 25 if( ipas .eq. 0 ) then
+c le second passage: recherche dans le sens ns2->ns1
+c tentative d'inversion des 2 sommets extremites de l'arete a forcer
+ na00 = ns1
+ ns1 = ns2
+ ns2 = na00
+ ipas = 1
+ goto 3
+ else
+c les sens ns1->ns2 et ns2->ns1 ne donne pas de solution!
+ write(imprim,*)'tefoar:arete ',ns1,' - ',ns2,' a imposer'
+ write(imprim,*)'tefoar:anomalie sommet ',ns1,
+ % 'non dans le triangle de sommets ',(nosotr(i),i=1,3)
+ pause
+ ierr = 11
+ return
+ endif
+c
+c le numero des aretes suivante et precedente
+ 26 na0 = nosui3( na00 )
+ na1 = nopre3( na00 )
+ ns3 = nosotr( na0 )
+ ns4 = nosotr( na1 )
+c
+cccc trace du triangle nt0 et de l'arete perdue
+ccc call mttrtr( pxyd, nt0, moartr, noartr, mosoar, nosoar,
+ccc % ncblan, ncjaun )
+ccc call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
+ccc call dvtrar( pxyd, ns3, ns4, ncbleu, nccyan )
+c
+c point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
+c ------------------------------------------------------------
+ call int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x1, y1 )
+ if( linter .le. 0 ) then
+c
+c pas d'intersection: rotation autour du point ns1
+c pour trouver le triangle de l'autre cote de l'arete na01
+ if( nsens .lt. 0 ) then
+c sens indirect de rotation: l'arete de sommet ns1
+ na01 = abs( noartr(na00,nt0) )
+ else
+c sens direct de rotation: l'arete de sommet ns1 qui precede
+ na01 = abs( noartr(na1,nt0) )
+ endif
+c le triangle de l'autre cote de l'arete na01
+ if( nosoar(4,na01) .eq. nt0 ) then
+ nt0 = nosoar(5,na01)
+ else
+ nt0 = nosoar(4,na01)
+ endif
+ if( nt0 .gt. 0 ) goto 20
+c
+c le parcours sort du domaine
+c il faut tourner dans l'autre sens autour de ns1
+ if( nsens .lt. 0 ) then
+ nsens = 1
+ nt0 = noarst( ns1 )
+ goto 20
+ endif
+c
+c dans les 2 sens, pas d'intersection => impossible
+c essai avec l'arete inversee ns1 <-> ns2
+ if( ipas .eq. 0 ) goto 25
+ write(imprim,*) 'tefoar: arete ',ns1,' ',ns2,
+ % ' sans intersection avec les triangles actuels'
+ write(imprim,*) 'revoyez les lignes du contour'
+ ierr = 11
+ return
+ endif
+c
+c il existe une intersection avec l'arete opposee au sommet ns1
+c =============================================================
+c nbtrcf : nombre de triangles du cf
+ nbtrcf = 1
+ notrcf( 1 ) = nt0
+c
+c le triangle oppose a l'arete na0 de nt0
+ 30 noar = abs( noartr(na0,nt0) )
+ if( nosoar(4,noar) .eq. nt0 ) then
+ nt1 = nosoar(5,noar)
+ else
+ nt1 = nosoar(4,noar)
+ endif
+c
+cccc trace du triangle nt1 et de l'arete perdue
+ccc call mttrtr( pxyd, nt1, moartr, noartr, mosoar, nosoar,
+ccc % ncjaun, ncmage )
+ccc call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
+c
+c le numero des 3 sommets du triangle nt1 dans le sens direct
+ call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
+c
+c le triangle nt1 contient il ns2 ?
+ do 32 j=1,3
+ if( nosotr(j) .eq. ns2 ) goto 70
+ 32 continue
+c
+c recherche de l'arete noar, na1 dans nt1 qui est l'arete na0 de nt0
+ do 34 na1=1,3
+ if( abs( noartr(na1,nt1) ) .eq. noar ) goto 35
+ 34 continue
+c
+c trace du triangle nt1 et de l'arete perdue
+ 35 continue
+ccc 35 call mttrtr( pxyd, nt1, moartr, noartr, mosoar, nosoar,
+ccc % ncjaun, ncmage )
+ccc call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
+c
+c recherche de l'intersection de ns1-ns2 avec les 2 autres aretes de nt1
+c ======================================================================
+ na2 = na1
+ do 50 i1 = 1,2
+c l'arete suivante
+ na2 = nosui3(na2)
+c
+c les 2 sommets de l'arete na2 de nt1
+ noar = abs( noartr(na2,nt1) )
+ ns3 = nosoar( 1, noar )
+ ns4 = nosoar( 2, noar )
+ccc call dvtrar( pxyd, ns3, ns4, ncbleu, nccyan )
+c
+c point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
+c ------------------------------------------------------------
+ call int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x , y )
+ if( linter .gt. 0 ) then
+c
+c les 2 aretes s'intersectent en (x,y)
+c distance de (x,y) a ns3 et ns4
+ d3 = (pxyd(1,ns3)-x)**2 + (pxyd(2,ns3)-y)**2
+ d4 = (pxyd(1,ns4)-x)**2 + (pxyd(2,ns4)-y)**2
+c nsp est le point le plus proche de (x,y)
+ if( d3 .lt. d4 ) then
+ nsp = ns3
+ d = d3
+ else
+ nsp = ns4
+ d = d4
+ endif
+ if( d .gt. 1d-5*d12 ) goto 60
+c
+c ici le sommet nsp est trop proche de l'arete perdue ns1-ns2
+ if( nsp .le. nbarpi ) then
+c point utilisateur ou frontalier non supprimable
+ ierr = 11
+ write(imprim,*) 'pause dans tefoar 1', d, d3, d4, d12
+ pause
+ return
+ endif
+c
+c le sommet interne nsp est supprime en mettant tous les triangles
+c l'ayant comme sommet dans la pile notrcf des triangles a supprimer
+c ------------------------------------------------------------------
+ccc write(imprim,*) 'tefoar: le sommet ',nsp,' est supprime'
+c construction de la liste des triangles de sommet nsp
+ call trp1st( nsp, noarst, mosoar, nosoar, moartr, noartr,
+ % mxpitr, nbt, lapitr )
+ if( nbt .le. 0 ) then
+c les triangles de sommet nsp ne forme pas une "boule"
+c avec ce sommet nsp pour "centre"
+ write(imprim,*)
+ % 'tefoar: pas d''etoile de triangles autour du sommet',nsp
+cccc trace des triangles de l'etoile du sommet nsp
+ccc tratri = .true.
+ccc call trpltr( nbt, lapitr, pxyd,
+ccc % moartr, noartr, mosoar, nosoar,
+ccc % ncroug, ncblan )
+ccc tratri = .false.
+ ierr = 11
+ write(imprim,*) 'pause dans tefoar 2'
+ pause
+ return
+ endif
+c
+c ajout des triangles de sommet ns1 a notrcf
+ nbtrc0 = nbtrcf
+ do 38 j=1,nbt
+ nt = lapitr(j)
+ do 37 k=nbtrcf,1,-1
+ if( nt .eq. notrcf(k) ) goto 38
+ 37 continue
+c triangle ajoute
+ nbtrcf = nbtrcf + 1
+ notrcf( nbtrcf ) = nt
+ccc call mttrtr( pxyd, nt, moartr, noartr, mosoar, nosoar,
+ccc % ncjaun, ncmage )
+ccc call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
+ 38 continue
+c
+c ce sommet supprime n'appartient plus a aucun triangle
+ noarst( nsp ) = 0
+c
+c ns2 est-il un sommet des triangles empiles?
+c -------------------------------------------
+ do 40 nt=nbtrc0+1,nbtrcf
+c le triangle a supprimer nt
+ nt1 = notrcf( nt )
+c le numero des 3 sommets du triangle nt1 dans le sens direct
+ call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr)
+ do 39 k=1,3
+c le sommet k de nt1
+ if( nosotr( k ) .eq. ns2 ) then
+c but atteint
+ goto 80
+ endif
+ 39 continue
+ 40 continue
+c
+c recherche du plus proche point d'intersection de ns1-ns2
+c par rapport a ns2 avec les aretes des triangles ajoutes
+ nt0 = 0
+ dmin = d12 * 10000
+ do 48 nt=nbtrc0+1,nbtrcf
+ nt1 = notrcf( nt )
+c le numero des 3 sommets du triangle nt1 dans le sens direct
+ call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr)
+ do 45 k=1,3
+c les 2 sommets de l'arete k de nt
+ ns3 = nosotr( k )
+ ns4 = nosotr( nosui3(k) )
+c
+c point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
+c ------------------------------------------------------------
+ call int1sd( ns1, ns2, ns3, ns4, pxyd,
+ % linter, x , y )
+ if( linter .gt. 0 ) then
+c les 2 aretes s'intersectent en (x,y)
+ d = (x-x2)**2+(y-y2)**2
+ if( d .lt. dmin ) then
+ nt0 = nt1
+ na0 = k
+ dmin = d
+ endif
+ endif
+ 45 continue
+ 48 continue
+c
+c redemarrage avec le triangle nt0 et l'arete na0
+ if( nt0 .gt. 0 ) goto 30
+c
+ write(imprim,*) 'tefoar: algorithme defaillant'
+ ierr = 11
+ pause
+ return
+ endif
+ 50 continue
+c
+c pas d'intersection differente de l'initiale => sommet sur ns1-ns2
+c rotation autour du sommet par l'arete suivant na1
+ write(imprim,*)
+ write(imprim,*) 'tefoar 50: revoyez vos donnees'
+ write(imprim,*) 'les lignes fermees doivent etre disjointes'
+ write(imprim,*) 'verifiez si elles ne se coupent pas'
+ ierr = 13
+ pause
+ return
+c
+c cas sans probleme : intersection differente de celle initiale
+c ================= =========================================
+ 60 nbtrcf = nbtrcf + 1
+ notrcf( nbtrcf ) = nt1
+c passage au triangle suivant
+ na0 = na2
+ nt0 = nt1
+ goto 30
+c
+c ----------------------------------------------------------
+c ici toutes les intersections de ns1-ns2 ont ete parcourues
+c tous les triangles intersectes ou etendus forment les
+c nbtrcf triangles du tableau notrcf
+c ----------------------------------------------------------
+ 70 nbtrcf = nbtrcf + 1
+ notrcf( nbtrcf ) = nt1
+c
+c formation du cf des aretes simples des triangles de notrcf
+c et destruction des nbtrcf triangles du tableau noartr
+c attention: le chainage lchain du tableau nosoar devient actif
+c =============================================================
+ 80 if( nbtrcf*3 .gt. mxarcf ) then
+ write(imprim,*) 'saturation du tableau noarcf'
+ ierr = 10
+ return
+ endif
+c
+ call focftr( nbtrcf, notrcf, pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr,
+ % nbarcf, n1arcf, noarcf,
+ % ierr )
+ if( ierr .ne. 0 ) return
+c
+c chainage des aretes vides dans le tableau noarcf
+c ------------------------------------------------
+c decalage de 2 aretes car 2 aretes sont necessaires ensuite pour
+c integrer 2 fois l'arete perdue et former ainsi 2 cf
+c comme nbtrcf*3 minore mxarcf il existe au moins 2 places vides
+c derriere => pas de test de debordement
+ n1arcf(0) = nbarcf+3
+ mmarcf = min(8*nbarcf,mxarcf)
+ do 90 i=nbarcf+3,mmarcf
+ noarcf(2,i) = i+1
+ 90 continue
+ noarcf(2,mmarcf) = 0
+c
+c reperage des sommets ns1 ns2 de l'arete perdue dans le cf
+c ---------------------------------------------------------
+ ns1 = nosoar( 1, narete )
+ ns2 = nosoar( 2, narete )
+ ns(1) = ns1
+ ns(2) = ns2
+ do 120 i=1,2
+c la premiere arete dans noarcf du cf
+ na0 = n1arcf(1)
+ 110 if( noarcf(1,na0) .ne. ns(i) ) then
+c passage a l'arete suivante
+ na0 = noarcf( 2, na0 )
+ goto 110
+ endif
+c position dans noarcf du sommet i de l'arete perdue
+ nacf(i) = na0
+ 120 continue
+c
+c formation des 2 cf chacun contenant l'arete ns1-ns2
+c ---------------------------------------------------
+c sauvegarde de l'arete suivante de celle de sommet ns1
+ na0 = noarcf( 2, nacf1 )
+ nt1 = noarcf( 3, nacf1 )
+c
+c le premier cf
+ n1arcf( 1 ) = nacf1
+c l'arete suivante dans le premier cf
+ noarcf( 2, nacf1 ) = nacf2
+c cette arete est celle perdue
+ noarcf( 3, nacf1 ) = narete
+c
+c le second cf
+c l'arete doublee
+ n1 = nbarcf + 1
+ n2 = nbarcf + 2
+c le premier sommet de la premiere arete du second cf
+ noarcf( 1, n1 ) = ns2
+c l'arete suivante dans le second cf
+ noarcf( 2, n1 ) = n2
+c cette arete est celle perdue
+ noarcf( 3, n1 ) = narete
+c la seconde arete du second cf
+ noarcf( 1, n2 ) = ns1
+ noarcf( 2, n2 ) = na0
+ noarcf( 3, n2 ) = nt1
+ n1arcf( 2 ) = n1
+c
+c recherche du precedent de nacf2
+ 130 na1 = noarcf( 2, na0 )
+ if( na1 .ne. nacf2 ) then
+c passage a l'arete suivante
+ na0 = na1
+ goto 130
+ endif
+c na0 precede nacf2 => il precede n1
+ noarcf( 2, na0 ) = n1
+c
+c depart avec 2 cf
+ nbcf = 2
+c
+c triangulation directe des 2 contours fermes
+c l'arete ns1-ns2 devient une arete de la triangulation des 2 cf
+c ==============================================================
+ call tridcf( nbcf, pxyd, noarst,
+ % mosoar, mxsoar, n1soar, nosoar,
+ % moartr, n1artr, noartr,
+ % mxarcf, n1arcf, noarcf, larmin,
+ % nbtrcf, notrcf, ierr )
+ end
+
+
+ subroutine te4ste( nbsomm, mxsomm, pxyd, ntrp, letree,
+ & ierr )
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c but : decouper un te ntrp de letree en 4 sous-triangles
+c ----- eliminer les sommets de te trop proches des points
+c
+c entrees:
+c --------
+c mxsomm : nombre maximal de points declarables dans pxyd
+c ntrp : numero letree du triangle a decouper en 4 sous-triangles
+c
+c modifies :
+c ----------
+c nbsomm : nombre actuel de points dans pxyd
+c pxyd : tableau des coordonnees des points
+c par point : x y distance_souhaitee
+c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
+c letree(0,0) : no du 1-er te vide dans letree
+c letree(0,1) : maximum du 1-er indice de letree (ici 8)
+c letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
+c letree(0:8,1) : racine de l'arbre (triangle sans sur triangle)
+c si letree(0,.)>0 alors
+c letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
+c sinon
+c letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
+c 0 si pas de point
+c ( j est alors une feuille de l'arbre )
+c letree(4,j) : no letree du sur-triangle du triangle j
+c letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
+c letree(6:8,j) : no pxyd des 3 sommets du triangle j
+c
+c sorties :
+c ---------
+c ierr : 0 si pas d'erreur, 51 saturation letree, 52 saturation pxyd
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c auteur : alain perronnet analyse numerique paris upmc juillet 1994
+c2345x7..............................................................012
+ common / unites / lecteu,imprim,nunite(30)
+ integer letree(0:8,0:*)
+ double precision pxyd(3,mxsomm)
+ integer np(0:3),milieu(3)
+c
+c debut par l'arete 2 du triangle ntrp
+ i1 = 2
+ i2 = 3
+ do 30 i=1,3
+c
+c le milieu de l'arete i1 existe t il deja ?
+ call n1trva( ntrp, i1, letree, noteva, niveau )
+ if( noteva .gt. 0 ) then
+c il existe un te voisin
+c s'il existe 4 sous-triangles le milieu existe deja
+ if( letree(0,noteva) .gt. 0 ) then
+c le milieu existe
+ nsot = letree(0,noteva)
+ milieu(i) = letree( 5+nopre3(i1), nsot )
+ goto 25
+ endif
+ endif
+c
+c le milieu n'existe pas. il est cree
+ nbsomm = nbsomm + 1
+ if( nbsomm .gt. mxsomm ) then
+c plus assez de place dans pxyd
+ write(imprim,*) 'te4ste: saturation pxyd'
+ write(imprim,*)
+ ierr = 52
+ return
+ endif
+c le milieu de l'arete i
+ milieu(i) = nbsomm
+c
+c ntrp est le triangle de milieux d'arete ces 3 sommets
+ ns1 = letree( 5+i1, ntrp )
+ ns2 = letree( 5+i2, ntrp )
+ pxyd(1,nbsomm) = ( pxyd(1,ns1) + pxyd(1,ns2) ) * 0.5
+ pxyd(2,nbsomm) = ( pxyd(2,ns1) + pxyd(2,ns2) ) * 0.5
+c
+c l'arete et milieu suivant
+ 25 i1 = i2
+ i2 = nosui3( i2 )
+ 30 continue
+c
+ do 50 i=0,3
+c
+c le premier triangle vide
+ nsot = letree(0,0)
+ if( nsot .le. 0 ) then
+c manque de place. saturation letree
+ ierr = 51
+ write(imprim,*) 'te4ste: saturation letree'
+ write(imprim,*)
+ return
+ endif
+c
+c mise a jour du premier te libre
+ letree(0,0) = letree(0,nsot)
+c
+c nsot est le i-eme sous triangle
+ letree(0,nsot) = 0
+ letree(1,nsot) = 0
+ letree(2,nsot) = 0
+ letree(3,nsot) = 0
+c
+c le numero des points et sous triangles dans ntrp
+ np(i) = -letree(i,ntrp)
+ letree(i,ntrp) = nsot
+c
+c le sommet commun avec le triangle ntrp
+ letree(5+i,nsot) = letree(5+i,ntrp)
+c
+c le sur-triangle et numero de sous-triangle de nsot
+c a laisser ici car incorrect sinon pour i=0
+ letree(4,nsot) = ntrp
+ letree(5,nsot) = i
+c
+c le sous-triangle du triangle
+ letree(i,ntrp) = nsot
+ 50 continue
+c
+c le numero des nouveaux sommets milieux
+ nsot = letree(0,ntrp)
+ letree(6,nsot) = milieu(1)
+ letree(7,nsot) = milieu(2)
+ letree(8,nsot) = milieu(3)
+c
+ nsot = letree(1,ntrp)
+ letree(7,nsot) = milieu(3)
+ letree(8,nsot) = milieu(2)
+c
+ nsot = letree(2,ntrp)
+ letree(6,nsot) = milieu(3)
+ letree(8,nsot) = milieu(1)
+c
+ nsot = letree(3,ntrp)
+ letree(6,nsot) = milieu(2)
+ letree(7,nsot) = milieu(1)
+c
+c repartition des eventuels 4 points np dans ces 4 sous-triangles
+c il y a obligatoirement suffisamment de place
+ do 110 i=0,3
+ if( np(i) .gt. 0 ) then
+ nsot = notrpt( pxyd(1,np(i)), pxyd, ntrp, letree )
+c ajout du point
+ do 100 i1=0,3
+ if( letree(i1,nsot) .eq. 0 ) then
+c place libre a occuper
+ letree(i1,nsot) = -np(i)
+ goto 110
+ endif
+ 100 continue
+ endif
+ 110 continue
+ end