smesh/src/MEFISTO2/trte.f

      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 <20>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 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 <20> 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 <20>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 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