src/MEFISTO2/trte.f

   1 c  MEFISTO : library to compute 2D triangulation from segmented boundaries
   2 c
   3 c  Copyright (C) 2003  Laboratoire J.-L. Lions UPMC Paris
   4 c
   5 c  This library is free software; you can redistribute it and/or
   6 c  modify it under the terms of the GNU Lesser General Public
   7 c  License as published by the Free Software Foundation; either
   8 c  version 2.1 of the License.
   9 c
  10 c  This library is distributed in the hope that it will be useful,
  11 c  but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 c  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 c  Lesser General Public License for more details.
  14 c
  15 c  You should have received a copy of the GNU Lesser General Public
  16 c  License along with this library; if not, write to the Free Software
  17 c  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
  18 c
  19 c  See http://www.ann.jussieu.fr/~perronne or email Perronnet@ann.jussieu.fr
  20 c
  21 c
  22 c  File   : trte.f
  23 c  Module : SMESH
  24 c  Author: Alain PERRONNET
  25
  26       subroutine qutr2d( p1, p2, p3, qualite )
  27 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  28 c but :     calculer la qualite d'un triangle de r**2
  29 c -----     2 coordonnees des 3 sommets en double precision
  30 c
  31 c entrees :
  32 c ---------
  33 c p1,p2,p3 : les 3 coordonnees des 3 sommets du triangle
  34 c            sens direct pour une surface et qualite >0
  35 c sorties :
  36 c ---------
  37 c qualite: valeur de la qualite du triangle entre 0 et 1 (equilateral)
  38 c          1 etant la qualite optimale
  39 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  40 c auteur : alain perronnet analyse numerique upmc paris     janvier 1995
  41 c2345x7..............................................................012
  42       parameter  ( d2uxr3 = 3.4641016151377544d0 )
  43 c                  d2uxr3 = 2 * sqrt(3)
  44       double precision  p1(2), p2(2), p3(2), qualite, a, b, c, p
  45 c
  46 c     la longueur des 3 cotes
  47       a = sqrt( (p2(1)-p1(1))**2 + (p2(2)-p1(2))**2 )
  48       b = sqrt( (p3(1)-p2(1))**2 + (p3(2)-p2(2))**2 )
  49       c = sqrt( (p1(1)-p3(1))**2 + (p1(2)-p3(2))**2 )
  50 c
  51 c     demi perimetre
  52       p = (a+b+c) * 0.5d0
  53 c
  54       if ( (a*b*c) .ne. 0d0 ) then
  55 c        critere : 2 racine(3) * rayon_inscrit / plus longue arete
  56          qualite = d2uxr3 * sqrt( abs( (p-a) / p * (p-b) * (p-c) ) )
  57      %          / max(a,b,c)
  58       else
  59          qualite = 0d0
  60       endif
  61 c
  62 c
  63 c     autres criteres possibles:
  64 c     critere : 2 * rayon_inscrit / rayon_circonscrit
  65 c     qualite = 8d0 * (p-a) * (p-b) * (p-c) / (a * b * c)
  66 c
  67 c     critere : 3*sqrt(3.) * ray_inscrit / demi perimetre
  68 c     qualite = 3*sqrt(3.) * sqrt ((p-a)*(p-b)*(p-c) / p**3)
  69 c
  70 c     critere : 2*sqrt(3.) * ray_inscrit / max( des aretes )
  71 c     qualite = 2*sqrt(3.) * sqrt( (p-a)*(p-b)*(p-c) / p ) / max(a,b,c)
  72       end
  73
  74
  75       double precision function surtd2( p1 , p2 , p3 )
  76 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  77 c but : calcul de la surface d'un triangle defini par 3 points de R**2
  78 c -----
  79 c parametres d entree :
  80 c ---------------------
  81 c p1 p2 p3 : les 3 fois 2 coordonnees des sommets du triangle
  82 c
  83 c parametre resultat :
  84 c --------------------
  85 c surtd2 : surface du triangle
  86 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  87 c auteur : alain perronnet analyse numerique upmc paris     fevrier 1992
  88 c2345x7..............................................................012
  89       double precision  p1(2), p2(2), p3(2)
  90 c
  91 c     la surface du triangle
  92       surtd2 = ( ( p2(1)-p1(1) ) * ( p3(2)-p1(2) )
  93      %         - ( p2(2)-p1(2) ) * ( p3(1)-p1(1) ) ) * 0.5d0
  94       end
  95
  96       integer function nopre3( i )
  97 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  98 c but :   numero precedent i dans le sens circulaire  1 2 3 1 ...
  99 c -----
 100 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 101 c auteur : alain perronnet  analyse numerique paris upmc    fevrier 1992
 102 c2345x7..............................................................012
 103       if( i .eq. 1 ) then
 104          nopre3 = 3
 105       else
 106          nopre3 = i - 1
 107       endif
 108       end
 109
 110       integer function nosui3( i )
 111 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 112 c but :   numero suivant i dans le sens circulaire  1 2 3 1 ...
 113 c -----
 114 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 115 c auteur : alain perronnet  analyse numerique paris upmc    fevrier 1992
 116 c2345x7..............................................................012
 117       if( i .eq. 3 ) then
 118          nosui3 = 1
 119       else
 120          nosui3 = i + 1
 121       endif
 122       end
 123
 124       subroutine provec( v1 , v2 , v3 )
 125 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 126 c but :    v3 vecteur = produit vectoriel de 2 vecteurs de r ** 3
 127 c -----
 128 c entrees:
 129 c --------
 130 c v1, v2 : les 2 vecteurs de 3 composantes
 131 c
 132 c sortie :
 133 c --------
 134 c v3     : vecteur = v1  produit vectoriel v2
 135 cc++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 136 c auteur : perronnet alain upmc analyse numerique paris        mars 1987
 137 c2345x7..............................................................012
 138       double precision    v1(3), v2(3), v3(3)
 139 c
 140       v3( 1 ) = v1( 2 ) * v2( 3 ) - v1( 3 ) * v2( 2 )
 141       v3( 2 ) = v1( 3 ) * v2( 1 ) - v1( 1 ) * v2( 3 )
 142       v3( 3 ) = v1( 1 ) * v2( 2 ) - v1( 2 ) * v2( 1 )
 143 c
 144       return
 145       end
 146
 147       subroutine norme1( n, v, ierr )
 148 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 149 c but :   normalisation euclidienne a 1 d un vecteur v de n composantes
 150 c -----
 151 c entrees :
 152 c ---------
 153 c n       : nombre de composantes du vecteur
 154 c
 155 c modifie :
 156 c ---------
 157 c v       : le vecteur a normaliser a 1
 158 c
 159 c sortie  :
 160 c ---------
 161 c ierr    : 1 si la norme de v est egale a 0
 162 c           0 si pas d'erreur
 163 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 164 c auteur : alain perronnet analyse numerique paris             mars 1987
 165 c ......................................................................
 166       double precision  v( n ), s, sqrt
 167 c
 168       s = 0.0d0
 169       do 10 i=1,n
 170          s = s + v( i ) * v( i )
 171    10 continue
 172 c
 173 c     test de nullite de la norme du vecteur
 174 c     --------------------------------------
 175       if( s .le. 0.0d0 ) then
 176 c        norme nulle du vecteur non normalisable a 1
 177          ierr = 1
 178          return
 179       endif
 180 c
 181       s = 1.0d0 / sqrt( s )
 182       do 20 i=1,n
 183          v( i ) = v ( i ) * s
 184    20 continue
 185 c
 186       ierr = 0
 187       end
 188
 189
 190       subroutine insoar( mxsomm, mosoar, mxsoar, n1soar, nosoar )
 191 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 192 c but :    initialiser le tableau nosoar pour le hachage des aretes
 193 c -----
 194 c
 195 c entrees:
 196 c --------
 197 c mxsomm : plus grand numero de sommet d'une arete au cours du calcul
 198 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
 199 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
 200 c          avec mxsoar>=3*mxsomm
 201 c
 202 c sorties:
 203 c --------
 204 c n1soar : numero de la premiere arete vide dans le tableau nosoar
 205 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
 206 c          chainage des aretes vides amont et aval
 207 c          l'arete vide qui precede=nosoar(4,i)
 208 c          l'arete vide qui suit   =nosoar(5,i)
 209 c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
 210 c          chainage momentan'e d'aretes, chainage du hachage des aretes
 211 c          hachage des aretes = min( nosoar(1), nosoar(2) )
 212 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 213 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
 214 c2345x7..............................................................012
 215       integer   nosoar(mosoar,mxsoar)
 216 c
 217 c     initialisation des aretes 1 a mxsomm
 218       do 10 i=1,mxsomm
 219 c
 220 c        sommet 1 = 0 <=> temoin d'arete vide pour le hachage
 221          nosoar( 1, i ) = 0
 222 c
 223 c        arete sur aucune ligne
 224          nosoar( 3, i ) = 0
 225 c
 226 c        la position de l'arete interne ou frontaliere est inconnue
 227          nosoar( 6, i ) = -2
 228 c
 229 c        fin de chainage du hachage pas d'arete suivante
 230          nosoar( mosoar, i ) = 0
 231 c
 232  10   continue
 233 c
 234 c     la premiere arete vide chainee est la mxsomm+1 du tableau
 235 c     car ces aretes ne sont pas atteignables par le hachage direct
 236       n1soar = mxsomm + 1
 237 c
 238 c     initialisation des aretes vides et des chainages
 239       do 20 i = n1soar, mxsoar
 240 c
 241 c        sommet 1 = 0 <=> temoin d'arete vide pour le hachage
 242          nosoar( 1, i ) = 0
 243 c
 244 c        arete sur aucune ligne
 245          nosoar( 3, i ) = 0
 246 c
 247 c        chainage sur l'arete vide qui precede
 248 c        (si arete occupee cela deviendra le no du triangle 1 de l'arete)
 249          nosoar( 4, i ) = i-1
 250 c
 251 c        chainage sur l'arete vide qui suit
 252 c        (si arete occupee cela deviendra le no du triangle 2 de l'arete)
 253          nosoar( 5, i ) = i+1
 254 c
 255 c        chainages des aretes frontalieres ou internes ou ...
 256          nosoar( 6, i ) = -2
 257 c
 258 c        fin de chainage du hachage
 259          nosoar( mosoar, i ) = 0
 260 c
 261  20   continue
 262 c
 263 c     la premiere arete vide n'a pas de precedent
 264       nosoar( 4, n1soar ) = 0
 265 c
 266 c     la derniere arete vide est mxsoar sans arete vide suivante
 267       nosoar( 5, mxsoar ) = 0
 268       end
 269
 270
 271       subroutine azeroi ( l , ntab )
 272 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 273 c but : initialisation a zero d un tableau ntab de l variables entieres
 274 c -----
 275 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 276 c auteur : alain perronnet analyse numerique upmc paris septembre 1988
 277 c23456---------------------------------------------------------------012
 278       integer ntab(l)
 279       do 1 i = 1 , l
 280          ntab( i ) = 0
 281     1 continue
 282       end
 283
 284
 285       subroutine fasoar( ns1,    ns2,    nt1,    nt2,    nolign,
 286      %                   mosoar, mxsoar, n1soar, nosoar, noarst,
 287      %                   noar,   ierr )
 288 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 289 c but :    former l'arete de sommet ns1-ns2 dans le hachage du tableau
 290 c -----    nosoar des aretes de la triangulation
 291 c
 292 c entrees:
 293 c --------
 294 c ns1 ns2: numero pxyd des 2 sommets de l'arete
 295 c nt1    : numero du triangle auquel appartient l'arete
 296 c          nt1=-1 si numero inconnu
 297 c nt2    : numero de l'eventuel second triangle de l'arete si connu
 298 c          nt2=-1 si numero inconnu
 299 c nolign : numero de la ligne de l'arete dans ladefi(wulftr-1+nolign)
 300 c          =0 si l'arete n'est une arete de ligne
 301 c          ce numero est ajoute seulement si l'arete est creee
 302 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
 303 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
 304 c
 305 c modifies:
 306 c ---------
 307 c n1soar : numero de la premiere arete vide dans le tableau nosoar
 308 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
 309 c          chainage des aretes vides amont et aval
 310 c          l'arete vide qui precede=nosoar(4,i)
 311 c          l'arete vide qui suit   =nosoar(5,i)
 312 c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
 313 c          chainage momentan'e d'aretes, chainage du hachage des aretes
 314 c          hachage des aretes = min( nosoar(1), nosoar(2) )
 315 c noarst : noarst(np) numero d'une arete du sommet np
 316 c
 317 c ierr   : si < 0  en entree pas d'affichage en cas d'erreur du type
 318 c         "arete appartenant a plus de 2 triangles et a creer!"
 319 c          si >=0  en entree       affichage de ce type d'erreur
 320 c
 321 c sorties:
 322 c --------
 323 c noar   : >0 numero de l'arete retrouvee ou ajoutee
 324 c ierr   : =0 si pas d'erreur
 325 c          =1 si le tableau nosoar est sature
 326 c          =2 si arete a creer et appartenant a 2 triangles distincts
 327 c             des triangles nt1 et nt2
 328 c          =3 si arete appartenant a 2 triangles distincts
 329 c             differents des triangles nt1 et nt2
 330 c          =4 si arete appartenant a 2 triangles distincts
 331 c             dont le second n'est pas le triangle nt2
 332 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 333 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
 334 c2345x7..............................................................012
 335       common / unites / lecteu, imprim, nunite(30)
 336       integer           nosoar(mosoar,mxsoar), noarst(*)
 337       integer           nu2sar(2)
 338 c
 339 c     ajout eventuel de l'arete s1 s2 dans nosoar
 340       nu2sar(1) = ns1
 341       nu2sar(2) = ns2
 342 c
 343 c     hachage de l'arete de sommets nu2sar
 344       call hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar, noar )
 345 c     en sortie: noar>0 => no arete retrouvee
 346 c                    <0 => no arete ajoutee
 347 c                    =0 => saturation du tableau nosoar
 348 c
 349       if( noar .eq. 0 ) then
 350 c
 351 c        saturation du tableau nosoar
 352          write(imprim,*) 'fasoar: tableau nosoar sature'
 353          ierr = 1
 354          return
 355 c
 356       else if( noar .lt. 0 ) then
 357 c
 358 c        l'arete a ete ajoutee. initialisation des autres informations
 359          noar = -noar
 360 c        le numero de la ligne de l'arete
 361          nosoar(3,noar) = nolign
 362 c        le triangle 1 de l'arete => le triangle nt1
 363          nosoar(4,noar) = nt1
 364 c        le triangle 2 de l'arete => le triangle nt2
 365          nosoar(5,noar) = nt2
 366 c
 367 c        le sommet appartient a l'arete noar
 368          noarst( nu2sar(1) ) = noar
 369          noarst( nu2sar(2) ) = noar
 370 c
 371       else
 372 c
 373 c        l'arete a ete retrouvee.
 374 c        si elle appartient a 2 triangles differents de nt1 et nt2
 375 c        alors il y a une erreur
 376          if( nosoar(4,noar) .gt. 0 .and.
 377      %       nosoar(5,noar) .gt. 0 ) then
 378              if( nosoar(4,noar) .ne. nt1 .and.
 379      %           nosoar(4,noar) .ne. nt2 .or.
 380      %           nosoar(5,noar) .ne. nt1 .and.
 381      %           nosoar(5,noar) .ne. nt2 ) then
 382 c                arete appartenant a plus de 2 triangles => erreur
 383                  if( ierr .ge. 0 ) then
 384                     write(imprim,*) 'erreur fasoar: arete ',noar,
 385      %              ' dans 2 triangles et a creer!'
 386                  endif
 387                  ierr = 2
 388                  return
 389              endif
 390          endif
 391 c
 392 c        mise a jour du numero des triangles de l'arete noar
 393 c        le triangle 2 de l'arete => le triangle nt1
 394          if( nosoar(4,noar) .lt. 0 ) then
 395 c            pas de triangle connu pour cette arete
 396              n = 4
 397          else
 398 c            deja un triangle connu. ce nouveau est le second
 399              if( nosoar(5,noar) .gt. 0  .and.  nt1 .gt. 0 .and.
 400      %          nosoar(5,noar) .ne. nt1 ) then
 401 c               arete appartenant a plus de 2 triangles => erreur
 402                 write(imprim,*) 'erreur fasoar: arete ',noar,
 403      %          ' dans plus de 2 triangles'
 404                 ierr = 3
 405                 return
 406              endif
 407              n = 5
 408          endif
 409          nosoar(n,noar) = nt1
 410 c
 411 c        cas de l'arete frontaliere retrouvee comme diagonale d'un quadrangle
 412          if( nt2 .gt. 0 ) then
 413 c           l'arete appartient a 2 triangles
 414             if( nosoar(5,noar) .gt. 0  .and.
 415      %          nosoar(5,noar) .ne. nt2 ) then
 416 c               arete appartenant a plus de 2 triangles => erreur
 417                 write(imprim,*) 'erreur fasoar: arete ',noar,
 418      %         ' dans plus de 2 triangles'
 419                 ierr = 4
 420                 return
 421             endif
 422             nosoar(5,noar) = nt2
 423          endif
 424 c
 425       endif
 426 c
 427 c     pas d'erreur
 428       ierr = 0
 429       end
 430
 431       subroutine fq1inv( x, y, s, xc, yc, ierr )
 432 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 433 c but :   calcul des 2 coordonnees (xc,yc) dans le carre (0,1)
 434 c -----   image par f:carre unite-->quadrangle appartenant a q1**2
 435 c         par une resolution directe due a nicolas thenault
 436 c
 437 c entrees:
 438 c --------
 439 c x,y   : coordonnees du point image dans le quadrangle de sommets s
 440 c s     : les 2 coordonnees des 4 sommets du quadrangle
 441 c
 442 c sorties:
 443 c --------
 444 c xc,yc : coordonnees dans le carre dont l'image par f vaut (x,y)
 445 c ierr  : 0 si calcul sans erreur, 1 si quadrangle degenere
 446 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 447 c auteurs: thenault tulenew  analyse numerique paris        janvier 1998
 448 c modifs : perronnet alain   analyse numerique paris        janvier 1998
 449 c234567..............................................................012
 450       real             s(1:2,1:4), dist(2)
 451       double precision a,b,c,d,alpha,beta,gamma,delta,x0,y0,t(2),u,v,w
 452 c
 453       a = s(1,1)
 454       b = s(1,2) - s(1,1)
 455       c = s(1,4) - s(1,1)
 456       d = s(1,1) - s(1,2) + s(1,3) - s(1,4)
 457 c
 458       alpha = s(2,1)
 459       beta  = s(2,2) - s(2,1)
 460       gamma = s(2,4) - s(2,1)
 461       delta = s(2,1) - s(2,2) + s(2,3) - s(2,4)
 462 c
 463       u = beta  * c - b * gamma
 464       if( u .eq. 0 ) then
 465 c        quadrangle degenere
 466          ierr = 1
 467          return
 468       endif
 469       v = delta * c - d * gamma
 470       w = b * delta - beta * d
 471 c
 472       x0 = c * (y-alpha) - gamma * (x-a)
 473       y0 = b * (y-alpha) - beta  * (x-a)
 474 c
 475       a = v  * w
 476       b = u  * u - w * x0 - v * y0
 477       c = x0 * y0
 478 c
 479       if( a .ne. 0 ) then
 480 c
 481          delta = sqrt( b*b-4*a*c )
 482          if( b .ge. 0.0 ) then
 483             t(2) = -b - delta
 484          else
 485             t(2) = -b + delta
 486          endif
 487 c        la racine de plus grande valeur absolue
 488 c       (elle donne le plus souvent le point exterieur au carre unite
 489 c        donc a tester en second pour reduire les calculs)
 490          t(2) = t(2) / ( 2 * a )
 491 c        calcul de la seconde racine a partir de la somme => plus stable
 492          t(1) = - b/a - t(2)
 493 c
 494          do 10 i=1,2
 495 c
 496 c           la solution i donne t elle un point interne au carre unite?
 497             xc = ( x0 - v * t(i) ) / u
 498             yc = ( w * t(i) - y0 ) / u
 499             if( 0.0 .le. xc .and. xc .le. 1.0 ) then
 500                if( 0.0 .le. yc .and. yc .le. 1.0 ) goto 9000
 501             endif
 502 c
 503 c           le point (xc,yc) n'est pas dans le carre unite
 504 c           cela peut etre du aux erreurs d'arrondi
 505 c           => choix par le minimum de la distance aux bords du carre
 506             dist(i) = max( 0.0, -xc, xc-1.0, -yc, yc-1.0 )
 507 c
 508  10      continue
 509 c
 510          if( dist(1) .gt. dist(2) ) then
 511 c           f(xc,yc) pour la racine 2 est plus proche de x,y
 512 c           xc yc sont deja calcules
 513             goto 9000
 514          endif
 515 c
 516       else if ( b .ne. 0 ) then
 517          t(1) = - c / b
 518       else
 519          t(1) = 0
 520       endif
 521 c
 522 c     les 2 coordonnees du point dans le carre unite
 523       xc = ( x0 - v * t(1) ) / u
 524       yc = ( w * t(1) - y0 ) / u
 525 c
 526  9000 ierr = 0
 527       return
 528       end
 529
 530
 531       subroutine ptdatr( point, pxyd, nosotr, nsigne )
 532 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 533 c but :    le point est il dans le triangle de sommets nosotr
 534 c -----
 535 c
 536 c entrees:
 537 c --------
 538 c point  : les 2 coordonnees du point
 539 c pxyd   : les 2 coordonnees et distance souhaitee des points du maillage
 540 c nosotr : le numero des 3 sommets du triangle
 541 c
 542 c sorties:
 543 c --------
 544 c nsigne : >0 si le point est dans le triangle ou sur une des 3 aretes
 545 c          =0 si le triangle est degenere ou indirect ou ne contient pas le poin
 546 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 547 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
 548 c....................................................................012
 549       integer           nosotr(3)
 550       double precision  point(2), pxyd(3,*)
 551       double precision  xp,yp, x1,x2,x3, y1,y2,y3, d,dd, cb1,cb2,cb3
 552 c
 553       xp = point( 1 )
 554       yp = point( 2 )
 555 c
 556       n1 = nosotr( 1 )
 557       x1 = pxyd( 1 , n1 )
 558       y1 = pxyd( 2 , n1 )
 559 c
 560       n2 = nosotr( 2 )
 561       x2 = pxyd( 1 , n2 )
 562       y2 = pxyd( 2 , n2 )
 563 c
 564       n3 = nosotr( 3 )
 565       x3 = pxyd( 1 , n3 )
 566       y3 = pxyd( 2 , n3 )
 567 c
 568 c     2 fois la surface du triangle = determinant de la matrice
 569 c     de calcul des coordonnees barycentriques du point p
 570       d  = ( x2 - x1 ) * ( y3 - y1 ) - ( x3 - x1 ) * ( y2 - y1 )
 571 c
 572       if( d .gt. 0 ) then
 573 c
 574 c        triangle non degenere
 575 c        =====================
 576 c        calcul des 3 coordonnees barycentriques du
 577 c        point xp yp dans le triangle
 578          cb1 = ( ( x2-xp ) * ( y3-yp ) - ( x3-xp ) * ( y2-yp ) ) / d
 579          cb2 = ( ( x3-xp ) * ( y1-yp ) - ( x1-xp ) * ( y3-yp ) ) / d
 580          cb3 = 1d0 - cb1 -cb2
 581 ccc         cb3 = ( ( x1-xp ) * ( y2-yp ) - ( x2-xp ) * ( y1-yp ) ) / d
 582 c
 583 ccc         if( cb1 .ge. -0.00005d0 .and. cb1 .le. 1.00005d0 .and.
 584          if( cb1 .ge. 0d0 .and. cb1 .le. 1d0 .and.
 585      %       cb2 .ge. 0d0 .and. cb2 .le. 1d0 .and.
 586      %       cb3 .ge. 0d0 .and. cb3 .le. 1d0 ) then
 587 c
 588 c           le triangle nosotr contient le point
 589             nsigne = 1
 590          else
 591             nsigne = 0
 592          endif
 593 c
 594       else
 595 c
 596 c        triangle degenere
 597 c        =================
 598 c        le point est il du meme cote que le sommet oppose de chaque arete?
 599          nsigne = 0
 600          do 10 i=1,3
 601 c           le sinus de l'angle p1 p2-p1 point
 602             x1  = pxyd(1,n1)
 603             y1  = pxyd(2,n1)
 604             d   = ( pxyd(1,n2) - x1 ) * ( point(2) - y1 )
 605      %          - ( pxyd(2,n2) - y1 ) * ( point(1) - x1 )
 606             dd  = ( pxyd(1,n2) - x1 ) * ( pxyd(2,n3) - y1 )
 607      %          - ( pxyd(2,n2) - y1 ) * ( pxyd(1,n3) - x1 )
 608             cb1 = ( pxyd(1,n2) - x1 ) ** 2
 609      %          + ( pxyd(2,n2) - y1 ) ** 2
 610             cb2 = ( point(1) - x1 ) ** 2
 611      %          + ( point(2) - y1 ) ** 2
 612             cb3 = ( pxyd(1,n3) - x1 ) ** 2
 613      %          + ( pxyd(2,n3) - y1 ) ** 2
 614             if( abs( dd ) .le. 1e-4 * sqrt( cb1 * cb3 ) ) then
 615 c              le point 3 est sur l'arete 1-2
 616 c              le point doit y etre aussi
 617                if( abs( d ) .le. 1e-4 * sqrt( cb1 * cb2 ) ) then
 618 c                 point sur l'arete
 619                   nsigne = nsigne + 1
 620                endif
 621             else
 622 c              le point 3 n'est pas sur l'arete . test des signes
 623                if( d * dd .ge. 0 ) then
 624                   nsigne = nsigne + 1
 625                endif
 626             endif
 627 c           permutation circulaire des 3 sommets et aretes
 628             n  = n1
 629             n1 = n2
 630             n2 = n3
 631             n3 = n
 632  10      continue
 633          if( nsigne .ne. 3 ) nsigne = 0
 634       endif
 635       end
 636
 637       integer function nosstr( p, pxyd, nt, letree )
 638 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 639 c but :    calculer le numero 0 a 3 du sous-triangle te contenant
 640 c -----    le point p
 641 c
 642 c entrees:
 643 c --------
 644 c p      : point de r**2 contenu dans le te nt de letree
 645 c pxyd   : x y distance des points
 646 c nt     : numero letree du te de te voisin a calculer
 647 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
 648 c      letree(0,0)  no du 1-er te vide dans letree
 649 c      letree(0,1) : maximum du 1-er indice de letree (ici 8)
 650 c      letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
 651 c      letree(0:8,1) : racine de l'arbre  (triangle sans sur triangle)
 652 c      si letree(0,.)>0 alors
 653 c         letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
 654 c      sinon
 655 c         letree(0:3,j) :-no pxyd des 1 \85a 4 points internes au triangle j
 656 c                         0  si pas de point
 657 c                       ( j est alors une feuille de l'arbre )
 658 c      letree(4,j) : no letree du sur-triangle du triangle j
 659 c      letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
 660 c      letree(6:8,j) : no pxyd des 3 sommets du triangle j
 661 c
 662 c sorties :
 663 c ---------
 664 c nosstr : 0 si le sous-triangle central contient p
 665 c          i =1,2,3 numero du sous-triangle contenant p
 666 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 667 c auteur : alain perronnet  analyse numerique paris upmc    fevrier 1992
 668 c2345x7..............................................................012
 669       integer           letree(0:8,0:*)
 670       double precision  pxyd(3,*), p(2),
 671      %                  x1, y1, x21, y21, x31, y31, d, xe, ye
 672 c
 673 c     le numero des 3 sommets du triangle
 674       ns1 = letree( 6, nt )
 675       ns2 = letree( 7, nt )
 676       ns3 = letree( 8, nt )
 677 c
 678 c     les coordonnees entre 0 et 1 du point p
 679       x1  = pxyd(1,ns1)
 680       y1  = pxyd(2,ns1)
 681 c
 682       x21 = pxyd(1,ns2) - x1
 683       y21 = pxyd(2,ns2) - y1
 684 c
 685       x31 = pxyd(1,ns3) - x1
 686       y31 = pxyd(2,ns3) - y1
 687 c
 688       d   = 1.0 / ( x21 * y31 - x31 * y21 )
 689 c
 690       xe  = ( ( p(1) - x1 ) * y31 - ( p(2) - y1 ) * x31 ) * d
 691       ye  = ( ( p(2) - y1 ) * x21 - ( p(1) - x1 ) * y21 ) * d
 692 c
 693       if( xe .gt. 0.5d0 ) then
 694 c        sous-triangle droit
 695          nosstr = 2
 696       else if( ye .gt. 0.5d0 ) then
 697 c        sous-triangle haut
 698          nosstr = 3
 699       else if( xe+ye .lt. 0.5d0 ) then
 700 c        sous-triangle gauche
 701          nosstr = 1
 702       else
 703 c        sous-triangle central
 704          nosstr = 0
 705       endif
 706       end
 707
 708
 709       integer function notrpt( p, pxyd, notrde, letree )
 710 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 711 c but :    calculer le numero letree du sous-triangle feuille contenant
 712 c -----    le point p a partir du te notrde de letree
 713 c
 714 c entrees:
 715 c --------
 716 c p      : point de r**2 contenu dans le te nt de letree
 717 c pxyd   : x y distance des points
 718 c notrde : numero letree du triangle depart de recherche (1=>racine)
 719 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
 720 c      letree(0,0)  no du 1-er te vide dans letree
 721 c      letree(0,1) : maximum du 1-er indice de letree (ici 8)
 722 c      letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
 723 c      letree(0:8,1) : racine de l'arbre  (triangle sans sur triangle)
 724 c      si letree(0,.)>0 alors
 725 c         letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
 726 c      sinon
 727 c         letree(0:3,j) :-no pxyd des 1 \85 4 points internes au triangle j
 728 c                         0  si pas de point
 729 c                        ( j est alors une feuille de l'arbre )
 730 c      letree(4,j) : no letree du sur-triangle du triangle j
 731 c      letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
 732 c      letree(6:8,j) : no pxyd des 3 sommets du triangle j
 733 c
 734 c sorties :
 735 c ---------
 736 c notrpt : numero letree du triangle contenant le point p
 737 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 738 c auteur : alain perronnet  analyse numerique paris upmc    fevrier 1992
 739 c2345x7..............................................................012
 740       integer           letree(0:8,0:*)
 741       double precision  pxyd(1:3,*), p(2)
 742 c
 743 c     la racine depart de la recherche
 744       notrpt = notrde
 745 c
 746 c     tant que la feuille n'est pas atteinte descendre l'arbre
 747  10   if( letree(0,notrpt) .gt. 0 ) then
 748 c
 749 c        recherche du sous-triangle contenant p
 750          nsot = nosstr( p, pxyd, notrpt, letree )
 751 c
 752 c        le numero letree du sous-triangle
 753          notrpt = letree( nsot, notrpt )
 754          goto 10
 755 c
 756       endif
 757       end
 758
 759
 760       subroutine teajpt( ns,   nbsomm, mxsomm, pxyd, letree,
 761      &                   ntrp, ierr )
 762 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 763 c but :    ajout du point ns de pxyd dans letree
 764 c -----
 765 c
 766 c entrees:
 767 c --------
 768 c ns     : numero du point a ajouter dans letree
 769 c mxsomm : nombre maximal de points declarables dans pxyd
 770 c pxyd   : tableau des coordonnees des points
 771 c          par point : x  y  distance_souhaitee
 772 c
 773 c modifies :
 774 c ----------
 775 c nbsomm : nombre actuel de points dans pxyd
 776 c
 777 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
 778 c      letree(0,0) : no du 1-er te vide dans letree
 779 c      letree(0,1) : maximum du 1-er indice de letree (ici 8)
 780 c      letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
 781 c      letree(0:8,1) : racine de l'arbre  (triangle sans sur triangle)
 782 c      si letree(0,.)>0 alors
 783 c         letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
 784 c      sinon
 785 c         letree(0:3,j) :-no pxyd des 1 \85a 4 points internes au triangle j
 786 c                         0  si pas de point
 787 c                        ( j est alors une feuille de l'arbre )
 788 c      letree(4,j) : no letree du sur-triangle du triangle j
 789 c      letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
 790 c      letree(6:8,j) : no pxyd des 3 sommets du triangle j
 791 c
 792 c sorties :
 793 c ---------
 794 c ntrp    : numero letree du triangle te ou a ete ajoute le point
 795 c ierr    : 0 si pas d'erreur,  51 saturation letree, 52 saturation pxyd
 796 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 797 c auteur : alain perronnet  analyse numerique paris upmc    fevrier 1992
 798 c2345x7..............................................................012
 799       integer           letree(0:8,0:*)
 800       double precision  pxyd(3,mxsomm)
 801 c
 802 c     depart de la racine
 803       ntrp = 1
 804 c
 805 c     recherche du triangle contenant le point pxyd(ns)
 806  1    ntrp = notrpt( pxyd(1,ns), pxyd, ntrp, letree )
 807 c
 808 c     existe t il un point libre
 809       do 10 i=0,3
 810          if( letree(i,ntrp) .eq. 0 ) then
 811 c           la place i est libre
 812             letree(i,ntrp) = -ns
 813             return
 814          endif
 815  10   continue
 816 c
 817 c     pas de place libre => 4 sous-triangles sont crees
 818 c                           a partir des 3 milieux des aretes
 819       call te4ste( nbsomm, mxsomm, pxyd, ntrp, letree, ierr )
 820       if( ierr .ne. 0 ) return
 821 c
 822 c     ajout du point ns
 823       goto 1
 824       end
 825
 826       subroutine n1trva( nt, lar, letree, notrva, lhpile )
 827 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 828 c but :    calculer le numero letree du triangle voisin du te nt
 829 c -----    par l'arete lar (1 a 3 ) de nt
 830 c          attention : notrva n'est pas forcement minimal
 831 c
 832 c entrees:
 833 c --------
 834 c nt     : numero letree du te de te voisin a calculer
 835 c lar    : numero 1 a 3 de l'arete du triangle nt
 836 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
 837 c   letree(0,0)  no du 1-er te vide dans letree
 838 c   letree(0,1) : maximum du 1-er indice de letree (ici 8)
 839 c   letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
 840 c   letree(0:8,1) : racine de l'arbre  (triangle sans sur-triangle)
 841 c   si letree(0,.)>0 alors
 842 c      letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
 843 c   sinon
 844 c      letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
 845 c                      0  si pas de point
 846 c                     ( j est alors une feuille de l'arbre )
 847 c   letree(4,j) : no letree du sur-triangle du triangle j
 848 c   letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
 849 c   letree(6:8,j) : no pxyd des 3 sommets du triangle j
 850 c
 851 c sorties :
 852 c ---------
 853 c notrva  : >0 numero letree du te voisin par l'arete lar
 854 c           =0 si pas de te voisin (racine , ... )
 855 c lhpile  : =0 si nt et notrva ont meme taille
 856 c           >0 nt est 4**lhpile fois plus petit que notrva
 857 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 858 c auteur : alain perronnet  analyse numerique paris upmc    fevrier 1992
 859 c2345x7..............................................................012
 860       integer   letree(0:8,0:*)
 861       integer   lapile(1:64)
 862 c
 863 c     initialisation de la pile
 864 c     le triangle est empile
 865       lapile(1) = nt
 866       lhpile = 1
 867 c
 868 c     tant qu'il existe un sur-triangle
 869  10   ntr  = lapile( lhpile )
 870       if( ntr .eq. 1 ) then
 871 c        racine atteinte => pas de triangle voisin
 872          notrva = 0
 873          lhpile = lhpile - 1
 874          return
 875       endif
 876 c
 877 c     le type du triangle ntr
 878       nty  = letree( 5, ntr )
 879 c     l'eventuel sur-triangle
 880       nsut = letree( 4, ntr )
 881 c
 882       if( nty .eq. 0 ) then
 883 c
 884 c        triangle de type 0 => triangle voisin de type precedent(lar)
 885 c                              dans le sur-triangle de ntr
 886 c                              ce triangle remplace ntr dans lapile
 887          lapile( lhpile ) = letree( nopre3(lar), nsut )
 888          goto 20
 889       endif
 890 c
 891 c     triangle ntr de type nty>0
 892       if( nosui3(nty) .eq. lar ) then
 893 c
 894 c        le triangle voisin par lar est le triangle 0
 895          lapile( lhpile ) = letree( 0, nsut )
 896          goto 20
 897       endif
 898 c
 899 c     triangle sans voisin direct => passage par le sur-triangle
 900       if( nsut .eq. 0 ) then
 901 c
 902 c        ntr est la racine => pas de triangle voisin par cette arete
 903          notrva = 0
 904          return
 905       else
 906 c
 907 c        le sur-triangle est empile
 908          lhpile = lhpile + 1
 909          lapile(lhpile) = nsut
 910          goto 10
 911       endif
 912 c
 913 c     descente aux sous-triangles selon la meme arete
 914  20   notrva = lapile( lhpile )
 915 c
 916  30   lhpile = lhpile - 1
 917       if( letree(0,notrva) .le. 0 ) then
 918 c        le triangle est une feuille de l'arbre 0 sous-triangle
 919 c        lhpile = nombre de differences de niveaux dans l'arbre
 920          return
 921       else
 922 c        le triangle a 4 sous-triangles
 923          if( lhpile .gt. 0 ) then
 924 c
 925 c           bas de pile non atteint
 926             nty  = letree( 5, lapile(lhpile) )
 927             if( nty .eq. lar ) then
 928 c              l'oppose est suivant(nty) de notrva
 929                notrva = letree( nosui3(nty) , notrva )
 930             else
 931 c              l'oppose est precedent(nty) de notrva
 932                notrva = letree( nopre3(nty) , notrva )
 933             endif
 934             goto 30
 935          endif
 936       endif
 937 c
 938 c     meme niveau dans l'arbre lhpile = 0
 939       end
 940
 941
 942       subroutine cenced( xy1, xy2, xy3, cetria, ierr )
 943 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 944 c but : calcul des coordonnees du centre du cercle circonscrit
 945 c ----- du triangle defini par ses 3 sommets de coordonnees
 946 c       xy1 xy2 xy3 ainsi que le carre du rayon de ce cercle
 947 c
 948 c entrees :
 949 c ---------
 950 c xy1 xy2 xy3 : les 2 coordonnees des 3 sommets du triangle
 951 c ierr   : <0  => pas d'affichage si triangle degenere
 952 c          >=0 =>       affichage si triangle degenere
 953 c
 954 c sortie :
 955 c --------
 956 c cetria : cetria(1)=abcisse  du centre
 957 c          cetria(2)=ordonnee du centre
 958 c          cetria(3)=carre du rayon   1d28 si triangle degenere
 959 c ierr   : 0 si triangle non degenere
 960 c          1 si triangle degenere
 961 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 962 c auteur : perronnet alain upmc analyse numerique paris        juin 1995
 963 c2345x7..............................................................012
 964       parameter        (epsurf=1d-7)
 965       common / unites / lecteu,imprim,nunite(30)
 966       double precision  x1,y1,x21,y21,x31,y31,
 967      %                  aire2,xc,yc,rot,
 968      %                  xy1(2),xy2(2),xy3(2),cetria(3)
 969 c
 970 c     le calcul de 2 fois l'aire du triangle
 971 c     attention l'ordre des 3 sommets est direct ou non
 972       x1  = xy1(1)
 973       x21 = xy2(1) - x1
 974       x31 = xy3(1) - x1
 975 c
 976       y1  = xy1(2)
 977       y21 = xy2(2) - y1
 978       y31 = xy3(2) - y1
 979 c
 980       aire2  = x21 * y31 - x31 * y21
 981 c
 982 c     recherche d'un test relatif peu couteux
 983 c     pour reperer la degenerescence du triangle
 984       if( abs(aire2) .le.
 985      %    epsurf*(abs(x21)+abs(x31))*(abs(y21)+abs(y31)) ) then
 986 c        triangle de qualite trop faible
 987          if( ierr .ge. 0 ) then
 988 c            nblgrc(nrerr) = 1
 989 c            kerr(1) = 'erreur cenced: triangle degenere'
 990 c            call lereur
 991             write(imprim,*) 'erreur cenced: triangle degenere'
 992             write(imprim,10000)  xy1,xy2,xy3,aire2
 993          endif
 994 10000 format( 3(' x=',g24.16,' y=',g24.16/),' aire*2=',g24.16)
 995          cetria(1) = 0d0
 996          cetria(2) = 0d0
 997          cetria(3) = 1d28
 998          ierr = 1
 999          return
1000       endif
1001 c
1002 c     les 2 coordonnees du centre intersection des 2 mediatrices
1003 c     x = (x1+x2)/2 + lambda * (y2-y1)
1004 c     y = (y1+y2)/2 - lambda * (x2-x1)
1005 c     x = (x1+x3)/2 + rot    * (y3-y1)
1006 c     y = (y1+y3)/2 - rot    * (x3-x1)
1007 c     ==========================================================
1008       rot = ((xy2(1)-xy3(1))*x21 + (xy2(2)-xy3(2))*y21) / (2 * aire2)
1009 c
1010       xc = ( x1 + xy3(1) ) * 0.5d0 + rot * y31
1011       yc = ( y1 + xy3(2) ) * 0.5d0 - rot * x31
1012 c
1013       cetria(1) = xc
1014       cetria(2) = yc
1015 c
1016 c     le carre du rayon
1017       cetria(3) = (x1-xc) ** 2 + (y1-yc) ** 2
1018 c
1019 c     pas d'erreur rencontree
1020       ierr = 0
1021       end
1022
1023
1024       double precision function angled( p1, p2, p3 )
1025 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1026 c but :   calculer l'angle (p1p2,p1p3) en radians
1027 c -----
1028 c
1029 c entrees :
1030 c ---------
1031 c p1,p2,p3 : les 2 coordonnees des 3 sommets de l'angle
1032 c               sens direct pour une surface >0
1033 c sorties :
1034 c ---------
1035 c angled :  angle (p1p2,p1p3) en radians entre [0 et 2pi]
1036 c           0 si p1=p2 ou p1=p3
1037 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1038 c auteur : alain perronnet analyse numerique upmc paris     fevrier 1992
1039 c2345x7..............................................................012
1040       double precision  p1(2),p2(2),p3(2),x21,y21,x31,y31,a1,a2,d,c
1041 c
1042 c     les cotes
1043       x21 = p2(1) - p1(1)
1044       y21 = p2(2) - p1(2)
1045       x31 = p3(1) - p1(1)
1046       y31 = p3(2) - p1(2)
1047 c
1048 c     longueur des cotes
1049       a1 = x21 * x21 + y21 * y21
1050       a2 = x31 * x31 + y31 * y31
1051       d  = sqrt( a1 * a2 )
1052       if( d .eq. 0 ) then
1053          angled = 0
1054          return
1055       endif
1056 c
1057 c     cosinus de l'angle
1058       c  = ( x21 * x31 + y21 * y31 ) / d
1059       if( c .le. -1.d0 ) then
1060 c        tilt sur apollo si acos( -1 -eps )
1061          angled = atan( 1.d0 ) * 4.d0
1062          return
1063       else if( c .ge. 1.d0 ) then
1064 c        tilt sur apollo si acos( 1 + eps )
1065          angled = 0
1066          return
1067       endif
1068 c
1069       angled = acos( c )
1070       if( x21 * y31 - x31 * y21 .lt. 0 ) then
1071 c        demi plan inferieur
1072          angled = 8.d0 * atan( 1.d0 ) - angled
1073       endif
1074       end
1075
1076
1077       subroutine teajte( mxsomm, nbsomm, pxyd,   comxmi,
1078      %                   aretmx, mxtree, letree,
1079      %                   ierr )
1080 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1081 c but :    initialisation des tableaux letree
1082 c -----    ajout des sommets 1 a nbsomm (valeur en entree) dans letree
1083 c
1084 c entrees:
1085 c --------
1086 c mxsomm : nombre maximal de sommets permis pour la triangulation
1087 c mxtree : nombre maximal de triangles equilateraux (te) declarables
1088 c aretmx : longueur maximale des aretes des triangles equilateraux
1089 c
1090 c entrees et sorties :
1091 c --------------------
1092 c nbsomm : nombre de sommets apres identification
1093 c pxyd   : tableau des coordonnees 2d des points
1094 c          par point : x  y  distance_souhaitee
1095 c          tableau reel(3,mxsomm)
1096 c
1097 c sorties:
1098 c --------
1099 c comxmi : coordonnees minimales et maximales des points frontaliers
1100 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
1101 c          letree(0,0) : no du 1-er te vide dans letree
1102 c          letree(0,1) : maximum du 1-er indice de letree (ici 8)
1103 c          letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
1104 c          letree(0:8,1) : racine de l'arbre  (triangle sans sur triangle)
1105 c          si letree(0,.)>0 alors
1106 c             letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
1107 c          sinon
1108 c             letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
1109 c                             0  si pas de point
1110 c                             ( j est alors une feuille de l'arbre )
1111 c          letree(4,j) : no letree du sur-triangle du triangle j
1112 c          letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
1113 c          letree(6:8,j) : no pxyd des 3 sommets du triangle j
1114 c
1115 c ierr   :  0 si pas d'erreur
1116 c          51 saturation letree
1117 c          52 saturation pxyd
1118 c           7 tous les points sont alignes
1119 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1120 c auteur : alain perronnet  analyse numerique paris upmc    juillet 1994
1121 c....................................................................012
1122       integer           letree(0:8,0:mxtree)
1123       double precision  pxyd(3,mxsomm)
1124       double precision  comxmi(3,2)
1125       double precision  a(2),s,aretmx,rac3
1126 c
1127 c     protection du nombre de sommets avant d'ajouter ceux de tetree
1128       nbsofr = nbsomm
1129       do 1 i = 1, nbsomm
1130          comxmi(1,1) = min( comxmi(1,1), pxyd(1,i) )
1131          comxmi(1,2) = max( comxmi(1,2), pxyd(1,i) )
1132          comxmi(2,1) = min( comxmi(2,1), pxyd(2,i) )
1133          comxmi(2,2) = max( comxmi(2,2), pxyd(2,i) )
1134  1    continue
1135 c
1136 c     creation de l'arbre tee
1137 c     =======================
1138 c     la premiere colonne vide de letree
1139       letree(0,0) = 2
1140 c     chainage des te vides
1141       do 4 i = 2 , mxtree
1142          letree(0,i) = i+1
1143  4    continue
1144       letree(0,mxtree) = 0
1145 c     les maxima des 2 indices de letree
1146       letree(1,0) = 8
1147       letree(2,0) = mxtree
1148 c
1149 c     la racine
1150 c     aucun point interne au triangle equilateral (te) 1
1151       letree(0,1) = 0
1152       letree(1,1) = 0
1153       letree(2,1) = 0
1154       letree(3,1) = 0
1155 c     pas de sur-triangle
1156       letree(4,1) = 0
1157       letree(5,1) = 0
1158 c     le numero pxyd des 3 sommets du te 1
1159       letree(6,1) = nbsomm + 1
1160       letree(7,1) = nbsomm + 2
1161       letree(8,1) = nbsomm + 3
1162 c
1163 c     calcul de la largeur et hauteur du rectangle englobant
1164 c     ======================================================
1165       a(1) = comxmi(1,2) - comxmi(1,1)
1166       a(2) = comxmi(2,2) - comxmi(2,1)
1167 c     la longueur de la diagonale
1168       s = sqrt( a(1)**2 + a(2)**2 )
1169       do 60 k=1,2
1170          if( a(k) .lt. 1e-4 * s ) then
1171 c            nblgrc(nrerr) = 1
1172             write(imprim,*) 'tous les points sont alignes'
1173 c            call lereur
1174             ierr = 7
1175             return
1176          endif
1177  60   continue
1178 c
1179 c     le maximum des ecarts
1180       s = s + s
1181 c
1182 c     le triangle equilateral englobant
1183 c     =================================
1184 c     ecart du rectangle au triangle equilateral
1185       rac3 = sqrt( 3.0d0 )
1186       arete = a(1) + 2 * aretmx + 2 * ( a(2) + aretmx ) / rac3
1187 c
1188 c     le point nbsomm + 1 en bas a gauche
1189       nbsomm = nbsomm + 1
1190       pxyd(1,nbsomm) = (comxmi(1,1)+comxmi(1,2))*0.5d0 - arete*0.5d0
1191       pxyd(2,nbsomm) =  comxmi(2,1) - aretmx
1192       pxyd(3,nbsomm) = s
1193 c
1194 c     le point nbsomm + 2 en bas a droite
1195       nbsomm = nbsomm + 1
1196       pxyd(1,nbsomm) = pxyd(1,nbsomm-1) + arete
1197       pxyd(2,nbsomm) = pxyd(2,nbsomm-1)
1198       pxyd(3,nbsomm) = s
1199 c
1200 c     le point nbsomm + 3 sommet au dessus
1201       nbsomm = nbsomm + 1
1202       pxyd(1,nbsomm) = pxyd(1,nbsomm-2) + arete * 0.5d0
1203       pxyd(2,nbsomm) = pxyd(2,nbsomm-2) + arete * 0.5d0 * rac3
1204       pxyd(3,nbsomm) = s
1205 c
1206 c     ajout des sommets des lignes pour former letree
1207 c     ===============================================
1208       do 150 i=1,nbsofr
1209 c        ajout du point i de pxyd a letree
1210          call teajpt(  i, nbsomm, mxsomm, pxyd, letree,
1211      &                nt, ierr )
1212          if( ierr .ne. 0 ) return
1213  150  continue
1214 c
1215       return
1216       end
1217
1218
1219       subroutine tetaid( nutysu, dx, dy, longai, ierr )
1220 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1221 c but :     calculer la longueur de l'arete ideale en dx,dy
1222 c -----
1223 c
1224 c entrees:
1225 c --------
1226 c nutysu : numero de traitement de areteideale() selon le type de surface
1227 c          0 pas d'emploi de la fonction areteideale() => aretmx active
1228 c          1 il existe une fonction areteideale(xyz,xyzdir)
1229 c          ... autres options a definir ...
1230 c dx, dy : abscisse et ordonnee dans le plan du point (reel2!)
1231 c
1232 c sorties:
1233 c --------
1234 c longai : longueur de l'areteideale(xyz,xyzdir) autour du point xyz
1235 c ierr   : 0 si pas d'erreur, <>0 sinon
1236 c          1 calcul incorrect de areteideale(xyz,xyzdir)
1237 c          2 longueur calculee nulle
1238 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1239 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
1240 c2345x7..............................................................012
1241       common / unites / lecteu, imprim, nunite(30)
1242 c
1243       double precision  areteideale
1244       double precision  dx, dy, longai
1245       double precision  xyz(3), xyzd(3), d0
1246 c
1247       ierr = 0
1248       if( nutysu .gt. 0 ) then
1249          d0 = longai
1250 c        le point ou se calcule la longueur
1251          xyz(1) = dx
1252          xyz(2) = dy
1253 c        z pour le calcul de la longueur (inactif ici!)
1254          xyz(3) = 0d0
1255 c        la direction pour le calcul de la longueur (inactif ici!)
1256          xyzd(1) = 0d0
1257          xyzd(2) = 0d0
1258          xyzd(3) = 0d0
1259
1260          longai = areteideale(xyz,xyzd)
1261          if( longai .lt. 0d0 ) then
1262             write(imprim,10000) xyz
1263 10000       format('attention: longueur de areteideale(',
1264      %              g14.6,',',g14.6,',',g14.6,')<=0! => rendue >0' )
1265             longai = -longai
1266          endif
1267          if( longai .eq. 0d0 ) then
1268             write(imprim,10001) xyz
1269 10001       format('erreur: longueur de areteideale(',
1270      %              g14.6,',',g14.6,',',g14.6,')=0!' )
1271             ierr = 2
1272             longai = d0
1273          endif
1274       endif
1275       end
1276
1277
1278       subroutine tehote( nutysu,
1279      %                   nbarpi, mxsomm, nbsomm, pxyd,
1280      %                   comxmi, aretmx,
1281      %                   letree, mxqueu, laqueu,
1282      %                   ierr )
1283 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1284 c but :     homogeneisation de l'arbre des te a un saut de taille au plus
1285 c -----     prise en compte des distances souhaitees autour des sommets initiaux
1286 c
1287 c entrees:
1288 c --------
1289 c nutysu : numero de traitement de areteideale() selon le type de surface
1290 c          0 pas d'emploi de la fonction areteideale() => aretmx active
1291 c          1 il existe une fonction areteideale()
1292 c            dont seules les 2 premieres composantes de uv sont actives
1293 c          autres options a definir...
1294 c nbarpi : nombre de sommets de la frontiere + nombre de points internes
1295 c          imposes par l'utilisateur
1296 c mxsomm : nombre maximal de sommets permis pour la triangulation  et te
1297 c mxqueu : nombre d'entiers utilisables dans laqueu
1298 c comxmi : minimum et maximum des coordonnees de l'objet
1299 c aretmx : longueur maximale des aretes des triangles equilateraux
1300 c permtr : perimetre de la ligne enveloppe dans le plan
1301 c          avant mise a l'echelle a 2**20
1302 c
1303 c modifies :
1304 c ----------
1305 c nbsomm : nombre de sommets apres identification
1306 c pxyd   : tableau des coordonnees 2d des points
1307 c          par point : x  y  distance_souhaitee
1308 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
1309 c          letree(0,0) : no du 1-er te vide dans letree
1310 c          letree(1,0) : maximum du 1-er indice de letree (ici 8)
1311 c          letree(2,0) : maximum declare du 2-eme indice de letree (ici mxtree)
1312 c          letree(0:8,1) : racine de l'arbre  (triangle sans sur triangle)
1313 c          si letree(0,.)>0 alors
1314 c             letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
1315 c          sinon
1316 c             letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
1317 c                             0  si pas de point
1318 c                             ( j est alors une feuille de l'arbre )
1319 c          letree(4,j) : no letree du sur-triangle du triangle j
1320 c          letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
1321 c          letree(6:8,j) : no pxyd des 3 sommets du triangle j
1322 c
1323 c auxiliaire :
1324 c ------------
1325 c laqueu : mxqueu entiers servant de queue pour le parcours de letree
1326 c
1327 c sorties:
1328 c --------
1329 c ierr   :  0 si pas d'erreur
1330 c          51 si saturation letree dans te4ste
1331 c          52 si saturation pxyd   dans te4ste
1332 c          >0 si autre erreur
1333 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1334 c auteur : alain perronnet  analyse numerique paris upmc      avril 1997
1335 c2345x7..............................................................012
1336       double precision  ampli
1337       parameter        (ampli=1.34d0)
1338       common / unites / lecteu, imprim, intera, nunite(29)
1339 c
1340       double precision  pxyd(3,mxsomm), d2, aretm2
1341       double precision  comxmi(3,2),aretmx,a,s,xrmin,xrmax,yrmin,yrmax
1342       double precision  dmin, dmax
1343       integer           letree(0:8,0:*)
1344 c
1345       integer           laqueu(1:mxqueu),lequeu
1346 c                       lequeu : entree dans la queue
1347 c                       lhqueu : longueur de la queue
1348 c                       gestion circulaire
1349 c
1350       integer           nuste(3)
1351       equivalence      (nuste(1),ns1),(nuste(2),ns2),(nuste(3),ns3)
1352 c
1353 c     existence ou non de la fonction 'taille_ideale' des aretes
1354 c     autour du point.  ici la carte est supposee isotrope
1355 c     ==========================================================
1356 c     attention: si la fonction taille_ideale existe
1357 c                alors pxyd(3,*) est la taille_ideale dans l'espace initial
1358 c                sinon pxyd(3,*) est la distance calculee dans le plan par
1359 c                propagation a partir des tailles des aretes de la frontiere
1360 c
1361       if( nutysu .gt. 0 ) then
1362 c
1363 c        la fonction taille_ideale(x,y,z) existe
1364 c        ---------------------------------------
1365 c        initialisation de la distance souhaitee autour des points 1 a nbsomm
1366          do 1 i=1,nbsomm
1367 c           calcul de pxyzd(3,i)
1368             call tetaid( nutysu, pxyd(1,i), pxyd(2,i),
1369      %                   pxyd(3,i), ierr )
1370             if( ierr .ne. 0 ) goto 9999
1371  1       continue
1372 c
1373       else
1374 c
1375 c        la fonction taille_ideale(x,y,z) n'existe pas
1376 c        ---------------------------------------------
1377 c        prise en compte des distances souhaitees dans le plan
1378 c        autour des points frontaliers et des points internes imposes
1379 c        toutes les autres distances souhaitees ont ete mis a aretmx
1380 c        lors de l'execution du sp teqini
1381          do 3 i=1,nbarpi
1382 c           le sommet i n'est pas un sommet de letree => sommet frontalier
1383 c           recherche du sous-triangle minimal feuille contenant le point i
1384             nte = 1
1385  2          nte = notrpt( pxyd(1,i), pxyd, nte, letree )
1386 c           la distance au sommet le plus eloigne est elle inferieure
1387 c           a la distance souhaitee?
1388             ns1 = letree(6,nte)
1389             ns2 = letree(7,nte)
1390             ns3 = letree(8,nte)
1391             d2  = max( ( pxyd(1,i)-pxyd(1,ns1) )**2 +
1392      %                 ( pxyd(2,i)-pxyd(2,ns1) )**2
1393      %               , ( pxyd(1,i)-pxyd(1,ns2) )**2 +
1394      %                 ( pxyd(2,i)-pxyd(2,ns2) )**2
1395      %               , ( pxyd(1,i)-pxyd(1,ns3) )**2 +
1396      %                 ( pxyd(2,i)-pxyd(2,ns3) )**2 )
1397             if( d2 .gt. pxyd(3,i)**2 ) then
1398 c              le triangle nte trop grand doit etre subdivise en 4 sous-triangle
1399                call te4ste( nbsomm, mxsomm, pxyd, nte, letree,
1400      &                      ierr )
1401                if( ierr .ne. 0 ) return
1402                goto 2
1403             endif
1404  3       continue
1405       endif
1406 c
1407 c     le sous-triangle central de la racine est decoupe systematiquement
1408 c     ==================================================================
1409       nte = 2
1410       if( letree(0,2) .le. 0 ) then
1411 c        le sous-triangle central de la racine n'est pas subdivise
1412 c        il est donc decoupe en 4 soustriangles
1413          nbsom0 = nbsomm
1414          call te4ste( nbsomm, mxsomm, pxyd, nte, letree,
1415      %                ierr )
1416          if( ierr .ne. 0 ) return
1417          do 4 i=nbsom0+1,nbsomm
1418 c           mise a jour de taille_ideale des nouveaux sommets de te
1419             call tetaid( nutysu, pxyd(1,i), pxyd(2,i), pxyd(3,i), ierr )
1420             if( ierr .ne. 0 ) goto 9999
1421  4       continue
1422       endif
1423 c
1424 c     le carre de la longueur de l'arete de triangles equilateraux
1425 c     souhaitee pour le fond de la triangulation
1426       aretm2 = (aretmx*ampli) ** 2
1427 c
1428 c     tout te contenu dans le rectangle englobant doit avoir un
1429 c     cote < aretmx et etre de meme taille que les te voisins
1430 c     s'il contient un point; sinon un seul saut de taille est permis
1431 c     ===============================================================
1432 c     le rectangle englobant pour selectionner les te "internes"
1433 c     le numero des 3 sommets du te englobant racine de l'arbre des te
1434       ns1 = letree(6,1)
1435       ns2 = letree(7,1)
1436       ns3 = letree(8,1)
1437       a   = aretmx * 0.01d0
1438 c     abscisse du milieu de l'arete gauche du te 1
1439       s      = ( pxyd(1,ns1) + pxyd(1,ns3) ) / 2
1440       xrmin  = min( s, comxmi(1,1) - aretmx ) - a
1441 c     abscisse du milieu de l'arete droite du te 1
1442       s      = ( pxyd(1,ns2) + pxyd(1,ns3) ) / 2
1443       xrmax  = max( s, comxmi(1,2) + aretmx ) + a
1444       yrmin  = comxmi(2,1) - aretmx
1445 c     ordonnee de la droite passant par les milieus des 2 aretes
1446 c     droite gauche du te 1
1447       s      = ( pxyd(2,ns1) + pxyd(2,ns3) ) / 2
1448       yrmax  = max( s, comxmi(2,2) + aretmx ) + a
1449 c
1450 c     cas particulier de 3 ou 4 ou peu d'aretes frontalieres
1451       if( nbarpi .le. 8 ) then
1452 c        tout le triangle englobant (racine) est a prendre en compte
1453          xrmin = pxyd(1,ns1) - a
1454          xrmax = pxyd(1,ns2) + a
1455          yrmin = pxyd(2,ns1) - a
1456          yrmax = pxyd(2,ns3) + a
1457       endif
1458 c
1459       nbs0   = nbsomm
1460       nbiter = -1
1461 c
1462 c     initialisation de la queue
1463   5   nbiter = nbiter + 1
1464       lequeu = 1
1465       lhqueu = 0
1466 c     la racine de letree initialise la queue
1467       laqueu(1) = 1
1468 c
1469 c     tant que la longueur de la queue est >=0 traiter le debut de queue
1470  10   if( lhqueu .ge. 0 ) then
1471 c
1472 c        le triangle te a traiter
1473          i   = lequeu - lhqueu
1474          if( i .le. 0 ) i = mxqueu + i
1475          nte = laqueu( i )
1476 c        la longueur de la queue est reduite
1477          lhqueu = lhqueu - 1
1478 c
1479 c        nte est il un sous-triangle feuille minimal ?
1480  15      if( letree(0,nte) .gt. 0 ) then
1481 c
1482 c           non les 4 sous-triangles sont mis dans la queue
1483             if( lhqueu + 4 .ge. mxqueu ) then
1484                write(imprim,*) 'tehote: saturation de la queue'
1485                ierr = 7
1486                return
1487             endif
1488             do 20 i=3,0,-1
1489 c              ajout du sous-triangle i
1490                lhqueu = lhqueu + 1
1491                lequeu = lequeu + 1
1492                if( lequeu .gt. mxqueu ) lequeu = lequeu - mxqueu
1493                laqueu( lequeu ) = letree( i, nte )
1494  20         continue
1495             goto 10
1496 c
1497          endif
1498 c
1499 c        ici nte est un triangle minimal non subdivise
1500 c        ---------------------------------------------
1501 c        le te est il dans le cadre englobant de l'objet ?
1502          ns1 = letree(6,nte)
1503          ns2 = letree(7,nte)
1504          ns3 = letree(8,nte)
1505          if( pxyd(1,ns1) .gt. pxyd(1,ns2) ) then
1506             dmin = pxyd(1,ns2)
1507             dmax = pxyd(1,ns1)
1508          else
1509             dmin = pxyd(1,ns1)
1510             dmax = pxyd(1,ns2)
1511          endif
1512          if( (xrmin .le. dmin .and. dmin .le. xrmax) .or.
1513      %       (xrmin .le. dmax .and. dmax .le. xrmax) ) then
1514             if( pxyd(2,ns1) .gt. pxyd(2,ns3) ) then
1515                dmin = pxyd(2,ns3)
1516                dmax = pxyd(2,ns1)
1517             else
1518                dmin = pxyd(2,ns1)
1519                dmax = pxyd(2,ns3)
1520             endif
1521             if( (yrmin .le. dmin .and. dmin .le. yrmax) .or.
1522      %          (yrmin .le. dmax .and. dmax .le. yrmax) ) then
1523 c
1524 c              nte est un te feuille et interne au rectangle englobant
1525 c              =======================================================
1526 c              le carre de la longueur de l'arete du te de numero nte
1527                d2 = (pxyd(1,ns1)-pxyd(1,ns2)) ** 2 +
1528      %              (pxyd(2,ns1)-pxyd(2,ns2)) ** 2
1529 c
1530                if( nutysu .eq. 0 ) then
1531 c
1532 c                 il n'existe pas de fonction 'taille_ideale'
1533 c                 -------------------------------------------
1534 c                 si la taille effective de l'arete du te est superieure a aretmx
1535 c                 alors le te est decoupe
1536                   if( d2 .gt. aretm2 ) then
1537 c                    le triangle nte trop grand doit etre subdivise
1538 c                    en 4 sous-triangles
1539                      call te4ste( nbsomm,mxsomm, pxyd,
1540      %                            nte, letree, ierr )
1541                      if( ierr .ne. 0 ) return
1542                      goto 15
1543                   endif
1544 c
1545                else
1546 c
1547 c                 il existe ici une fonction 'taille_ideale'
1548 c                 ------------------------------------------
1549 c                 si la taille effective de l'arete du te est superieure au mini
1550 c                 des 3 tailles_ideales aux sommets  alors le te est decoupe
1551                   do 28 i=1,3
1552                      if( d2 .gt. (pxyd(3,nuste(i))*ampli)**2 ) then
1553 c                       le triangle nte trop grand doit etre subdivise
1554 c                       en 4 sous-triangles
1555                         nbsom0 = nbsomm
1556                         call te4ste( nbsomm, mxsomm, pxyd,
1557      &                               nte, letree, ierr )
1558                         if( ierr .ne. 0 ) return
1559                         do 27 j=nbsom0+1,nbsomm
1560 c                          mise a jour de taille_ideale des nouveaux sommets de
1561                            call tetaid( nutysu, pxyd(1,j), pxyd(2,j),
1562      %                                  pxyd(3,j), ierr )
1563                            if( ierr .ne. 0 ) goto 9999
1564  27                     continue
1565                         goto 15
1566                      endif
1567  28               continue
1568                endif
1569 c
1570 c              recherche du nombre de niveaux entre nte et les te voisins par se
1571 c              si la difference de subdivisions excede 1 alors le plus grand des
1572 c              =================================================================
1573  29            do 30 i=1,3
1574 c
1575 c                 noteva triangle voisin de nte par l'arete i
1576                   call n1trva( nte, i, letree, noteva, niveau )
1577                   if( noteva .le. 0 ) goto 30
1578 c                 il existe un te voisin
1579                   if( niveau .gt. 0 ) goto 30
1580 c                 nte a un te voisin plus petit ou egal
1581                   if( letree(0,noteva) .le. 0 ) goto 30
1582 c                 nte a un te voisin noteva subdivise au moins une fois
1583 c
1584                   if( nbiter .gt. 0 ) then
1585 c                    les 2 sous triangles voisins sont-ils subdivises?
1586                      ns2 = letree(i,noteva)
1587                      if( letree(0,ns2) .le. 0 ) then
1588 c                       ns2 n'est pas subdivise
1589                         ns2 = letree(nosui3(i),noteva)
1590                         if( letree(0,ns2) .le. 0 ) then
1591 c                          les 2 sous-triangles ne sont pas subdivises
1592                            goto 30
1593                         endif
1594                      endif
1595                   endif
1596 c
1597 c                 saut>1 => le triangle nte doit etre subdivise en 4 sous-triang
1598 c                 --------------------------------------------------------------
1599                   nbsom0 = nbsomm
1600                   call te4ste( nbsomm,mxsomm, pxyd, nte, letree,
1601      &                         ierr )
1602                   if( ierr .ne. 0 ) return
1603                   if( nutysu .gt. 0 ) then
1604                      do 32 j=nbsom0+1,nbsomm
1605 c                       mise a jour de taille_ideale des nouveaux sommets de te
1606                         call tetaid( nutysu, pxyd(1,j), pxyd(2,j),
1607      %                               pxyd(3,j), ierr )
1608                         if( ierr .ne. 0 ) goto 9999
1609  32                  continue
1610                   endif
1611                   goto 15
1612 c
1613  30            continue
1614             endif
1615          endif
1616          goto 10
1617       endif
1618       if( nbs0 .lt. nbsomm ) then
1619          nbs0 = nbsomm
1620          goto 5
1621       endif
1622       return
1623 c
1624 c     pb dans le calcul de la fonction taille_ideale
1625
1626  9999 write(imprim,*) 'pb dans le calcul de taille_ideale'
1627 c      nblgrc(nrerr) = 1
1628 c      kerr(1) = 'pb dans le calcul de taille_ideale'
1629 c      call lereur
1630       return
1631       end
1632
1633
1634       subroutine tetrte( comxmi, aretmx, nbarpi, mxsomm, pxyd,
1635      %                   mxqueu, laqueu, letree,
1636      %                   mosoar, mxsoar, n1soar, nosoar,
1637      %                   moartr, mxartr, n1artr, noartr, noarst,
1638      %                   ierr  )
1639 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1640 c but :    trianguler les triangles equilateraux feuilles et
1641 c -----    les points de la frontiere et les points internes imposes
1642 c
1643 c attention: la triangulation finale n'est pas de type delaunay!
1644 c
1645 c entrees:
1646 c --------
1647 c comxmi : minimum et maximum des coordonnees de l'objet
1648 c aretmx : longueur maximale des aretes des triangles equilateraux
1649 c nbarpi : nombre de sommets de la frontiere + nombre de points internes
1650 c          imposes par l'utilisateur
1651 c mxsomm : nombre maximal de sommets declarables dans pxyd
1652 c pxyd   : tableau des coordonnees 2d des points
1653 c          par point : x  y  distance_souhaitee
1654 c
1655 c mxqueu : nombre d'entiers utilisables dans laqueu
1656 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
1657 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
1658 c moartr : nombre maximal d'entiers par arete du tableau noartr
1659 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
1660 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
1661 c          letree(0,0) : no du 1-er te vide dans letree
1662 c          letree(0,1) : maximum du 1-er indice de letree (ici 8)
1663 c          letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
1664 c          letree(0:8,1) : racine de l'arbre  (triangle sans sur triangle)
1665 c          si letree(0,.)>0 alors
1666 c             letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
1667 c          sinon
1668 c             letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
1669 c                             0  si pas de point
1670 c                             ( j est alors une feuille de l'arbre )
1671 c          letree(4,j) : no letree du sur-triangle du triangle j
1672 c          letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
1673 c          letree(6:8,j) : no pxyd des 3 sommets du triangle j
1674 c
1675 c modifies:
1676 c ---------
1677 c n1soar : numero de la premiere arete vide dans le tableau nosoar
1678 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
1679 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
1680 c          chainage des aretes frontalieres, chainage du hachage des aretes
1681 c          hachage des aretes = nosoar(1)+nosoar(2)*2
1682 c noarst : noarst(i) numero d'une arete de sommet i
1683 c
1684 c auxiliaire :
1685 c ------------
1686 c laqueu : mxqueu entiers servant de queue pour le parcours de letree
1687 c
1688 c sorties:
1689 c --------
1690 c n1artr : numero du premier triangle vide dans le tableau noartr
1691 c          le chainage des triangles vides se fait sur noartr(2,.)
1692 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
1693 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
1694 c ierr   : =0 si pas d'erreur
1695 c          =1 si le tableau nosoar est sature
1696 c          =2 si le tableau noartr est sature
1697 c          =3 si aucun des triangles ne contient l'un des points internes d'un t
1698 c          =5 si saturation de la queue de parcours de l'arbre des te
1699 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1700 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
1701 c2345x7..............................................................012
1702       common / unites / lecteu, imprim, intera, nunite(29)
1703 c
1704       double precision  pxyd(3,mxsomm)
1705       double precision  comxmi(3,2),aretmx,a,s,xrmin,xrmax,yrmin,yrmax
1706       double precision  dmin, dmax
1707 c
1708       integer           nosoar(mosoar,mxsoar),
1709      %                  noartr(moartr,mxartr),
1710      %                  noarst(mxsomm)
1711 c
1712       integer           letree(0:8,0:*)
1713       integer           laqueu(1:mxqueu)
1714 c                       lequeu:entree dans la queue en gestion circulaire
1715 c                       lhqueu:longueur de la queue en gestion circulaire
1716 c
1717       integer           milieu(3), nutr(1:13)
1718 c
1719 c     le rectangle englobant pour selectionner les te "internes"
1720 c     le numero des 3 sommets du te englobant racine de l'arbre des te
1721       ns1 = letree(6,1)
1722       ns2 = letree(7,1)
1723       ns3 = letree(8,1)
1724       a   = aretmx * 0.01d0
1725 c     abscisse du milieu de l'arete gauche du te 1
1726       s      = ( pxyd(1,ns1) + pxyd(1,ns3) ) / 2
1727       xrmin  = min( s, comxmi(1,1) - aretmx ) - a
1728 c     abscisse du milieu de l'arete droite du te 1
1729       s      = ( pxyd(1,ns2) + pxyd(1,ns3) ) / 2
1730       xrmax  = max( s, comxmi(1,2) + aretmx ) + a
1731       yrmin  = comxmi(2,1) - aretmx
1732 c     ordonnee de la droite passant par les milieus des 2 aretes
1733 c     droite gauche du te 1
1734       s      = ( pxyd(2,ns1) + pxyd(2,ns3) ) / 2
1735       yrmax  = max( s, comxmi(2,2) + aretmx ) + a
1736 c
1737 c     cas particulier de 3 ou 4 ou peu d'aretes frontalieres
1738       if( nbarpi .le. 8 ) then
1739 c        tout le triangle englobant (racine) est a prendre en compte
1740          xrmin = pxyd(1,ns1) - a
1741          xrmax = pxyd(1,ns2) + a
1742          yrmin = pxyd(2,ns1) - a
1743          yrmax = pxyd(2,ns3) + a
1744       endif
1745 c
1746 c     initialisation du tableau noartr
1747       do 5 i=1,mxartr
1748 c        le numero de l'arete est inconnu
1749          noartr(1,i) = 0
1750 c        le chainage sur le triangle vide suivant
1751          noartr(2,i) = i+1
1752  5    continue
1753       noartr(2,mxartr) = 0
1754       n1artr = 1
1755 c
1756 c     parcours des te jusqu'a trianguler toutes les feuilles (triangles eq)
1757 c     =====================================================================
1758 c     initialisation de la queue sur les te
1759       ierr   = 0
1760       lequeu = 1
1761       lhqueu = 0
1762 c     la racine de letree initialise la queue
1763       laqueu(1) = 1
1764 c
1765 c     tant que la longueur de la queue est >=0 traiter le debut de queue
1766  10   if( lhqueu .ge. 0 ) then
1767 c
1768 c        le triangle te a traiter
1769          i   = lequeu - lhqueu
1770          if( i .le. 0 ) i = mxqueu + i
1771          nte = laqueu( i )
1772 c        la longueur est reduite
1773          lhqueu = lhqueu - 1
1774 c
1775 c        nte est il un sous-triangle feuille (minimal) ?
1776  15      if( letree(0,nte) .gt. 0 ) then
1777 c           non les 4 sous-triangles sont mis dans la queue
1778             if( lhqueu + 4 .ge. mxqueu ) then
1779                write(imprim,*) 'tetrte: saturation de la queue'
1780                ierr = 5
1781                return
1782             endif
1783             do 20 i=3,0,-1
1784 c              ajout du sous-triangle i
1785                lhqueu = lhqueu + 1
1786                lequeu = lequeu + 1
1787                if( lequeu .gt. mxqueu ) lequeu = lequeu - mxqueu
1788                laqueu( lequeu ) = letree( i, nte )
1789  20         continue
1790             goto 10
1791          endif
1792 c
1793 c        ici nte est un triangle minimal non subdivise
1794 c        ---------------------------------------------
1795 c        le te est il dans le cadre englobant de l'objet ?
1796          ns1 = letree(6,nte)
1797          ns2 = letree(7,nte)
1798          ns3 = letree(8,nte)
1799          if( pxyd(1,ns1) .gt. pxyd(1,ns2) ) then
1800             dmin = pxyd(1,ns2)
1801             dmax = pxyd(1,ns1)
1802          else
1803             dmin = pxyd(1,ns1)
1804             dmax = pxyd(1,ns2)
1805          endif
1806          if( (xrmin .le. dmin .and. dmin .le. xrmax) .or.
1807      %       (xrmin .le. dmax .and. dmax .le. xrmax) ) then
1808             if( pxyd(2,ns1) .gt. pxyd(2,ns3) ) then
1809                dmin = pxyd(2,ns3)
1810                dmax = pxyd(2,ns1)
1811             else
1812                dmin = pxyd(2,ns1)
1813                dmax = pxyd(2,ns3)
1814             endif
1815             if( (yrmin .le. dmin .and. dmin .le. yrmax) .or.
1816      %          (yrmin .le. dmax .and. dmax .le. yrmax) ) then
1817 c
1818 c              te minimal et interne au rectangle englobant
1819 c              --------------------------------------------
1820 c              recherche du nombre de niveaux entre nte et les te voisins
1821 c              par ses aretes
1822                nbmili = 0
1823                do 30 i=1,3
1824 c
1825 c                 a priori pas de milieu de l'arete i du te nte
1826                   milieu(i) = 0
1827 c
1828 c                 recherche de noteva te voisin de nte par l'arete i
1829                   call n1trva( nte, i, letree, noteva, niveau )
1830 c                 noteva  : >0 numero letree du te voisin par l'arete i
1831 c                           =0 si pas de te voisin (racine , ... )
1832 c                 niveau  : =0 si nte et noteva ont meme taille
1833 c                           >0 nte est 4**niveau fois plus petit que noteva
1834                   if( noteva .gt. 0 ) then
1835 c                    il existe un te voisin
1836                      if( letree(0,noteva) .gt. 0 ) then
1837 c                       noteva est plus petit que nte
1838 c                       => recherche du numero du milieu du cote=sommet du te no
1839 c                       le sous-te 0 du te noteva
1840                         nsot = letree(0,noteva)
1841 c                       le numero dans pxyd du milieu de l'arete i de nte
1842                         milieu( i ) = letree( 5+nopre3(i), nsot )
1843                         nbmili = nbmili + 1
1844                      endif
1845                   endif
1846 c
1847  30            continue
1848 c
1849 c              triangulation du te nte en fonction du nombre de ses milieux
1850                goto( 50, 100, 200, 300 ) , nbmili + 1
1851 c
1852 c              0 milieu => 1 triangle = le te nte
1853 c              ----------------------------------
1854  50            call f0trte( letree(0,nte),  pxyd,
1855      %                      mosoar, mxsoar, n1soar, nosoar,
1856      %                      moartr, mxartr, n1artr, noartr,
1857      %                      noarst,
1858      %                      nbtr,   nutr,   ierr )
1859                if( ierr .ne. 0 ) return
1860                goto 10
1861 c
1862 c              1 milieu => 2 triangles = 2 demi te
1863 c              -----------------------------------
1864  100           call f1trte( letree(0,nte),  pxyd,   milieu,
1865      %                      mosoar, mxsoar, n1soar, nosoar,
1866      %                      moartr, mxartr, n1artr, noartr,
1867      %                      noarst,
1868      %                      nbtr,   nutr,   ierr )
1869                if( ierr .ne. 0 ) return
1870                goto 10
1871 c
1872 c              2 milieux => 3 triangles
1873 c              -----------------------------------
1874  200           call f2trte( letree(0,nte),  pxyd,   milieu,
1875      %                      mosoar, mxsoar, n1soar, nosoar,
1876      %                      moartr, mxartr, n1artr, noartr,
1877      %                      noarst,
1878      %                      nbtr,   nutr,   ierr )
1879                if( ierr .ne. 0 ) return
1880                goto 10
1881 c
1882 c              3 milieux => 4 triangles = 4 quart te
1883 c              -------------------------------------
1884  300           call f3trte( letree(0,nte),  pxyd,   milieu,
1885      %                      mosoar, mxsoar, n1soar, nosoar,
1886      %                      moartr, mxartr, n1artr, noartr,
1887      %                      noarst,
1888      %                      nbtr,   nutr,   ierr )
1889                if( ierr .ne. 0 ) return
1890                goto 10
1891             endif
1892          endif
1893          goto 10
1894       endif
1895       end
1896
1897
1898       subroutine aisoar( mosoar, mxsoar, nosoar, na1 )
1899 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1900 c but :    chainer en colonne lchain les aretes non vides et
1901 c -----    non frontalieres du tableau nosoar
1902 c
1903 c entrees:
1904 c --------
1905 c mosoar : nombre maximal d'entiers par arete dans le tableau nosoar
1906 c mxsoar : nombre maximal d'aretes frontalieres declarables
1907 c
1908 c modifies :
1909 c ----------
1910 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
1911 c          nosoar(lchain,i)=arete interne suivante
1912 c
1913 c sortie :
1914 c --------
1915 c na1    : numero dans nosoar de la premiere arete interne
1916 c          les suivantes sont nosoar(lchain,na1), ...
1917 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1918 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
1919 c....................................................................012
1920       parameter (lchain=6)
1921       integer    nosoar(mosoar,mxsoar)
1922 c
1923 c     formation du chainage des aretes internes a echanger eventuellement
1924 c     recherche de la premiere arete non vide et non frontaliere
1925       do 10 na1=1,mxsoar
1926          if( nosoar(1,na1) .gt. 0 .and. nosoar(3,na1) .le. 0 ) goto 15
1927  10   continue
1928 c
1929 c     protection de la premiere arete non vide et non frontaliere
1930  15   na0 = na1
1931       do 20 na=na1+1,mxsoar
1932          if( nosoar(1,na) .gt. 0 .and. nosoar(3,na) .le. 0 ) then
1933 c           arete interne => elle est chainee a partir de la precedente
1934             nosoar(lchain,na0) = na
1935             na0 = na
1936          endif
1937  20   continue
1938 c
1939 c     la derniere arete interne n'a pas de suivante
1940       nosoar(lchain,na0) = 0
1941       end
1942
1943
1944       subroutine tedela( pxyd,   noarst,
1945      %                   mosoar, mxsoar, n1soar, nosoar, n1ardv,
1946      %                   moartr, mxartr, n1artr, noartr, modifs )
1947 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1948 c but :    pour toutes les aretes chainees dans nosoar(lchain,*)
1949 c -----    du tableau nosoar
1950 c          echanger la diagonale des 2 triangles si le sommet oppose
1951 c          a un triangle ayant en commun une arete appartient au cercle
1952 c          circonscrit de l'autre (violation boule vide delaunay)
1953 c
1954 c entrees:
1955 c --------
1956 c pxyd   : tableau des x  y  distance_souhaitee de chaque sommet
1957 c
1958 c modifies :
1959 c ----------
1960 c noarst : noarst(i) numero d'une arete de sommet i
1961 c mosoar : nombre maximal d'entiers par arete dans le tableau nosoar
1962 c mxsoar : nombre maximal d'aretes frontalieres declarables
1963 c n1soar : numero de la premiere arete vide dans le tableau nosoar
1964 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
1965 c n1ardv : numero dans nosoar de la premiere arete du chainage
1966 c          des aretes a rendre delaunay
1967 c
1968 c moartr : nombre d'entiers par triangle dans le tableau noartr
1969 c mxartr : nombre maximal de triangles declarables dans noartr
1970 c n1artr : numero du premier triangle vide dans le tableau noartr
1971 c          le chainage des triangles vides se fait sur noartr(2,.)
1972 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
1973 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
1974 c modifs : nombre d'echanges de diagonales pour maximiser la qualite
1975 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1976 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
1977 c....................................................................012
1978       parameter        (lchain=6)
1979       common / unites / lecteu, imprim, nunite(30)
1980       double precision  pxyd(3,*), surtd2, s123, s142, s143, s234,
1981      %                  s12, s34, a12, cetria(3), r0
1982       integer           nosoar(mosoar,mxsoar),
1983      %                  noartr(moartr,mxartr),
1984      %                  noarst(*)
1985 c
1986 c     le nombre d'echanges de diagonales pour minimiser l'aire
1987       modifs = 0
1988       r0     = 0
1989 c
1990 c     la premiere arete du chainage des aretes a rendre delaunay
1991       na0 = n1ardv
1992 c
1993 c     tant que la pile des aretes a echanger eventuellement est non vide
1994 c     ==================================================================
1995  20   if( na0 .gt. 0 ) then
1996 c
1997 c        l'arete a traiter
1998          na  = na0
1999 c        la prochaine arete a traiter
2000          na0 = nosoar(lchain,na0)
2001 c
2002 c        l'arete est marquee traitee avec le numero -1
2003          nosoar(lchain,na) = -1
2004 c
2005 c        l'arete est elle active?
2006          if( nosoar(1,na) .eq. 0 ) goto 20
2007 c
2008 c        si arete frontaliere pas d'echange possible
2009          if( nosoar(3,na) .gt. 0 ) goto 20
2010 c
2011 c        existe-t-il 2 triangles ayant cette arete commune?
2012          if( nosoar(4,na) .le. 0 .or. nosoar(5,na) .le. 0 ) goto 20
2013 c
2014 c        aucun des 2 triangles est-il desactive?
2015          if( noartr(1,nosoar(4,na)) .eq. 0 .or.
2016      %       noartr(1,nosoar(5,na)) .eq. 0 ) goto 20
2017 c
2018 c        l'arete appartient a deux triangles actifs
2019 c        le numero des 4 sommets du quadrangle des 2 triangles
2020          call mt4sqa( na, moartr, noartr, mosoar, nosoar,
2021      %                ns1, ns2, ns3, ns4 )
2022          if( ns4 .eq. 0 ) goto 20
2023 c
2024 c        carre de la longueur de l'arete ns1 ns2
2025          a12 = (pxyd(1,ns2)-pxyd(1,ns1))**2+(pxyd(2,ns2)-pxyd(2,ns1))**2
2026 c
2027 c        comparaison de la somme des aires des 2 triangles
2028 c        -------------------------------------------------
2029 c        calcul des surfaces des triangles 123 et 142 de cette arete
2030          s123=surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
2031          s142=surtd2( pxyd(1,ns1), pxyd(1,ns4), pxyd(1,ns2) )
2032          s12 = abs( s123 ) + abs( s142 )
2033          if( s12 .le. 0.001*a12 ) goto 20
2034 c
2035 c        calcul des surfaces des triangles 143 et 234 de cette arete
2036          s143=surtd2( pxyd(1,ns1), pxyd(1,ns4), pxyd(1,ns3) )
2037          s234=surtd2( pxyd(1,ns2), pxyd(1,ns3), pxyd(1,ns4) )
2038          s34 = abs( s234 ) + abs( s143 )
2039 c
2040          if( abs(s34-s12) .gt. 1d-15*s34 ) goto 20
2041 c
2042 c        quadrangle convexe : le critere de delaunay intervient
2043 c        ------------------   ---------------------------------
2044 c        calcul du centre et rayon de la boule circonscrite a 123
2045 c        pas d'affichage si le triangle est degenere
2046          ierr = -1
2047          call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), cetria,
2048      %                ierr )
2049          if( ierr .gt. 0 ) then
2050 c           ierr=1 si triangle degenere  => abandon
2051             goto 20
2052          endif
2053 c
2054          if( (cetria(1)-pxyd(1,ns4))**2+(cetria(2)-pxyd(2,ns4))**2
2055      %       .lt. cetria(3) ) then
2056 c
2057 c           protection contre une boucle infinie sur le meme cercle
2058             if( r0 .eq. cetria(3) ) goto 20
2059 c
2060 c           oui: ns4 est dans le cercle circonscrit a ns1 ns2 ns3
2061 c           => ns3 est aussi dans le cercle circonscrit de ns1 ns2 ns4
2062 c
2063 cccc           les 2 triangles d'arete na sont effaces
2064 ccc            do 25 j=4,5
2065 ccc               nt = nosoar(j,na)
2066 cccc              trace du triangle nt
2067 ccc               call mttrtr( pxyd, nt, moartr, noartr, mosoar, nosoar,
2068 ccc     %                      ncnoir, ncjaun )
2069 ccc 25         continue
2070 c
2071 c           echange de la diagonale 12 par 34 des 2 triangles
2072             call te2t2t( na,     mosoar, n1soar, nosoar, noarst,
2073      %                   moartr, noartr, na34 )
2074             if( na34 .eq. 0 ) goto 20
2075             r0 = cetria(3)
2076 c
2077 c           l'arete na34 est marquee traitee
2078             nosoar(lchain,na34) = -1
2079             modifs = modifs + 1
2080 c
2081 c           les aretes internes peripheriques des 2 triangles sont enchainees
2082             do 60 j=4,5
2083                nt = nosoar(j,na34)
2084 cccc              trace du triangle nt
2085 ccc               call mttrtr( pxyd, nt, moartr, noartr, mosoar, nosoar,
2086 ccc     %                      ncoran, ncgric )
2087                do 50 i=1,3
2088                   n = abs( noartr(i,nt) )
2089                   if( n .ne. na34 ) then
2090                      if( nosoar(3,n)      .eq.  0  .and.
2091      %                   nosoar(lchain,n) .eq. -1 ) then
2092 c                        cette arete marquee est chainee pour etre traitee
2093                          nosoar(lchain,n) = na0
2094                          na0 = n
2095                      endif
2096                   endif
2097  50            continue
2098  60         continue
2099             goto 20
2100          endif
2101 c
2102 c        retour en haut de la pile des aretes a traiter
2103          goto 20
2104       endif
2105       end
2106
2107
2108       subroutine terefr( nbarpi, pxyd,
2109      %                   mosoar, mxsoar, n1soar, nosoar,
2110      %                   moartr, n1artr, noartr, noarst,
2111      %                   mxarcf, n1arcf, noarcf, larmin, notrcf,
2112      %                   nbarpe, ierr )
2113 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2114 c but :   recherche des aretes de la frontiere non dans la triangulation
2115 c -----   triangulation frontale pour les reobtenir
2116 c
2117 c         attention: le chainage lchain de nosoar devient celui des cf
2118 c
2119 c entrees:
2120 c --------
2121 c          le tableau nosoar
2122 c nbarpi : numero du dernier point interne impose par l'utilisateur
2123 c pxyd   : tableau des coordonnees 2d des points
2124 c          par point : x  y  distance_souhaitee
2125 c mosoar : nombre maximal d'entiers par arete et
2126 c          indice dans nosoar de l'arete suivante dans le hachage
2127 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
2128 c          attention: mxsoar>3*mxsomm obligatoire!
2129 c moartr : nombre maximal d'entiers par arete du tableau noartr
2130 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
2131 c
2132 c modifies:
2133 c ---------
2134 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
2135 c          chainage des vides suivant en 3 et precedant en 2 de nosoar
2136 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
2137 c          chainage des aretes frontalieres, chainage du hachage des aretes
2138 c          hachage des aretes = nosoar(1)+nosoar(2)*2
2139 c          avec mxsoar>=3*mxsomm
2140 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
2141 c          nosoar(2,arete vide)=l'arete vide qui precede
2142 c          nosoar(3,arete vide)=l'arete vide qui suit
2143 c n1artr : numero du premier triangle vide dans le tableau noartr
2144 c          le chainage des triangles vides se fait sur noartr(2,.)
2145 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2146 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
2147 c noarst : noarst(i) numero d'une arete de sommet i
2148 c
2149 c
2150 c auxiliaires :
2151 c -------------
2152 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
2153 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
2154 c larmin : tableau (mxarcf)   auxiliaire d'entiers
2155 c notrcf : tableau (mxarcf)   auxiliaire d'entiers
2156 c
2157 c sortie :
2158 c --------
2159 c nbarpe : nombre d'aretes perdues puis retrouvees
2160 c ierr   : =0 si pas d'erreur
2161 c          >0 si une erreur est survenue
2162 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2163 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
2164 c....................................................................012
2165       parameter        (lchain=6)
2166       common / unites / lecteu,imprim,intera,nunite(29)
2167       double precision  pxyd(3,*)
2168       integer           nosoar(mosoar,mxsoar),
2169      %                  noartr(moartr,*),
2170      %                  noarst(*),
2171      %                  n1arcf(0:mxarcf),
2172      %                  noarcf(3,mxarcf),
2173      %                  larmin(mxarcf),
2174      %                  notrcf(mxarcf)
2175 c
2176 c     le nombre d'aretes de la frontiere non arete de la triangulation
2177       nbarpe = 0
2178 c
2179 c     initialisation du chainage des aretes des cf => 0 arete de cf
2180       do 10 narete=1,mxsoar
2181          nosoar( lchain, narete) = -1
2182  10   continue
2183 c
2184 c     boucle sur l'ensemble des aretes actuelles
2185 c     ==========================================
2186       do 30 narete=1,mxsoar
2187 c
2188          if( nosoar(3,narete) .gt. 0 ) then
2189 c           arete appartenant a une ligne => frontaliere
2190 c
2191             if(nosoar(4,narete) .le. 0 .or. nosoar(5,narete) .le. 0)then
2192 c              l'arete narete frontaliere n'appartient pas a 2 triangles
2193 c              => elle est perdue
2194                nbarpe = nbarpe + 1
2195 c
2196 c              le numero des 2 sommets de l'arete frontaliere perdue
2197                ns1 = nosoar( 1, narete )
2198                ns2 = nosoar( 2, narete )
2199 c               write(imprim,10000) ns1,(pxyd(j,ns1),j=1,2),
2200 c     %                             ns2,(pxyd(j,ns2),j=1,2)
2201 10000          format(' arete perdue a forcer',
2202      %               (t24,'sommet=',i6,' x=',g13.5,' y=',g13.5))
2203 c
2204 c              traitement de cette arete perdue ns1-ns2
2205                call tefoar( narete, nbarpi, pxyd,
2206      %                      mosoar, mxsoar, n1soar, nosoar,
2207      %                      moartr, n1artr, noartr, noarst,
2208      %                      mxarcf, n1arcf, noarcf, larmin, notrcf,
2209      %                      ierr )
2210                if( ierr .ne. 0 ) return
2211 c
2212 c              fin du traitement de cette arete perdue et retrouvee
2213             endif
2214          endif
2215 c
2216  30   continue
2217       end
2218
2219
2220       subroutine tesuex( nblftr, nulftr,
2221      %                   ndtri0, nbsomm, pxyd, nslign,
2222      %                   mosoar, mxsoar, nosoar,
2223      %                   moartr, mxartr, n1artr, noartr, noarst,
2224      %                   nbtria, letrsu, ierr  )
2225 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2226 c but :    supprimer du tableau noartr les triangles externes au domaine
2227 c -----    en annulant le numero de leur 1-ere arete dans noartr
2228 c          et en les chainant comme triangles vides
2229 c
2230 c entrees:
2231 c --------
2232 c nblftr : nombre de  lignes fermees definissant la surface
2233 c nulftr : numero des lignes fermees definissant la surface
2234 c ndtri0 : plus grand numero dans noartr d'un triangle
2235 c pxyd   : tableau des coordonnees 2d des points
2236 c          par point : x  y  distance_souhaitee
2237 c nslign : tableau du numero de sommet dans sa ligne pour chaque
2238 c          sommet frontalier
2239 c          numero du point dans le lexique point si interne impose
2240 c          0 si le point est interne non impose par l'utilisateur
2241 c         -1 si le sommet est externe au domaine
2242 c mosoar : nombre maximal d'entiers par arete et
2243 c          indice dans nosoar de l'arete suivante dans le hachage
2244 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
2245 c          attention: mxsoar>3*mxsomm obligatoire!
2246 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
2247 c          chainage des aretes frontalieres, chainage du hachage des aretes
2248 c          hachage des aretes = nosoar(1)+nosoar(2)*2
2249 c          avec mxsoar>=3*mxsomm
2250 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
2251 c          nosoar(2,arete vide)=l'arete vide qui precede
2252 c          nosoar(3,arete vide)=l'arete vide qui suit
2253 c moartr : nombre maximal d'entiers par arete du tableau noartr
2254 c mxartr : nombre maximal de triangles declarables
2255 c n1artr : numero du premier triangle vide dans le tableau noartr
2256 c          le chainage des triangles vides se fait sur noartr(2,.)
2257 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2258 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
2259 c noarst : noarst(i) numero nosoar d'une arete de sommet i
2260 c
2261 c sorties:
2262 c --------
2263 c nbtria : nombre de triangles internes au domaine
2264 c letrsu : letrsu(nt)=numero du triangle interne, 0 sinon
2265 c noarst : noarst(i) numero nosoar d'une arete du sommet i (modifi'e)
2266 c ierr   : 0 si pas d'erreur, >0 sinon
2267 cc++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2268 c auteur : alain perronnet  analyse numerique paris upmc        mai 1999
2269 c2345x7..............................................................012
2270       double precision  pxyd(3,*)
2271       integer           nulftr(nblftr),nslign(nbsomm),
2272      %                  nosoar(mosoar,mxsoar),
2273      %                  noartr(moartr,mxartr),
2274      %                  noarst(*)
2275       integer           letrsu(1:ndtri0)
2276       double precision  dmin
2277 c
2278 c     les triangles sont a priori non marques
2279       do 5 nt=1,ndtri0
2280          letrsu(nt) = 0
2281  5    continue
2282 c
2283 c     les aretes sont marquees non chainees
2284       do 10 noar1=1,mxsoar
2285          nosoar(6,noar1) = -2
2286  10   continue
2287 c
2288 c     recherche du sommet de la triangulation de plus petite abscisse
2289 c     ===============================================================
2290       ntmin = 0
2291       dmin  = 1d38
2292       do 20 i=1,nbsomm
2293          if( pxyd(1,i) .lt. dmin ) then
2294 c           le nouveau minimum
2295             noar1 = noarst(i)
2296             if( noar1 .gt. 0 ) then
2297 c              le sommet appartient a une arete de triangle
2298                if( nosoar(4,noar1) .gt. 0 ) then
2299 c                 le nouveau minimum
2300                   dmin  = pxyd(1,i)
2301                   ntmin = i
2302                endif
2303             endif
2304          endif
2305  20   continue
2306 c
2307 c     une arete de sommet ntmin
2308       noar1 = noarst( ntmin )
2309 c     un triangle d'arete noar1
2310       ntmin = nosoar( 4, noar1 )
2311       if( ntmin .le. 0 ) then
2312 c         nblgrc(nrerr) = 1
2313 c         kerr(1) = 'pas de triangle d''abscisse minimale'
2314 c         call lereur
2315          write(imprim,*) 'pas de triangle d''abscisse minimale'
2316          ierr = 2
2317          goto 9990
2318       endif
2319 c
2320 c     chainage des 3 aretes du triangle ntmin
2321 c     =======================================
2322 c     la premiere arete du chainage des aretes traitees
2323       noar1 = abs( noartr(1,ntmin) )
2324       na0   = abs( noartr(2,ntmin) )
2325 c     elle est chainee sur la seconde arete du triangle ntmin
2326       nosoar(6,noar1) = na0
2327 c     les 2 autres aretes du triangle ntmin sont chainees
2328       na1 = abs( noartr(3,ntmin) )
2329 c     la seconde est chainee sur la troisieme arete
2330       nosoar(6,na0) = na1
2331 c     la troisieme n'a pas de suivante
2332       nosoar(6,na1) = 0
2333 c
2334 c     le triangle ntmin est a l'exterieur du domaine
2335 c     tous les triangles externes sont marques -123 456 789
2336 c     les triangles de l'autre cote d'une arete sur une ligne
2337 c     sont marques: no de la ligne de l'arete * signe oppose
2338 c     =======================================================
2339       ligne0 = 0
2340       ligne  = -123 456 789
2341 c
2342  40   if( noar1 .ne. 0 ) then
2343 c
2344 c        l'arete noar1 du tableau nosoar est a traiter
2345 c        ---------------------------------------------
2346          noar = noar1
2347 c        l'arete suivante devient la premiere a traiter ensuite
2348          noar1 = nosoar(6,noar1)
2349 c        l'arete noar est traitee
2350          nosoar(6,noar) = -3
2351 c
2352          do 60 i=4,5
2353 c
2354 c           l'un des 2 triangles de l'arete
2355             nt = nosoar(i,noar)
2356             if( nt .gt. 0 ) then
2357 c
2358 c              triangle deja traite pour une ligne anterieure?
2359                if(     letrsu(nt)  .ne. 0      .and.
2360      %             abs(letrsu(nt)) .ne. ligne ) goto 60
2361 c
2362 cccc              trace du triangle nt en couleur ligne0
2363 ccc               call mttrtr( pxyd,   nt, moartr, noartr, mosoar, nosoar,
2364 ccc     %                      ligne0, ncnoir )
2365 c
2366 c              le triangle est marque avec la valeur de ligne
2367                letrsu(nt) = ligne
2368 c
2369 c              chainage eventuel des autres aretes de ce triangle
2370 c              si ce n'est pas encore fait
2371                do 50 j=1,3
2372 c
2373 c                 le numero na de l'arete j du triangle nt dans nosoar
2374                   na = abs( noartr(j,nt) )
2375                   if( nosoar(6,na) .ne. -2 ) goto 50
2376 c
2377 c                 le numero de 1 a nblftr dans nulftr de la ligne de l'arete
2378                   nl = nosoar(3,na)
2379 c
2380 c                 si l'arete est sur une ligne fermee differente de celle envelo
2381 c                 et non marquee alors examen du triangle oppose
2382                   if( nl .gt. 0 ) then
2383 c
2384                      if( nl .eq. ligne0 ) goto 50
2385 c
2386 c                    arete frontaliere de ligne non traitee
2387 c                    => passage de l'autre cote de la ligne
2388 c                    le triangle de l'autre cote de la ligne est recherche
2389                      if( nt .eq. abs( nosoar(4,na) ) ) then
2390                         nt2 = 5
2391                      else
2392                         nt2 = 4
2393                      endif
2394                      nt2 = abs( nosoar(nt2,na) )
2395                      if( nt2 .gt. 0 ) then
2396 c
2397 c                       le triangle nt2 de l'autre cote est marque avec le
2398 c                       avec le signe oppose de celui de ligne
2399                         if( ligne .ge. 0 ) then
2400                            lsigne = -1
2401                         else
2402                            lsigne =  1
2403                         endif
2404                         letrsu(nt2) = lsigne * nl
2405 c
2406 c                       temoin de ligne a traiter ensuite dans nulftr
2407                         nulftr(nl) = -abs( nulftr(nl) )
2408 c
2409 cccc                       trace du triangle nt2 en jaune borde de magenta
2410 ccc                        call mttrtr( pxyd,nt2,
2411 ccc     %                               moartr,noartr,mosoar,nosoar,
2412 ccc     %                               ncjaun, ncmage )
2413 c
2414 c                       l'arete est traitee
2415                         nosoar(6,na) = -3
2416 c
2417                      endif
2418 c
2419 c                    l'arete est traitee
2420                      goto 50
2421 c
2422                   endif
2423 c
2424 c                 arete non traitee => elle est chainee
2425                   nosoar(6,na) = noar1
2426                   noar1 = na
2427 c
2428  50            continue
2429 c
2430             endif
2431  60      continue
2432 c
2433          goto 40
2434       endif
2435 c     les triangles de la ligne fermee ont tous ete marques
2436 c     plus d'arete chainee
2437 c
2438 c     recherche d'une nouvelle ligne fermee a traiter
2439 c     ===============================================
2440  65   do 70 nl=1,nblftr
2441          if( nulftr(nl) .lt. 0 ) goto 80
2442  70   continue
2443 c     plus de ligne fermee a traiter
2444       goto 110
2445 c
2446 c     tous les triangles de cette composante connexe
2447 c     entre ligne et ligne0 vont etre marques
2448 c     ==============================================
2449 c     remise en etat du numero de ligne
2450 c     nl est le numero de la ligne dans nulftr a traiter
2451  80   nulftr(nl) = -nulftr(nl)
2452       do 90 nt2=1,ndtri0
2453          if( abs(letrsu(nt2)) .eq. nl ) goto 92
2454  90   continue
2455 c
2456 c     recherche de l'arete j du triangle nt2 avec ce numero de ligne nl
2457  92   do 95 j=1,3
2458 c
2459 c        le numero de l'arete j du triangle dans nosoar
2460          noar1 = 0
2461          na0   = abs( noartr(j,nt2) )
2462          if( nl .eq. nosoar(3,na0) ) then
2463 c
2464 c           na0 est l'arete de ligne nl
2465 c           l'arete suivante du triangle nt2
2466             i   = mod(j,3) + 1
2467 c           le numero dans nosoar de l'arete i de nt2
2468             na1 = abs( noartr(i,nt2) )
2469             if( nosoar(6,na1) .eq. -2 ) then
2470 c              arete non traitee => elle est la premiere du chainage
2471                noar1 = na1
2472 c              pas de suivante dans ce chainage
2473                nosoar(6,na1) = 0
2474             else
2475                na1 = 0
2476             endif
2477 c
2478 c           l'eventuelle seconde arete suivante
2479             i  = mod(i,3) + 1
2480             na = abs( noartr(i,nt2) )
2481             if( nosoar(6,na) .eq. -2 ) then
2482                if( na1 .eq. 0 ) then
2483 c                 1 arete non traitee et seule a chainer
2484                   noar1 = na
2485                   nosoar(6,na) = 0
2486                else
2487 c                 2 aretes a chainer
2488                   noar1 = na
2489                   nosoar(6,na) = na1
2490                endif
2491             endif
2492 c
2493             if( noar1 .gt. 0 ) then
2494 c
2495 c              il existe au moins une arete a visiter pour ligne
2496 c              marquage des triangles internes a la ligne nl
2497                ligne  = letrsu(nt2)
2498                ligne0 = nl
2499                goto 40
2500 c
2501             else
2502 c
2503 c              nt2 est le seul triangle de la ligne fermee
2504                goto 65
2505 c
2506             endif
2507          endif
2508  95   continue
2509 c
2510 c     reperage des sommets internes ou externes dans nslign
2511 c     nslign(sommet externe au domaine)=-1
2512 c     nslign(sommet interne au domaine)= 0
2513 c     =====================================================
2514  110  do 170 ns1=1,nbsomm
2515 c        tout sommet non sur la frontiere ou interne impose
2516 c        est suppose externe
2517          if( nslign(ns1) .eq. 0 ) nslign(ns1) = -1
2518  170  continue
2519 c
2520 c     les triangles externes sont marques vides dans le tableau noartr
2521 c     ================================================================
2522       nbtria = 0
2523       do 200 nt=1,ndtri0
2524 c
2525          if( letrsu(nt) .le. 0 ) then
2526 c
2527 c           triangle nt externe
2528             if( noartr(1,nt) .ne. 0 ) then
2529 c              la premiere arete est annulee
2530                noartr(1,nt) = 0
2531 c              le triangle nt est considere comme etant vide
2532                noartr(2,nt) = n1artr
2533                n1artr = nt
2534             endif
2535 c
2536          else
2537 c
2538 c           triangle nt interne
2539             nbtria = nbtria + 1
2540             letrsu(nt) = nbtria
2541 c
2542 c           marquage des 3 sommets du triangle nt
2543             do 190 i=1,3
2544 c              le numero nosoar de l'arete i du triangle nt
2545                noar = abs( noartr(i,nt) )
2546 c              le numero des 2 sommets
2547                ns1 = nosoar(1,noar)
2548                ns2 = nosoar(2,noar)
2549 c              mise a jour du numero d'une arete des 2 sommets de l'arete
2550                noarst( ns1 ) = noar
2551                noarst( ns2 ) = noar
2552 c              ns1 et ns2 sont des sommets de la triangulation du domaine
2553                if( nslign(ns1) .lt. 0 ) nslign(ns1)=0
2554                if( nslign(ns2) .lt. 0 ) nslign(ns2)=0
2555  190        continue
2556 c
2557          endif
2558 c
2559  200  continue
2560 c     ici tout sommet externe ns verifie nslign(ns)=-1
2561 c
2562 c     les triangles externes sont mis a zero dans nosoar
2563 c     ==================================================
2564       do 300 noar=1,mxsoar
2565 c
2566          if( nosoar(1,noar) .gt. 0 ) then
2567 c
2568 c           le second triangle de l'arete noar
2569             nt = nosoar(5,noar)
2570             if( nt .gt. 0 ) then
2571 c              si le triangle nt est externe
2572 c              alors il est supprime pour l'arete noar
2573                if( letrsu(nt) .le. 0 ) nosoar(5,noar)=0
2574             endif
2575 c
2576 c           le premier triangle de l'arete noar
2577             nt = nosoar(4,noar)
2578             if( nt .gt. 0 ) then
2579                if( letrsu(nt) .le. 0 ) then
2580 c                 si le triangle nt est externe
2581 c                 alors il est supprime pour l'arete noar
2582 c                 et l'eventuel triangle oppose prend sa place
2583 c                 en position 4 de nosoar
2584                   if( nosoar(5,noar) .gt. 0 ) then
2585                      nosoar(4,noar)=nosoar(5,noar)
2586                      nosoar(5,noar)=0
2587                   else
2588                      nosoar(4,noar)=0
2589                   endif
2590                endif
2591             endif
2592          endif
2593 c
2594  300  continue
2595 c
2596 c     remise en etat pour eviter les modifications de ladefi
2597  9990 do 9991 nl=1,nblftr
2598          if( nulftr(nl) .lt. 0 ) nulftr(nl)=-nulftr(nl)
2599  9991 continue
2600       return
2601       end
2602
2603
2604
2605       subroutine trp1st( ns,     noarst, mosoar, nosoar, moartr, noartr,
2606      %                   mxpile, lhpile, lapile )
2607 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2608 c but :   recherche des triangles de noartr partageant le sommet ns
2609 c -----
2610 c         limite: un camembert de centre ns entame 2 fois
2611 c                 ne donne que l'une des parties
2612 c
2613 c entrees:
2614 c --------
2615 c ns     : numero du sommet
2616 c noarst : noarst(i) numero d'une arete de sommet i
2617 c mosoar : nombre maximal d'entiers par arete et
2618 c          indice dans nosoar de l'arete suivante dans le hachage
2619 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
2620 c          chainage des aretes frontalieres, chainage du hachage des aretes
2621 c moartr : nombre maximal d'entiers par arete du tableau noartr
2622 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2623 c mxpile : nombre maximal de triangles empilables
2624 c
2625 c sorties :
2626 c --------
2627 c lhpile : >0 nombre de triangles empiles
2628 c          =0       si impossible de tourner autour du point
2629 c          =-lhpile si apres butee sur la frontiere il y a a nouveau
2630 c          butee sur la frontiere . a ce stade on ne peut dire si tous
2631 c          les triangles ayant ce sommet ont ete recenses
2632 c          ce cas arrive seulement si le sommet est sur la frontiere
2633 c lapile : numero dans noartr des triangles de sommet ns
2634 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2635 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
2636 c....................................................................012
2637       common / unites / lecteu, imprim, nunite(30)
2638       integer           noartr(moartr,*),
2639      %                  nosoar(mosoar,*),
2640      %                  noarst(*)
2641       integer           lapile(1:mxpile)
2642       integer           nosotr(3)
2643 c
2644 c     la premiere arete de sommet ns
2645       nar = noarst( ns )
2646       if( nar .le. 0 ) then
2647          write(imprim,*) 'trp1st: sommet',ns,' sans arete'
2648          goto 9999
2649       endif
2650 c
2651 c     l'arete nar est elle active?
2652       if( nosoar(1,nar) .le. 0 ) then
2653 ccc         write(imprim,*) 'trp1st: arete vide',nar,
2654 ccc     %                  ' st1:', nosoar(1,nar),' st2:',nosoar(2,nar)
2655          goto 9999
2656       endif
2657 c
2658 c     le premier triangle de sommet ns
2659       nt0 = abs( nosoar(4,nar) )
2660       if( nt0 .le. 0 ) then
2661          write(imprim,*) 'trp1st: sommet',ns,' dans aucun triangle'
2662          goto 9999
2663       endif
2664 c
2665 c     le triangle est il interne?
2666       if( noartr(1,nt0) .eq. 0 ) goto 9999
2667 c
2668 c     le numero des 3 sommets du triangle nt0 dans le sens direct
2669       call nusotr( nt0, mosoar, nosoar, moartr, noartr, nosotr )
2670 c
2671 c     reperage du sommet ns dans le triangle nt0
2672       do 5 nar=1,3
2673          if( nosotr(nar) .eq. ns ) goto 10
2674  5    continue
2675       nta = nt0
2676       goto 9995
2677 c
2678 c     ns retrouve : le triangle nt0 est empile
2679  10   lhpile = 1
2680       lapile(1) = nt0
2681       nta = nt0
2682 c
2683 c     recherche dans le sens des aiguilles d'une montre
2684 c     (sens indirect) du triangle nt1 de l'autre cote de l'arete
2685 c     nar du triangle et en tournant autour du sommet ns
2686 c     ==========================================================
2687       noar = abs( noartr(nar,nt0) )
2688 c     le triangle nt1 oppose du triangle nt0 par l'arete noar
2689       if( nosoar(4,noar) .eq. nt0 ) then
2690          nt1 = nosoar(5,noar)
2691       else
2692          nt1 = nosoar(4,noar)
2693       endif
2694 c
2695 c     la boucle sur les triangles nt1 de sommet ns dans le sens indirect
2696 c     ==================================================================
2697       if( nt1 .gt. 0 ) then
2698 c
2699          if( noartr(1,nt1) .eq. 0 ) goto 30
2700 c
2701 c        le triangle nt1 n'a pas ete detruit. il est actif
2702 c        le triangle oppose par l'arete noar existe
2703 c        le numero des 3 sommets du triangle nt1 dans le sens direct
2704  15      call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
2705 c
2706 c        reperage du sommet ns dans nt1
2707          do 20 nar=1,3
2708             if( nosotr(nar) .eq. ns ) goto 25
2709  20      continue
2710          nta = nt1
2711          goto 9995
2712 c
2713 c        nt1 est empile
2714  25      if( lhpile .ge. mxpile ) goto 9990
2715          lhpile = lhpile + 1
2716          lapile(lhpile) = nt1
2717 c
2718 c        le triangle nt1 de l'autre cote de l'arete de sommet ns
2719 c        sauvegarde du precedent triangle dans nta
2720          nta  = nt1
2721          noar = abs( noartr(nar,nt1) )
2722          if( nosoar(4,noar) .eq. nt1 ) then
2723             nt1 = nosoar(5,noar)
2724          else
2725             nt1 = nosoar(4,noar)
2726          endif
2727          if( nt1 .le. 0   ) goto 30
2728 c        le triangle suivant est a l'exterieur
2729          if( nt1 .ne. nt0 ) goto 15
2730 c
2731 c        recherche terminee par arrivee sur nt0
2732 c        les triangles forment un "cercle" de "centre" ns
2733          return
2734 c
2735       endif
2736 c
2737 c     pas de triangle voisin a nt1
2738 c     ============================
2739 c     le parcours passe par 1 des triangles exterieurs
2740 c     le parcours est inverse par l'arete de gauche
2741 c     le triangle nta est le premier triangle empile
2742  30   lhpile = 1
2743       lapile(lhpile) = nta
2744 c
2745 c     le numero des 3 sommets du triangle nta dans le sens direct
2746       call nusotr( nta, mosoar, nosoar, moartr, noartr, nosotr )
2747       do 32 nar=1,3
2748          if( nosotr(nar) .eq. ns ) goto 33
2749  32   continue
2750       goto 9995
2751 c
2752 c     l'arete qui precede (rotation / ns dans le sens direct)
2753  33   if( nar .eq. 1 ) then
2754          nar = 3
2755       else
2756          nar = nar - 1
2757       endif
2758 c
2759 c     le triangle voisin de nta dans le sens direct
2760       noar = abs( noartr(nar,nta) )
2761       if( nosoar(4,noar) .eq. nta ) then
2762          nt1 = nosoar(5,noar)
2763       else
2764          nt1 = nosoar(4,noar)
2765       endif
2766       if( nt1 .le. 0 ) then
2767 c        un seul triangle contient ns
2768          goto 70
2769       endif
2770 c
2771 c     boucle sur les triangles de sommet ns dans le sens direct
2772 c     ==========================================================
2773  40   if( noartr(1,nt1) .eq. 0 ) goto 70
2774 c
2775 c     le triangle nt1 n'a pas ete detruit. il est actif
2776 c     le numero des 3 sommets du triangle nt1 dans le sens direct
2777       call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
2778 c
2779 c     reperage du sommet ns dans nt1
2780       do 50 nar=1,3
2781          if( nosotr(nar) .eq. ns ) goto 60
2782  50   continue
2783       nta = nt1
2784       goto 9995
2785 c
2786 c     nt1 est empile
2787  60   if( lhpile .ge. mxpile ) goto 9990
2788       lhpile = lhpile + 1
2789       lapile(lhpile) = nt1
2790 c
2791 c     l'arete qui precede dans le sens direct
2792       if( nar .eq. 1 ) then
2793          nar = 3
2794       else
2795          nar = nar - 1
2796       endif
2797 c
2798 c     l'arete de sommet ns dans nosoar
2799       noar = abs( noartr(nar,nt1) )
2800 c
2801 c     le triangle voisin de nta dans le sens direct
2802       nta  = nt1
2803       if( nosoar(4,noar) .eq. nt1 ) then
2804          nt1 = nosoar(5,noar)
2805       else
2806          nt1 = nosoar(4,noar)
2807       endif
2808       nta = nt1
2809       if( nt1 .gt. 0 ) goto 40
2810 c
2811 c     butee sur le trou => fin des triangles de sommet ns
2812 c     ----------------------------------------------------
2813  70   lhpile = -lhpile
2814 c     impossible ici de trouver les autres triangles de sommet ns
2815 c     les triangles de sommet ns ne forment pas une boule de centre ns
2816       return
2817 c
2818 c     saturation de la pile des triangles
2819 c     -----------------------------------
2820  9990 write(imprim,*) 'trp1st:saturation pile des triangles autour ',
2821      %'sommet',ns
2822       goto 9999
2823 c
2824 c     erreur triangle ne contenant pas le sommet ns
2825 c     ----------------------------------------------
2826  9995 write(imprim,*) 'trp1st:triangle ',nta,' st=',
2827      %   (nosotr(nar),nar=1,3),' sans le sommet' ,ns
2828 c
2829  9999 lhpile = 0
2830       return
2831       end
2832
2833
2834
2835       subroutine nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
2836 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2837 c but :    calcul du numero des 3 sommets du triangle nt de noartr
2838 c -----    dans le sens direct (aire>0 si non degenere)
2839 c
2840 c entrees:
2841 c --------
2842 c nt     : numero du triangle dans le tableau noartr
2843 c mosoar : nombre maximal d'entiers par arete
2844 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
2845 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
2846 c moartr : nombre maximal d'entiers par arete du tableau noartr
2847 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2848 c          arete1=0 si triangle vide => arete2=triangle vide suivant
2849 c
2850 c sorties:
2851 c --------
2852 c nosotr : numero (dans le tableau pxyd) des 3 sommets du triangle
2853 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2854 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
2855 c2345x7..............................................................012
2856       integer     nosoar(mosoar,*), noartr(moartr,*), nosotr(3)
2857 c
2858 c     les 2 sommets de l'arete 1 du triangle nt dans le sens direct
2859       na = noartr( 1, nt )
2860       if( na .gt. 0 ) then
2861          nosotr(1) = 1
2862          nosotr(2) = 2
2863       else
2864          nosotr(1) = 2
2865          nosotr(2) = 1
2866          na = -na
2867       endif
2868       nosotr(1) = nosoar( nosotr(1), na )
2869       nosotr(2) = nosoar( nosotr(2), na )
2870 c
2871 c     l'arete suivante
2872       na = abs( noartr(2,nt) )
2873 c
2874 c     le sommet nosotr(3 du triangle 123
2875       nosotr(3) = nosoar( 1, na )
2876       if( nosotr(3) .eq. nosotr(1) .or. nosotr(3) .eq. nosotr(2) ) then
2877          nosotr(3) = nosoar(2,na)
2878       endif
2879       end
2880
2881
2882       subroutine tesusp( nbarpi, pxyd,   noarst,
2883      %                   mosoar, mxsoar, n1soar, nosoar,
2884      %                   moartr, mxartr, n1artr, noartr,
2885      %                   mxarcf, n1arcf, noarcf, larmin, notrcf, liarcf,
2886      %                   nbstsu, ierr )
2887 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2888 c but :   supprimer de la triangulation les sommets de te trop proches
2889 c -----   soit d'un sommet frontalier ou point interne impose
2890 c         soit d'une arete frontaliere
2891 c
2892 c         attention: le chainage lchain de nosoar devient celui des cf
2893 c
2894 c entrees:
2895 c --------
2896 c nbarpi : numero du dernier point interne impose par l'utilisateur
2897 c pxyd   : tableau des coordonnees 2d des points
2898 c          par point : x  y  distance_souhaitee
2899 c mosoar : nombre maximal d'entiers par arete et
2900 c          indice dans nosoar de l'arete suivante dans le hachage
2901 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
2902 c          attention: mxsoar>3*mxsomm obligatoire!
2903 c moartr : nombre maximal d'entiers par arete du tableau noartr
2904 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
2905 c
2906 c modifies:
2907 c ---------
2908 c noarst : noarst(i) numero d'une arete de sommet i
2909 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
2910 c          chainage des vides suivant en 3 et precedant en 2 de nosoar
2911 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
2912 c          chainage des aretes frontalieres, chainage du hachage des aretes
2913 c          hachage des aretes = nosoar(1)+nosoar(2)*2
2914 c          avec mxsoar>=3*mxsomm
2915 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
2916 c          nosoar(2,arete vide)=l'arete vide qui precede
2917 c          nosoar(3,arete vide)=l'arete vide qui suit
2918 c n1artr : numero du premier triangle vide dans le tableau noartr
2919 c          le chainage des triangles vides se fait sur noartr(2,.)
2920 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
2921 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
2922 c
2923 c
2924 c auxiliaires :
2925 c -------------
2926 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
2927 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
2928 c larmin : tableau ( mxarcf ) auxiliaire d'entiers
2929 c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
2930 c liarcf : tableau ( mxarcf ) auxiliaire d'entiers
2931 c
2932 c sortie :
2933 c --------
2934 c nbstsu : nombre de sommets de te supprimes
2935 c ierr   : =0 si pas d'erreur
2936 c          >0 si une erreur est survenue
2937 c          11 algorithme defaillant
2938 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2939 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
2940 c....................................................................012
2941 c      parameter       ( quamal=0.3 ) => ok
2942 c      parameter       ( quamal=0.4 ) => pb pour le test ocean
2943 c      parameter       ( quamal=0.5 ) => pb pour le test ocean
2944 c
2945       parameter       ( quamal=0.333, lchain=6 )
2946       common / unites / lecteu,imprim,intera,nunite(29)
2947       double precision  pxyd(3,*), qualit
2948       integer           nosoar(mosoar,mxsoar),
2949      %                  noartr(moartr,*),
2950      %                  noarst(*),
2951      %                  n1arcf(0:mxarcf),
2952      %                  noarcf(3,mxarcf),
2953      %                  larmin(mxarcf),
2954      %                  notrcf(mxarcf),
2955      %                  liarcf(mxarcf)
2956 c
2957       integer           nosotr(3)
2958       equivalence      (nosotr(1),ns1), (nosotr(2),ns2),
2959      %                 (nosotr(3),ns3)
2960 c
2961 c     le nombre de sommets de te supprimes
2962       nbstsu = 0
2963 c
2964 c     initialisation du chainage des aretes des cf => 0 arete de cf
2965       do 10 narete=1,mxsoar
2966          nosoar( lchain, narete ) = -1
2967  10   continue
2968 c
2969 c     boucle sur l'ensemble des sommets frontaliers ou points internes
2970 c     ================================================================
2971       do 100 ns = 1, nbarpi
2972 c
2973 cccc        le nombre de sommets supprimes pour ce sommet ns
2974 ccc         nbsuns = 0
2975 c
2976 c        la qualite minimale au dessous de laquelle le point proche
2977 c        interne est supprime
2978          quaopt = quamal
2979 c
2980 c        une arete de sommet ns
2981  15      narete = noarst( ns )
2982          if( narete .le. 0 ) then
2983 c           erreur: le point appartient a aucune arete
2984             write(imprim,*) 'sommet ',ns,' dans aucune arete'
2985             pause
2986             ierr = 11
2987             return
2988          endif
2989 c
2990 c        recherche des triangles de sommet ns
2991 c        ils doivent former un contour ferme de type etoile
2992          call trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
2993      %                mxarcf, nbtrcf, notrcf )
2994          if( nbtrcf .le. 0 ) then
2995 c           erreur: impossible de trouver tous les triangles de sommet ns
2996 c           seule une partie est a priori retrouvee
2997             nbtrcf = -nbtrcf
2998          endif
2999 c
3000 c        boucle sur les triangles de l'etoile du sommet ns
3001          quamin = 2.0
3002          do 20 i=1,nbtrcf
3003 c
3004 c           le numero des 3 sommets du triangle nt
3005             nt = notrcf(i)
3006             call nusotr( nt, mosoar, nosoar, moartr, noartr,
3007      %                   nosotr )
3008 c           nosotr(1:3) est en equivalence avec ns1, ns2, ns3
3009 c
3010 c           la qualite du triangle ns1 ns2 ns3
3011             call qutr2d( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), qualit )
3012             if( qualit .lt. quamin ) then
3013                quamin = qualit
3014                ntqmin = nt
3015             endif
3016  20      continue
3017 c
3018 c        bilan sur la qualite des triangles de sommet ns
3019          if( quamin .lt. quaopt ) then
3020 c
3021 c           recherche du sommet de ntqmin le plus proche et non frontalier
3022 c           ==============================================================
3023 c           le numero des 3 sommets du triangle nt
3024             call nusotr( ntqmin, mosoar, nosoar, moartr, noartr,
3025      %                   nosotr )
3026             nste   = 0
3027             quamin = 1e28
3028             do 30 j=1,3
3029                if( nosotr(j) .ne. ns .and. nosotr(j) .gt. nbarpi ) then
3030                   d = (pxyd(1,nosotr(j))-pxyd(1,ns))**2
3031      %              + (pxyd(2,nosotr(j))-pxyd(2,ns))**2
3032                   if( d .lt. quamin ) then
3033                      quamin = d
3034                      nste   = j
3035                   endif
3036                endif
3037  30         continue
3038 c
3039             if( nste .gt. 0 ) then
3040 c
3041 c              nste est le sommet le plus proche de ns de ce
3042 c              triangle de mauvaise qualite et sommet non encore traite
3043                nste = nosotr( nste )
3044 c
3045 c              nste est un sommet de triangle equilateral
3046 c              => le sommet nste va etre supprime
3047 c              ==========================================
3048                call te1stm( nste,   pxyd,   noarst,
3049      %                      mosoar, mxsoar, n1soar, nosoar,
3050      %                      moartr, mxartr, n1artr, noartr,
3051      %                      mxarcf, n1arcf, noarcf,
3052      %                      larmin, notrcf, liarcf, ierr )
3053                if( ierr .eq. 0 ) then
3054 c                 un sommet de te supprime de plus
3055                   nbstsu = nbstsu + 1
3056                else if( ierr .lt. 0 ) then
3057 c                 le sommet nste est externe donc non supprime
3058 c                 ou bien le sommet nste est le centre d'un cf dont toutes
3059 c                 les aretes simples sont frontalieres
3060 c                 dans les 2 cas le sommet n'est pas supprime
3061                   ierr = 0
3062                   goto 100
3063                else
3064 c                 erreur motivant un arret de la triangulation
3065                   return
3066                endif
3067 c
3068 c              boucle jusqu'a obtenir une qualite suffisante
3069 c              si triangulation tres irreguliere =>
3070 c              destruction de beaucoup de points internes
3071 c              les 2 variables suivantes brident ces destructions massives
3072 ccc               nbsuns = nbsuns + 1
3073                quaopt = quaopt * 0.8
3074 ccc               if( nbsuns .le. 5 ) goto 15
3075                goto 15
3076             endif
3077          endif
3078 c
3079  100  continue
3080       end
3081
3082
3083       subroutine teamqa( nutysu,
3084      %                   noarst, mosoar, mxsoar, n1soar, nosoar,
3085      %                   moartr, mxartr, n1artr, noartr,
3086      %                   mxtrcf, notrcf, nostbo,
3087      %                   n1arcf, noarcf, larmin,
3088      %                   comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
3089      %                   ierr )
3090 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3091 c but:    si la taille de l'arete moyenne est >ampli*taille souhaitee
3092 c ----    alors ajout d'un sommet barycentre du plus grand triangle
3093 c               de sommet ns
3094 c         si la taille de l'arete moyenne est <ampli/2*taille souhaitee
3095 c         alors suppression du sommet ns
3096 c         sinon le sommet ns devient le barycentre pondere de ses voisins
3097 c
3098 c         remarque: ampli est defini dans $mefisto/mail/tehote.f
3099 c         et doit avoir la meme valeur pour eviter trop de modifications
3100 c
3101 c entrees:
3102 c --------
3103 c nutysu : numero de traitement de areteideale() selon le type de surface
3104 c          0 pas d'emploi de la fonction areteideale() => aretmx active
3105 c          1 il existe une fonction areteideale()
3106 c            dont seules les 2 premieres composantes de uv sont actives
3107 c          autres options a definir...
3108 c noarst : noarst(i) numero d'une arete de sommet i
3109 c mosoar : nombre maximal d'entiers par arete et
3110 c          indice dans nosoar de l'arete suivante dans le hachage
3111 c mxsoar : nombre maximal d'aretes frontalieres declarables
3112 c n1soar : numero de la premiere arete vide dans le tableau nosoar
3113 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
3114 c          chainage des aretes frontalieres, chainage du hachage des aretes
3115 c moartr : nombre maximal d'entiers par arete du tableau noartr
3116 c mxartr : nombre maximal de triangles declarables dans noartr
3117 c n1artr : numero du premier triangle vide dans le tableau noartr
3118 c          le chainage des triangles vides se fait sur noartr(2,.)
3119 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
3120 c mxtrcf : nombre maximal de triangles empilables
3121 c nbarpi : numero du dernier sommet frontalier ou interne impose
3122 c nslign : tableau du numero de sommet dans sa ligne pour chaque
3123 c          sommet frontalier
3124 c          numero du point dans le lexique point si interne impose
3125 c          0 si le point est interne non impose par l'utilisateur
3126 c         -1 si le sommet est externe au domaine
3127 c comxmi : min et max des coordonneees des sommets du maillage
3128 c
3129 c modifies :
3130 c ----------
3131 c nbsomm : nombre actuel de sommets de la triangulation
3132 c          (certains sommets internes ont ete desactives ou ajoutes)
3133 c pxyd   : tableau des coordonnees 2d des points
3134 c
3135 c auxiliaires:
3136 c ------------
3137 c notrcf : tableau ( mxtrcf ) auxiliaire d'entiers
3138 c          numero dans noartr des triangles de sommet ns
3139 c nostbo : tableau ( mxtrcf ) auxiliaire d'entiers
3140 c          numero dans pxyd des sommets des aretes simples de la boule
3141 c n1arcf : tableau (0:mxtrcf) auxiliaire d'entiers
3142 c noarcf : tableau (3,mxtrcf) auxiliaire d'entiers
3143 c larmin : tableau ( mxtrcf ) auxiliaire d'entiers
3144 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3145 c auteur : alain perronnet  analyse numerique paris upmc       juin 1997
3146 c....................................................................012
3147       double precision  ampli,ampli2
3148       parameter        (ampli=1.34d0,ampli2=ampli/2d0)
3149       parameter        (lchain=6)
3150       common / unites / lecteu, imprim, nunite(30)
3151       double precision  pxyd(3,*)
3152       double precision  ponder, ponde1, xbar, ybar, x, y, surtd2
3153       double precision  d, dmoy
3154       double precision  d2d3(3,3)
3155       real              origin(3), xyz(3)
3156       integer           noartr(moartr,*),
3157      %                  nosoar(mosoar,*),
3158      %                  noarst(*),
3159      %                  notrcf(mxtrcf),
3160      %                  nslign(*),
3161      %                  nostbo(*),
3162      %                  n1arcf(0:mxtrcf),
3163      %                  noarcf(3,mxtrcf),
3164      %                  larmin(mxtrcf)
3165       double precision  comxmi(3,2)
3166       integer           nosotr(3)
3167 c
3168 c     le nombre d'iterations pour ameliorer la qualite
3169       nbitaq = 4
3170       ier    = 0
3171 c
3172 c     initialisation du parcours
3173       nbs1 = nbsomm
3174       nbs2 = nbarpi + 1
3175       nbs3 = -1
3176 c
3177       do 5000 iter=1,nbitaq
3178 c
3179 c        le nombre de sommets supprimes
3180          nbstsu = 0
3181          nbbaaj = 0
3182 c
3183 c        coefficient de ponderation croissant avec les iterations
3184          ponder = min( 1d0, ( 50 + (50*iter)/nbitaq ) * 0.01d0 )
3185          ponde1 = 1d0 - ponder
3186 c
3187 c        l'ordre du parcours dans le sens croissant ou decroissant
3188          nt   = nbs1
3189          nbs1 = nbs2
3190          nbs2 = nt
3191 c        alternance du parcours
3192          nbs3 = -nbs3
3193 c
3194          do 1000 ns = nbs1, nbs2, nbs3
3195 c
3196 c           le sommet est il interne au domaine?
3197             if( nslign(ns) .ne. 0 ) goto 1000
3198 c
3199 c           existe-t-il une arete de sommet ns ?
3200  10         noar = noarst( ns )
3201             if( noar .le. 0 ) goto 1000
3202 c
3203 c           le 1-er triangle de l'arete noar
3204             nt = nosoar( 4, noar )
3205             if( nt .le. 0 ) goto 1000
3206 c
3207 c           recherche des triangles de sommet ns
3208 c           ils doivent former un contour ferme de type etoile
3209             call trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
3210      %                   mxtrcf, nbtrcf, notrcf )
3211             if( nbtrcf .le. 0 ) goto 1000
3212 c
3213 c           mise a jour de la distance souhaitee
3214             if( nutysu .gt. 0 ) then
3215 c              la fonction taille_ideale(x,y,z) existe
3216 c              calcul de pxyzd(3,ns) dans le repere initial => xyz(1:3)
3217                call tetaid( nutysu, pxyd(1,ns), pxyd(2,ns),
3218      %                      pxyd(3,ns), ier )
3219             endif
3220 c
3221 c           boucle sur les triangles qui forment une boule autour du sommet ns
3222             nbstbo = 0
3223 c           chainage des aretes simples de la boule a rendre delaunay
3224             noar0  = 0
3225             do 40 i=1,nbtrcf
3226 c
3227 c              le numero de l'arete du triangle nt ne contenant pas le sommet ns
3228                nt = notrcf(i)
3229                do 20 na=1,3
3230 c                 le numero de l'arete na dans le tableau nosoar
3231                   noar = abs( noartr(na,nt) )
3232                   if( nosoar(1,noar) .ne. ns   .and.
3233      %                nosoar(2,noar) .ne. ns ) goto 25
3234  20            continue
3235 c
3236 c              construction de la liste des sommets des aretes simples
3237 c              de la boule des triangles de sommet ns
3238 c              -------------------------------------------------------
3239  25            do 35 na=1,2
3240                   ns1 = nosoar(na,noar)
3241                   do 30 j=nbstbo,1,-1
3242                      if( ns1 .eq. nostbo(j) ) goto 35
3243  30               continue
3244 c                 ns1 est un nouveau sommet a ajouter
3245                   nbstbo = nbstbo + 1
3246                   nostbo(nbstbo) = ns1
3247  35            continue
3248 c
3249 c              noar est une arete potentielle a rendre delaunay
3250                if( nosoar(3,noar) .eq. 0 ) then
3251 c                 arete non frontaliere
3252                   nosoar(lchain,noar) = noar0
3253                   noar0 = noar
3254                endif
3255 c
3256  40         continue
3257 c
3258 c           calcul des 2 coordonnees du barycentre de la boule du sommet ns
3259 c           calcul de la longueur moyenne des aretes issues du sommet ns
3260 c           ---------------------------------------------------------------
3261             xbar = 0d0
3262             ybar = 0d0
3263             dmoy = 0d0
3264             do 50 i=1,nbstbo
3265                x    = pxyd(1,nostbo(i))
3266                y    = pxyd(2,nostbo(i))
3267                xbar = xbar + x
3268                ybar = ybar + y
3269                dmoy = dmoy + sqrt( (x-pxyd(1,ns))**2+(y-pxyd(2,ns))**2 )
3270  50         continue
3271             dmoy = dmoy / nbstbo
3272 c
3273 c           pas de modification de la topologie lors de la derniere iteration
3274 c           =================================================================
3275             if( iter .eq. nbitaq ) goto 200
3276 c
3277 c           si la taille de l'arete moyenne est >ampli*taille souhaitee
3278 c           alors ajout d'un sommet barycentre du plus grand triangle
3279 c                 de sommet ns
3280 c           ===========================================================
3281             if( dmoy .gt. ampli*pxyd(3,ns) ) then
3282 c
3283                dmoy = 0d0
3284                do 150 i=1,nbtrcf
3285 c                 recherche du plus grand triangle en surface
3286                   call nusotr( notrcf(i), mosoar, nosoar,
3287      %                         moartr, noartr, nosotr )
3288                   d  = surtd2( pxyd(1,nosotr(1)),
3289      %                         pxyd(1,nosotr(2)),
3290      %                         pxyd(1,nosotr(3)) )
3291                   if( d .gt. dmoy ) then
3292                      dmoy = d
3293                      imax = i
3294                   endif
3295  150           continue
3296 c
3297 c              ajout du barycentre du triangle notrcf(imax)
3298                nt = notrcf( imax )
3299                call nusotr( nt, mosoar, nosoar,
3300      %                      moartr, noartr, nosotr )
3301                if( nbsomm .ge. mxsomm ) then
3302                   write(imprim,*) 'saturation du tableau pxyd'
3303 c                 abandon de l'amelioration du sommet ns
3304                   goto 9999
3305                endif
3306                nbsomm = nbsomm + 1
3307                do 160 i=1,3
3308                   pxyd(i,nbsomm) = ( pxyd(i,nosotr(1))
3309      %                             + pxyd(i,nosotr(2))
3310      %                             + pxyd(i,nosotr(3)) ) / 3d0
3311  160           continue
3312 c
3313                if( nutysu .gt. 0 ) then
3314 c                 la fonction taille_ideale(x,y,z) existe
3315 c                 calcul de pxyzd(3,nbsomm) dans le repere initial => xyz(1:3)
3316                   call tetaid( nutysu, pxyd(1,nbsomm), pxyd(2,nbsomm),
3317      %                         pxyd(3,nbsomm), ier )
3318                endif
3319 c
3320 c              sommet interne a la triangulation
3321                nslign(nbsomm) = 0
3322 c
3323 c              les 3 aretes du triangle nt sont a rendre delaunay
3324                do 170 i=1,3
3325                   noar = abs( noartr(i,nt) )
3326                   if( nosoar(3,noar) .eq. 0 ) then
3327 c                    arete non frontaliere
3328                      if( nosoar(lchain,noar) .lt. 0 ) then
3329 c                       arete non encore chainee
3330                         nosoar(lchain,noar) = noar0
3331                         noar0 = noar
3332                      endif
3333                   endif
3334  170           continue
3335 c
3336 c              triangulation du triangle de barycentre nbsomm
3337 c              protection a ne pas modifier sinon erreur!
3338                call tr3str( nbsomm, nt,
3339      %                      mosoar, mxsoar, n1soar, nosoar,
3340      %                      moartr, mxartr, n1artr, noartr,
3341      %                      noarst,
3342      %                      nosotr, ierr )
3343                if( ierr .ne. 0 ) goto 9999
3344 c
3345 c              un barycentre ajoute de plus
3346                nbbaaj = nbbaaj + 1
3347 c
3348 c              les aretes chainees de la boule sont rendues delaunay
3349                goto 900
3350 c
3351             endif
3352 c
3353 c           si la taille de l'arete moyenne est <ampli/2*taille souhaitee
3354 c           alors suppression du sommet ns
3355 c           =============================================================
3356             if( dmoy .lt. ampli2*pxyd(3,ns) ) then
3357 c              remise a -1 du chainage des aretes peripheriques de la boule ns
3358                noar = noar0
3359  90            if( noar .gt. 0 ) then
3360 c                 protection du no de l'arete suivante
3361                   na = nosoar(lchain,noar)
3362 c                 l'arete interne est remise a -1
3363                   nosoar(lchain,noar) = -1
3364 c                 l'arete suivante
3365                   noar = na
3366                   goto 90
3367                endif
3368                call te1stm( ns,     pxyd,   noarst,
3369      %                      mosoar, mxsoar, n1soar, nosoar,
3370      %                      moartr, mxartr, n1artr, noartr,
3371      %                      mxtrcf, n1arcf, noarcf,
3372      %                      larmin, notrcf, nostbo,
3373      %                      ierr )
3374                if( ierr .lt. 0 ) then
3375 c                 le sommet ns est externe donc non supprime
3376 c                 ou bien le sommet ns est le centre d'un cf dont toutes
3377 c                 les aretes simples sont frontalieres
3378 c                 dans les 2 cas le sommet ns n'est pas supprime
3379                   ierr = 0
3380                   goto 200
3381                else if( ierr .gt. 0 ) then
3382 c                 erreur irrecuperable
3383                   goto 9999
3384                endif
3385                nbstsu = nbstsu + 1
3386                goto 1000
3387 c
3388             endif
3389 c
3390 c           les 2 coordonnees du barycentre des sommets des aretes
3391 c           simples de la boule du sommet ns
3392 c           ======================================================
3393  200        xbar = xbar / nbstbo
3394             ybar = ybar / nbstbo
3395 c
3396 c           ponderation pour eviter les degenerescenses
3397             pxyd(1,ns) = ponde1 * pxyd(1,ns) + ponder * xbar
3398             pxyd(2,ns) = ponde1 * pxyd(2,ns) + ponder * ybar
3399 c
3400             if( nutysu .gt. 0 ) then
3401 c              la fonction taille_ideale(x,y,z) existe
3402 c              calcul de pxyzd(3,ns) dans le repere initial => xyz(1:3)
3403                call tetaid( nutysu, pxyd(1,ns), pxyd(2,ns),
3404      %                      pxyd(3,ns), ier )
3405             endif
3406 c
3407 c           les aretes chainees de la boule sont rendues delaunay
3408  900        call tedela( pxyd,   noarst,
3409      %                   mosoar, mxsoar, n1soar, nosoar, noar0,
3410      %                   moartr, mxartr, n1artr, noartr, modifs )
3411 c
3412  1000    continue
3413 c
3414 ccc         write(imprim,11000) nbstsu, nbbaaj
3415 ccc11000 format( i6,' sommets supprimes ' ,
3416 ccc     %        i6,' barycentres ajoutes' )
3417 c
3418 c        mise a jour pour ne pas oublier les nouveaux sommets
3419          if( nbs1 .gt. nbs2 ) then
3420             nbs1 = nbsomm
3421          else
3422             nbs2 = nbsomm
3423          endif
3424 c
3425  5000 continue
3426 c
3427  9999 return
3428       end
3429
3430
3431       subroutine teamsf( nutysu,
3432      %                   noarst, mosoar, mxsoar, n1soar, nosoar,
3433      %                   moartr, mxartr, n1artr, noartr,
3434      %                   mxtrcf, notrcf, nostbo,
3435      %                   n1arcf, noarcf, larmin,
3436      %                   comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
3437      %                   ierr )
3438 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3439 c but :    modification de la topologie des triangles autour des
3440 c -----    sommets frontaliers et mise en triangulation delaunay locale
3441 c
3442 c entrees:
3443 c --------
3444 c nutysu : numero de traitement de areteideale() selon le type de surface
3445 c          0 pas d'emploi de la fonction areteideale() => aretmx active
3446 c          1 il existe une fonction areteideale()
3447 c            dont seules les 2 premieres composantes de uv sont actives
3448 c          autres options a definir...
3449 c noarst : noarst(i) numero d'une arete de sommet i
3450 c mosoar : nombre maximal d'entiers par arete et
3451 c          indice dans nosoar de l'arete suivante dans le hachage
3452 c mxsoar : nombre maximal d'aretes frontalieres declarables
3453 c n1soar : numero de la premiere arete vide dans le tableau nosoar
3454 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
3455 c          chainage des aretes frontalieres, chainage du hachage des aretes
3456 c moartr : nombre maximal d'entiers par arete du tableau noartr
3457 c mxartr : nombre maximal de triangles declarables dans noartr
3458 c n1artr : numero du premier triangle vide dans le tableau noartr
3459 c          le chainage des triangles vides se fait sur noartr(2,.)
3460 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
3461 c mxtrcf : nombre maximal de triangles empilables
3462 c nbarpi : numero du dernier sommet frontalier ou interne impose
3463 c nslign : >0 => ns numero du point dans le lexique point si interne impose
3464 c          ou => 1 000 000 * n + ns1
3465 c              ou n   est le numero (1 a nblftr) de la ligne de ce point
3466 c                 ns1 est le numero du point dans sa ligne
3467 c          = 0 si le point est interne non impose par l'utilisateur
3468 c          =-1 si le sommet est externe au domaine
3469 c comxmi : min et max des coordonneees des sommets du maillage
3470 c
3471 c modifies :
3472 c ----------
3473 c nbsomm : nombre actuel de sommets de la triangulation
3474 c          (certains sommets internes ont ete desactives ou ajoutes)
3475 c pxyd   : tableau des coordonnees 2d des points
3476 c
3477 c auxiliaires:
3478 c ------------
3479 c notrcf : tableau ( mxtrcf ) auxiliaire d'entiers
3480 c          numero dans noartr des triangles de sommet ns
3481 c nostbo : tableau ( mxtrcf ) auxiliaire d'entiers
3482 c          numero dans pxyd des sommets des aretes simples de la boule
3483 c n1arcf : tableau (0:mxtrcf) auxiliaire d'entiers
3484 c noarcf : tableau (3,mxtrcf) auxiliaire d'entiers
3485 c larmin : tableau ( mxtrcf ) auxiliaire d'entiers
3486 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3487 c auteur : alain perronnet  analyse numerique paris upmc    janvier 1998
3488 c....................................................................012
3489       parameter        (lchain=6)
3490       common / unites / lecteu, imprim, nunite(30)
3491       double precision  pxyd(3,*)
3492       double precision  a, angle, angled, pi, deuxpi, pis3
3493       double precision  d2d3(3,3)
3494       real              origin(3), xyz(3)
3495       integer           noartr(moartr,*),
3496      %                  nosoar(mosoar,*),
3497      %                  noarst(*),
3498      %                  notrcf(mxtrcf),
3499      %                  nslign(*),
3500      %                  nostbo(*),
3501      %                  n1arcf(0:mxtrcf),
3502      %                  noarcf(3,mxtrcf),
3503      %                  larmin(mxtrcf),
3504      %                  nosotr(3)
3505       double precision  comxmi(3,2)
3506 c
3507 c     le nombre d'iterations pour ameliorer la qualite
3508       nbitaq = 2
3509       ier    = 0
3510 c
3511 c     pi / 3
3512       pi     = atan(1d0) * 4d0
3513       pis3   = pi / 3d0
3514       deuxpi = 2d0 * pi
3515 c
3516 c     initialisation du parcours
3517       modifs = 0
3518       nbs1   = nbarpi
3519       nbs2   =  1
3520 c     => pas de traitement sur les points des lignes de la frontiere
3521       nbs3   = -1
3522 c
3523       do 5000 iter=1,nbitaq
3524 c
3525 c        le nombre de sommets supprimes
3526          nbstsu = 0
3527 c
3528 c        l'ordre du parcours dans le sens croissant ou decroissant
3529          nt   = nbs1
3530          nbs1 = nbs2
3531          nbs2 = nt
3532 c        alternance du parcours
3533          nbs3 = -nbs3
3534 c
3535          do 1000 ns = nbs1, nbs2, nbs3
3536 c
3537 c           le sommet est il sur une ligne de la frontiere?
3538 c           if( nslign(ns) .lt. 1 000 000 ) goto 1000
3539 c
3540 c           traitement d'un sommet d'une ligne de la frontiere
3541 c           ==================================================
3542 c           existe-t-il une arete de sommet ns ?
3543             noar = noarst( ns )
3544             if( noar .le. 0 ) goto 1000
3545 c
3546 c           le 1-er triangle de l'arete noar
3547             nt = nosoar( 4, noar )
3548             if( nt .le. 0 ) goto 1000
3549 c
3550 c           recherche des triangles de sommet ns
3551 c           ils doivent former un contour ferme de type camembert
3552             call trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
3553      %                   mxtrcf, nbtrcf, notrcf )
3554             if( nbtrcf .ge. -1 ) goto 1000
3555 c
3556 c           boucle sur les triangles qui forment un camembert autour du sommet n
3557             nbtrcf = -nbtrcf
3558 c
3559 c           angle interne au camembert autour du sommet ns
3560             angle = 0d0
3561             do 540 i=1,nbtrcf
3562 c
3563 c              le numero de l'arete du triangle nt ne contenant pas le sommet ns
3564                nt = notrcf(i)
3565                do 520 na=1,3
3566 c                 le numero de l'arete na dans le tableau nosoar
3567                   noar = abs( noartr(na,nt) )
3568                   if( nosoar(1,noar) .ne. ns   .and.
3569      %                nosoar(2,noar) .ne. ns ) goto 525
3570  520           continue
3571 c
3572 c              calcul de l'angle (ns-st1 arete, ns-st2 arete)
3573  525           ns1 = nosoar(1,noar)
3574                ns2 = nosoar(2,noar)
3575                a   = angled( pxyd(1,ns), pxyd(1,ns1), pxyd(1,ns2) )
3576                if( a .gt. pi ) a = deuxpi - a
3577                angle = angle + a
3578 c
3579  540        continue
3580 c
3581 c           nombre ideal de triangles autour du sommet ns
3582             n = nint( angle / pis3 )
3583             if( n .le. 1 ) goto 1000
3584             i = 1
3585             if( nbtrcf .gt. n ) then
3586 c
3587 c              ajout du barycentre du triangle "milieu"
3588                nt = notrcf( (n+1)/2 )
3589                call nusotr( nt, mosoar, nosoar,
3590      %                      moartr, noartr, nosotr )
3591                if( nbsomm .ge. mxsomm ) then
3592                   write(imprim,*) 'saturation du tableau pxyd'
3593 c                 abandon de l'amelioration du sommet ns
3594                   goto 1000
3595                endif
3596                nbsomm = nbsomm + 1
3597                do 560 i=1,3
3598                   pxyd(i,nbsomm) = ( pxyd(i,nosotr(1))
3599      %                             + pxyd(i,nosotr(2))
3600      %                             + pxyd(i,nosotr(3)) ) / 3d0
3601  560           continue
3602 c
3603                if( nutysu .gt. 0 ) then
3604 c                 la fonction taille_ideale(x,y,z) existe
3605 c                 calcul de pxyzd(3,nbsomm) dans le repere initial => xyz(1:3)
3606                   call tetaid( nutysu, pxyd(1,nbsomm), pxyd(2,nbsomm),
3607      %                         pxyd(3,nbsomm), ier )
3608                endif
3609 c
3610 c              sommet interne a la triangulation
3611                nslign(nbsomm) = 0
3612 c
3613 c              les 3 aretes du triangle nt sont a rendre delaunay
3614                noar0 = 0
3615                do 570 i=1,3
3616                   noar = abs( noartr(i,nt) )
3617                   if( nosoar(3,noar) .eq. 0 ) then
3618 c                    arete non frontaliere
3619                      if( nosoar(lchain,noar) .lt. 0 ) then
3620 c                       arete non encore chainee
3621                         nosoar(lchain,noar) = noar0
3622                         noar0 = noar
3623                      endif
3624                   endif
3625  570           continue
3626 c
3627 c              triangulation du triangle de barycentre nbsomm
3628 c              protection a ne pas modifier sinon erreur!
3629                call tr3str( nbsomm, nt,
3630      %                      mosoar, mxsoar, n1soar, nosoar,
3631      %                      moartr, mxartr, n1artr, noartr,
3632      %                      noarst,
3633      %                      nosotr, ierr )
3634                if( ierr .ne. 0 ) goto 9999
3635 c
3636 c              les aretes chainees de la boule sont rendues delaunay
3637                call tedela( pxyd,   noarst,
3638      %                      mosoar, mxsoar, n1soar, nosoar, noar0,
3639      %                      moartr, mxartr, n1artr, noartr, modifs )
3640             endif
3641 c
3642  1000    continue
3643 c
3644  5000 continue
3645 c
3646  9999 return
3647       end
3648
3649
3650       subroutine teamqs( nutysu,
3651      %                   noarst, mosoar, mxsoar, n1soar, nosoar,
3652      %                   moartr, mxartr, n1artr, noartr,
3653      %                   mxtrcf, notrcf, nostbo,
3654      %                   n1arcf, noarcf, larmin,
3655      %                   comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
3656      %                   ierr )
3657 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3658 c but :    une iteration de barycentrage des points internes
3659 c -----    modification de la topologie pour avoir 4 ou 5 ou 6 triangles
3660 c          pour chaque sommet de la triangulation
3661 c          mise en triangulation delaunay
3662 c
3663 c entrees:
3664 c --------
3665 c nutysu : numero de traitement de areteideale() selon le type de surface
3666 c          0 pas d'emploi de la fonction areteideale() => aretmx active
3667 c          1 il existe une fonction areteideale()
3668 c            dont seules les 2 premieres composantes de uv sont actives
3669 c          autres options a definir...
3670 c noarst : noarst(i) numero d'une arete de sommet i
3671 c mosoar : nombre maximal d'entiers par arete et
3672 c          indice dans nosoar de l'arete suivante dans le hachage
3673 c mxsoar : nombre maximal d'aretes frontalieres declarables
3674 c n1soar : numero de la premiere arete vide dans le tableau nosoar
3675 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
3676 c          chainage des aretes frontalieres, chainage du hachage des aretes
3677 c moartr : nombre maximal d'entiers par arete du tableau noartr
3678 c mxartr : nombre maximal de triangles declarables dans noartr
3679 c n1artr : numero du premier triangle vide dans le tableau noartr
3680 c          le chainage des triangles vides se fait sur noartr(2,.)
3681 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
3682 c mxtrcf : nombre maximal de triangles empilables
3683 c nbarpi : numero du dernier sommet frontalier ou interne impose
3684 c nslign : >0 => ns numero du point dans le lexique point si interne impose
3685 c          ou => 1 000 000 * n + ns1
3686 c              ou n   est le numero (1 a nblftr) de la ligne de ce point
3687 c                 ns1 est le numero du point dans sa ligne
3688 c          = 0 si le point est interne non impose par l'utilisateur
3689 c          =-1 si le sommet est externe au domaine
3690 c comxmi : min et max des coordonneees des sommets du maillage
3691 c
3692 c modifies :
3693 c ----------
3694 c nbsomm : nombre actuel de sommets de la triangulation
3695 c          (certains sommets internes ont ete desactives ou ajoutes)
3696 c pxyd   : tableau des coordonnees 2d des points
3697 c
3698 c auxiliaires:
3699 c ------------
3700 c notrcf : tableau ( mxtrcf ) auxiliaire d'entiers
3701 c          numero dans noartr des triangles de sommet ns
3702 c nostbo : tableau ( mxtrcf ) auxiliaire d'entiers
3703 c          numero dans pxyd des sommets des aretes simples de la boule
3704 c n1arcf : tableau (0:mxtrcf) auxiliaire d'entiers
3705 c noarcf : tableau (3,mxtrcf) auxiliaire d'entiers
3706 c larmin : tableau ( mxtrcf ) auxiliaire d'entiers
3707 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3708 c auteur : alain perronnet  analyse numerique paris upmc        mai 1997
3709 c....................................................................012
3710       parameter        (lchain=6)
3711       common / unites / lecteu, imprim, nunite(30)
3712       double precision  pxyd(3,*)
3713       double precision  ponder, ponde1, xbar, ybar, x, y, d, dmin, dmax
3714       double precision  d2d3(3,3)
3715       real              origin(3), xyz(3)
3716       integer           noartr(moartr,*),
3717      %                  nosoar(mosoar,*),
3718      %                  noarst(*),
3719      %                  notrcf(mxtrcf),
3720      %                  nslign(*),
3721      %                  nostbo(*),
3722      %                  n1arcf(0:mxtrcf),
3723      %                  noarcf(3,mxtrcf),
3724      %                  larmin(mxtrcf)
3725       integer           nosotr(3,2)
3726       double precision  comxmi(3,2)
3727 c
3728 c     le nombre d'iterations pour ameliorer la qualite
3729       nbitaq = 6
3730       ier    = 0
3731 c
3732 c     initialisation du parcours
3733       nbs1 = nbsomm
3734       nbs2 = nbarpi + 1
3735 c     => pas de traitement sur les points des lignes de la frontiere
3736       nbs3 = -1
3737 c
3738       do 5000 iter=1,nbitaq
3739 c
3740 c        le nombre de sommets supprimes
3741          nbstsu = 0
3742 c
3743 c        les compteurs de passage sur les differents cas
3744          nbst4 = 0
3745          nbst5 = 0
3746          nbst8 = 0
3747 c
3748 c        coefficient de ponderation croissant avec les iterations
3749          ponder = min( 1d0, ( 50 + (50*iter)/nbitaq ) * 0.01d0 )
3750          ponde1 = 1d0 - ponder
3751 c
3752 c        l'ordre du parcours dans le sens croissant ou decroissant
3753          nt   = nbs1
3754          nbs1 = nbs2
3755          nbs2 = nt
3756 c        alternance du parcours
3757          nbs3 = -nbs3
3758 c
3759          do 1000 ns = nbs1, nbs2, nbs3
3760 c
3761 c           le sommet est il interne au domaine?
3762             if( nslign(ns) .ne. 0 ) goto 1000
3763 c
3764 c           traitement d'un sommet interne non impose par l'utilisateur
3765 c           ===========================================================
3766 c           existe-t-il une arete de sommet ns ?
3767  10         noar = noarst( ns )
3768             if( noar .le. 0 ) goto 1000
3769 c
3770 c           le 1-er triangle de l'arete noar
3771             nt = nosoar( 4, noar )
3772             if( nt .le. 0 ) goto 1000
3773 c
3774 c           recherche des triangles de sommet ns
3775 c           ils doivent former un contour ferme de type etoile
3776             call trp1st( ns, noarst, mosoar, nosoar, moartr, noartr,
3777      %                   mxtrcf, nbtrcf, notrcf )
3778             if( nbtrcf .le. 0 ) goto 1000
3779 c
3780 c           boucle sur les triangles qui forment une boule autour du sommet ns
3781             nbstbo = 0
3782 c           chainage des aretes simples de la boule a rendre delaunay
3783             noar0  = 0
3784             do 40 i=1,nbtrcf
3785 c
3786 c              le numero de l'arete du triangle nt ne contenant pas le sommet ns
3787                nt = notrcf(i)
3788                do 20 na=1,3
3789 c                 le numero de l'arete na dans le tableau nosoar
3790                   noar = abs( noartr(na,nt) )
3791                   if( nosoar(1,noar) .ne. ns   .and.
3792      %                nosoar(2,noar) .ne. ns ) goto 25
3793  20            continue
3794 c
3795 c              construction de la liste des sommets des aretes simples
3796 c              de la boule des triangles de sommet ns
3797 c              -------------------------------------------------------
3798  25            do 35 na=1,2
3799                   ns1 = nosoar(na,noar)
3800                   do 30 j=nbstbo,1,-1
3801                      if( ns1 .eq. nostbo(j) ) goto 35
3802  30               continue
3803 c                 ns1 est un nouveau sommet a ajouter
3804                   nbstbo = nbstbo + 1
3805                   nostbo(nbstbo) = ns1
3806  35            continue
3807 c
3808 c              noar est une arete potentielle a rendre delaunay
3809                if( nosoar(3,noar) .eq. 0 ) then
3810 c                 arete non frontaliere
3811                   nosoar(lchain,noar) = noar0
3812                   noar0 = noar
3813                endif
3814 c
3815  40         continue
3816 c
3817 c           calcul des 2 coordonnees du barycentre de la boule du sommet ns
3818 c           calcul de l'arete de taille maximale et minimale issue de ns
3819 c           ---------------------------------------------------------------
3820             xbar = 0d0
3821             ybar = 0d0
3822             dmin = 1d28
3823             dmax = 0d0
3824             do 50 i=1,nbstbo
3825                x    = pxyd(1,nostbo(i))
3826                y    = pxyd(2,nostbo(i))
3827                xbar = xbar + x
3828                ybar = ybar + y
3829                d    = (x-pxyd(1,ns)) ** 2 + (y-pxyd(2,ns)) ** 2
3830                if( d .gt. dmax ) then
3831                   dmax = d
3832                   imax = i
3833                endif
3834                if( d .lt. dmin ) then
3835                   dmin = d
3836                   imin = i
3837                endif
3838  50         continue
3839 c
3840 c           pas de modification de la topologie lors de la derniere iteration
3841 c           =================================================================
3842             if( iter .ge. nbitaq ) goto 200
3843 c
3844 c           si la boule de ns contient 3 ou 4 triangles le sommet ns est detruit
3845 c           ====================================================================
3846             if( nbtrcf .le. 4 ) then
3847 c
3848 c              remise a -1 du chainage des aretes peripheriques de la boule ns
3849                noar = noar0
3850  60            if( noar .gt. 0 ) then
3851 c                 protection du no de l'arete suivante
3852                   na = nosoar(lchain,noar)
3853 c                 l'arete interne est remise a -1
3854                   nosoar(lchain,noar) = -1
3855 c                 l'arete suivante
3856                   noar = na
3857                   goto 60
3858                endif
3859                call te1stm( ns,     pxyd,   noarst,
3860      %                      mosoar, mxsoar, n1soar, nosoar,
3861      %                      moartr, mxartr, n1artr, noartr,
3862      %                      mxtrcf, n1arcf, noarcf,
3863      %                      larmin, notrcf, nostbo,
3864      %                      ierr )
3865                if( ierr .lt. 0 ) then
3866 c                 le sommet ns est externe donc non supprime
3867 c                 ou bien le sommet ns est le centre d'un cf dont toutes
3868 c                 les aretes simples sont frontalieres
3869 c                 dans les 2 cas le sommet ns n'est pas supprime
3870                   ierr = 0
3871                   goto 200
3872                else if( ierr .eq. 0 ) then
3873                   nbst4  = nbst4 + 1
3874                   nbstsu = nbstsu + 1
3875                else
3876 c                 erreur irrecuperable
3877                   goto 9999
3878                endif
3879                goto 1000
3880 c
3881             endif
3882 c
3883 c           si la boule de ns contient 5 triangles et a un sommet voisin
3884 c           sommet de 5 triangles alors l'arete joignant ces 2 sommets
3885 c           est transformee en un seul sommet de 6 triangles
3886 c           ============================================================
3887             if( nbtrcf .eq. 5 ) then
3888 c
3889                do 80 i=1,5
3890 c                 le numero du sommet de l'arete i et different de ns
3891                   ns1 = nostbo(i)
3892 c                 la liste des triangles de sommet ns1
3893                   call trp1st( ns1, noarst,
3894      %                         mosoar, nosoar, moartr, noartr,
3895      %                         mxtrcf-5, nbtrc1, notrcf(6) )
3896                   if( nbtrc1 .eq. 5 ) then
3897 c
3898 c                    l'arete de sommets ns-ns1 devient un point
3899 c                    par suppression du sommet ns
3900 c
3901 c                    remise a -1 du chainage des aretes peripheriques de la boul
3902                      noar = noar0
3903  70                  if( noar .gt. 0 ) then
3904 c                       protection du no de l'arete suivante
3905                         na = nosoar(lchain,noar)
3906 c                       l'arete interne est remise a -1
3907                         nosoar(lchain,noar) = -1
3908 c                       l'arete suivante
3909                         noar = na
3910                         goto 70
3911                      endif
3912 c
3913 c                    le point ns1 devient le milieu de l'arete ns-ns1
3914                      do 75 j=1,3
3915                         pxyd(j,ns1) = (pxyd(j,ns) + pxyd(j,ns1)) * 0.5d0
3916  75                  continue
3917 c
3918                      if( nutysu .gt. 0 ) then
3919 c                       la fonction taille_ideale(x,y,z) existe
3920 c                       calcul de pxyzd(3,ns1) dans le repere initial => xyz(1:3
3921                         call tetaid( nutysu,pxyd(1,ns1),pxyd(2,ns1),
3922      %                               pxyd(3,ns1), ier )
3923                      endif
3924 c
3925 c                    suppression du point ns et mise en delaunay
3926                      call te1stm( ns,     pxyd,   noarst,
3927      %                            mosoar, mxsoar, n1soar, nosoar,
3928      %                            moartr, mxartr, n1artr, noartr,
3929      %                            mxtrcf, n1arcf, noarcf,
3930      %                            larmin, notrcf, nostbo,
3931      %                            ierr )
3932                      if( ierr .lt. 0 ) then
3933 c                       le sommet ns est externe donc non supprime
3934 c                       ou bien le sommet ns est le centre d'un cf dont toutes
3935 c                       les aretes simples sont frontalieres
3936 c                       dans les 2 cas le sommet ns n'est pas supprime
3937                         ierr = 0
3938                         goto 200
3939                      else if( ierr .eq. 0 ) then
3940                         nbstsu = nbstsu + 1
3941                         nbst5  = nbst5 + 1
3942                         goto 1000
3943                      else
3944 c                       erreur irrecuperable
3945                         goto 9999
3946                      endif
3947                   endif
3948  80            continue
3949             endif
3950 c
3951 c           si la boule de ns contient au moins 8 triangles
3952 c           alors un triangle interne est ajoute + 3 triangles (1 par arete)
3953 c           ================================================================
3954             if( nbtrcf .ge. 8 ) then
3955 c
3956 c              modification des coordonnees du sommet ns
3957 c              il devient le barycentre du triangle notrcf(1)
3958                call nusotr( notrcf(1), mosoar, nosoar,
3959      %                      moartr, noartr, nosotr )
3960                do 110 i=1,3
3961                   pxyd(i,ns) = ( pxyd(i,nosotr(1,1))
3962      %                         + pxyd(i,nosotr(2,1))
3963      %                         + pxyd(i,nosotr(3,1)) ) / 3d0
3964  110           continue
3965 c
3966                if( nutysu .gt. 0 ) then
3967 c                 la fonction taille_ideale(x,y,z) existe
3968 c                 calcul de pxyzd(3,nbsomm) dans le repere initial => xyz(1:3)
3969                   call tetaid( nutysu, pxyd(1,ns), pxyd(2,ns),
3970      %                         pxyd(3,ns), ier )
3971                endif
3972 c
3973 c              ajout des 2 autres sommets comme barycentres des triangles
3974 c              notrcf(1+nbtrcf/3) et notrcf(1+2*nbtrcf/3)
3975                nbt1 = ( nbtrcf + 1 ) / 3
3976                do 140 n=1,2
3977 c
3978 c                 le triangle traite
3979                   nt = notrcf(1 + n * nbt1 )
3980 c
3981 c                 le numero pxyd de ses 3 sommets
3982                   call nusotr( nt, mosoar, nosoar,
3983      %                         moartr, noartr, nosotr )
3984 c
3985 c                 ajout du nouveau barycentre
3986                   if( nbsomm .ge. mxsomm ) then
3987                      write(imprim,*) 'saturation du tableau pxyd'
3988 c                    abandon de l'amelioration
3989                      goto 1100
3990                   endif
3991                   nbsomm = nbsomm + 1
3992                   do 120 i=1,3
3993                      pxyd(i,nbsomm) = ( pxyd(i,nosotr(1,1))
3994      %                                + pxyd(i,nosotr(2,1))
3995      %                                + pxyd(i,nosotr(3,1)) ) / 3d0
3996  120              continue
3997 c
3998                   if( nutysu .gt. 0 ) then
3999 c                    la fonction taille_ideale(x,y,z) existe
4000 c                    calcul de pxyzd(3,nbsomm) dans le repere initial => xyz(1:3
4001                      call tetaid( nutysu, pxyd(1,nbsomm),pxyd(2,nbsomm),
4002      %                            pxyd(3,nbsomm), ier )
4003                   endif
4004 c
4005 c                 sommet interne a la triangulation
4006                   nslign(nbsomm) = 0
4007 c
4008 c                 les 3 aretes du triangle nt sont a rendre delaunay
4009                   do 130 i=1,3
4010                      noar = abs( noartr(i,nt) )
4011                      if( nosoar(3,noar) .eq. 0 ) then
4012 c                       arete non frontaliere
4013                         if( nosoar(lchain,noar) .lt. 0 ) then
4014 c                          arete non encore chainee
4015                            nosoar(lchain,noar) = noar0
4016                            noar0 = noar
4017                         endif
4018                      endif
4019  130              continue
4020 c
4021 c                 triangulation du triangle de barycentre nbsomm
4022 c                 protection a ne pas modifier sinon erreur!
4023                   call tr3str( nbsomm, nt,
4024      %                         mosoar, mxsoar, n1soar, nosoar,
4025      %                         moartr, mxartr, n1artr, noartr,
4026      %                         noarst,
4027      %                         nosotr, ierr )
4028                   if( ierr .ne. 0 ) goto 9999
4029  140           continue
4030 c
4031                nbst8  = nbst8 + 1
4032 c
4033 c              les aretes chainees de la boule sont rendues delaunay
4034                goto 300
4035 c
4036             endif
4037 c
4038 c           nbtrcf est compris entre 5 et 7 => barycentrage simple
4039 c           ======================================================
4040 c           les 2 coordonnees du barycentre des sommets des aretes
4041 c           simples de la boule du sommet ns
4042  200        xbar = xbar / nbstbo
4043             ybar = ybar / nbstbo
4044 c
4045 c           ponderation pour eviter les degenerescenses
4046             pxyd(1,ns) = ponde1 * pxyd(1,ns) + ponder * xbar
4047             pxyd(2,ns) = ponde1 * pxyd(2,ns) + ponder * ybar
4048 c
4049 c           les aretes chainees de la boule sont rendues delaunay
4050  300        call tedela( pxyd,   noarst,
4051      %                   mosoar, mxsoar, n1soar, nosoar, noar0,
4052      %                   moartr, mxartr, n1artr, noartr, modifs )
4053 c
4054  1000    continue
4055 c
4056 c        trace de la triangulation actuelle et calcul de la qualite
4057  1100    continue
4058 c
4059 ccc         write(imprim,11000) nbst4, nbst5, nbst8
4060 ccc11000 format( i7,' sommets de 4t',
4061 ccc     %        i7,' sommets 5t+5t',
4062 ccc     %        i7,' sommets >7t' )
4063 c
4064 c        mise a jour pour ne pas oublier les nouveaux sommets
4065          if( nbs1 .gt. nbs2 ) then
4066             nbs1 = nbsomm
4067             nbs2 = nbarpi + 1
4068          else
4069             nbs1 = nbarpi + 1
4070             nbs2 = nbsomm
4071          endif
4072 c
4073  5000 continue
4074 c
4075  9999 return
4076       end
4077
4078
4079       subroutine teamqt( nutysu,
4080      %                   noarst, mosoar, mxsoar, n1soar, nosoar,
4081      %                   moartr, mxartr, n1artr, noartr,
4082      %                   mxarcf, notrcf, nostbo,
4083      %                   n1arcf, noarcf, larmin,
4084      %                   comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
4085      %                   ierr )
4086 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4087 c but :    amelioration de la qualite de la triangulation issue de teabr4
4088 c -----
4089 c
4090 c entrees:
4091 c --------
4092 c nutysu : numero de traitement de areteideale() selon le type de surface
4093 c          0 pas d'emploi de la fonction areteideale() => aretmx active
4094 c          1 il existe une fonction areteideale()
4095 c            dont seules les 2 premieres composantes de uv sont actives
4096 c          autres options a definir...
4097 c noarst : noarst(i) numero d'une arete de sommet i
4098 c mosoar : nombre maximal d'entiers par arete et
4099 c          indice dans nosoar de l'arete suivante dans le hachage
4100 c mxsoar : nombre maximal d'aretes frontalieres declarables
4101 c n1soar : numero de la premiere arete vide dans le tableau nosoar
4102 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4103 c          chainage des aretes frontalieres, chainage du hachage des aretes
4104 c moartr : nombre maximal d'entiers par arete du tableau noartr
4105 c mxartr : nombre maximal de triangles declarables dans noartr
4106 c n1artr : numero du premier triangle vide dans le tableau noartr
4107 c          le chainage des triangles vides se fait sur noartr(2,.)
4108 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4109 c mxarcf : nombre maximal de triangles empilables
4110 c nbarpi : numero du dernier sommet frontalier ou interne impose
4111 c nslign : tableau du numero de sommet dans sa ligne pour chaque
4112 c          sommet frontalier
4113 c          numero du point dans le lexique point si interne impose
4114 c          0 si le point est interne non impose par l'utilisateur
4115 c         -1 si le sommet est externe au domaine
4116 c comxmi : min et max des coordonneees des sommets du maillage
4117 c
4118 c modifies :
4119 c ----------
4120 c nbsomm : nombre actuel de sommets de la triangulation
4121 c          (certains sommets internes ont ete desactives ou ajoutes)
4122 c pxyd   : tableau des coordonnees 2d des points
4123 c
4124 c auxiliaires:
4125 c ------------
4126 c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
4127 c          numero dans noartr des triangles de sommet ns
4128 c nostbo : tableau ( mxarcf ) auxiliaire d'entiers
4129 c          numero dans pxyd des sommets des aretes simples de la boule
4130 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
4131 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
4132 c larmin : tableau ( mxarcf ) auxiliaire d'entiers
4133 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4134 c auteur : alain perronnet  analyse numerique paris upmc       juin 1997
4135 c....................................................................012
4136       common / unites / lecteu, imprim, nunite(30)
4137       double precision  pxyd(3,*), d2d3(3,3)
4138       integer           noartr(moartr,*),
4139      %                  nosoar(mosoar,*),
4140      %                  noarst(*),
4141      %                  notrcf(mxarcf),
4142      %                  nslign(*),
4143      %                  nostbo(mxarcf),
4144      %                  n1arcf(0:mxarcf),
4145      %                  noarcf(3,mxarcf),
4146      %                  larmin(mxarcf)
4147       double precision  comxmi(3,2)
4148 c
4149 c     suppression des sommets de triangles equilateraux trop proches
4150 c     d'un sommet frontalier ou d'un point interne impose par
4151 c     triangulation frontale de l'etoile et mise en delaunay
4152 c     ==============================================================
4153       call tesusp( nbarpi, pxyd,   noarst,
4154      %             mosoar, mxsoar, n1soar, nosoar,
4155      %             moartr, mxartr, n1artr, noartr,
4156      %             mxarcf, n1arcf, noarcf, larmin, notrcf, nostbo,
4157      %             nbstsu, ierr )
4158       if( ierr .ne. 0 ) goto 9999
4159 c      write(imprim,*) 'retrait de',nbstsu,
4160 c     %                ' sommets de te trop proches de la frontiere'
4161 c
4162 c     ajustage des tailles moyennes des aretes avec ampli=1.34d0 entre
4163 c     ampli/2 x taille_souhaitee et ampli x taille_souhaitee
4164 c     + barycentrage des sommets et mise en triangulation delaunay
4165 c     ================================================================
4166       call teamqa( nutysu,
4167      %             noarst, mosoar, mxsoar, n1soar, nosoar,
4168      %             moartr, mxartr, n1artr, noartr,
4169      %             mxarcf, notrcf, nostbo,
4170      %             n1arcf, noarcf, larmin,
4171      %             comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
4172      %             ierr )
4173       if( ierr .ne. 0 ) goto 9999
4174 c
4175 c     modification de la topologie autour des sommets frontaliers
4176 c     pour avoir un nombre de triangles egal a l'angle/60 degres
4177 c     et mise en triangulation delaunay locale
4178 c     ===========================================================
4179       call teamsf( nutysu,
4180      %             noarst, mosoar, mxsoar, n1soar, nosoar,
4181      %             moartr, mxartr, n1artr, noartr,
4182      %             mxarcf, notrcf, nostbo,
4183      %             n1arcf, noarcf, larmin,
4184      %             comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
4185      %             ierr )
4186       if( ierr .ne. 0 ) goto 9999
4187 c
4188 c     quelques iterations de barycentrage des points internes
4189 c     modification de la topologie pour avoir 4 ou 5 ou 6 triangles
4190 c     pour chaque sommet de la triangulation
4191 c     et mise en triangulation delaunay
4192 c     =============================================================
4193       call teamqs( nutysu,
4194      %             noarst, mosoar, mxsoar, n1soar, nosoar,
4195      %             moartr, mxartr, n1artr, noartr,
4196      %             mxarcf, notrcf, nostbo,
4197      %             n1arcf, noarcf, larmin,
4198      %             comxmi, nbarpi, nbsomm, mxsomm, pxyd, nslign,
4199      %             ierr )
4200 c
4201  9999 return
4202       end
4203
4204       subroutine trfrcf( nscent, mosoar, nosoar, moartr, noartr,
4205      %                   nbtrcf, notrcf, nbarfr )
4206 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4207 c but :    calculer le nombre d'aretes simples du contour ferme des
4208 c -----    nbtrcf triangles de numeros stockes dans le tableau notrcf
4209 c          ayant tous le sommet nscent
4210 c
4211 c entrees:
4212 c --------
4213 c nscent : numero du sommet appartenant a tous les triangles notrcf
4214 c mosoar : nombre maximal d'entiers par arete et
4215 c          indice dans nosoar de l'arete suivante dans le hachage
4216 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4217 c          chainage des aretes frontalieres, chainage du hachage des aretes
4218 c moartr : nombre maximal d'entiers par arete du tableau noartr
4219 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4220 c nbtrcf : >0 nombre de triangles empiles
4221 c          =0       si impossible de tourner autour du point
4222 c          =-nbtrcf si apres butee sur la frontiere il y a a nouveau
4223 c          butee sur la frontiere . a ce stade on ne peut dire si tous
4224 c          les triangles ayant ce sommet ont ete recenses
4225 c          ce cas arrive seulement si le sommet est sur la frontiere
4226 c notrcf : numero dans noartr des triangles de sommet ns
4227 c
4228 c sortie :
4229 c --------
4230 c nbarfr : nombre d'aretes simples frontalieres
4231 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4232 c auteur : alain perronnet  analyse numerique paris upmc       juin 1997
4233 c....................................................................012
4234       integer           noartr(moartr,*),
4235      %                  nosoar(mosoar,*),
4236      %                  notrcf(1:nbtrcf)
4237 c
4238       nbarfr = 0
4239       do 50 n=1,nbtrcf
4240 c        le numero du triangle n dans le tableau noartr
4241          nt = notrcf( n )
4242 c        parcours des 3 aretes du triangle nt
4243          do 40 i=1,3
4244 c           le numero de l'arete i dans le tableau nosoar
4245             noar = abs( noartr( i, nt ) )
4246             do 30 j=1,2
4247 c              le numero du sommet j de l'arete noar
4248                ns = nosoar( j, noar )
4249                if( ns .eq. nscent ) goto 40
4250  30         continue
4251 c           l'arete noar (sans sommet nscent) est elle frontaliere?
4252             if( nosoar( 5, noar ) .le. 0 ) then
4253 c              l'arete appartient au plus a un triangle
4254 c              une arete simple frontaliere de plus
4255                nbarfr = nbarfr + 1
4256             endif
4257 c           le triangle a au plus une arete sans sommet nscent
4258             goto 50
4259  40      continue
4260  50   continue
4261       end
4262
4263       subroutine int2ar( p1, p2, p3, p4, oui )
4264 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4265 c but :    les 2 aretes de r**2 p1-p2  p3-p4 s'intersectent elles
4266 c -----    entre leurs sommets?
4267 c
4268 c entrees:
4269 c --------
4270 c p1,p2,p3,p4 : les 2 coordonnees reelles des sommets des 2 aretes
4271 c
4272 c sortie :
4273 c --------
4274 c oui    : .true. si intersection, .false. sinon
4275 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4276 c auteur : alain perronnet  analyse numerique paris upmc    octobre 1991
4277 c2345x7..............................................................012
4278       double precision  p1(2),p2(2),p3(2),p4(2)
4279       double precision  x21,y21,d21,x43,y43,d43,d,x,y,xx
4280       logical  oui
4281 c
4282 c     longueur des aretes
4283       x21 = p2(1)-p1(1)
4284       y21 = p2(2)-p1(2)
4285       d21 = x21**2 + y21**2
4286 c
4287       x43 = p4(1)-p3(1)
4288       y43 = p4(2)-p3(2)
4289       d43 = x43**2 + y43**2
4290 c
4291 c     les 2 aretes sont-elles jugees paralleles ?
4292       d = x43 * y21 - y43 * x21
4293       if( abs(d) .le. 0.001 * sqrt(d21 * d43) ) then
4294 c        aretes paralleles . pas d'intersection
4295          oui = .false.
4296          return
4297       endif
4298 c
4299 c     les 2 coordonnees du point d'intersection
4300       x = ( p1(1)*x43*y21 - p3(1)*x21*y43 - (p1(2)-p3(2))*x21*x43 ) / d
4301       y =-( p1(2)*y43*x21 - p3(2)*y21*x43 - (p1(1)-p3(1))*y21*y43 ) / d
4302 c
4303 c     coordonnees de x,y dans le repere ns1-ns2
4304       xx  = ( x - p1(1) ) * x21 + ( y - p1(2) ) * y21
4305 c     le point est il entre p1 et p2 ?
4306       oui = -0.00001d0*d21 .le. xx .and. xx .le. 1.00001d0*d21
4307 c
4308 c     coordonnees de x,y dans le repere ns3-ns4
4309       xx  = ( x - p3(1) ) * x43 + ( y - p3(2) ) * y43
4310 c     le point est il entre p3 et p4 ?
4311       oui = oui .and. -0.00001d0*d43 .le. xx .and. xx .le. 1.00001d0*d43
4312       end
4313
4314
4315       subroutine trchtd( pxyd,   nar00, nar0,  noarcf,
4316      %                   namin0, namin, larmin )
4317 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4318 c but :    recherche dans le contour ferme du sommet qui joint a la plus
4319 c -----    courte arete nar00 donne le triangle sans intersection
4320 c          avec le contour ferme de meilleure qualite
4321 c
4322 c entrees:
4323 c --------
4324 c pxyd   : tableau des coordonnees des sommets et distance_souhaitee
4325 c
4326 c entrees et sorties:
4327 c -------------------
4328 c nar00  : numero dans noarcf de l'arete avant nar0
4329 c nar0   : numero dans noarcf de la plus petite arete du contour ferme
4330 c          a joindre a noarcf(1,namin) pour former le triangle ideal
4331 c noarcf : numero du sommet , numero de l'arete suivante
4332 c          numero du triangle exterieur a l'etoile
4333 c
4334 c sortie :
4335 c --------
4336 c namin0 : numero dans noarcf de l'arete avant namin
4337 c namin  : numero dans noarcf du sommet choisi
4338 c          0 si contour ferme reduit a moins de 3 aretes
4339 c larmin : tableau auxiliaire pour stocker la liste des numeros des
4340 c          aretes de meilleure qualite pour faire le choix final
4341 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4342 c auteur : alain perronnet  analyse numerique paris upmc    fevrier 1992
4343 c2345x7..............................................................012
4344       double precision dmaxim, precision
4345       parameter        (dmaxim=1.7d+308, precision=1d-16)
4346 c     ATTENTION:variables a ajuster selon la machine!
4347 c     ATTENTION:dmaxim : le plus grand reel machine
4348 c     ATTENTION:sur dec-alpha la precision est de 10**-14 seulement
4349
4350       common / unites / lecteu,imprim,nunite(30)
4351       double precision  pxyd(1:3,1:*)
4352       integer           noarcf(1:3,1:*),
4353      %                  larmin(1:*)
4354       double precision  q, dd, dmima,
4355      %                  unpeps, rayon, surtd2
4356       logical           oui
4357       double precision  centre(3)
4358 c
4359 c     initialisations
4360 c     dmaxim : le plus grand reel machine
4361       unpeps = 1d0 + 100d0 * precision
4362 c
4363 c     recherche de la plus courte arete du contour ferme
4364       nbmin = 0
4365       na00  = nar00
4366       dmima = dmaxim
4367       nbar  = 0
4368 c
4369  2    na0  = noarcf( 2, na00 )
4370       na1  = noarcf( 2, na0  )
4371       nbar = nbar + 1
4372 c     les 2 sommets de l'arete na0 du cf
4373       ns1  = noarcf( 1, na0 )
4374       ns2  = noarcf( 1, na1 )
4375       dd   = (pxyd(1,ns2)-pxyd(1,ns1))**2 + (pxyd(2,ns2)-pxyd(2,ns1))**2
4376       if( dd .lt. dmima ) then
4377          dmima = dd
4378          larmin(1) = na00
4379       endif
4380       na00 = na0
4381       if( na00 .ne. nar00 ) then
4382 c        derniere arete non atteinte
4383          goto 2
4384       endif
4385 c
4386       if( nbar .eq. 3 ) then
4387 c
4388 c        contour ferme reduit a un triangle
4389 c        ----------------------------------
4390          namin  = nar00
4391          nar0   = noarcf( 2, nar00 )
4392          namin0 = noarcf( 2, nar0  )
4393          return
4394 c
4395       else if( nbar .le. 2 ) then
4396          write(imprim,*) 'erreur trchtd: cf<3 aretes'
4397          pause
4398          namin  = 0
4399          namin0 = 0
4400          return
4401       endif
4402 c
4403 c     cf non reduit a un triangle
4404 c     la plus petite arete est nar0 dans noarcf
4405       nar00 = larmin( 1 )
4406       nar0  = noarcf( 2, nar00 )
4407       nar   = noarcf( 2, nar0  )
4408 c
4409       ns1   = noarcf( 1, nar0 )
4410       ns2   = noarcf( 1, nar  )
4411 c
4412 c     recherche dans cette etoile du sommet offrant la meilleure qualite
4413 c     du triangle ns1-ns2 ns3 sans intersection avec le contour ferme
4414 c     ==================================================================
4415       nar3  = nar
4416       qmima = -1
4417 c
4418 c     parcours des sommets possibles ns3
4419  10   nar3  = noarcf( 2, nar3 )
4420       if( nar3 .ne. nar0 ) then
4421 c
4422 c        il existe un sommet ns3 different de ns1 et ns2
4423          ns3 = noarcf( 1, nar3 )
4424 c
4425 c        les aretes ns1-ns3 et ns2-ns3 intersectent-elles une arete
4426 c        du contour ferme ?
4427 c        ----------------------------------------------------------
4428 c        intersection de l'arete ns2-ns3 et des aretes du cf
4429 c        jusqu'au sommet ns3
4430          nar1 = noarcf( 2, nar )
4431 c
4432  15      if( nar1 .ne. nar3 .and. noarcf( 2, nar1 ) .ne. nar3 ) then
4433 c           l'arete suivante
4434             nar2 = noarcf( 2, nar1 )
4435 c           le numero des 2 sommets de l'arete
4436             np1  = noarcf( 1, nar1 )
4437             np2  = noarcf( 1, nar2 )
4438             call int2ar( pxyd(1,ns2), pxyd(1,ns3),
4439      %                   pxyd(1,np1), pxyd(1,np2), oui )
4440             if( oui ) goto 10
4441 c           les 2 aretes ne s'intersectent pas entre leurs sommets
4442             nar1 = nar2
4443             goto 15
4444          endif
4445 c
4446 c        intersection de l'arete ns3-ns1 et des aretes du cf
4447 c        jusqu'au sommet de l'arete nar0
4448          nar1 = noarcf( 2, nar3 )
4449 c
4450  18      if( nar1 .ne. nar0 .and. noarcf( 2, nar1 ) .ne. nar0 ) then
4451 c           l'arete suivante
4452             nar2 = noarcf( 2, nar1 )
4453 c           le numero des 2 sommets de l'arete
4454             np1  = noarcf( 1, nar1 )
4455             np2  = noarcf( 1, nar2 )
4456             call int2ar( pxyd(1,ns1), pxyd(1,ns3),
4457      %                   pxyd(1,np1), pxyd(1,np2), oui )
4458             if( oui ) goto 10
4459 c           les 2 aretes ne s'intersectent pas entre leurs sommets
4460             nar1 = nar2
4461             goto 18
4462          endif
4463 c
4464 c        le triangle ns1-ns2-ns3 n'intersecte pas une arete du contour ferme
4465 c        le calcul de la surface du triangle
4466          dd = surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
4467          if( dd .le. 0d0 ) then
4468 c           surface negative => triangle a rejeter
4469             q = 0
4470          else
4471 c           calcul de la qualite du  triangle  ns1-ns2-ns3
4472             call qutr2d( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), q )
4473          endif
4474 c
4475          if( q .ge. qmima*1.00001 ) then
4476 c           q est un vrai maximum de la qualite
4477             qmima = q
4478             nbmin = 1
4479             larmin(1) = nar3
4480          else if( q .ge. qmima*0.999998 ) then
4481 c           q est voisin de qmima
4482 c           il est empile
4483             nbmin = nbmin + 1
4484             larmin( nbmin ) = nar3
4485          endif
4486          goto 10
4487       endif
4488 c
4489 c     bilan : existe t il plusieurs sommets de meme qualite?
4490 c     ======================================================
4491       if( nbmin .gt. 1 ) then
4492 c
4493 c        oui:recherche de ceux de cercle ne contenant pas d'autres sommets
4494          do 80 i=1,nbmin
4495 c           le sommet
4496             nar = larmin( i )
4497             if( nar .le. 0 ) goto 80
4498             ns3 = noarcf(1,nar)
4499 c           les coordonnees du centre du cercle circonscrit
4500 c           et son rayon
4501             ier = -1
4502             call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3),
4503      %                   centre, ier )
4504             if( ier .ne. 0 ) then
4505 c              le sommet ns3 ne convient pas
4506                larmin( i ) = 0
4507                goto 80
4508             endif
4509             rayon = centre(3) * unpeps
4510             do 70 j=1,nbmin
4511                if( j .ne. i ) then
4512 c                 l'autre sommet
4513                   nar1 = larmin(j)
4514                   if( nar1 .le. 0 ) goto 70
4515                   ns4 = noarcf(1,nar1)
4516 c                 appartient t il au cercle ns1 ns2 ns3 ?
4517                   dd = (centre(1)-pxyd(1,ns4))**2 +
4518      %                 (centre(2)-pxyd(2,ns4))**2
4519                   if( dd .le. rayon ) then
4520 c                    ns4 est dans le cercle circonscrit  ns1 ns2 ns3
4521 c                    le sommet ns3 ne convient pas
4522                      larmin( i ) = 0
4523                      goto 80
4524                   endif
4525                endif
4526  70         continue
4527  80      continue
4528 c
4529 c        existe t il plusieurs sommets ?
4530          j = 0
4531          do 90 i=1,nbmin
4532             if( larmin( i ) .gt. 0 ) then
4533 c              compactage des min
4534                j = j + 1
4535                larmin(j) = larmin(i)
4536             endif
4537  90      continue
4538 c
4539          if( j .gt. 1 ) then
4540 c           oui : choix du plus petit rayon de cercle circonscrit
4541             dmima = dmaxim
4542             do 120 i=1,nbmin
4543                ns3 = noarcf(1,larmin(i))
4544 c
4545 c              les coordonnees du centre de cercle circonscrit
4546 c              au triangle nt et son rayon
4547                ier = -1
4548                call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3),
4549      %                      centre, ier )
4550                if( ier .ne. 0 ) then
4551 c                 le sommet ns3 ne convient pas
4552                   goto 120
4553                endif
4554                rayon = sqrt( centre(3) )
4555                if( rayon .lt. dmima ) then
4556                   dmima = rayon
4557                   larmin(1) = larmin(i)
4558                endif
4559  120        continue
4560          endif
4561       endif
4562 c
4563 c     le choix final
4564 c     ==============
4565       namin = larmin(1)
4566 c
4567 c     recherche de l'arete avant namin ( nar0 <> namin )
4568 c     ==================================================
4569       nar1 = nar0
4570  200  if( nar1 .ne. namin ) then
4571          namin0 = nar1
4572          nar1   = noarcf( 2, nar1 )
4573          goto 200
4574       endif
4575       end
4576
4577       subroutine trcf0a( nbcf,   na01,   na1, na2, na3,
4578      %                   noar1,  noar2,  noar3,
4579      %                   mosoar, mxsoar, n1soar, nosoar,
4580      %                   moartr, n1artr, noartr, noarst,
4581      %                   mxarcf, n1arcf, noarcf, nt )
4582 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4583 c but :    modification de la triangulation du contour ferme nbcf
4584 c -----    par ajout d'un triangle ayant 0 arete sur le contour
4585 c          creation des 3 aretes dans le tableau nosoar
4586 c          modification du contour par ajout de la 3-eme arete
4587 c          creation d'un contour ferme a partir de la seconde arete
4588 c
4589 c entrees:
4590 c --------
4591 c nbcf    : numero dans n1arcf du cf traite ici
4592 c na01    : numero noarcf de l'arete precedent l'arete na1 de noarcf
4593 c na1     : numero noarcf du 1-er sommet du triangle
4594 c           implicitement l'arete na1 n'est pas une arete du triangle
4595 c na2     : numero noarcf du 2-eme sommet du triangle
4596 c           implicitement l'arete na1 n'est pas une arete du triangle
4597 c na3     : numero noarcf du 3-eme sommet du triangle
4598 c           implicitement l'arete na1 n'est pas une arete du triangle
4599 c
4600 c mosoar : nombre maximal d'entiers par arete et
4601 c          indice dans nosoar de l'arete suivante dans le hachage
4602 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
4603 c          attention: mxsoar>3*mxsomm obligatoire!
4604 c moartr : nombre maximal d'entiers par arete du tableau noartr
4605 c
4606 c entrees et sorties :
4607 c --------------------
4608 c n1soar : numero de la premiere arete vide dans le tableau nosoar
4609 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
4610 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4611 c          chainage des aretes frontalieres, chainage du hachage des aretes
4612 c          hachage des aretes = nosoar(1)+nosoar(2)*2
4613 c n1artr : numero du premier triangle vide dans le tableau noartr
4614 c          le chainage des triangles vides se fait sur noartr(2,.)
4615 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4616 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
4617 c
4618 c noarst : noarst(i) numero d'une arete de sommet i
4619 c n1arcf : numero d'une arete de chaque contour
4620 c noarcf : numero des aretes de la ligne du contour ferme
4621 c          attention : chainage circulaire des aretes
4622 c
4623 c sortie :
4624 c --------
4625 c noar1  : numero dans le tableau nosoar de l'arete 1 du triangle
4626 c noar2  : numero dans le tableau nosoar de l'arete 2 du triangle
4627 c noar3  : numero dans le tableau nosoar de l'arete 3 du triangle
4628 c nt     : numero du triangle ajoute dans noartr
4629 c          0 si saturation du tableau noartr ou noarcf ou n1arcf
4630 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4631 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
4632 c2345x7..............................................................012
4633       common / unites / lecteu, imprim, nunite(30)
4634       integer           nosoar(mosoar,*),
4635      %                  noartr(moartr,*),
4636      %                  noarst(*),
4637      %                  n1arcf(0:*),
4638      %                  noarcf(3,*)
4639 c
4640       ierr = 0
4641 c
4642 c     2 contours fermes peuvent ils etre ajoutes ?
4643       if( nbcf+2 .gt. mxarcf ) goto 9100
4644 c
4645 c     creation des 3 aretes du triangle dans le tableau nosoar
4646 c     ========================================================
4647 c     la formation de l'arete sommet1-sommet2 dans le tableau nosoar
4648       call fasoar( noarcf(1,na1), noarcf(1,na2), -1, -1,  0,
4649      %             mosoar, mxsoar, n1soar, nosoar, noarst,
4650      %             noar1,  ierr )
4651       if( ierr .ne. 0 ) goto 9900
4652 c
4653 c     la formation de l'arete sommet2-sommet3 dans le tableau nosoar
4654       call fasoar( noarcf(1,na2), noarcf(1,na3), -1, -1,  0,
4655      %             mosoar, mxsoar, n1soar, nosoar, noarst,
4656      %             noar2,  ierr )
4657       if( ierr .ne. 0 ) goto 9900
4658 c
4659 c     la formation de l'arete sommet3-sommet1 dans le tableau nosoar
4660       call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1,  0,
4661      %             mosoar, mxsoar, n1soar, nosoar, noarst,
4662      %             noar3,  ierr )
4663       if( ierr .ne. 0 ) goto 9900
4664 c
4665 c     ajout dans noartr de ce triangle nt
4666 c     ===================================
4667       call trcf3a( noarcf(1,na1),  noarcf(1,na2), noarcf(1,na3),
4668      %             noar1,  noar2,  noar3,
4669      %             mosoar, nosoar,
4670      %             moartr, n1artr, noartr,
4671      %             nt )
4672       if( nt .le. 0 ) return
4673 c
4674 c     modification du contour nbcf existant
4675 c     chainage de l'arete na2 vers l'arete na1
4676 c     ========================================
4677 c     modification du cf en pointant na2 sur na1
4678       na2s = noarcf( 2, na2 )
4679       noarcf( 2, na2 ) = na1
4680 c     le numero de l'arete dans le tableau nosoar
4681       noar2s = noarcf( 3, na2 )
4682 c     le numero de l'arete dans le tableau nosoar
4683       noarcf( 3, na2 ) = noar1
4684 c     debut du cf
4685       n1arcf( nbcf ) = na2
4686 c
4687 c     creation d'un nouveau contour ferme na2 - na3
4688 c     =============================================
4689       nbcf = nbcf + 1
4690 c     recherche d'une arete de cf vide
4691       nav = n1arcf(0)
4692       if( nav .le. 0 ) goto 9100
4693 c     la 1-ere arete vide est mise a jour
4694       n1arcf(0) = noarcf( 2, nav )
4695 c
4696 c     ajout de l'arete nav pointant sur na2s
4697 c     le numero du sommet
4698       noarcf( 1, nav ) = noarcf( 1, na2 )
4699 c     l'arete suivante
4700       noarcf( 2, nav ) = na2s
4701 c     le numero nosoar de cette arete
4702       noarcf( 3, nav ) = noar2s
4703 c
4704 c     l'arete na3 se referme sur nav
4705       na3s = noarcf( 2, na3 )
4706       noarcf( 2, na3 ) = nav
4707 c     le numero de l'arete dans le tableau nosoar
4708       noar3s = noarcf( 3, na3 )
4709       noarcf( 3, na3 ) = noar2
4710 c     debut du cf+1
4711       n1arcf( nbcf ) = na3
4712 c
4713 c     creation d'un nouveau contour ferme na3 - na1
4714 c     =============================================
4715       nbcf = nbcf + 1
4716 c     recherche d'une arete de cf vide
4717       nav = n1arcf(0)
4718       if( nav .le. 0 ) goto 9100
4719 c     la 1-ere arete vide est mise a jour
4720       n1arcf(0) = noarcf( 2, nav )
4721 c
4722 c     ajout de l'arete nav pointant sur na3s
4723 c     le numero du sommet
4724       noarcf( 1, nav ) = noarcf( 1, na3 )
4725 c     l'arete suivante
4726       noarcf( 2, nav ) = na3s
4727 c     le numero de l'arete dans le tableau nosoar
4728       noarcf( 3, nav ) = noar3s
4729 c
4730 c     recherche d'une arete de cf vide
4731       nav1 = n1arcf(0)
4732       if( nav1 .le. 0 ) goto 9100
4733 c     la 1-ere arete vide est mise a jour
4734       n1arcf(0) = noarcf( 2, nav1 )
4735 c
4736 c     l'arete precedente na01 de na1 pointe sur la nouvelle nav1
4737       noarcf( 2, na01 ) = nav1
4738 c
4739 c     ajout de l'arete nav1 pointant sur nav
4740 c     le numero du sommet
4741       noarcf( 1, nav1 ) = noarcf( 1, na1 )
4742 c     l'arete suivante
4743       noarcf( 2, nav1 ) = nav
4744 c     le numero de l'arete dans le tableau nosoar
4745       noarcf( 3, nav1 ) = noar3
4746 c
4747 c     debut du cf+2
4748       n1arcf( nbcf ) = nav1
4749       return
4750 c
4751 c     erreur
4752  9100 write(imprim,*) 'saturation du tableau mxarcf'
4753       nt = 0
4754       return
4755 c
4756 c     erreur tableau nosoar sature
4757  9900 write(imprim,*) 'saturation du tableau nosoar'
4758       nt = 0
4759       return
4760       end
4761
4762
4763       subroutine trcf1a( nbcf,   na01,   na1,    na2, noar1, noar3,
4764      %                   mosoar, mxsoar, n1soar, nosoar,
4765      %                   moartr, n1artr, noartr, noarst,
4766      %                   mxarcf, n1arcf, noarcf, nt )
4767 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4768 c but :    modification de la triangulation du contour ferme nbcf
4769 c -----    par ajout d'un triangle ayant 1 arete sur le contour
4770 c          modification du contour par ajout de la 3-eme arete
4771 c          creation d'un contour ferme a partir de la seconde arete
4772 c
4773 c entrees:
4774 c --------
4775 c nbcf    : numero dans n1arcf du cf traite ici
4776 c na01    : numero noarcf de l'arete precedant l'arete na1 de noarcf
4777 c na1     : numero noarcf du 1-er sommet du triangle
4778 c           implicitement l'arete na1 n'est pas une arete du triangle
4779 c na2     : numero noarcf du 2-eme sommet du triangle
4780 c           cette arete est l'arete 2 du triangle a ajouter
4781 c           son arete suivante dans noarcf n'est pas sur le contour
4782 c mosoar : nombre maximal d'entiers par arete et
4783 c          indice dans nosoar de l'arete suivante dans le hachage
4784 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
4785 c          attention: mxsoar>3*mxsomm obligatoire!
4786 c moartr : nombre maximal d'entiers par arete du tableau noartr
4787 c
4788 c entrees et sorties :
4789 c --------------------
4790 c n1soar : numero de la premiere arete vide dans le tableau nosoar
4791 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
4792 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4793 c          chainage des aretes frontalieres, chainage du hachage des aretes
4794 c          hachage des aretes = nosoar(1)+nosoar(2)*2
4795 c n1artr : numero du premier triangle vide dans le tableau noartr
4796 c          le chainage des triangles vides se fait sur noartr(2,.)
4797 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4798 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
4799 c
4800 c noarst : noarst(i) numero d'une arete de sommet i
4801 c n1arcf : numero d'une arete de chaque contour
4802 c noarcf : numero des aretes de la ligne du contour ferme
4803 c          attention : chainage circulaire des aretes
4804 c
4805 c sortie :
4806 c --------
4807 c noar1  : numero nosoar de l'arete 1 du triangle cree
4808 c noar3  : numero nosoar de l'arete 3 du triangle cree
4809 c nt     : numero du triangle ajoute dans notria
4810 c          0 si saturation du tableau notria ou noarcf ou n1arcf
4811 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4812 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
4813 c2345x7..............................................................012
4814       common / unites / lecteu, imprim, nunite(30)
4815       integer           nosoar(mosoar,mxsoar),
4816      %                  noartr(moartr,*),
4817      %                  noarst(*),
4818      %                  n1arcf(0:*),
4819      %                  noarcf(3,*)
4820 c
4821 c     un cf supplementaire peut il etre ajoute ?
4822       if( nbcf .ge. mxarcf ) then
4823          write(imprim,*) 'saturation du tableau noarcf'
4824          nt = 0
4825          return
4826       endif
4827 c
4828       ierr = 0
4829 c
4830 c     l' arete suivante du triangle non sur le cf
4831       na3 = noarcf( 2, na2 )
4832 c
4833 c     creation des 2 nouvelles aretes du triangle dans le tableau nosoar
4834 c     ==================================================================
4835 c     la formation de l'arete sommet1-sommet2 dans le tableau nosoar
4836       call fasoar( noarcf(1,na1), noarcf(1,na2), -1, -1,  0,
4837      %             mosoar, mxsoar, n1soar, nosoar, noarst,
4838      %             noar1,  ierr )
4839       if( ierr .ne. 0 ) goto 9900
4840 c
4841 c     la formation de l'arete sommet1-sommet3 dans le tableau nosoar
4842       call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1,  0,
4843      %             mosoar, mxsoar, n1soar, nosoar, noarst,
4844      %             noar3,  ierr )
4845       if( ierr .ne. 0 ) goto 9900
4846 c
4847 c     le triangle nt de noartr a l'arete 2 comme arete du contour na2
4848 c     ===============================================================
4849       call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
4850      %             noar1, noarcf(3,na2), noar3,
4851      %             mosoar, nosoar,
4852      %             moartr, n1artr, noartr,
4853      %             nt )
4854       if( nt .le. 0 ) return
4855 c
4856 c     modification du contour ferme existant
4857 c     suppression de l'arete na2 du cf
4858 c     ======================================
4859 c     modification du cf en pointant na2 sur na1
4860       noarcf( 2, na2 ) = na1
4861       noarcf( 3, na2 ) = noar1
4862 c     debut du cf
4863       n1arcf( nbcf ) = na2
4864 c
4865 c     creation d'un nouveau contour ferme na3 - na1
4866 c     =============================================
4867       nbcf = nbcf + 1
4868 c
4869 c     recherche d'une arete de cf vide
4870       nav = n1arcf(0)
4871       if( nav .le. 0 ) then
4872          write(imprim,*) 'saturation du tableau noarcf'
4873          nt = 0
4874          return
4875       endif
4876 c
4877 c     la 1-ere arete vide est mise a jour
4878       n1arcf(0) = noarcf( 2, nav )
4879 c
4880 c     ajout de l'arete nav pointant sur na3
4881 c     le numero du sommet
4882       noarcf( 1, nav ) = noarcf( 1, na1 )
4883 c     l'arete suivante
4884       noarcf( 2, nav ) = na3
4885 c     le numero de l'arete dans le tableau nosoar
4886       noarcf( 3, nav ) = noar3
4887 c
4888 c     l'arete precedente na01 de na1 pointe sur la nouvelle nav
4889       noarcf( 2, na01 ) = nav
4890 c
4891 c     debut du cf
4892       n1arcf( nbcf ) = nav
4893       return
4894 c
4895 c     erreur tableau nosoar sature
4896  9900 write(imprim,*) 'saturation du tableau nosoar'
4897       nt = 0
4898       return
4899       end
4900
4901
4902       subroutine trcf2a( nbcf,   na1,    noar3,
4903      %                   mosoar, mxsoar, n1soar, nosoar,
4904      %                   moartr, n1artr, noartr, noarst,
4905      %                   n1arcf, noarcf, nt )
4906 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4907 c but :    modification de la triangulation du contour ferme nbcf
4908 c -----    par ajout d'un triangle ayant 2 aretes sur le contour
4909 c          creation d'une arete dans nosoar (sommet3-sommet1)
4910 c          et modification du contour par ajout de la 3-eme arete
4911 c
4912 c entrees:
4913 c --------
4914 c nbcf   : numero dans n1arcf du cf traite ici
4915 c na1    : numero noarcf de la premiere arete sur le contour
4916 c          implicitement sa suivante est sur le contour
4917 c          la suivante de la suivante n'est pas sur le contour
4918 c mosoar : nombre maximal d'entiers par arete et
4919 c          indice dans nosoar de l'arete suivante dans le hachage
4920 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
4921 c          attention: mxsoar>3*mxsomm obligatoire!
4922 c moartr : nombre maximal d'entiers par arete du tableau noartr
4923 c
4924 c entrees et sorties :
4925 c --------------------
4926 c n1soar : numero de la premiere arete vide dans le tableau nosoar
4927 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
4928 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
4929 c          chainage des aretes frontalieres, chainage du hachage des aretes
4930 c          hachage des aretes = nosoar(1)+nosoar(2)*2
4931 c n1artr : numero du premier triangle vide dans le tableau noartr
4932 c          le chainage des triangles vides se fait sur noartr(2,.)
4933 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
4934 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
4935 c
4936 c noarst : noarst(i) numero d'une arete de sommet i
4937 c n1arcf : numero d'une arete de chaque contour
4938 c noarcf : numero des aretes de la ligne du contour ferme
4939 c          attention : chainage circulaire des aretes
4940 c
4941 c sortie :
4942 c --------
4943 c noar3  : numero de l'arete 3 dans le tableau nosoar
4944 c nt     : numero du triangle ajoute dans noartr
4945 c          0 si saturation du tableau noartr ou nosoar
4946 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4947 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
4948 c2345x7..............................................................012
4949       common / unites / lecteu, imprim, nunite(30)
4950       integer           nosoar(mosoar,*),
4951      %                  noartr(moartr,*),
4952      %                  noarst(*)
4953       integer           n1arcf(0:*),
4954      %                  noarcf(3,*)
4955 c
4956       ierr = 0
4957 c
4958 c     l'arete suivante de l'arete na1 dans noarcf
4959       na2 = noarcf( 2, na1 )
4960 c     l'arete suivante de l'arete na2 dans noarcf
4961       na3 = noarcf( 2, na2 )
4962 c
4963 c     la formation de l'arete sommet3-sommet1 dans le tableau nosoar
4964       call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1,  0,
4965      %             mosoar, mxsoar, n1soar, nosoar, noarst,
4966      %             noar3,  ierr )
4967       if( ierr .ne. 0 ) then
4968          if( ierr .eq. 1 ) then
4969             write(imprim,*) 'saturation des aretes (tableau nosoar)'
4970          endif
4971          nt = 0
4972          return
4973       endif
4974 c
4975 c     le triangle a ses 2 aretes na1 na2 sur le contour ferme
4976 c     ajout dans noartr de ce triangle nt
4977       call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
4978      %             noarcf(3,na1), noarcf(3,na2), noar3,
4979      %             mosoar, nosoar,
4980      %             moartr, n1artr, noartr,
4981      %             nt )
4982       if( nt .le. 0 ) return
4983 c
4984 c     suppression des 2 aretes (na1 na2) du cf
4985 c     ces 2 aretes se suivent dans le chainage du cf
4986 c     ajout de la 3-eme arete  (noar3) dans le cf
4987 c     l'arete suivante de na1 devient la suivante de na2
4988       noarcf(2,na1) = na3
4989       noarcf(3,na1) = noar3
4990 c
4991 c     l'arete na2 devient vide dans noarcf
4992       noarcf(2,na2) = n1arcf( 0 )
4993       n1arcf( 0 )   = na2
4994 c
4995 c     la premiere pointee dans noarcf est na1
4996 c     chainage circulaire => ce peut etre n'importe laquelle
4997       n1arcf(nbcf) = na1
4998       end
4999
5000
5001       subroutine trcf3a( ns1,    ns2,    ns3,
5002      %                   noar1,  noar2,  noar3,
5003      %                   mosoar, nosoar,
5004      %                   moartr, n1artr, noartr,
5005      %                   nt )
5006 c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5007 c but :    ajouter dans le tableau noartr le triangle
5008 c -----    de sommets ns1   ns2   ns3
5009 c          d'aretes   noar1 noar2 noar3 deja existantes
5010 c                     dans le tableau nosoar des aretes
5011 c
5012 c entrees:
5013 c --------
5014 c ns1,  ns2,  ns3   : le numero dans pxyd   des 3 sommets du triangle
5015 c noar1,noar2,noar3 : le numero dans nosoar des 3 aretes  du triangle
5016 c mosoar : nombre maximal d'entiers par arete et
5017 c          indice dans nosoar de l'arete suivante dans le hachage
5018 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5019 c          attention: mxsoar>3*mxsomm obligatoire!
5020 c moartr : nombre maximal d'entiers par arete du tableau noartr
5021 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
5022 c
5023 c modifies :
5024 c ----------
5025 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
5026 c          chainage des aretes frontalieres, chainage du hachage des aretes
5027 c          hachage des aretes = nosoar(1)+nosoar(2)*2
5028 c n1artr : numero du premier triangle vide dans le tableau noartr
5029 c          le chainage des triangles vides se fait sur noartr(2,.)
5030 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5031 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5032 c
5033 c sorties:
5034 c --------
5035 c nt     : numero dans noartr du triangle ajoute
5036 c          =0 si le tableau noartr est sature
5037 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5038 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
5039 c....................................................................012
5040       common / unites / lecteu,imprim,nunite(30)
5041       integer           nosoar(mosoar,*),
5042      %                  noartr(moartr,*)
5043 c
5044 c     recherche d'un triangle libre dans le tableau noartr
5045       if( n1artr .le. 0 ) then
5046          write(imprim,*) 'saturation du tableau noartr des aretes'
5047          nt = 0
5048          return
5049       endif
5050 c
5051 c     le numero dans noartr du nouveau triangle
5052       nt = n1artr
5053 c
5054 c     le nouveau premier triangle vide dans le tableau noartr
5055       n1artr = noartr(2,n1artr)
5056 c
5057 c     arete 1 du triangle nt
5058 c     ======================
5059 c     orientation des 3 aretes du triangle pour qu'il soit direct
5060       if( ns1 .eq. nosoar(1,noar1) ) then
5061          n =  1
5062       else
5063          n = -1
5064       endif
5065 c     le numero de l'arete 1 du triangle nt
5066       noartr(1,nt) = n * noar1
5067 c
5068 c     le numero du triangle nt pour l'arete
5069       if( nosoar(4,noar1) .le. 0 ) then
5070          n = 4
5071       else
5072          n = 5
5073       endif
5074       nosoar(n,noar1) = nt
5075 c
5076 c     arete 2 du triangle nt
5077 c     ======================
5078 c     orientation des 3 aretes du triangle pour qu'il soit direct
5079       if( ns2 .eq. nosoar(1,noar2) ) then
5080          n =  1
5081       else
5082          n = -1
5083       endif
5084 c     le numero de l'arete 2 du triangle nt
5085       noartr(2,nt) = n * noar2
5086 c
5087 c     le numero du triangle nt pour l'arete
5088       if( nosoar(4,noar2) .le. 0 ) then
5089          n = 4
5090       else
5091          n = 5
5092       endif
5093       nosoar(n,noar2) = nt
5094 c
5095 c     arete 3 du triangle nt
5096 c     ======================
5097 c     orientation des 3 aretes du triangle pour qu'il soit direct
5098       if( ns3 .eq. nosoar(1,noar3) ) then
5099          n =  1
5100       else
5101          n = -1
5102       endif
5103 c     le numero de l'arete 3 du triangle nt
5104       noartr(3,nt) = n * noar3
5105 c
5106 c     le numero du triangle nt pour l'arete
5107       if( nosoar(4,noar3) .le. 0 ) then
5108          n = 4
5109       else
5110          n = 5
5111       endif
5112       nosoar(n,noar3) = nt
5113       end
5114
5115
5116
5117       subroutine trcf3s( nbcf,   na01,   na1,    na02,  na2, na03, na3,
5118      %                   mosoar, mxsoar, n1soar, nosoar,
5119      %                   moartr, n1artr, noartr, noarst,
5120      %                   mxarcf, n1arcf, noarcf, nt )
5121 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5122 c but :     ajout d'un triangle d'aretes na1 2 3 du tableau noarcf
5123 c -----     a la triangulation d'un contour ferme (cf)
5124 c
5125 c entrees:
5126 c --------
5127 c nbcf    : numero dans n1arcf du cf traite ici
5128 c           mais aussi nombre actuel de cf avant ajout du triangle
5129 c na01    : numero noarcf de l'arete precedent l'arete na1 de noarcf
5130 c na1     : numero noarcf du 1-er sommet du triangle
5131 c na02    : numero noarcf de l'arete precedent l'arete na2 de noarcf
5132 c na2     : numero noarcf du 2-eme sommet du triangle
5133 c na03    : numero noarcf de l'arete precedent l'arete na3 de noarcf
5134 c na3     : numero noarcf du 3-eme sommet du triangle
5135 c
5136 c mosoar : nombre maximal d'entiers par arete et
5137 c          indice dans nosoar de l'arete suivante dans le hachage
5138 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5139 c          attention: mxsoar>3*mxsomm obligatoire!
5140 c moartr : nombre maximal d'entiers par arete du tableau noartr
5141 c mxarcf : nombre maximal d'aretes declarables dans noarcf, n1arcf
5142 c
5143 c modifies:
5144 c ---------
5145 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
5146 c          chainage des vides suivant en 3 et precedant en 2 de nosoar
5147 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
5148 c          chainage des aretes frontalieres, chainage du hachage des aretes
5149 c          hachage des aretes = nosoar(1)+nosoar(2)*2
5150 c          avec mxsoar>=3*mxsomm
5151 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
5152 c          nosoar(2,arete vide)=l'arete vide qui precede
5153 c          nosoar(3,arete vide)=l'arete vide qui suit
5154 c
5155 c n1artr : numero du premier triangle vide dans le tableau noartr
5156 c          le chainage des triangles vides se fait sur noartr(2,.)
5157 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5158 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5159 c noarst : noarst(i) numero d'une arete de sommet i
5160 c
5161 c n1arcf : numero d'une arete de chaque contour ferme
5162 c noarcf : numero du sommet , numero de l'arete suivante
5163 c          numero de l'arete dans le tableau nosoar
5164 c          attention : chainage circulaire des aretes
5165 c
5166 c sortie :
5167 c --------
5168 c nbcf   : nombre actuel de cf apres ajout du triangle
5169 c nt     : numero du triangle ajoute dans noartr
5170 c          0 si saturation du tableau nosoar ou noartr ou noarcf ou n1arcf
5171 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5172 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
5173 c2345x7..............................................................012
5174       integer        nosoar(mosoar,*),
5175      %               noartr(moartr,*),
5176      %               noarst(*),
5177      %               n1arcf(0:mxarcf),
5178      %               noarcf(3,mxarcf)
5179 c
5180 c     combien y a t il d'aretes nbascf sur le cf ?
5181 c     ============================================
5182 c     la premiere arete est elle sur le cf?
5183       if( noarcf(2,na1) .eq. na2 ) then
5184 c        la 1-ere arete est sur le cf
5185          na1cf  = 1
5186       else
5187 c        la 1-ere arete n'est pas sur le cf
5188          na1cf  = 0
5189       endif
5190 c
5191 c     la seconde arete est elle sur le cf?
5192       if( noarcf(2,na2) .eq. na3 ) then
5193 c        la 2-eme arete est sur le cf
5194          na2cf = 1
5195       else
5196          na2cf = 0
5197       endif
5198 c
5199 c     la troisieme arete est elle sur le cf?
5200       if( noarcf(2,na3) .eq. na1 ) then
5201 c        la 3-eme arete est sur le cf
5202          na3cf = 1
5203       else
5204          na3cf = 0
5205       endif
5206 c
5207 c     le nombre d'aretes sur le cf
5208       nbascf = na1cf + na2cf + na3cf
5209 c
5210 c     traitement selon le nombre d'aretes sur le cf
5211 c     =============================================
5212       if( nbascf .eq. 3 ) then
5213 c
5214 c        le contour ferme se reduit a un triangle avec 3 aretes sur le cf
5215 c        ----------------------------------------------------------------
5216 c        ajout dans noartr de ce nouveau triangle
5217          call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
5218      %                noarcf(3,na1), noarcf(3,na2), noarcf(3,na3),
5219      %                mosoar, nosoar,
5220      %                moartr, n1artr, noartr,
5221      %                nt )
5222          if( nt .le. 0 ) return
5223 c
5224 c        le cf est supprime et chaine vide
5225          noarcf(2,na3) = n1arcf(0)
5226          n1arcf( 0 )   = na1
5227 c
5228 c        ce cf a ete traite => un cf de moins a traiter
5229          nbcf = nbcf - 1
5230 c
5231       else if( nbascf .eq. 2 ) then
5232 c
5233 c        le triangle a 2 aretes sur le contour
5234 c        -------------------------------------
5235 c        les 2 aretes sont la 1-ere et 2-eme du triangle
5236          if( na1cf .eq. 0 ) then
5237 c           l'arete 1 n'est pas sur le cf
5238             naa1 = na2
5239          else if( na2cf .eq. 0 ) then
5240 c           l'arete 2 n'est pas sur le cf
5241             naa1 = na3
5242          else
5243 c           l'arete 3 n'est pas sur le cf
5244             naa1 = na1
5245          endif
5246 c        le triangle oppose a l'arete 3 est inconnu
5247 c        modification du contour apres integration du
5248 c        triangle ayant ses 2-eres aretes sur le cf
5249          call trcf2a( nbcf,   naa1,   naor3,
5250      %                mosoar, mxsoar, n1soar, nosoar,
5251      %                moartr, n1artr, noartr, noarst,
5252      %                n1arcf, noarcf, nt )
5253 c
5254       else if( nbascf .eq. 1 ) then
5255 c
5256 c        le triangle a 1 arete sur le contour
5257 c        ------------------------------------
5258 c        cette arete est la seconde du triangle
5259          if( na3cf .ne. 0 ) then
5260 c           l'arete 3 est sur le cf
5261             naa01 = na02
5262             naa1  = na2
5263             naa2  = na3
5264          else if( na1cf .ne. 0 ) then
5265 c           l'arete 1 est sur le cf
5266             naa01 = na03
5267             naa1  = na3
5268             naa2  = na1
5269          else
5270 c           l'arete 2 est sur le cf
5271             naa01 = na01
5272             naa1  = na1
5273             naa2  = na2
5274          endif
5275 c        le triangle oppose a l'arete 1 et 3 est inconnu
5276 c        modification du contour apres integration du
5277 c        triangle ayant 1 arete sur le cf avec creation
5278 c        d'un nouveau contour ferme
5279          call trcf1a( nbcf, naa01, naa1, naa2, naor1, naor3,
5280      %                mosoar, mxsoar, n1soar, nosoar,
5281      %                moartr, n1artr, noartr, noarst,
5282      %                mxarcf, n1arcf, noarcf, nt )
5283 c
5284       else
5285 c
5286 c        le triangle a 0 arete sur le contour
5287 c        ------------------------------------
5288 c        modification du contour apres integration du
5289 c        triangle ayant 0 arete sur le cf avec creation
5290 c        de 2 nouveaux contours fermes
5291          call trcf0a( nbcf, na01,  na1, na2, na3,
5292      %                naa1, naa2, naa01,
5293      %                mosoar, mxsoar, n1soar, nosoar,
5294      %                moartr, n1artr, noartr, noarst,
5295      %                mxarcf, n1arcf, noarcf, nt )
5296       endif
5297       end
5298
5299
5300       subroutine tridcf( nbcf0,  pxyd,   noarst,
5301      %                   mosoar, mxsoar, n1soar, nosoar,
5302      %                   moartr, n1artr, noartr,
5303      %                   mxarcf, n1arcf, noarcf, larmin,
5304      %                   nbtrcf, notrcf, ierr )
5305 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5306 c but :    triangulation directe de nbcf0 contours fermes (cf)
5307 c -----    definis par la liste circulaire de leurs aretes peripheriques
5308 c
5309 c entrees:
5310 c --------
5311 c nbcf0  : nombre initial de cf a trianguler
5312 c pxyd   : tableau des coordonnees 2d des points
5313 c          par point : x  y  distance_souhaitee
5314 c mosoar : nombre maximal d'entiers par arete et
5315 c          indice dans nosoar de l'arete suivante dans le hachage
5316 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5317 c          attention: mxsoar>3*mxsomm obligatoire!
5318 c moartr : nombre maximal d'entiers par arete du tableau noartr
5319 c mxarcf  : nombre maximal d'aretes declarables dans noarcf, n1arcf, larmin, not
5320 c
5321 c modifies:
5322 c ---------
5323 c noarst : noarst(i) numero d'une arete de sommet i
5324 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
5325 c          chainage des vides suivant en 3 et precedant en 2 de nosoar
5326 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
5327 c          chainage des aretes frontalieres, chainage du hachage des aretes
5328 c          hachage des aretes = nosoar(1)+nosoar(2)*2
5329 c          avec mxsoar>=3*mxsomm
5330 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
5331 c          nosoar(2,arete vide)=l'arete vide qui precede
5332 c          nosoar(3,arete vide)=l'arete vide qui suit
5333 c
5334 c n1artr : numero du premier triangle vide dans le tableau noartr
5335 c          le chainage des triangles vides se fait sur noartr(2,.)
5336 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5337 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5338 c
5339 c n1arcf : numero de la premiere arete de chacun des nbcf0 cf
5340 c          n1arcf(0)   no de la premiere arete vide du tableau noarcf
5341 c          noarcf(2,i) no de l'arete suivante
5342 c noarcf : numero du sommet , numero de l'arete suivante du cf
5343 c          numero de l'arete dans le tableau nosoar
5344 c
5345 c auxiliaires :
5346 c -------------
5347 c larmin : tableau (mxarcf)   auxiliaire
5348 c          stocker la liste des numeros des meilleures aretes
5349 c          lors de la selection du meilleur sommet du cf a trianguler
5350 c          cf le sp trchtd
5351 c
5352 c sortie :
5353 c --------
5354 c nbtrcf : nombre de  triangles des nbcf0 cf
5355 c notrcf : numero des triangles des nbcf0 cf dans le tableau noartr
5356 c ierr   : 0 si pas d'erreur
5357 c          2 saturation de l'un des des tableaux nosoar, noartr, ...
5358 c          3 si contour ferme reduit a moins de 3 aretes
5359 c          4 saturation du tableau notrcf
5360 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5361 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
5362 c....................................................................012
5363       common / unites / lecteu, imprim, nunite(30)
5364       double precision  pxyd(3,*)
5365       integer           noartr(moartr,*),
5366      %                  nosoar(mosoar,mxsoar),
5367      %                  noarst(*),
5368      %                  n1arcf(0:mxarcf),
5369      %                  noarcf(3,mxarcf),
5370      %                  larmin(mxarcf),
5371      %                  notrcf(mxarcf)
5372 c
5373 ccc      integer           nosotr(3)
5374 ccc      double precision  d, surtd2
5375 c
5376 c     depart avec nbcf0 cf a trianguler
5377       nbcf   = nbcf0
5378 c
5379 c     le nombre de triangles formes dans l'ensemble des cf
5380       nbtrcf = 0
5381 c
5382 c     tant qu'il existe un cf a trianguler faire
5383 c     la triangulation directe du cf
5384 c     ==========================================
5385  10   if( nbcf .gt. 0 ) then
5386 c
5387 c        le cf en haut de pile a pour premiere arete
5388          na01 = n1arcf( nbcf )
5389          na1  = noarcf( 2, na01 )
5390 c
5391 c        choix du sommet du cf a relier a l'arete na1
5392 c        --------------------------------------------
5393          call trchtd( pxyd, na01, na1, noarcf,
5394      %                na03, na3,  larmin )
5395          if( na3 .eq. 0 ) then
5396             ierr = 3
5397             return
5398          endif
5399 c
5400 c        l'arete suivante de na1
5401          na02 = na1
5402          na2  = noarcf( 2, na1 )
5403 c
5404 c        formation du triangle arete na1 - sommet noarcf(1,na3)
5405 c        ------------------------------------------------------
5406          call trcf3s( nbcf,   na01, na1, na02, na2, na03, na3,
5407      %                mosoar, mxsoar, n1soar, nosoar,
5408      %                moartr, n1artr, noartr, noarst,
5409      %                mxarcf, n1arcf, noarcf, nt )
5410          if( nt .le. 0 ) then
5411 c           saturation du tableau noartr ou noarcf ou n1arcf
5412             ierr = 2
5413             return
5414          endif
5415 c
5416 c        ajout du triangle cree a sa pile
5417          if( nbtrcf .ge. mxarcf ) then
5418             write(imprim,*) 'saturation du tableau notrcf'
5419             ierr = 4
5420             return
5421          endif
5422          nbtrcf = nbtrcf + 1
5423          notrcf( nbtrcf ) = nt
5424          goto 10
5425       endif
5426 c
5427 c     mise a jour du chainage des triangles des aretes
5428 c     ================================================
5429       do 30 ntp0 = 1, nbtrcf
5430 c
5431 c        le numero du triangle ajoute dans le tableau noartr
5432          nt0 = notrcf( ntp0 )
5433 c
5434 cccc        aire signee du triangle nt0
5435 cccc        le numero des 3 sommets du triangle nt
5436 ccc         call nusotr( nt0, mosoar, nosoar, moartr, noartr,
5437 ccc     %                nosotr )
5438 ccc         d = surtd2( pxyd(1,nosotr(1)), pxyd(1,nosotr(2)),
5439 ccc     %               pxyd(1,nosotr(3)) )
5440 ccc         if( d .le. 0 ) then
5441 cccc
5442 cccc           un triangle d'aire negative de plus
5443 ccc            write(imprim,*) 'triangle ',nt0,' st:',nosotr,
5444 ccc     %                      ' d aire ',d,'<=0'
5445 ccc            pause
5446 ccc         endif
5447 c
5448 cccc        trace du triangle nt0
5449 ccc         call mttrtr( pxyd, nt0, moartr, noartr, mosoar, nosoar,
5450 ccc     %                ncturq, ncblan )
5451 c
5452 c        boucle sur les 3 aretes du triangle
5453          do 20 i=1,3
5454 c
5455 c           le numero de l'arete i du triangle dans le tableau nosoar
5456             noar = abs( noartr(i,nt0) )
5457 c
5458 c           ce triangle est il deja chaine dans cette arete?
5459             nt1 = nosoar(4,noar)
5460             nt2 = nosoar(5,noar)
5461             if( nt1 .eq. nt0 .or. nt2 .eq. nt0 ) goto 20
5462 c
5463 c           ajout de ce triangle nt0 a l'arete noar
5464             if( nt1 .le. 0 ) then
5465 c               le triangle est ajoute a l'arete
5466                 nosoar( 4, noar ) = nt0
5467             else if( nt2 .le. 0 ) then
5468 c               le triangle est ajoute a l'arete
5469                 nosoar( 5, noar ) = nt0
5470             else
5471 c              l'arete appartient a 2 triangles differents de nt0
5472 c              anomalie. chainage des triangles des aretes defectueux
5473 c              a corriger
5474                write(imprim,*) 'pause dans tridcf'
5475                pause
5476                ierr = 5
5477                return
5478             endif
5479 c
5480  20      continue
5481 c
5482  30   continue
5483       end
5484
5485
5486       subroutine te1stm( nsasup, pxyd,   noarst,
5487      %                   mosoar, mxsoar, n1soar, nosoar,
5488      %                   moartr, mxartr, n1artr, noartr,
5489      %                   mxarcf, n1arcf, noarcf, larmin, notrcf, liarcf,
5490      %                   ierr )
5491 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5492 c but :    supprimer de la triangulation le sommet nsasup qui doit
5493 c -----    etre un sommet interne ("centre" d'une boule de triangles)
5494 c
5495 c          attention: le chainage lchain de nosoar devient celui des cf
5496 c
5497 c entrees:
5498 c --------
5499 c nsasup : numero dans le tableau pxyd du sommet a supprimer
5500 c pxyd   : tableau des coordonnees 2d des points
5501 c          par point : x  y  distance_souhaitee
5502 c mosoar : nombre maximal d'entiers par arete et
5503 c          indice dans nosoar de l'arete suivante dans le hachage
5504 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5505 c          attention: mxsoar>3*mxsomm obligatoire!
5506 c moartr : nombre maximal d'entiers par arete du tableau noartr
5507 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
5508 c
5509 c modifies:
5510 c ---------
5511 c noarst : noarst(i) numero d'une arete de sommet i
5512 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
5513 c          chainage des vides suivant en 3 et precedant en 2 de nosoar
5514 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
5515 c          chainage des aretes frontalieres, chainage du hachage des aretes
5516 c          hachage des aretes = nosoar(1)+nosoar(2)*2
5517 c          avec mxsoar>=3*mxsomm
5518 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
5519 c          nosoar(2,arete vide)=l'arete vide qui precede
5520 c          nosoar(3,arete vide)=l'arete vide qui suit
5521 c n1artr : numero du premier triangle vide dans le tableau noartr
5522 c          le chainage des triangles vides se fait sur noartr(2,.)
5523 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5524 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5525 c
5526 c
5527 c auxiliaires :
5528 c -------------
5529 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
5530 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
5531 c larmin : tableau ( mxarcf ) auxiliaire d'entiers
5532 c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
5533 c liarcf : tableau ( mxarcf ) auxiliaire d'entiers
5534 c
5535 c sortie :
5536 c --------
5537 c ierr   : =0 si pas d'erreur
5538 c          -1 le sommet a supprimer n'est pas le centre d'une boule
5539 c             de triangles. il est suppose externe
5540 c             ou bien le sommet est centre d'un cf dont toutes les
5541 c             aretes sont frontalieres
5542 c             dans les 2 cas => retour sans modifs
5543 c          >0 si une erreur est survenue
5544 c          =11 algorithme defaillant
5545 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5546 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
5547 c....................................................................012
5548       parameter       ( lchain=6, quamal=0.3)
5549       common / unites / lecteu,imprim,intera,nunite(29)
5550       double precision  pxyd(3,*)
5551       integer           nosoar(mosoar,mxsoar),
5552      %                  noartr(moartr,*),
5553      %                  noarst(*),
5554      %                  n1arcf(0:mxarcf),
5555      %                  noarcf(3,mxarcf),
5556      %                  larmin(mxarcf),
5557      %                  notrcf(mxarcf),
5558      %                  liarcf(mxarcf)
5559 c
5560 c     nsasup est il un sommet interne, "centre" d'une boule de triangles?
5561 c     => le sommet nsasup peut etre supprime
5562 c     ===================================================================
5563 c     formation du cf de ''centre'' le sommet nsasup
5564       call trp1st( nsasup, noarst, mosoar, nosoar,
5565      %             moartr, noartr,
5566      %             mxarcf, nbtrcf, notrcf )
5567       if( nbtrcf .le. 0 ) then
5568 c        erreur: impossible de trouver tous les triangles de sommet nsasup
5569 c        le sommet nsasup n'est pas supprime de la triangulation
5570          ierr = -1
5571          return
5572       else if( nbtrcf .le. 2 ) then
5573 c        le sommet nsasup n'est pas supprime
5574          ierr = -1
5575          return
5576       endif
5577       if( nbtrcf*3 .gt. mxarcf ) then
5578          write(imprim,*) 'saturation du tableau noarcf'
5579          ierr = 10
5580          return
5581       endif
5582 c
5583 ccc      trace des triangles de l'etoile du sommet nsasup
5584 ccc      call trpltr( nbtrcf, notrcf, pxyd,
5585 ccc     %             moartr, noartr, mosoar, nosoar,
5586 ccc     %             ncroug, ncblan )
5587 c
5588 c     si toutes les aretes du cf sont frontalieres, alors il est
5589 c     interdit de detruire le sommet "centre" du cf
5590 c     calcul du nombre nbarfr des aretes simples des nbtrcf triangles
5591       call trfrcf( nsasup, mosoar, nosoar, moartr, noartr,
5592      %             nbtrcf, notrcf, nbarfr  )
5593       if( nbarfr .ge. nbtrcf ) then
5594 c        toutes les aretes simples sont frontalieres
5595 c        le sommet nsasup ("centre" de la cavite) n'est pas supprime
5596          ierr = -1
5597          return
5598       endif
5599 c
5600 c     formation du contour ferme (liste chainee des aretes simples)
5601 c     forme a partir des aretes des triangles de l'etoile du sommet nsasup
5602       call focftr( nbtrcf, notrcf, pxyd,   noarst,
5603      %             mosoar, mxsoar, n1soar, nosoar,
5604      %             moartr, n1artr, noartr,
5605      %             nbarcf, n1arcf, noarcf,
5606      %             ierr )
5607       if( ierr .ne. 0 ) return
5608 c
5609 c     ici le sommet nsasup appartient a aucune arete
5610       noarst( nsasup ) = 0
5611 c
5612 c     chainage des aretes vides dans le tableau noarcf
5613       n1arcf(0) = nbarcf+1
5614       mmarcf = min(8*nbarcf,mxarcf)
5615       do 40 i=nbarcf+1,mmarcf
5616          noarcf(2,i) = i+1
5617  40   continue
5618       noarcf(2,mmarcf) = 0
5619 c
5620 c     sauvegarde du chainage des aretes peripheriques
5621 c     pour la mise en delaunay du maillage
5622       nbcf = n1arcf(1)
5623       do 50 i=1,nbarcf
5624 c        le numero de l'arete dans le tableau nosoar
5625          liarcf( i ) = noarcf( 3, nbcf )
5626 c        l'arete suivante dans le cf
5627          nbcf = noarcf( 2, nbcf )
5628  50   continue
5629 c
5630 c     triangulation directe du contour ferme sans le sommet nsasup
5631 c     ============================================================
5632       nbcf = 1
5633       call tridcf( nbcf,   pxyd,   noarst,
5634      %             mosoar, mxsoar, n1soar, nosoar,
5635      %             moartr, n1artr, noartr,
5636      %             mxarcf, n1arcf, noarcf, larmin,
5637      %             nbtrcf, notrcf, ierr )
5638       if( ierr .ne. 0 ) return
5639 c
5640 c     transformation des triangles du cf en triangles delaunay
5641 c     ========================================================
5642 c     construction du chainage lchain dans nosoar
5643 c     des aretes peripheriques du cf a partir de la sauvegarde liarcf
5644       noar0 = liarcf(1)
5645       do 60 i=2,nbarcf
5646 c        le numero de l'arete peripherique du cf dans nosoar
5647          noar = liarcf( i )
5648          if( nosoar(3,noar) .le. 0 ) then
5649 c           arete interne => elle est chainee a partir de la precedente
5650             nosoar( lchain, noar0 ) = noar
5651             noar0 = noar
5652          endif
5653  60   continue
5654 c     la derniere arete peripherique n'a pas de suivante
5655       nosoar(lchain,noar0) = 0
5656 c
5657 c     mise en delaunay des aretes chainees
5658       call tedela( pxyd,   noarst,
5659      %             mosoar, mxsoar, n1soar, nosoar, liarcf(1),
5660      %             moartr, mxartr, n1artr, noartr, modifs )
5661 ccc   write(imprim,*) 'nombre echanges diagonales =',modifs
5662       return
5663       end
5664
5665
5666       subroutine tr3str( np,     nt,
5667      %                   mosoar, mxsoar, n1soar, nosoar,
5668      %                   moartr, mxartr, n1artr, noartr,
5669      %                   noarst,
5670      %                   nutr,   ierr )
5671 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5672 c but :    former les 3 sous-triangles du triangle nt a partir
5673 c -----    du point interne np
5674 c
5675 c entrees:
5676 c --------
5677 c np     : numero dans le tableau pxyd du point
5678 c nt     : numero dans le tableau noartr du triangle a trianguler
5679 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
5680 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
5681 c moartr : nombre maximal d'entiers par arete du tableau noartr
5682 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
5683 c
5684 c modifies:
5685 c ---------
5686 c n1soar : numero de la premiere arete vide dans le tableau nosoar
5687 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
5688 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages
5689 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
5690 c          hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
5691 c n1artr : numero du premier triangle vide dans le tableau noartr
5692 c          le chainage des triangles vides se fait sur noartr(2,.)
5693 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5694 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5695 c noarst : noarst(i) numero d'une arete de sommet i
5696 c
5697 c sorties:
5698 c --------
5699 c nutr   : le numero des 3 sous-triangles du triangle nt
5700 c nt     : en sortie le triangle initial n'est plus actif dans noartr
5701 c          c'est en fait le premier triangle vide de noartr
5702 c ierr   : =0 si pas d'erreur
5703 c          =1 si le tableau nosoar est sature
5704 c          =2 si le tableau noartr est sature
5705 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5706 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
5707 c....................................................................012
5708       integer    nosoar(mosoar,mxsoar),
5709      %           noartr(moartr,mxartr),
5710      %           noarst(*),
5711      %           nutr(3)
5712 c
5713       integer    nosotr(3), nu2sar(2), nuarco(3)
5714 c
5715 c     reservation des 3 nouveaux triangles dans le tableau noartr
5716 c     ===========================================================
5717       do 10 i=1,3
5718 c        le numero du sous-triangle i dans le tableau noartr
5719          if( n1artr .le. 0 ) then
5720 c           tableau noartr sature
5721             ierr = 2
5722             return
5723          endif
5724          nutr(i) = n1artr
5725 c        le nouveau premier triangle libre dans noartr
5726          n1artr = noartr(2,n1artr)
5727  10   continue
5728 c
5729 c     les numeros des 3 sommets du triangle nt
5730       call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
5731 c
5732 c     formation des 3 aretes nosotr(i)-np dans le tableau nosoar
5733 c     ==========================================================
5734       nt0 = nutr(3)
5735       do 20 i=1,3
5736 c
5737 c        le triangle a creer
5738          nti = nutr(i)
5739 c
5740 c        les 2 sommets du cote i du triangle nosotr
5741          nu2sar(1) = nosotr(i)
5742          nu2sar(2) = np
5743          call hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar, noar )
5744 c        en sortie: noar>0 => no arete retrouvee
5745 c                       <0 => no arete ajoutee
5746 c                       =0 => saturation du tableau nosoar
5747 c
5748          if( noar .eq. 0 ) then
5749 c           saturation du tableau nosoar
5750             ierr = 1
5751             return
5752          else if( noar .lt. 0 ) then
5753 c           l'arete a ete ajoutee. initialisation des autres informations
5754             noar = -noar
5755 c           le numero des 2 sommets a ete initialise par hasoar
5756 c           et (nosoar(1,noar)<nosoar(2,noar))
5757 c           le numero de la ligne de l'arete: ici arete interne
5758             nosoar(3,noar) = 0
5759 c        else
5760 c           l'arete a ete retrouvee
5761 c           le numero des 2 sommets a ete retrouve par hasoar
5762 c           et (nosoar(1,noar)<nosoar(2,noar))
5763 c           le numero de ligne reste inchange
5764          endif
5765 c
5766 c        le triangle 1 de l'arete noar => le triangle nt0
5767          nosoar(4,noar) = nt0
5768 c        le triangle 2 de l'arete noar => le triangle nti
5769          nosoar(5,noar) = nti
5770 c
5771 c        le sommet nosotr(i) appartient a l'arete noar
5772          noarst( nosotr(i) ) = noar
5773 c
5774 c        le numero d'arete nosotr(i)-np
5775          nuarco(i) = noar
5776 c
5777 c        le triangle qui precede le suivant
5778          nt0 = nti
5779  20   continue
5780 c
5781 c     le numero d'une arete du point np
5782       noarst( np ) = noar
5783 c
5784 c     les 3 sous-triangles du triangle nt sont formes dans le tableau noartr
5785 c     ======================================================================
5786       do 30 i=1,3
5787 c
5788 c        le numero suivant i => i mod 3 + 1
5789          if( i .ne. 3 ) then
5790             i1 = i + 1
5791          else
5792             i1 = 1
5793          endif
5794 c
5795 c        le numero dans noartr du sous-triangle a ajouter
5796          nti = nutr( i )
5797 c
5798 c        le numero de l'arete i du triangle initial nt
5799 c        est l'arete 1 du sous-triangle i
5800          noar = noartr(i,nt)
5801          noartr( 1, nti ) = noar
5802 c
5803 c        mise a jour du numero de triangle de cette arete
5804          noar = abs( noar )
5805          if( nosoar(4,noar) .eq. nt ) then
5806 c           le sous-triangle nti remplace le triangle nt
5807             nosoar(4,noar) = nti
5808          else
5809 c           le sous-triangle nti remplace le triangle nt
5810             nosoar(5,noar) = nti
5811          endif
5812 c
5813 c        l'arete 2 du sous-triangle i est l'arete i1 ajoutee
5814          if( nosotr(i1) .eq. nosoar(1,nuarco(i1)) ) then
5815 c           l'arete ns i1-np dans nosoar est dans le sens direct
5816             noartr( 2, nti ) = nuarco(i1)
5817          else
5818 c           l'arete ns i1-np dans nosoar est dans le sens indirect
5819             noartr( 2, nti ) = -nuarco(i1)
5820          endif
5821 c
5822 c        l'arete 3 du sous-triangle i est l'arete i ajoutee
5823          if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
5824 c           l'arete ns i1-np dans nosoar est dans le sens indirect
5825             noartr( 3, nti ) = -nuarco(i)
5826          else
5827 c           l'arete ns i1-np dans nosoar est dans le sens direct
5828             noartr( 3, nti ) = nuarco(i)
5829          endif
5830  30   continue
5831 c
5832 c     le triangle nt est rendu libre
5833 c     ==============================
5834 c     il devient n1artr le premier triangle libre
5835       noartr( 1, nt ) = 0
5836       noartr( 2, nt ) = n1artr
5837       n1artr = nt
5838       end
5839
5840
5841       subroutine mt4sqa( na,  moartr, noartr, mosoar, nosoar,
5842      %                   ns1, ns2, ns3, ns4)
5843 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5844 c but :    calcul du numero des 4 sommets de l'arete na de nosoar
5845 c -----    formant un quadrangle
5846 c
5847 c entrees:
5848 c --------
5849 c na     : numero de l'arete dans nosoar a traiter
5850 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5851 c          arete1=0 si triangle vide => arete2=triangle vide suivant
5852 c mosoar : nombre maximal d'entiers par arete
5853 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
5854 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
5855 c
5856 c sorties:
5857 c --------
5858 c ns1,ns2,ns3 : les 3 numeros des sommets du triangle t1 en sens direct
5859 c ns1,ns4,ns2 : les 3 numeros des sommets du triangle t2 en sens direct
5860 c
5861 c si erreur rencontree => ns4 = 0
5862 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5863 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
5864 c2345x7..............................................................012
5865       common / unites / lecteu, imprim, nunite(30)
5866       integer           noartr(moartr,*), nosoar(mosoar,*)
5867 c
5868 c     le numero de triangle est il correct  ?
5869 c     a supprimer apres mise au point
5870       if( na .le. 0 ) then
5871 c         nblgrc(nrerr) = 1
5872 c         write(kerr(mxlger)(1:6),'(i6)') na
5873 c         kerr(1) = kerr(mxlger)(1:6) //
5874 c     %           ' no incorrect arete dans nosoar'
5875 c         call lereur
5876           write(imprim,*) na, ' no incorrect arete dans nosoar'
5877          ns4 = 0
5878          return
5879       endif
5880 c
5881       if( nosoar(1,na) .le. 0 ) then
5882 c         nblgrc(nrerr) = 1
5883 c         write(kerr(mxlger)(1:6),'(i6)') na
5884 c         kerr(1) = kerr(mxlger)(1:6) //
5885 c     %           ' arete non active dans nosoar'
5886 c         call lereur
5887          write(imprim,*) na, ' arete non active dans nosoar'
5888          ns4 = 0
5889          return
5890       endif
5891 c
5892 c     recherche de l'arete na dans le premier triangle
5893       nt = nosoar(4,na)
5894       if( nt .le. 0 ) then
5895 c         nblgrc(nrerr) = 1
5896 c         write(kerr(mxlger)(1:6),'(i6)') na
5897 c         kerr(1) =  'triangle 1 incorrect pour l''arete ' //
5898 c     %               kerr(mxlger)(1:6)
5899 c         call lereur
5900          write(imprim,*) 'triangle 1 incorrect pour l''arete ', na
5901          ns4 = 0
5902          return
5903       endif
5904 c
5905       do 5 i=1,3
5906          if( abs( noartr(i,nt) ) .eq. na ) goto 8
5907  5    continue
5908 c     si arrivee ici => bogue avant
5909       write(imprim,*) 'mt4sqa: arete',na,' non dans le triangle',nt
5910       ns4 = 0
5911       return
5912 c
5913 c     les 2 sommets de l'arete na
5914  8    if( noartr(i,nt) .gt. 0 ) then
5915          ns1 = 1
5916          ns2 = 2
5917       else
5918          ns1 = 2
5919          ns2 = 1
5920       endif
5921       ns1 = nosoar(ns1,na)
5922       ns2 = nosoar(ns2,na)
5923 c
5924 c     l'arete suivante
5925       if( i .lt. 3 ) then
5926          i = i + 1
5927       else
5928          i = 1
5929       endif
5930       naa = abs( noartr(i,nt) )
5931 c
5932 c     le sommet ns3 du triangle 123
5933       ns3 = nosoar(1,naa)
5934       if( ns3 .eq. ns1 .or. ns3 .eq. ns2 ) then
5935          ns3 = nosoar(2,naa)
5936       endif
5937 c
5938 c     le triangle de l'autre cote de l'arete na
5939 c     =========================================
5940       nt = nosoar(5,na)
5941       if( nt .le. 0 ) then
5942 c         nblgrc(nrerr) = 1
5943 c         write(kerr(mxlger)(1:6),'(i6)') na
5944 c         kerr(1) =  'triangle 2 incorrect pour l''arete ' //
5945 c     %               kerr(mxlger)(1:6)
5946 c         call lereur
5947           write(imprim,*) 'triangle 2 incorrect pour l''arete ',na
5948          ns4 = 0
5949          return
5950       endif
5951 c
5952 c     le numero de l'arete naa du triangle nt
5953       naa = abs( noartr(1,nt) )
5954       if( naa .eq. na ) naa = abs( noartr(2,nt) )
5955       ns4 = nosoar(1,naa)
5956       if( ns4 .eq. ns1 .or. ns4 .eq. ns2 ) then
5957          ns4 = nosoar(2,naa)
5958       endif
5959       end
5960
5961
5962       subroutine te2t2t( noaret, mosoar, n1soar, nosoar, noarst,
5963      %                   moartr, noartr, noar34 )
5964 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5965 c but :    echanger la diagonale des 2 triangles ayant en commun
5966 c -----    l'arete noaret du tableau nosoar si c'est possible
5967 c
5968 c entrees:
5969 c --------
5970 c noaret : numero de l'arete a echanger entre les 2 triangles
5971 c mosoar : nombre maximal d'entiers par arete
5972 c moartr : nombre maximal d'entiers par triangle
5973 c
5974 c modifies :
5975 c ----------
5976 c n1soar : numero de la premiere arete vide dans le tableau nosoar
5977 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
5978 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
5979 c noarst : noarst(i) numero d'une arete de sommet i
5980 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
5981 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
5982 c
5983 c sortie :
5984 c --------
5985 c noar34 : numero nosoar de la nouvelle arete diagonale
5986 c          0 si pas d'echange des aretes diagonales
5987 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5988 c auteur : alain perronnet  analyse numerique paris upmc      avril 1997
5989 c....................................................................012
5990       integer     nosoar(mosoar,*),
5991      %            noartr(moartr,*),
5992      %            noarst(*)
5993 c
5994 c     une arete frontaliere ne peut etre echangee
5995       noar34 = 0
5996       if( nosoar(3,noaret) .gt. 0 ) return
5997 c
5998 c     les 4 sommets des 2 triangles ayant l'arete noaret en commun
5999       call mt4sqa( noaret, moartr, noartr, mosoar, nosoar,
6000      %             ns1, ns2, ns3, ns4)
6001 c     ns1,ns2,ns3 : les 3 numeros des sommets du triangle nt1 en sens direct
6002 c     ns1,ns4,ns2 : les 3 numeros des sommets du triangle nt2 en sens direct
6003 c
6004 c     recherche du numero de l'arete noaret dans le triangle nt1
6005       nt1 = nosoar(4,noaret)
6006       do 10 n1 = 1, 3
6007          if( abs(noartr(n1,nt1)) .eq. noaret ) goto 15
6008  10   continue
6009 c     impossible d'arriver ici sans bogue!
6010       write(imprim,*) 'pause dans te2t2t 1'
6011       pause
6012 c
6013 c     l'arete de sommets 2 et 3
6014  15   if( n1 .lt. 3 ) then
6015          n2 = n1 + 1
6016       else
6017          n2 = 1
6018       endif
6019       na23 = noartr(n2,nt1)
6020 c
6021 c     l'arete de sommets 3 et 1
6022       if( n2 .lt. 3 ) then
6023          n3 = n2 + 1
6024       else
6025          n3 = 1
6026       endif
6027       na31 = noartr(n3,nt1)
6028 c
6029 c     recherche du numero de l'arete noaret dans le triangle nt2
6030       nt2 = nosoar(5,noaret)
6031       do 20 n1 = 1, 3
6032          if( abs(noartr(n1,nt2)) .eq. noaret ) goto 25
6033  20   continue
6034 c     impossible d'arriver ici sans bogue!
6035       write(imprim,*) 'pause dans te2t2t 2'
6036       pause
6037 c
6038 c     l'arete de sommets 1 et 4
6039  25   if( n1 .lt. 3 ) then
6040          n2 = n1 + 1
6041       else
6042          n2 = 1
6043       endif
6044       na14 = noartr(n2,nt2)
6045 c
6046 c     l'arete de sommets 4 et 2
6047       if( n2 .lt. 3 ) then
6048          n3 = n2 + 1
6049       else
6050          n3 = 1
6051       endif
6052       na42 = noartr(n3,nt2)
6053 c
6054 c     les triangles 123 142 deviennent 143 234
6055 c     ========================================
6056 c     ajout de l'arete ns3-ns4
6057 c     on evite l'affichage de l'erreur
6058       ierr = -1
6059       call fasoar( ns3,    ns4,    nt1,    nt2,    0,
6060      %             mosoar, mxsoar, n1soar, nosoar, noarst,
6061      %             noar34, ierr )
6062       if( ierr .gt. 0 ) then
6063 c        ierr=1 si le tableau nosoar est sature
6064 c            =2 si arete a creer et appartenant a 2 triangles distincts
6065 c               des triangles nt1 et nt2
6066 c            =3 si arete appartenant a 2 triangles distincts
6067 c               differents des triangles nt1 et nt2
6068 c            =4 si arete appartenant a 2 triangles distincts
6069 c               dont le second n'est pas le triangle nt2
6070 c        => pas d'echange
6071          noar34 = 0
6072          return
6073       endif
6074 c
6075 c     suppression de l'arete noaret
6076       call sasoar( noaret, mosoar, mxsoar, n1soar, nosoar )
6077 c
6078 c     nt1 = triangle 143
6079       noartr(1,nt1) =  na14
6080 c     sens de stockage de l'arete ns3-ns4 dans nosoar?
6081       if( nosoar(1,noar34) .eq. ns3 ) then
6082          n1 = -1
6083       else
6084          n1 =  1
6085       endif
6086       noartr(2,nt1) = noar34 * n1
6087       noartr(3,nt1) = na31
6088 c
6089 c     nt2 = triangle 234
6090       noartr(1,nt2) =  na23
6091       noartr(2,nt2) = -noar34 * n1
6092       noartr(3,nt2) =  na42
6093 c
6094 c     echange nt1 -> nt2 pour l'arete na23
6095       na23 = abs( na23 )
6096       if( nosoar(4,na23) .eq. nt1 ) then
6097          n1 = 4
6098       else
6099          n1 = 5
6100       endif
6101       nosoar(n1,na23) = nt2
6102 c
6103 c     echange nt2 -> nt1 pour l'arete na14
6104       na14 = abs( na14 )
6105       if( nosoar(4,na14) .eq. nt2 ) then
6106          n1 = 4
6107       else
6108          n1 = 5
6109       endif
6110       nosoar(n1,na14) = nt1
6111 c
6112 c     numero d'une arete de chacun des 4 sommets
6113       noarst(ns1) = na14
6114       noarst(ns2) = na23
6115       noarst(ns3) = noar34
6116       noarst(ns4) = noar34
6117       end
6118
6119
6120
6121       subroutine f0trte( letree, pxyd,
6122      %                   mosoar, mxsoar, n1soar, nosoar,
6123      %                   moartr, mxartr, n1artr, noartr,
6124      %                   noarst,
6125      %                   nbtr,   nutr,   ierr )
6126 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6127 c but :    former le ou les triangles du triangle equilateral letree
6128 c -----    les points internes au te deviennent des sommets des
6129 c          sous-triangles du te
6130 c
6131 c entrees:
6132 c --------
6133 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
6134 c          si letree(0)>0 alors
6135 c             letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
6136 c          sinon
6137 c             letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
6138 c                           0  si pas de point
6139 c                         ( le te est une feuille de l'arbre )
6140 c          letree(4) : no letree du sur-triangle du triangle j
6141 c          letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
6142 c          letree(6:8) : no pxyd des 3 sommets du triangle j
6143 c pxyd   : tableau des x  y  distance_souhaitee de chaque sommet
6144 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
6145 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6146 c moartr : nombre maximal d'entiers par arete du tableau noartr
6147 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
6148 c
6149 c modifies:
6150 c ---------
6151 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6152 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
6153 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6154 c          chainage des aretes frontalieres, chainage du hachage des aretes
6155 c          hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
6156 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6157 c n1artr : numero du premier triangle vide dans le tableau noartr
6158 c          le chainage des triangles vides se fait sur noartr(2,.)
6159 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6160 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
6161 c noarst : noarst(i) numero d'une arete de sommet i
6162 c
6163 c sorties:
6164 c --------
6165 c nbtr   : nombre de sous-triangles du te, triangulation du te
6166 c nutr   : numero des nbtr sous-triangles du te dans le tableau noartr
6167 c ierr   : =0 si pas d'erreur
6168 c          =1 si le tableau nosoar est sature
6169 c          =2 si le tableau noartr est sature
6170 c          =3 si aucun des triangles ne contient l'un des points internes au te
6171 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6172 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
6173 c....................................................................012
6174       common / unites / lecteu, imprim, nunite(30)
6175       double precision  pxyd(3,*)
6176       integer           letree(0:8),
6177      %                  nosoar(mosoar,mxsoar),
6178      %                  noartr(moartr,mxartr),
6179      %                  noarst(*),
6180      %                  nutr(1:nbtr)
6181       integer           nuarco(3)
6182 c
6183 c     le numero nt du triangle dans le tableau noartr
6184       if( n1artr .le. 0 ) then
6185 c        tableau noartr sature
6186          write(imprim,*) 'f0trte: tableau noartr sature'
6187          ierr = 2
6188          return
6189       endif
6190       nt = n1artr
6191 c     le numero du nouveau premier triangle libre dans noartr
6192       n1artr = noartr( 2, n1artr )
6193 c
6194 c     formation du triangle = le triangle equilateral letree
6195       do 10 i=1,3
6196          if( i .ne. 3 ) then
6197             i1 = i + 1
6198          else
6199             i1 = 1
6200          endif
6201 c        ajout eventuel de l'arete si si+1 dans le tableau nosoar
6202          call fasoar( letree(5+i), letree(5+i1), nt, -1, 0,
6203      %                mosoar, mxsoar, n1soar, nosoar, noarst,
6204      %                nuarco(i), ierr )
6205          if( ierr .ne. 0 ) return
6206  10   continue
6207 c
6208 c     le triangle nt est forme dans le tableau noartr
6209       do 20 i=1,3
6210 c        letree(5+i) est le numero du sommet 1 de l'arete i du te
6211          if( letree(5+i) .eq. nosoar(1,nuarco(i)) ) then
6212             lesign =  1
6213          else
6214             lesign = -1
6215          endif
6216 c        l'arete ns1-ns2 dans nosoar est celle du cote du te
6217          noartr( i, nt ) = lesign * nuarco(i)
6218  20   continue
6219 c
6220 c     triangulation du te=triangle nt par ajout des points internes du te
6221       nbtr    = 1
6222       nutr(1) = nt
6223       call trpite( letree, pxyd,
6224      %             mosoar, mxsoar, n1soar, nosoar,
6225      %             moartr, mxartr, n1artr, noartr, noarst,
6226      %             nbtr,   nutr,   ierr )
6227       end
6228
6229
6230       subroutine f1trte( letree, pxyd,   milieu,
6231      %                   mosoar, mxsoar, n1soar, nosoar,
6232      %                   moartr, mxartr, n1artr, noartr,
6233      %                   noarst,
6234      %                   nbtr,   nutr,   ierr )
6235 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6236 c but :    former les triangles du triangle equilateral letree
6237 c -----    a partir de l'un des 3 milieux des cotes du te
6238 c          et des points internes au te
6239 c          ils deviennent tous des sommets des sous-triangles du te
6240 c
6241 c entrees:
6242 c --------
6243 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
6244 c          si letree(0)>0 alors
6245 c             letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
6246 c          sinon
6247 c             letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
6248 c                           0  si pas de point
6249 c                         ( le te est une feuille de l'arbre )
6250 c          letree(4) : no letree du sur-triangle du triangle j
6251 c          letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
6252 c          letree(6:8) : no pxyd des 3 sommets du triangle j
6253 c pxyd   : tableau des x  y  distance_souhaitee de chaque sommet
6254 c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
6255 c                    0 si pas de milieu du cote i a ajouter
6256 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
6257 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6258 c moartr : nombre maximal d'entiers par arete du tableau noartr
6259 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
6260 c
6261 c modifies:
6262 c ---------
6263 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6264 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
6265 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6266 c          chainage des aretes frontalieres, chainage du hachage des aretes
6267 c          hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
6268 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6269 c n1artr : numero du premier triangle vide dans le tableau noartr
6270 c          le chainage des triangles vides se fait sur noartr(2,.)
6271 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6272 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
6273 c noarst : noarst(np) numero d'une arete du sommet np
6274 c
6275 c sorties:
6276 c --------
6277 c nbtr   : nombre de sous-triangles du te, triangulation du te
6278 c nutr   : numero des nbtr sous-triangles du te dans le tableau noartr
6279 c ierr   : =0 si pas d'erreur
6280 c          =1 si le tableau nosoar est sature
6281 c          =2 si le tableau noartr est sature
6282 c          =3 si aucun des triangles ne contient l'un des points internes au te
6283 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6284 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
6285 c....................................................................012
6286       double precision  pxyd(3,*)
6287       integer           letree(0:8),
6288      %                  milieu(3),
6289      %                  nosoar(mosoar,mxsoar),
6290      %                  noartr(moartr,mxartr),
6291      %                  noarst(*),
6292      %                  nutr(1:nbtr)
6293 c
6294       integer           nosotr(3), nuarco(5)
6295 c
6296 c     le numero des 2 triangles (=2 demi te) a creer dans le tableau noartr
6297       do 5 nbtr=1,2
6298          if( n1artr .le. 0 ) then
6299 c           tableau noartr sature
6300             ierr = 2
6301             return
6302          endif
6303          nutr(nbtr) = n1artr
6304 c        le nouveau premier triangle libre dans noartr
6305          n1artr = noartr(2,n1artr)
6306  5    continue
6307       nbtr = 2
6308 c
6309 c     recherche du milieu a creer
6310       do 7 i=1,3
6311          if( milieu(i) .ne. 0 ) goto 9
6312  7    continue
6313 c     le numero pxyd du point milieu du cote i
6314  9    nm = milieu( i )
6315 c
6316 c     on se ramene au seul cas i=3 c-a-d le milieu est sur le cote 3
6317       if( i .eq. 1 ) then
6318 c        milieu sur le cote 1
6319          nosotr(1) = letree(7)
6320          nosotr(2) = letree(8)
6321          nosotr(3) = letree(6)
6322       else if( i .eq. 2 ) then
6323 c        milieu sur le cote 2
6324          nosotr(1) = letree(8)
6325          nosotr(2) = letree(6)
6326          nosotr(3) = letree(7)
6327       else
6328 c        milieu sur le cote 3
6329          nosotr(1) = letree(6)
6330          nosotr(2) = letree(7)
6331          nosotr(3) = letree(8)
6332       endif
6333 c
6334 c     formation des 2 aretes s1 s2 et s2 s3
6335       do 10 i=1,2
6336          if( i .ne. 3 ) then
6337             i1 = i + 1
6338          else
6339             i1 = 1
6340          endif
6341 c        ajout eventuel de l'arete dans nosoar
6342          call fasoar( nosotr(i), nosotr(i1), nutr(i), -1, 0,
6343      %                mosoar, mxsoar, n1soar, nosoar, noarst,
6344      %                nuarco(i), ierr )
6345          if( ierr .ne. 0 ) return
6346  10   continue
6347 c
6348 c     ajout eventuel de l'arete s3 milieu dans nosoar
6349       call fasoar( nosotr(3), nm, nutr(2), -1, 0,
6350      %             mosoar, mxsoar, n1soar, nosoar, noarst,
6351      %             nuarco(3), ierr )
6352       if( ierr .ne. 0 ) return
6353 c
6354 c     ajout eventuel de l'arete milieu s1 dans nosoar
6355       call fasoar( nosotr(1), nm, nutr(1), -1, 0,
6356      %             mosoar, mxsoar, n1soar, nosoar, noarst,
6357      %             nuarco(4), ierr )
6358       if( ierr .ne. 0 ) return
6359 c
6360 c     ajout eventuel de l'arete milieu s2 dans nosoar
6361       call fasoar( nosotr(2), nm, nutr(1), nutr(2), 0,
6362      %             mosoar, mxsoar, n1soar, nosoar, noarst,
6363      %             nuarco(5), ierr )
6364       if( ierr .ne. 0 ) return
6365 c
6366 c     les aretes s1 s2 et s2 s3 dans le tableau noartr
6367       do 20 i=1,2
6368 c        nosotr(i) est le numero du sommet 1 de l'arete i du te
6369          if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
6370             lesign = 1
6371          else
6372             lesign = -1
6373          endif
6374 c        l'arete ns1-ns2 dans nosoar est celle du cote du te
6375          noartr( 1, nutr(i) ) = lesign * nuarco(i)
6376  20   continue
6377 c
6378 c     l'arete mediane s2 milieu
6379       if( nm .eq. nosoar(1,nuarco(5)) ) then
6380          lesign = -1
6381       else
6382          lesign =  1
6383       endif
6384       noartr( 2, nutr(1) ) =  lesign * nuarco(5)
6385       noartr( 3, nutr(2) ) = -lesign * nuarco(5)
6386 c
6387 c     l'arete s1 milieu
6388       if( nm .eq. nosoar(1,nuarco(4)) ) then
6389          lesign =  1
6390       else
6391          lesign = -1
6392       endif
6393       noartr( 3, nutr(1) ) = lesign * nuarco(4)
6394 c
6395 c     l'arete s3 milieu
6396       if( nm .eq. nosoar(1,nuarco(3)) ) then
6397          lesign = -1
6398       else
6399          lesign =  1
6400       endif
6401       noartr( 2, nutr(2) ) = lesign * nuarco(3)
6402 c
6403 c     triangulation des 2 demi te par ajout des points internes du te
6404       call trpite( letree, pxyd,
6405      %             mosoar, mxsoar, n1soar, nosoar,
6406      %             moartr, mxartr, n1artr, noartr, noarst,
6407      %             nbtr,   nutr,   ierr )
6408       end
6409
6410
6411       subroutine f2trte( letree, pxyd,   milieu,
6412      %                   mosoar, mxsoar, n1soar, nosoar,
6413      %                   moartr, mxartr, n1artr, noartr,
6414      %                   noarst,
6415      %                   nbtr,   nutr,   ierr )
6416 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6417 c but :    former les triangles du triangle equilateral letree
6418 c -----    a partir de 2 milieux des cotes du te
6419 c          et des points internes au te
6420 c          ils deviennent tous des sommets des sous-triangles du te
6421 c
6422 c entrees:
6423 c --------
6424 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
6425 c          si letree(0)>0 alors
6426 c             letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
6427 c          sinon
6428 c             letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
6429 c                           0  si pas de point
6430 c                         ( le te est une feuille de l'arbre )
6431 c          letree(4) : no letree du sur-triangle du triangle j
6432 c          letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
6433 c          letree(6:8) : no pxyd des 3 sommets du triangle j
6434 c pxyd   : tableau des x  y  distance_souhaitee de chaque sommet
6435 c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
6436 c                    0 si pas de milieu du cote i a ajouter
6437 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
6438 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6439 c moartr : nombre maximal d'entiers par arete du tableau noartr
6440 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
6441 c
6442 c modifies:
6443 c ---------
6444 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6445 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
6446 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6447 c          chainage des aretes frontalieres, chainage du hachage des aretes
6448 c          hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
6449 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6450 c n1artr : numero du premier triangle vide dans le tableau noartr
6451 c          le chainage des triangles vides se fait sur noartr(2,.)
6452 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6453 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
6454 c noarst : noarst(np) numero d'une arete du sommet np
6455 c
6456 c sorties:
6457 c --------
6458 c nbtr   : nombre de sous-triangles du te, triangulation du te
6459 c nutr   : numero des nbtr sous-triangles du te dans le tableau noartr
6460 c ierr   : =0 si pas d'erreur
6461 c          =1 si le tableau nosoar est sature
6462 c          =2 si le tableau noartr est sature
6463 c          =3 si aucun des triangles ne contient l'un des points internes au te
6464 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6465 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
6466 c....................................................................012
6467       common / unites / lecteu, imprim, nunite(30)
6468       double precision  pxyd(3,*)
6469       integer           letree(0:8),
6470      %                  milieu(3),
6471      %                  nosoar(mosoar,mxsoar),
6472      %                  noartr(moartr,mxartr),
6473      %                  noarst(*),
6474      %                  nutr(1:nbtr)
6475 c
6476       integer           nosotr(3), nuarco(7)
6477 c
6478 c     le numero des 3 triangles a creer dans le tableau noartr
6479       do 5 nbtr=1,3
6480          if( n1artr .le. 0 ) then
6481 c           tableau noartr sature
6482             ierr = 2
6483             return
6484          endif
6485          nutr(nbtr) = n1artr
6486 c        le nouveau premier triangle libre dans noartr
6487          n1artr = noartr(2,n1artr)
6488  5    continue
6489       nbtr = 3
6490 c
6491 c     recherche du premier milieu a creer
6492       do 7 i=1,3
6493          if( milieu(i) .ne. 0 ) goto 9
6494  7    continue
6495 c
6496 c     on se ramene au seul cas i=2 c-a-d le cote 1 n'a pas de milieu
6497  9    if( i .eq. 2 ) then
6498 c        pas de milieu sur le cote 1
6499          nosotr(1) = letree(6)
6500          nosotr(2) = letree(7)
6501          nosotr(3) = letree(8)
6502 c        le numero pxyd du milieu du cote 2
6503          nm2 = milieu( 2 )
6504 c        le numero pxyd du milieu du cote 3
6505          nm3 = milieu( 3 )
6506       else if( milieu(2) .ne. 0 ) then
6507 c        pas de milieu sur le cote 3
6508          nosotr(1) = letree(8)
6509          nosotr(2) = letree(6)
6510          nosotr(3) = letree(7)
6511 c        le numero pxyd du milieu du cote 2
6512          nm2 = milieu( 1 )
6513 c        le numero pxyd du milieu du cote 3
6514          nm3 = milieu( 2 )
6515       else
6516 c        pas de milieu sur le cote 2
6517          nosotr(1) = letree(7)
6518          nosotr(2) = letree(8)
6519          nosotr(3) = letree(6)
6520 c        le numero pxyd du milieu du cote 2
6521          nm2 = milieu( 3 )
6522 c        le numero pxyd du milieu du cote 3
6523          nm3 = milieu( 1 )
6524       endif
6525 c
6526 c     ici seul le cote 1 n'a pas de milieu
6527 c     nm2 est le milieu du cote 2
6528 c     nm3 est le milieu du cote 3
6529 c
6530 c     ajout eventuel de l'arete s1 s2 dans nosoar
6531       call fasoar( nosotr(1), nosotr(2), nutr(1), -1, 0,
6532      %             mosoar, mxsoar, n1soar, nosoar, noarst,
6533      %             nuarco(1), ierr )
6534       if( ierr .ne. 0 ) return
6535 c
6536 c     ajout eventuel de l'arete s1 s2 dans nosoar
6537       call fasoar( nosotr(2), nm2, nutr(1), -1, 0,
6538      %             mosoar, mxsoar, n1soar, nosoar, noarst,
6539      %             nuarco(2), ierr )
6540       if( ierr .ne. 0 ) return
6541 c
6542 c     ajout eventuel de l'arete s1 nm2 dans nosoar
6543       call fasoar( nosotr(1), nm2, nutr(1), nutr(2), 0,
6544      %             mosoar, mxsoar, n1soar, nosoar, noarst,
6545      %             nuarco(3), ierr )
6546       if( ierr .ne. 0 ) return
6547 c
6548 c     ajout eventuel de l'arete nm2 nm3 dans nosoar
6549       call fasoar( nm3, nm2, nutr(2), nutr(3), 0,
6550      %             mosoar, mxsoar, n1soar, nosoar, noarst,
6551      %             nuarco(4), ierr )
6552       if( ierr .ne. 0 ) return
6553 c
6554 c     ajout eventuel de l'arete s1 nm3 dans nosoar
6555       call fasoar( nosotr(1), nm3, nutr(2), -1, 0,
6556      %             mosoar, mxsoar, n1soar, nosoar, noarst,
6557      %             nuarco(5), ierr )
6558       if( ierr .ne. 0 ) return
6559 c
6560 c     ajout eventuel de l'arete nm2 s3 dans nosoar
6561       call fasoar( nm2, nosotr(3), nutr(3), -1, 0,
6562      %             mosoar, mxsoar, n1soar, nosoar, noarst,
6563      %             nuarco(6), ierr )
6564 c
6565 c     ajout eventuel de l'arete nm3 s3 dans nosoar
6566       call fasoar( nosotr(3), nm3, nutr(3), -1, 0,
6567      %             mosoar, mxsoar, n1soar, nosoar, noarst,
6568      %             nuarco(7), ierr )
6569       if( ierr .ne. 0 ) return
6570 c
6571 c     le triangle s1 s2 nm2  ou arete1 arete2 arete3
6572       do 20 i=1,2
6573 c        nosotr(i) est le numero du sommet 1 de l'arete i du te
6574          if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
6575             lesign = 1
6576          else
6577             lesign = -1
6578          endif
6579 c        l'arete ns1-ns2 dans nosoar est celle du cote du te
6580          noartr( i, nutr(1) ) = lesign * nuarco(i)
6581  20   continue
6582       if( nm2 .eq. nosoar(1,nuarco(3)) ) then
6583          lesign =  1
6584       else
6585          lesign = -1
6586       endif
6587       noartr( 3, nutr(1) ) = lesign * nuarco(3)
6588 c
6589 c     le triangle s1 nm2 nm3
6590       noartr( 1, nutr(2) ) = -lesign * nuarco(3)
6591       if( nm2 .eq. nosoar(1,nuarco(4)) ) then
6592          lesign =  1
6593       else
6594          lesign = -1
6595       endif
6596       noartr( 2, nutr(2) ) =  lesign * nuarco(4)
6597       noartr( 1, nutr(3) ) = -lesign * nuarco(4)
6598       if( nm3 .eq. nosoar(1,nuarco(5)) ) then
6599          lesign =  1
6600       else
6601          lesign = -1
6602       endif
6603       noartr( 3, nutr(2) ) = lesign * nuarco(5)
6604 c
6605 c     le triangle nm2 nm3 s3
6606       if( nm2 .eq. nosoar(1,nuarco(6)) ) then
6607          lesign =  1
6608       else
6609          lesign = -1
6610       endif
6611       noartr( 2, nutr(3) ) =  lesign * nuarco(6)
6612       if( nm3 .eq. nosoar(1,nuarco(7)) ) then
6613          lesign = -1
6614       else
6615          lesign =  1
6616       endif
6617       noartr( 3, nutr(3) ) = lesign * nuarco(7)
6618 c
6619 c     triangulation des 3 sous-te par ajout des points internes du te
6620       call trpite( letree, pxyd,
6621      %             mosoar, mxsoar, n1soar, nosoar,
6622      %             moartr, mxartr, n1artr, noartr, noarst,
6623      %             nbtr,   nutr,   ierr )
6624       end
6625
6626
6627       subroutine f3trte( letree, pxyd,   milieu,
6628      %                   mosoar, mxsoar, n1soar, nosoar,
6629      %                   moartr, mxartr, n1artr, noartr,
6630      %                   noarst,
6631      %                   nbtr,   nutr,   ierr )
6632 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6633 c but :    former les triangles du triangle equilateral letree
6634 c -----    a partir de 3 milieux des cotes du te
6635 c          et des points internes au te
6636 c          ils deviennent tous des sommets des sous-triangles du te
6637 c
6638 c entrees:
6639 c --------
6640 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
6641 c          si letree(0)>0 alors
6642 c             letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
6643 c          sinon
6644 c             letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
6645 c                           0  si pas de point
6646 c                         ( le te est une feuille de l'arbre )
6647 c          letree(4) : no letree du sur-triangle du triangle j
6648 c          letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
6649 c          letree(6:8) : no pxyd des 3 sommets du triangle j
6650 c pxyd   : tableau des x  y  distance_souhaitee de chaque sommet
6651 c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
6652 c                    0 si pas de milieu du cote i a ajouter
6653 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
6654 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6655 c moartr : nombre maximal d'entiers par arete du tableau noartr
6656 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
6657 c
6658 c modifies:
6659 c ---------
6660 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6661 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
6662 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
6663 c          chainage des aretes frontalieres, chainage du hachage des aretes
6664 c          hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
6665 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6666 c n1artr : numero du premier triangle vide dans le tableau noartr
6667 c          le chainage des triangles vides se fait sur noartr(2,.)
6668 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6669 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
6670 c noarst : noarst(np) numero d'une arete du sommet np
6671 c
6672 c sorties:
6673 c --------
6674 c nbtr   : nombre de sous-triangles du te, triangulation du te
6675 c nutr   : numero des nbtr sous-triangles du te dans le tableau noartr
6676 c ierr   : =0 si pas d'erreur
6677 c          =1 si le tableau nosoar est sature
6678 c          =2 si le tableau noartr est sature
6679 c          =3 si aucun des triangles ne contient l'un des points internes au te
6680 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6681 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
6682 c....................................................................012
6683       common / unites / lecteu, imprim, nunite(30)
6684       double precision  pxyd(3,*)
6685       integer           letree(0:8),
6686      %                  milieu(3),
6687      %                  nosoar(mosoar,mxsoar),
6688      %                  noartr(moartr,mxartr),
6689      %                  noarst(*),
6690      %                  nutr(1:nbtr)
6691 c
6692       integer           nuarco(9)
6693 c
6694 c     le numero des 4 triangles a creer dans le tableau noartr
6695       do 5 nbtr=1,4
6696          if( n1artr .le. 0 ) then
6697 c           tableau noartr sature
6698             ierr = 2
6699             return
6700          endif
6701          nutr(nbtr) = n1artr
6702 c        le nouveau premier triangle libre dans noartr
6703          n1artr = noartr(2,n1artr)
6704  5    continue
6705       nbtr = 4
6706 c
6707       do 10 i=1,3
6708 c        le sommet suivant
6709          if( i .ne. 3 ) then
6710             i1 = i + 1
6711          else
6712             i1 = 1
6713          endif
6714 c        le sommet precedant
6715          if( i .ne. 1 ) then
6716             i0 = i - 1
6717          else
6718             i0 = 3
6719          endif
6720          i3 = 3 * i
6721 c
6722 c        ajout eventuel de l'arete si mi dans nosoar
6723          call fasoar( letree(5+i), milieu(i), nutr(i), -1, 0,
6724      %                mosoar, mxsoar, n1soar, nosoar, noarst,
6725      %                nuarco(i3-2), ierr )
6726          if( ierr .ne. 0 ) return
6727 c
6728 c        ajout eventuel de l'arete mi mi-1 dans nosoar
6729          call fasoar( milieu(i), milieu(i0), nutr(i), nutr(4), 0,
6730      %                mosoar, mxsoar, n1soar, nosoar, noarst,
6731      %                nuarco(i3-1), ierr )
6732          if( ierr .ne. 0 ) return
6733 c
6734 c        ajout eventuel de l'arete m i-1  si dans nosoar
6735          call fasoar( milieu(i0), letree(5+i), nutr(i), -1, 0,
6736      %                mosoar, mxsoar, n1soar, nosoar, noarst,
6737      %                nuarco(i3), ierr )
6738          if( ierr .ne. 0 ) return
6739 c
6740  10   continue
6741 c
6742 c     les 3 sous-triangles pres des sommets
6743       do 20 i=1,3
6744 c        le sommet suivant
6745          if( i .ne. 3 ) then
6746             i1 = i + 1
6747          else
6748             i1 = 1
6749          endif
6750 c        le sommet precedant
6751          if( i .ne. 1 ) then
6752             i0 = i - 1
6753          else
6754             i0 = 3
6755          endif
6756          i3 = 3 * i
6757 c
6758 c        ajout du triangle  arete3i-2 arete3i-1 arete3i
6759          if( letree(5+i) .eq. nosoar(1,nuarco(i3-2)) ) then
6760             lesign =  1
6761          else
6762             lesign = -1
6763          endif
6764          noartr( 1, nutr(i) ) = lesign * nuarco(i3-2)
6765 c
6766          if( milieu(i) .eq. nosoar(1,nuarco(i3-1)) ) then
6767             lesign =  1
6768          else
6769             lesign = -1
6770          endif
6771          noartr( 2, nutr(i) ) = lesign * nuarco(i3-1)
6772 c
6773          if( milieu(i0) .eq. nosoar(1,nuarco(i3)) ) then
6774             lesign =  1
6775          else
6776             lesign = -1
6777          endif
6778          noartr( 3, nutr(i) ) = lesign * nuarco(i3)
6779 c
6780  20   continue
6781 c
6782 c     le sous triangle central
6783       i3 = -1
6784       do 30 i=1,3
6785          i3 = i3 + 3
6786          if( milieu(i) .eq. nosoar(1,nuarco(i3)) ) then
6787             lesign = -1
6788          else
6789             lesign =  1
6790          endif
6791          noartr( i, nutr(4) ) = lesign * nuarco(i3)
6792  30   continue
6793 c
6794 c     triangulation des 3 sous-te par ajout des points internes du te
6795       call trpite( letree, pxyd,
6796      %             mosoar, mxsoar, n1soar, nosoar,
6797      %             moartr, mxartr, n1artr, noartr, noarst,
6798      %             nbtr,   nutr,   ierr )
6799       end
6800
6801
6802
6803       subroutine hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar,
6804      %                   noar )
6805 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6806 c but :    rechercher le numero des 2 sommets d'une arete parmi
6807 c -----    les numeros des 2 sommets des aretes du tableau nosoar
6808 c          s ils n y sont pas stockes les y ajouter
6809 c          dans tous les cas retourner le numero de l'arete dans nosoar
6810 c
6811 c          la methode employee ici est celle du hachage
6812 c          avec pour fonction d'adressage h(ns1,ns2)=min(ns1,ns2)
6813 c
6814 c          remarque: h(ns1,ns2)=ns1 + 2*ns2
6815 c                    ne marche pas si des aretes sont detruites
6816 c                    et ajoutees aux aretes vides
6817 c                    le chainage est commun a plusieurs hachages!
6818 c                    d'ou ce choix du minimum pour le hachage
6819 c
6820 c entrees:
6821 c --------
6822 c mosoar : nombre maximal d'entiers par arete et
6823 c          indice dans nosoar de l'arete suivante dans le hachage
6824 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
6825 c          attention: mxsoar>3*mxsomm obligatoire!
6826 c
6827 c modifies:
6828 c ---------
6829 c n1soar : numero de la premiere arete vide dans le tableau nosoar
6830 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
6831 c          chainage des aretes vides amont et aval
6832 c          l'arete vide qui precede=nosoar(4,i)
6833 c          l'arete vide qui suit   =nosoar(5,i)
6834 c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
6835 c          chainage momentan'e d'aretes, chainage du hachage des aretes
6836 c          hachage des aretes = min( nosoar(1), nosoar(2) )
6837 c nu2sar : en entree les 2 numeros des sommets de l'arete
6838 c          en sortie nu2sar(1)<nu2sar(2) numeros des 2 sommets de l'arete
6839 c
6840 c sorties:
6841 c --------
6842 c noar   : numero dans nosoar de l'arete apres hachage
6843 c          =0 si saturation du tableau nosoar
6844 c          >0 si le tableau nu2sar est l'arete noar retrouvee
6845 c             dans le tableau nosoar
6846 c          <0 si le tableau nu2sar a ete ajoute et forme l'arete
6847 c             -noar du tableau nosoar avec nosoar(1,noar)<nosoar(2,noar)
6848 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6849 c auteur : alain perronnet  analyse numerique upmc paris       mars 1997
6850 c ...................................................................012
6851       integer  nu2sar(2), nosoar(mosoar,mxsoar)
6852 c
6853       if( nu2sar(1) .gt. nu2sar(2) ) then
6854 c
6855 c        permutation des numeros des 2 sommets pour
6856 c        amener le plus petit dans nu2sar(1)
6857          i         = nu2sar(1)
6858          nu2sar(1) = nu2sar(2)
6859          nu2sar(2) = i
6860       endif
6861 c
6862 c     la fonction d'adressage du hachage des aretes : h(ns1,ns2)=min(ns1,ns2)
6863 c     ===============================================
6864       noar = nu2sar(1)
6865 c
6866 c     la recherche de l'arete dans le chainage du hachage
6867 c     ---------------------------------------------------
6868  10   if( nu2sar(1) .eq. nosoar(1,noar) ) then
6869          if( nu2sar(2) .eq. nosoar(2,noar) ) then
6870 c
6871 c           l'arete est retrouvee
6872 c           .....................
6873             return
6874          endif
6875       endif
6876 c
6877 c     l'arete suivante parmi celles ayant meme fonction d'adressage
6878       i = nosoar( mosoar, noar )
6879       if( i .gt. 0 ) then
6880          noar = i
6881          goto 10
6882       endif
6883 c
6884 c     noar est ici la derniere arete (sans suivante) du chainage
6885 c     a partir de l'adressage du hachage
6886 c
6887 c     l'arete non retrouvee doit etre ajoutee
6888 c     .......................................
6889       if( nosoar( 1, nu2sar(1) ) .eq. 0 ) then
6890 c
6891 c        l'adresse de hachage est libre => elle devient la nouvelle arete
6892 c        retouche des chainages de cette arete noar qui ne sera plus vide
6893          noar = nu2sar(1)
6894 c        l'eventuel chainage du hachage n'est pas modifie
6895 c
6896       else
6897 c
6898 c        la premiere arete dans l'adressage du hachage n'est pas libre
6899 c        => choix quelconque d'une arete vide pour ajouter cette arete
6900          if( n1soar .le. 0 ) then
6901 c
6902 c           le tableau nosoar est sature avec pour temoin d'erreur
6903             noar = 0
6904             return
6905 c
6906          else
6907 c
6908 c           l'arete n1soar est vide => c'est la nouvelle arete
6909 c           mise a jour du chainage de la derniere arete noar du chainage
6910 c           sa suivante est la nouvelle arete n1soar
6911             nosoar( mosoar, noar ) = n1soar
6912 c
6913 c           l'arete ajoutee est n1soar
6914             noar = n1soar
6915 c
6916 c           la nouvelle premiere arete vide
6917             n1soar = nosoar( 5, n1soar )
6918 c
6919 c           la premiere arete vide n1soar n'a pas d'arete vide precedente
6920             nosoar( 4, n1soar ) = 0
6921 c
6922 c           noar la nouvelle arete est la derniere du chainage du hachage
6923             nosoar( mosoar, noar ) = 0
6924 c
6925          endif
6926 c
6927       endif
6928 c
6929 c     les 2 sommets de la nouvelle arete noar
6930       nosoar( 1, noar ) = nu2sar(1)
6931       nosoar( 2, noar ) = nu2sar(2)
6932 c
6933 c     le tableau nu2sar a ete ajoute avec l'indice -noar
6934       noar = - noar
6935       end
6936
6937
6938       subroutine mt3str( nt, moartr, noartr, mosoar, nosoar,
6939      %                   ns1, ns2, ns3 )
6940 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6941 c but : calcul du numero des 3 sommets du triangle nt du tableau noartr
6942 c -----
6943 c
6944 c entrees:
6945 c --------
6946 c nt     : numero du triangle de noartr a traiter
6947 c moartr : nombre maximal d'entiers par triangle
6948 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
6949 c          arete1=0 si triangle vide => arete2=triangle vide suivant
6950 c mosoar : nombre maximal d'entiers par arete
6951 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
6952 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
6953 c
6954 c sorties:
6955 c --------
6956 c ns1,ns2,ns3 : les 3 numeros des sommets du triangle en sens direct
6957 c
6958 c si erreur rencontree => ns1 = 0
6959 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6960 c auteur : alain perronnet  analyse numerique paris upmc    juillet 1995
6961 c2345x7..............................................................012
6962       integer    noartr(moartr,*), nosoar(mosoar,*)
6963 c
6964 c     le numero de triangle est il correct  ?
6965 c     a supprimer apres mise au point
6966       if( nt .le. 0 ) then
6967 c         nblgrc(nrerr) = 1
6968 c         write(kerr(mxlger)(1:6),'(i6)') nt
6969 c         kerr(1) = kerr(mxlger)(1:6) //
6970 c     %           ' no triangle dans noartr incorrect'
6971 c         call lereur
6972          write(imprim,*) nt,' no triangle dans noartr incorrect'
6973          ns1 = 0
6974          return
6975       endif
6976 c
6977       na = noartr(1,nt)
6978       if( na .gt. 0 ) then
6979 c        arete dans le sens direct
6980          ns1 = nosoar(1,na)
6981          ns2 = nosoar(2,na)
6982       else
6983 c        arete dans le sens indirect
6984          ns1 = nosoar(2,-na)
6985          ns2 = nosoar(1,-na)
6986       endif
6987 c
6988       na = noartr(2,nt)
6989       if( na .gt. 0 ) then
6990 c        arete dans le sens direct => ns3 est le second sommet de l'arete
6991          ns3 = nosoar(2,na)
6992       else
6993 c        arete dans le sens indirect => ns3 est le premier sommet de l'arete
6994          ns3 = nosoar(1,-na)
6995       endif
6996       end
6997       subroutine trpite( letree, pxyd,
6998      %                   mosoar, mxsoar, n1soar, nosoar,
6999      %                   moartr, mxartr, n1artr, noartr,
7000      %                   noarst,
7001      %                   nbtr,   nutr,   ierr )
7002 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7003 c but :    former le ou les sous-triangles des nbtr triangles nutr
7004 c -----    qui forment le triangle equilateral letree par ajout
7005 c          des points internes au te qui deviennent des sommets des
7006 c          sous-triangles des nbtr triangles
7007 c
7008 c entrees:
7009 c --------
7010 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
7011 c          letree(0:3):-no pxyd des 1 a 4 points internes au triangle j
7012 c                       0  si pas de point
7013 c                     ( le te est ici une feuille de l'arbre )
7014 c          letree(4) : no letree du sur-triangle du triangle j
7015 c          letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
7016 c          letree(6:8) : no pxyd des 3 sommets du triangle j
7017 c pxyd   : tableau des x  y  distance_souhaitee de chaque sommet
7018 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
7019 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
7020 c moartr : nombre maximal d'entiers par arete du tableau noartr
7021 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
7022 c
7023 c modifies:
7024 c ---------
7025 c n1soar : numero de la premiere arete vide dans le tableau nosoar
7026 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
7027 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
7028 c          chainage des aretes frontalieres, chainage du hachage des aretes
7029 c          hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
7030 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
7031 c n1artr : numero du premier triangle vide dans le tableau noartr
7032 c          le chainage des triangles vides se fait sur noartr(2,.)
7033 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
7034 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
7035 c noarst : noarst(i) numero d'une arete de sommet i
7036 c
7037 c sorties:
7038 c --------
7039 c nbtr   : nombre de sous-triangles du te
7040 c nutr   : numero des nbtr sous-triangles du te dans le tableau noartr
7041 c ierr   : =0 si pas d'erreur
7042 c          =1 si le tableau nosoar est sature
7043 c          =2 si le tableau noartr est sature
7044 c          =3 si aucun des triangles ne contient l'un des points internes au te
7045 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7046 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
7047 c....................................................................012
7048       logical           tratri
7049       common / dv2dco / tratri
7050 c     trace ou non des triangles generes dans la triangulation
7051       common / unites / lecteu, imprim, nunite(30)
7052       double precision  pxyd(3,*)
7053       integer           letree(0:8),
7054      %                  nosoar(mosoar,mxsoar),
7055      %                  noartr(moartr,mxartr),
7056      %                  noarst(*),
7057      %                  nutr(1:nbtr)
7058 c
7059       integer           nosotr(3)
7060 c
7061 c     si pas de point interne alors trace eventuel puis retour
7062       if( letree(0) .eq. 0 ) goto 150
7063 c
7064 c     il existe au moins un point interne a trianguler
7065 c     dans les nbtr triangles
7066       do 100 k=0,3
7067 c
7068 c        le numero du point
7069          np = -letree(k)
7070          if( np .eq. 0 ) goto 150
7071 c
7072 c        le point np dans pxyd est a traiter
7073          do 10 n = 1, nbtr
7074 c
7075 c           les numeros des 3 sommets du triangle nt=nutr(n)
7076             nt = nutr(n)
7077             call nusotr( nt, mosoar, nosoar, moartr, noartr,  nosotr )
7078 c
7079 c           le triangle nt contient il le point np?
7080             call ptdatr( pxyd(1,np), pxyd, nosotr, nsigne )
7081 c           nsigne>0 si le point est dans le triangle ou sur une des 3 aretes
7082 c                 =0 si triangle degenere ou indirect ou ne contient pas le poin
7083 c
7084             if( nsigne .gt. 0 ) then
7085 c
7086 c              le triangle nt est triangule en 3 sous-triangles
7087                call tr3str( np, nt,
7088      %                      mosoar, mxsoar, n1soar, nosoar,
7089      %                      moartr, mxartr, n1artr, noartr,
7090      %                      noarst,
7091      %                      nutr(nbtr+1),  ierr )
7092                if( ierr .ne. 0 ) return
7093 c
7094 c              reamenagement des 3 triangles crees dans nutr
7095 c              en supprimant le triangle nt
7096                nutr( n ) = nutr( nbtr + 3 )
7097                nbtr = nbtr + 2
7098 c              le point np est triangule
7099                goto 100
7100 c
7101             endif
7102  10      continue
7103 c
7104 c        erreur: le point np n'est pas dans l'un des nbtr triangles
7105          write(imprim,10010) np
7106          pause
7107          ierr = 3
7108          return
7109 c
7110  100  continue
7111 10010 format(' erreur trpite: pas de triangle contenant le point',i7)
7112 c
7113  150  continue
7114
7115 ccc 150  if( tratri ) then
7116 cccc       les traces sont demandes
7117 ccc        call efface
7118 cccc       le cadre objet global en unites utilisateur
7119 ccc        xx1 = min(pxyd(1,nosotr(1)),pxyd(1,nosotr(2)),pxyd(1,nosotr(3)))
7120 ccc        xx2 = max(pxyd(1,nosotr(1)),pxyd(1,nosotr(2)),pxyd(1,nosotr(3)))
7121 ccc        yy1 = min(pxyd(2,nosotr(1)),pxyd(2,nosotr(2)),pxyd(2,nosotr(3)))
7122 ccc        yy2 = max(pxyd(2,nosotr(1)),pxyd(2,nosotr(2)),pxyd(2,nosotr(3)))
7123 ccc        if( xx1 .ge. xx2 ) xx2 = xx1 + (yy2-yy1)
7124 ccc        if( yy1 .ge. yy2 ) yy2 = yy1 + (xx2-xx1)*0.5
7125 ccc        call isofenetre( xx1-(xx2-xx1), xx2+(xx2-xx1),
7126 ccc     %                   yy1-(yy2-yy1), yy2+(yy2-yy1) )
7127 ccc         do 200 i=1,nbtr
7128 cccc           trace du triangle nutr(i)
7129 ccc            call mttrtr( pxyd, nutr(i), moartr, noartr, mosoar, nosoar,
7130 ccc     %                   i, ncblan )
7131 ccc 200     continue
7132 ccc      endif
7133
7134       end
7135
7136
7137       subroutine sasoar( noar, mosoar, mxsoar, n1soar, nosoar )
7138 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7139 c but :    supprimer l'arete noar du tableau nosoar
7140 c -----    si celle ci n'est pas une arete des lignes de la frontiere
7141 c
7142 c          la methode employee ici est celle du hachage
7143 c          avec pour fonction d'adressage h = min( nu2sar(1), nu2sar(2) )
7144 c
7145 c          attention: il faut mettre a jour le no d'arete des 2 sommets
7146 c                     de l'arete supprimee dans le tableau noarst!
7147 c
7148 c entrees:
7149 c --------
7150 c noar   : numero de l'arete de nosoar a supprimer
7151 c mosoar : nombre maximal d'entiers par arete et
7152 c          indice dans nosoar de l'arete suivante dans le hachage h
7153 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
7154 c          attention: mxsoar>3*mxsomm obligatoire!
7155 c
7156 c modifies:
7157 c ---------
7158 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
7159 c          chainage des vides suivant en 3 et precedant en 2 de nosoar
7160 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
7161 c          chainage des aretes frontalieres, chainage du hachage des aretes
7162 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
7163 c          nosoar(4,arete vide)=l'arete vide qui precede
7164 c          nosoar(5,arete vide)=l'arete vide qui suit
7165 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7166 c auteur : alain perronnet  analyse numerique upmc paris       mars 1997
7167 c ...................................................................012
7168       common / unites / lecteu, imprim, nunite(30)
7169       integer           nosoar(mosoar,mxsoar)
7170 c
7171       if( nosoar(3,noar) .le. 0 ) then
7172 c
7173 c        l'arete n'est pas frontaliere => elle devient une arete vide
7174 c
7175 c        recherche de l'arete qui precede dans le chainage du hachage
7176          noar1 = nosoar(1,noar)
7177 c
7178 c        parcours du chainage du hachage jusqu'a retrouver l'arete noar
7179  10      if( noar1 .ne. noar ) then
7180 c
7181 c           l'arete suivante parmi celles ayant meme fonction d'adressage
7182             noar0 = noar1
7183             noar1 = nosoar( mosoar, noar1 )
7184             if( noar1 .gt. 0 ) goto 10
7185 c
7186 c           l'arete noar n'a pas ete retrouvee dans le chainage => erreur
7187             write(imprim,*) 'erreur sasoar:arete non dans le chainage '
7188      %                      ,noar
7189             write(imprim,*) 'arete de st1=',nosoar(1,noar),
7190      %      ' st2=',nosoar(2,noar),' ligne=',nosoar(3,noar),
7191      %      ' tr1=',nosoar(4,noar),' tr2=',nosoar(5,noar)
7192             write(imprim,*) 'chainages=',(nosoar(i,noar),i=6,mosoar)
7193             pause
7194 c           l'arete n'est pas detruite
7195             return
7196 c
7197          endif
7198 c
7199          if( noar .ne. nosoar(1,noar) ) then
7200 c
7201 c           saut de l'arete noar dans le chainage du hachage
7202 c           noar0 initialisee est ici l'arete qui precede noar dans ce chainage
7203             nosoar( mosoar, noar0 ) = nosoar( mosoar, noar )
7204 c
7205 c           le chainage du hachage n'existe plus pour noar
7206 c           pas utile car mise a zero faite dans le sp hasoar
7207 ccc         nosoar( mosoar, noar ) = 0
7208 c
7209 c           noar devient la nouvelle premiere arete du chainage des vides
7210             nosoar( 4, noar ) = 0
7211             nosoar( 5, noar ) = n1soar
7212 c           la nouvelle precede l'ancienne premiere
7213             nosoar( 4, n1soar ) = noar
7214             n1soar = noar
7215 c
7216 ccc      else
7217 c
7218 c           noar est la premiere arete du chainage du hachage h
7219 c           cette arete ne peut etre consideree dans le chainage des vides
7220 c           car le chainage du hachage doit etre conserve (sinon perte...)
7221 c
7222          endif
7223 c
7224 c        le temoin d'arete vide
7225          nosoar( 1, noar ) = 0
7226       endif
7227       end
7228
7229
7230       subroutine caetoi( noar,   mosoar, mxsoar, n1soar, nosoar,
7231      %                   n1aeoc, nbtrar  )
7232 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7233 c but :    ajouter (ou retirer) l'arete noar de nosoar de l'etoile
7234 c -----    des aretes simples chainees en position lchain de nosoar
7235 c          detruire du tableau nosoar les aretes doubles
7236 c
7237 c          attention: le chainage lchain de nosoar devient celui des cf
7238 c
7239 c entree :
7240 c --------
7241 c noar   : numero dans le tableau nosoar de l'arete a traiter
7242 c mosoar : nombre maximal d'entiers par arete et
7243 c          indice dans nosoar de l'arete suivante dans le hachage
7244 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
7245 c          attention: mxsoar>3*mxsomm obligatoire!
7246 c
7247 c entrees et sorties:
7248 c -------------------
7249 c n1soar : numero de la premiere arete vide dans le tableau nosoar
7250 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
7251 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
7252 c          chainage des aretes frontalieres, chainage du hachage des aretes
7253 c n1aeoc : numero dans nosoar de la premiere arete simple de l'etoile
7254 c
7255 c sortie :
7256 c --------
7257 c nbtrar : 1 si arete ajoutee, 2 si arete double supprimee
7258 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7259 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
7260 c2345x7..............................................................012
7261       parameter        (lchain=6)
7262       integer           nosoar(mosoar,mxsoar)
7263 c
7264 c     si    l'arete n'appartient pas aux aretes de l'etoile naetoi
7265 c     alors elle est ajoutee a l'etoile dans naetoi
7266 c     sinon elle est empilee dans npile pour etre detruite ensuite
7267 c           elle est supprimee de l'etoile naetoi
7268 c
7269       if( nosoar( lchain, noar ) .lt. 0 ) then
7270 c
7271 c        arete de l'etoile vue pour la premiere fois
7272 c        elle est ajoutee au chainage
7273          nosoar( lchain, noar ) = n1aeoc
7274 c        elle devient la premiere du chainage
7275          n1aeoc = noar
7276 c        arete simple
7277          nbtrar = 1
7278 c
7279       else
7280 c
7281 c        arete double de l'etoile. elle est supprimee du chainage
7282          na0 = 0
7283          na  = n1aeoc
7284 c        parcours des aretes chainees jusqu'a trouver l'arete noar
7285  10      if( na .ne. noar ) then
7286 c           passage a la suivante
7287             na0 = na
7288             na  = nosoar( lchain, na )
7289             goto 10
7290          endif
7291 c
7292 c        suppression de noar du chainage des aretes simples de l'etoile
7293          if( na0 .gt. 0 ) then
7294 c           il existe une arete qui precede
7295             nosoar( lchain, na0 ) = nosoar( lchain, noar )
7296          else
7297 c           noar est en fait n1aeoc la premiere du chainage
7298             n1aeoc = nosoar( lchain, noar )
7299          endif
7300 c        noar n'est plus une arete simple de l'etoile
7301          nosoar( lchain, noar ) = -1
7302 c
7303 c        destruction du tableau nosoar de l'arete double noar
7304          call sasoar( noar, mosoar, mxsoar, n1soar, nosoar )
7305 c
7306 c        arete double
7307          nbtrar = 2
7308       endif
7309       end
7310
7311
7312       subroutine focftr( nbtrcf, notrcf, pxyd,   noarst,
7313      %                   mosoar, mxsoar, n1soar, nosoar,
7314      %                   moartr, n1artr, noartr,
7315      %                   nbarcf, n1arcf, noarcf,
7316      %                   ierr )
7317 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7318 c but :    former un contour ferme (cf) avec les aretes simples des
7319 c -----    nbtrcf triangles du tableau notrcf
7320 c          destruction des nbtrcf triangles du tableau noartr
7321 c          destruction des aretes doubles   du tableau nosoar
7322 c
7323 c          attention: le chainage lchain de nosoar devient celui des cf
7324 c
7325 c entrees:
7326 c --------
7327 c nbtrcf : nombre de  triangles du cf a former
7328 c notrcf : numero des triangles dans le tableau noartr
7329 c pxyd   : tableau des coordonnees 2d des points
7330 c          par point : x  y  distance_souhaitee
7331 c
7332 c mosoar : nombre maximal d'entiers par arete et
7333 c          indice dans nosoar de l'arete suivante dans le hachage
7334 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
7335 c          attention: mxsoar>3*mxsomm obligatoire!
7336 c moartr : nombre maximal d'entiers par arete du tableau noartr
7337 c
7338 c entrees et sorties :
7339 c --------------------
7340 c noarst : noarst(i) numero d'une arete de sommet i
7341 c n1soar : numero de la premiere arete vide dans le tableau nosoar
7342 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
7343 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
7344 c          chainage des aretes frontalieres, chainage du hachage des aretes
7345 c          hachage des aretes = nosoar(1)+nosoar(2)*2
7346 c n1artr : numero du premier triangle vide dans le tableau noartr
7347 c          le chainage des triangles vides se fait sur noartr(2,.)
7348 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
7349 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
7350 c
7351 c sorties:
7352 c --------
7353 c nbarcf : nombre d'aretes du cf
7354 c n1arcf : numero d'une arete de chaque contour
7355 c noarcf : numero des aretes de la ligne du contour ferme
7356 c attention: chainage circulaire des aretes
7357 c            les aretes vides pointes par n1arcf(0) ne sont pas chainees
7358 c ierr   :  0 si pas d'erreur
7359 c          14 si les lignes fermees se coupent => donnees a revoir
7360 c          15 si une seule arete simple frontaliere
7361 c          16 si boucle infinie car toutes les aretes simples
7362 c                de la boule sont frontalieres!
7363 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7364 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
7365 c....................................................................012
7366       parameter        (lchain=6)
7367       common / unites / lecteu, imprim, nunite(30)
7368       double precision  pxyd(3,*)
7369       integer           notrcf(1:nbtrcf)
7370       integer           nosoar(mosoar,mxsoar),
7371      %                  noartr(moartr,*),
7372      %                  n1arcf(0:*),
7373      %                  noarcf(3,*),
7374      %                  noarst(*)
7375 c
7376 c     formation des aretes simples du cf autour de l'arete ns1-ns2
7377 c     attention: le chainage lchain du tableau nosoar devient actif
7378 c     ============================================================
7379 c     ici toutes les aretes du tableau nosoar verifient nosoar(lchain,i) = -1
7380 c     ce qui equivaut a dire que l'etoile des aretes simples est vide
7381 c     (initialisation dans le sp insoar puis remise a -1 dans la suite!)
7382       n1aeoc = 0
7383 c
7384 c     ajout a l'etoile des aretes simples des 3 aretes des triangles a supprimer
7385 c     suppression des triangles de l'etoile pour les aretes simples de l'etoile
7386       do 10 i=1,nbtrcf
7387 c        ajout ou retrait des 3 aretes du triangle notrcf(i) de l'etoile
7388          nt = notrcf( i )
7389          do 5 j=1,3
7390 c           l'arete de nosoar a traiter
7391             noar = abs( noartr(j,nt) )
7392             call caetoi( noar,   mosoar, mxsoar, n1soar, nosoar,
7393      %                   n1aeoc, nbtrar  )
7394 c           si arete simple alors suppression du numero de triangle pour cette a
7395             if( nbtrar .eq. 1 ) then
7396                if( nosoar(4,noar) .eq. nt ) then
7397                   nosoar(4,noar) = nosoar(5,noar)
7398                endif
7399                nosoar(5,noar) = -1
7400 c           else
7401 c              l'arete appartient a aucun triangle => elle est vide
7402 c              les positions 4 et 5 servent maintenant aux chainages des vides
7403             endif
7404   5      continue
7405  10   continue
7406 c
7407 c     les aretes simples de l'etoile sont reordonnees pour former une
7408 c     ligne fermee = un contour ferme peripherique de l'etoile encore dit 1 cf
7409 c     ========================================================================
7410       n1ae00 = n1aeoc
7411  12   na1    = n1aeoc
7412 c     la premiere arete du contour ferme
7413       ns0 = nosoar(1,na1)
7414       ns1 = nosoar(2,na1)
7415 c
7416 c     l'arete est-elle dans le sens direct?
7417 c     recherche de l'arete du triangle exterieur nt d'arete na1
7418       nt = nosoar(4,na1)
7419       if( nt .le. 0 ) nt = nosoar(5,na1)
7420 c
7421 c     attention au cas de l'arete initiale frontaliere de no de triangles 0 et -
7422       if( nt .le. 0 ) then
7423 c        permutation circulaire des aretes simples chainees
7424 c        la premiere arete doit devenir la derniere du chainage,
7425 c        la 2=>1, la 3=>2, ... , la derniere=>l'avant derniere, 1=>derniere
7426          n1aeoc = nosoar( lchain, n1aeoc )
7427          if( n1aeoc .eq. n1ae00 ) then
7428 c           attention: boucle infinie si toutes les aretes simples
7429 c           de la boule sont frontalieres!... arretee par ce test
7430             ierr = 16
7431             return
7432          endif
7433          noar = n1aeoc
7434          na0  = 0
7435  14      if( noar .gt. 0 ) then
7436 c           la sauvegarde de l'arete et l'arete suivante
7437             na0  = noar
7438             noar = nosoar(lchain,noar)
7439             goto 14
7440          endif
7441          if( na0 .le. 0 ) then
7442 c           une seule arete simple frontaliere
7443             ierr = 15
7444             return
7445          endif
7446 c        le suivant de l'ancien dernier est l'ancien premier
7447          nosoar(lchain,na0) = na1
7448 c        le nouveau dernier est l'ancien premier
7449          nosoar(lchain,na1) = 0
7450          goto 12
7451       endif
7452 c
7453 c     ici l'arete na1 est l'une des aretes du triangle nt
7454       do 15 i=1,3
7455          if( abs(noartr(i,nt)) .eq. na1 ) then
7456 c           c'est l'arete
7457             if( noartr(i,nt) .gt. 0 ) then
7458 c              elle est parcourue dans le sens indirect de l'etoile
7459 c             (car c'est en fait le triangle exterieur a la boule)
7460                ns0 = nosoar(2,na1)
7461                ns1 = nosoar(1,na1)
7462             endif
7463             goto 17
7464          endif
7465  15   continue
7466 c
7467 c     le 1-er sommet ou arete du contour ferme
7468  17   n1arcf( 1 ) = 1
7469 c     le nombre de sommets du contour ferme de l'etoile
7470       nbarcf = 1
7471 c     le premier sommet de l'etoile
7472       noarcf( 1, nbarcf ) = ns0
7473 c     l'arete suivante du cf
7474       noarcf( 2, nbarcf ) = nbarcf + 1
7475 c     le numero de cette arete dans le tableau nosoar
7476       noarcf( 3, nbarcf ) = na1
7477 c     mise a jour du numero d'arete du sommet ns0
7478       noarst(ns0) = na1
7479 c
7480 cccc     trace de l'arete
7481 ccc      call dvtrar( pxyd, ns0, ns1, ncvert, ncblan )
7482 c
7483 c     l'arete suivante a chainer
7484       n1aeoc = nosoar( lchain, na1 )
7485 c     l'arete na1 n'est plus dans l'etoile
7486       nosoar( lchain, na1 ) = -1
7487 c
7488 c     boucle sur les aretes simples de l'etoile
7489  20   if( n1aeoc .gt. 0 ) then
7490 c
7491 c        recherche de l'arete de 1-er sommet ns1
7492          na0 = -1
7493          na1 = n1aeoc
7494  25      if( na1 .gt. 0 ) then
7495 c
7496 c           le numero du dernier sommet de l'arete precedente
7497 c           est il l'un des 2 sommets de l'arete na1?
7498             if ( ns1 .eq. nosoar(1,na1) ) then
7499 c               l'autre sommet de l'arete na1
7500                 ns2 = nosoar(2,na1)
7501             else if( ns1 .eq. nosoar(2,na1) ) then
7502 c               l'autre sommet de l'arete na1
7503                 ns2 = nosoar(1,na1)
7504             else
7505 c              non: passage a l'arete suivante
7506                na0 = na1
7507                na1 = nosoar( lchain, na1 )
7508                goto 25
7509             endif
7510 c
7511 c           oui: na1 est l'arete peripherique suivante
7512 c                na0 est sa precedente dans le chainage
7513 c           une arete de plus dans le contour ferme (cf)
7514             nbarcf = nbarcf + 1
7515 c           le premier sommet de l'arete nbarcf peripherique
7516             noarcf( 1, nbarcf ) = ns1
7517 c           l'arete suivante du cf
7518             noarcf( 2, nbarcf ) = nbarcf + 1
7519 c           le numero de cette arete dans le tableau nosoar
7520             noarcf( 3, nbarcf ) = na1
7521 c           mise a jour du numero d'arete du sommet ns1
7522             noarst(ns1) = na1
7523 c
7524 cccc           trace de l'arete
7525 ccc            call dvtrar( pxyd, ns1, ns2, ncvert, ncblan )
7526 c
7527 c           suppression de l'arete des aretes simples de l'etoile
7528             if( n1aeoc .eq. na1 ) then
7529                 n1aeoc = nosoar( lchain, na1 )
7530             else
7531                 nosoar( lchain, na0 ) = nosoar( lchain, na1 )
7532             endif
7533 c           l'arete n'est plus une arete simple de l'etoile
7534             nosoar( lchain, na1 ) = -1
7535 c
7536 c           le sommet final de l'arete a rechercher ensuite
7537             ns1 = ns2
7538             goto 20
7539          endif
7540       endif
7541 c
7542 c     verification
7543       if( ns1 .ne. ns0 ) then
7544 c        arete non retrouvee : l'etoile ne se referme pas
7545 c         nblgrc(nrerr) = 3
7546 c         kerr(1) = 'focftr: revoyez vos donnees'
7547 c         kerr(2) = 'les lignes fermees doivent etre disjointes'
7548 c         kerr(3) = 'verifiez si elles ne se coupent pas'
7549 c         call lereur
7550           write(imprim,*) 'focftr: revoyez vos donnees'
7551           write(imprim,*)'les lignes fermees doivent etre disjointes'
7552           write(imprim,*)'verifiez si elles ne se coupent pas'
7553          ierr = 14
7554          return
7555       endif
7556 c
7557 c     l'arete suivant la derniere arete du cf est la premiere du cf
7558 c     => realisation d'un chainage circulaire des aretes du cf
7559       noarcf( 2, nbarcf ) = 1
7560 c
7561 c     destruction des triangles de l'etoile du tableau noartr
7562 c     -------------------------------------------------------
7563       do 50 i=1,nbtrcf
7564 c        le numero du triangle dans noartr
7565          nt0 = notrcf( i )
7566 c        l'arete 1 de nt0 devient nulle
7567          noartr( 1, nt0 ) = 0
7568 c        chainage de nt0 en tete du chainage des triangles vides de noartr
7569          noartr( 2, nt0 ) = n1artr
7570          n1artr = nt0
7571  50   continue
7572       end
7573
7574
7575       subroutine int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x0, y0 )
7576 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7577 c but :    existence ou non  d'une intersection a l'interieur
7578 c -----    des 2 aretes ns1-ns2 et ns3-ns4
7579 c          attention les intersections au sommet sont comptees
7580 c
7581 c entrees:
7582 c --------
7583 c ns1,...ns4 : numero pxyd des 4 sommets
7584 c pxyd   : les coordonnees des sommets
7585 c
7586 c sortie :
7587 c --------
7588 c linter : -1 si ns3-ns4 parallele a ns1 ns2
7589 c           0 si ns3-ns4 n'intersecte pas ns1-ns2 entre les aretes
7590 c           1 si ns3-ns4   intersecte     ns1-ns2 entre les aretes
7591 c           2 si le point d'intersection est ns1  entre ns3-ns4
7592 c           3 si le point d'intersection est ns3  entre ns1-ns2
7593 c           4 si le point d'intersection est ns4  entre ns1-ns2
7594 c x0,y0  :  2 coordonnees du point d'intersection s'il existe(linter>=1)
7595 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7596 c auteur : alain perronnet  analyse numerique paris upmc    fevrier 1992
7597 c2345x7..............................................................012
7598       parameter        ( epsmoi=-0.000001d0, eps=0.001d0,
7599      %                   unmeps= 0.999d0, unpeps=1.000001d0 )
7600       double precision  pxyd(3,*), x0, y0
7601       double precision  x1,y1,x21,y21,d21,x43,y43,d43,d,x,y,p21,p43
7602 c
7603       x1  = pxyd(1,ns1)
7604       y1  = pxyd(2,ns1)
7605       x21 = pxyd(1,ns2) - x1
7606       y21 = pxyd(2,ns2) - y1
7607       d21 = x21**2 + y21**2
7608 c
7609       x43 = pxyd(1,ns4) - pxyd(1,ns3)
7610       y43 = pxyd(2,ns4) - pxyd(2,ns3)
7611       d43 = x43**2 + y43**2
7612 c
7613 c     les 2 aretes sont-elles jugees paralleles ?
7614       d = x43 * y21 - y43 * x21
7615       if( d*d .le. 0.000001d0 * d21 * d43 ) then
7616 c        cote i parallele a ns1-ns2
7617          linter = -1
7618          return
7619       endif
7620 c
7621 c     les 2 coordonnees du point d'intersection
7622       x =( x1*x43*y21-pxyd(1,ns3)*x21*y43-(y1-pxyd(2,ns3))*x21*x43)/d
7623       y =(-y1*y43*x21+pxyd(2,ns3)*y21*x43+(x1-pxyd(1,ns3))*y21*y43)/d
7624 c
7625 c     coordonnee barycentrique de x,y dans le repere ns1-ns2
7626       p21 = ( ( x - x1 )       * x21 + ( y - y1 )        * y21 ) / d21
7627 c     coordonnee barycentrique de x,y dans le repere ns3-ns4
7628       p43 = ( (x - pxyd(1,ns3))* x43 + (y - pxyd(2,ns3)) * y43 ) / d43
7629 c
7630 c
7631       if( epsmoi .le. p21 .and. p21 .le. unpeps ) then
7632 c        x,y est entre ns1-ns2
7633          if( (p21 .le. eps)  .and.
7634      %       (epsmoi .le. p43 .and. p43 .le. unpeps) ) then
7635 c           le point x,y est proche de ns1 et interne a ns3-ns4
7636             linter = 2
7637             x0 = pxyd(1,ns1)
7638             y0 = pxyd(2,ns1)
7639             return
7640          else if( epsmoi .le. p43 .and. p43 .le. eps ) then
7641 c           le point x,y est proche de ns3 et entre ns1-ns2
7642             linter = 3
7643             x0 = pxyd(1,ns3)
7644             y0 = pxyd(2,ns3)
7645             return
7646          else if( unmeps .le. p43 .and. p43 .le. unpeps ) then
7647 c           le point x,y est proche de ns4 et entre ns1-ns2
7648             linter = 4
7649             x0 = pxyd(1,ns4)
7650             y0 = pxyd(2,ns4)
7651             return
7652          else if( eps .le. p43 .and. p43 .le. unmeps ) then
7653 c           le point x,y est entre ns3-ns4
7654             linter = 1
7655             x0     = x
7656             y0     = y
7657             return
7658          endif
7659       endif
7660 c
7661 c     pas d'intersection a l'interieur des aretes
7662       linter = 0
7663       end
7664
7665
7666       subroutine tefoar( narete, nbarpi, pxyd,
7667      %                   mosoar, mxsoar, n1soar, nosoar,
7668      %                   moartr, n1artr, noartr, noarst,
7669      %                   mxarcf, n1arcf, noarcf, larmin, notrcf,
7670      %                   ierr )
7671 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7672 c but :   forcer l'arete narete de nosoar dans la triangulation actuelle
7673 c -----   triangulation frontale pour la reobtenir
7674 c
7675 c         attention: le chainage lchain(=6) de nosoar devient actif
7676 c                    durant la formation des contours fermes (cf)
7677 c
7678 c entrees:
7679 c --------
7680 c narete : numero nosoar de l'arete frontaliere a forcer
7681 c nbarpi : numero du dernier point interne impose par l'utilisateur
7682 c pxyd   : tableau des coordonnees 2d des points
7683 c          par point : x  y  distance_souhaitee
7684 c
7685 c mosoar : nombre maximal d'entiers par arete et
7686 c          indice dans nosoar de l'arete suivante dans le hachage
7687 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
7688 c          attention: mxsoar>3*mxsomm obligatoire!
7689 c moartr : nombre maximal d'entiers par arete du tableau noartr
7690 c
7691 c modifies:
7692 c ---------
7693 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
7694 c          chainage des vides suivant en 3 et precedant en 2 de nosoar
7695 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
7696 c          chainage des aretes frontalieres, chainage du hachage des aretes
7697 c          hachage des aretes = nosoar(1)+nosoar(2)*2
7698 c          avec mxsoar>=3*mxsomm
7699 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
7700 c          nosoar(2,arete vide)=l'arete vide qui precede
7701 c          nosoar(3,arete vide)=l'arete vide qui suit
7702 c n1artr : numero du premier triangle vide dans le tableau noartr
7703 c          le chainage des triangles vides se fait sur noartr(2,.)
7704 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
7705 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
7706 c noarst : noarst(i) numero d'une arete de sommet i
7707 c
7708 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
7709 c
7710 c tableaux auxiliaires :
7711 c ----------------------
7712 c n1arcf : tableau (0:mxarcf) auxiliaire
7713 c noarcf : tableau (3,mxarcf) auxiliaire
7714 c larmin : tableau (mxarcf)   auxiliaire
7715 c notrcf : tableau (1:mxarcf) auxiliaire
7716 c
7717 c sortie :
7718 c --------
7719 c ierr   : 0 si pas d'erreur
7720 c          1 saturation des sommets
7721 c          2 ns1 dans aucun triangle
7722 c          9 tableau nosoar de taille insuffisante car trop d'aretes
7723 c            a probleme
7724 c          10 un des tableaux n1arcf, noarcf notrcf est sature
7725 c             augmenter a l'appel mxarcf
7726 c          11 algorithme defaillant
7727 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7728 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
7729 c....................................................................012
7730       parameter        (mxpitr=32)
7731       common / unites / lecteu,imprim,intera,nunite(29)
7732       logical           tratri
7733       common / dv2dco / tratri
7734       double precision  pxyd(3,*)
7735       integer           noartr(moartr,*),
7736      %                  nosoar(mosoar,mxsoar),
7737      %                  noarst(*),
7738      %                  n1arcf(0:mxarcf),
7739      %                  noarcf(3,mxarcf),
7740      %                  larmin(mxarcf),
7741      %                  notrcf(mxarcf)
7742 c
7743       integer           lapitr(mxpitr)
7744       double precision  x1,y1,x2,y2,d12,d3,d4,x,y,d,dmin
7745       integer           nosotr(3), ns(2)
7746       integer           nacf(1:2), nacf1, nacf2
7747       equivalence      (nacf(1),nacf1), (nacf(2),nacf2)
7748 c
7749 c     traitement de cette arete perdue
7750       ns1 = nosoar( 1, narete )
7751       ns2 = nosoar( 2, narete )
7752 c
7753       if( tratri ) then
7754 c        les traces sont demandes
7755 c         call efface
7756 c        le cadre objet global en unites utilisateur
7757          xx1 = min( pxyd(1,ns1), pxyd(1,ns2) )
7758          xx2 = max( pxyd(1,ns1), pxyd(1,ns2) )
7759          yy1 = min( pxyd(2,ns1), pxyd(2,ns2) )
7760          yy2 = max( pxyd(2,ns1), pxyd(2,ns2) )
7761          if( xx1 .ge. xx2 ) xx2 = xx1 + (yy2-yy1)
7762          if( yy1 .ge. yy2 ) yy2 = yy1 + (xx2-xx1)*0.5
7763 c         call isofenetre( xx1-(xx2-xx1), xx2+(xx2-xx1),
7764 c     %                    yy1-(yy2-yy1), yy2+(yy2-yy1) )
7765       endif
7766 c
7767 cccc     trace de l'arete perdue
7768 ccc      call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
7769 c
7770 c     le sommet ns2 est il correct?
7771       na = noarst( ns2 )
7772       if( na .le. 0 ) then
7773          write(imprim,*) 'tefoar: erreur sommet ',ns2,' sans arete'
7774          ierr = 8
7775          return
7776       endif
7777       if( nosoar(4,na) .le. 0 ) then
7778          write(imprim,*) 'tefoar: erreur sommet ',ns2,
7779      %                   ' dans aucun triangle'
7780          ierr = 8
7781          return
7782       endif
7783 c
7784 c     recherche du triangle voisin dans le sens indirect de rotation
7785       nsens = -1
7786 c     le premier passage: recherche dans le sens ns1->ns2
7787       ipas = 0
7788 c
7789 c     recherche des triangles intersectes par le segment ns1-ns2
7790 c     ==========================================================
7791  3    x1  = pxyd(1,ns1)
7792       y1  = pxyd(2,ns1)
7793       x2  = pxyd(1,ns2)
7794       y2  = pxyd(2,ns2)
7795       d12 = (x2-x1)**2 + (y2-y1)**2
7796 c
7797 c     recherche du no local du sommet ns1 dans l'un de ses triangles
7798       na01 = noarst( ns1 )
7799       if( na01 .le. 0 ) then
7800          write(imprim,*) 'tefoar: sommet ',ns1,' sans arete'
7801          ierr = 8
7802          return
7803       endif
7804       nt0 = nosoar(4,na01)
7805       if( nt0 .le. 0 ) then
7806          write(imprim,*) 'tefoar: sommet ',ns1,' dans aucun triangle'
7807          ierr = 8
7808          return
7809       endif
7810 c
7811 c     le numero des 3 sommets du triangle nt0 dans le sens direct
7812  20   call nusotr( nt0, mosoar, nosoar, moartr, noartr, nosotr )
7813       do 22 na00=1,3
7814          if( nosotr(na00) .eq. ns1 ) goto 26
7815  22   continue
7816 c
7817  25   if( ipas .eq. 0 ) then
7818 c        le second passage: recherche dans le sens ns2->ns1
7819 c        tentative d'inversion des 2 sommets extremites de l'arete a forcer
7820          na00 = ns1
7821          ns1  = ns2
7822          ns2  = na00
7823          ipas = 1
7824          goto 3
7825       else
7826 c        les sens ns1->ns2 et ns2->ns1 ne donne pas de solution!
7827          write(imprim,*)'tefoar:arete ',ns1,' - ',ns2,' a imposer'
7828          write(imprim,*)'tefoar:anomalie sommet ',ns1,
7829      %   'non dans le triangle de sommets ',(nosotr(i),i=1,3)
7830          pause
7831          ierr = 11
7832          return
7833       endif
7834 c
7835 c     le numero des aretes suivante et precedente
7836  26   na0 = nosui3( na00 )
7837       na1 = nopre3( na00 )
7838       ns3 = nosotr( na0 )
7839       ns4 = nosotr( na1 )
7840 c
7841 cccc     trace du triangle nt0 et de l'arete perdue
7842 ccc      call mttrtr( pxyd, nt0, moartr, noartr, mosoar, nosoar,
7843 ccc     %             ncblan, ncjaun )
7844 ccc      call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
7845 ccc      call dvtrar( pxyd, ns3, ns4, ncbleu, nccyan )
7846 c
7847 c     point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
7848 c     ------------------------------------------------------------
7849       call int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x1, y1 )
7850       if( linter .le. 0 ) then
7851 c
7852 c        pas d'intersection: rotation autour du point ns1
7853 c        pour trouver le triangle de l'autre cote de l'arete na01
7854          if( nsens .lt. 0 ) then
7855 c           sens indirect de rotation: l'arete de sommet ns1
7856             na01 = abs( noartr(na00,nt0) )
7857          else
7858 c           sens direct de rotation: l'arete de sommet ns1 qui precede
7859             na01 = abs( noartr(na1,nt0) )
7860          endif
7861 c        le triangle de l'autre cote de l'arete na01
7862          if( nosoar(4,na01) .eq. nt0 ) then
7863             nt0 = nosoar(5,na01)
7864          else
7865             nt0 = nosoar(4,na01)
7866          endif
7867          if( nt0 .gt. 0 ) goto 20
7868 c
7869 c        le parcours sort du domaine
7870 c        il faut tourner dans l'autre sens autour de ns1
7871          if( nsens .lt. 0 ) then
7872             nsens = 1
7873             nt0   = noarst( ns1 )
7874             goto 20
7875          endif
7876 c
7877 c        dans les 2 sens, pas d'intersection => impossible
7878 c        essai avec l'arete inversee ns1 <-> ns2
7879          if( ipas .eq. 0 ) goto 25
7880          write(imprim,*) 'tefoar: arete ',ns1,' ',ns2,
7881      %  ' sans intersection avec les triangles actuels'
7882          write(imprim,*) 'revoyez les lignes du contour'
7883          ierr = 11
7884          return
7885       endif
7886 c
7887 c     il existe une intersection avec l'arete opposee au sommet ns1
7888 c     =============================================================
7889 c     nbtrcf : nombre de triangles du cf
7890       nbtrcf = 1
7891       notrcf( 1 ) = nt0
7892 c
7893 c     le triangle oppose a l'arete na0 de nt0
7894  30   noar = abs( noartr(na0,nt0) )
7895       if( nosoar(4,noar) .eq. nt0 ) then
7896          nt1 = nosoar(5,noar)
7897       else
7898          nt1 = nosoar(4,noar)
7899       endif
7900 c
7901 cccc     trace du triangle nt1 et de l'arete perdue
7902 ccc      call mttrtr( pxyd, nt1, moartr, noartr, mosoar, nosoar,
7903 ccc     %             ncjaun, ncmage )
7904 ccc      call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
7905 c
7906 c     le numero des 3 sommets du triangle nt1 dans le sens direct
7907       call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
7908 c
7909 c     le triangle nt1 contient il ns2 ?
7910       do 32 j=1,3
7911          if( nosotr(j) .eq. ns2 ) goto 70
7912  32   continue
7913 c
7914 c     recherche de l'arete noar, na1 dans nt1 qui est l'arete na0 de nt0
7915       do 34 na1=1,3
7916          if( abs( noartr(na1,nt1) ) .eq. noar ) goto 35
7917  34   continue
7918 c
7919 c     trace du triangle nt1 et de l'arete perdue
7920  35   continue
7921 ccc 35   call mttrtr( pxyd, nt1, moartr, noartr, mosoar, nosoar,
7922 ccc     %             ncjaun, ncmage )
7923 ccc      call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
7924 c
7925 c     recherche de l'intersection de ns1-ns2 avec les 2 autres aretes de nt1
7926 c     ======================================================================
7927       na2 = na1
7928       do 50 i1 = 1,2
7929 c        l'arete suivante
7930          na2 = nosui3(na2)
7931 c
7932 c        les 2 sommets de l'arete na2 de nt1
7933          noar = abs( noartr(na2,nt1) )
7934          ns3  = nosoar( 1, noar )
7935          ns4  = nosoar( 2, noar )
7936 ccc         call dvtrar( pxyd, ns3, ns4, ncbleu, nccyan )
7937 c
7938 c        point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
7939 c        ------------------------------------------------------------
7940          call int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x , y )
7941          if( linter .gt. 0 ) then
7942 c
7943 c           les 2 aretes s'intersectent en (x,y)
7944 c           distance de (x,y) a ns3 et ns4
7945             d3 = (pxyd(1,ns3)-x)**2 + (pxyd(2,ns3)-y)**2
7946             d4 = (pxyd(1,ns4)-x)**2 + (pxyd(2,ns4)-y)**2
7947 c           nsp est le point le plus proche de (x,y)
7948             if( d3 .lt. d4 ) then
7949                nsp = ns3
7950                d   = d3
7951             else
7952                nsp = ns4
7953                d   = d4
7954             endif
7955             if( d .gt. 1d-5*d12 ) goto 60
7956 c
7957 c           ici le sommet nsp est trop proche de l'arete perdue ns1-ns2
7958             if( nsp .le. nbarpi ) then
7959 c              point utilisateur ou frontalier non supprimable
7960                ierr = 11
7961                write(imprim,*) 'pause dans tefoar 1', d, d3, d4, d12
7962                pause
7963                return
7964             endif
7965 c
7966 c           le sommet interne nsp est supprime en mettant tous les triangles
7967 c           l'ayant comme sommet dans la pile notrcf des triangles a supprimer
7968 c           ------------------------------------------------------------------
7969 ccc            write(imprim,*) 'tefoar: le sommet ',nsp,' est supprime'
7970 c           construction de la liste des triangles de sommet nsp
7971             call trp1st( nsp, noarst, mosoar, nosoar, moartr, noartr,
7972      %                   mxpitr, nbt, lapitr )
7973             if( nbt .le. 0 ) then
7974 c              les triangles de sommet nsp ne forme pas une "boule"
7975 c              avec ce sommet nsp pour "centre"
7976                write(imprim,*)
7977      %        'tefoar: pas d''etoile de triangles autour du sommet',nsp
7978 cccc              trace des triangles de l'etoile du sommet nsp
7979 ccc               tratri = .true.
7980 ccc               call trpltr( nbt,    lapitr, pxyd,
7981 ccc     %                      moartr, noartr, mosoar, nosoar,
7982 ccc     %                      ncroug, ncblan )
7983 ccc               tratri = .false.
7984                ierr = 11
7985                write(imprim,*) 'pause dans tefoar 2'
7986                pause
7987                return
7988             endif
7989 c
7990 c           ajout des triangles de sommet ns1 a notrcf
7991             nbtrc0 = nbtrcf
7992             do 38 j=1,nbt
7993                nt = lapitr(j)
7994                do 37 k=nbtrcf,1,-1
7995                   if( nt .eq. notrcf(k) ) goto 38
7996  37            continue
7997 c              triangle ajoute
7998                nbtrcf = nbtrcf + 1
7999                notrcf( nbtrcf ) = nt
8000 ccc               call mttrtr( pxyd, nt, moartr, noartr, mosoar, nosoar,
8001 ccc     %                      ncjaun, ncmage )
8002 ccc               call dvtrar( pxyd, ns1, ns2, ncroug, ncblan )
8003  38         continue
8004 c
8005 c           ce sommet supprime n'appartient plus a aucun triangle
8006             noarst( nsp ) = 0
8007 c
8008 c           ns2 est-il un sommet des triangles empiles?
8009 c           -------------------------------------------
8010             do 40 nt=nbtrc0+1,nbtrcf
8011 c              le triangle a supprimer nt
8012                nt1 = notrcf( nt )
8013 c              le numero des 3 sommets du triangle nt1 dans le sens direct
8014                call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr)
8015                do 39 k=1,3
8016 c                 le sommet k de nt1
8017                   if( nosotr( k ) .eq. ns2 ) then
8018 c                    but atteint
8019                      goto 80
8020                   endif
8021  39            continue
8022  40         continue
8023 c
8024 c           recherche du plus proche point d'intersection de ns1-ns2
8025 c           par rapport a ns2 avec les aretes des triangles ajoutes
8026             nt0  = 0
8027             dmin = d12 * 10000
8028             do 48 nt=nbtrc0+1,nbtrcf
8029                nt1 = notrcf( nt )
8030 c              le numero des 3 sommets du triangle nt1 dans le sens direct
8031                call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr)
8032                do 45 k=1,3
8033 c                 les 2 sommets de l'arete k de nt
8034                   ns3 = nosotr( k )
8035                   ns4 = nosotr( nosui3(k) )
8036 c
8037 c                 point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
8038 c                 ------------------------------------------------------------
8039                   call int1sd( ns1, ns2, ns3, ns4, pxyd,
8040      %                         linter, x , y )
8041                   if( linter .gt. 0 ) then
8042 c                    les 2 aretes s'intersectent en (x,y)
8043                      d = (x-x2)**2+(y-y2)**2
8044                      if( d .lt. dmin ) then
8045                         nt0  = nt1
8046                         na0  = k
8047                         dmin = d
8048                      endif
8049                   endif
8050  45            continue
8051  48         continue
8052 c
8053 c           redemarrage avec le triangle nt0 et l'arete na0
8054             if( nt0 .gt. 0 ) goto 30
8055 c
8056             write(imprim,*) 'tefoar: algorithme defaillant'
8057             ierr = 11
8058             pause
8059             return
8060          endif
8061  50   continue
8062 c
8063 c     pas d'intersection differente de l'initiale => sommet sur ns1-ns2
8064 c     rotation autour du sommet par l'arete suivant na1
8065       write(imprim,*)
8066       write(imprim,*) 'tefoar 50: revoyez vos donnees'
8067       write(imprim,*) 'les lignes fermees doivent etre disjointes'
8068       write(imprim,*) 'verifiez si elles ne se coupent pas'
8069       ierr = 13
8070       pause
8071       return
8072 c
8073 c     cas sans probleme : intersection differente de celle initiale
8074 c     =================   =========================================
8075  60   nbtrcf = nbtrcf + 1
8076       notrcf( nbtrcf ) = nt1
8077 c     passage au triangle suivant
8078       na0 = na2
8079       nt0 = nt1
8080       goto 30
8081 c
8082 c     ----------------------------------------------------------
8083 c     ici toutes les intersections de ns1-ns2 ont ete parcourues
8084 c     tous les triangles intersectes ou etendus forment les
8085 c     nbtrcf triangles du tableau notrcf
8086 c     ----------------------------------------------------------
8087  70   nbtrcf = nbtrcf + 1
8088       notrcf( nbtrcf ) = nt1
8089 c
8090 c     formation du cf des aretes simples des triangles de notrcf
8091 c     et destruction des nbtrcf triangles du tableau noartr
8092 c     attention: le chainage lchain du tableau nosoar devient actif
8093 c     =============================================================
8094  80   if( nbtrcf*3 .gt. mxarcf ) then
8095          write(imprim,*) 'saturation du tableau noarcf'
8096          ierr = 10
8097          return
8098       endif
8099 c
8100       call focftr( nbtrcf, notrcf, pxyd,   noarst,
8101      %             mosoar, mxsoar, n1soar, nosoar,
8102      %             moartr, n1artr, noartr,
8103      %             nbarcf, n1arcf, noarcf,
8104      %             ierr )
8105       if( ierr .ne. 0 ) return
8106 c
8107 c     chainage des aretes vides dans le tableau noarcf
8108 c     ------------------------------------------------
8109 c     decalage de 2 aretes car 2 aretes sont necessaires ensuite pour
8110 c     integrer 2 fois l'arete perdue et former ainsi 2 cf
8111 c     comme nbtrcf*3 minore mxarcf il existe au moins 2 places vides
8112 c     derriere => pas de test de debordement
8113       n1arcf(0) = nbarcf+3
8114       mmarcf = min(8*nbarcf,mxarcf)
8115       do 90 i=nbarcf+3,mmarcf
8116          noarcf(2,i) = i+1
8117  90   continue
8118       noarcf(2,mmarcf) = 0
8119 c
8120 c     reperage des sommets ns1 ns2 de l'arete perdue dans le cf
8121 c     ---------------------------------------------------------
8122       ns1   = nosoar( 1, narete )
8123       ns2   = nosoar( 2, narete )
8124       ns(1) = ns1
8125       ns(2) = ns2
8126       do 120 i=1,2
8127 c        la premiere arete dans noarcf du cf
8128          na0 = n1arcf(1)
8129  110     if( noarcf(1,na0) .ne. ns(i) ) then
8130 c           passage a l'arete suivante
8131             na0 = noarcf( 2, na0 )
8132             goto 110
8133          endif
8134 c        position dans noarcf du sommet i de l'arete perdue
8135          nacf(i) = na0
8136  120  continue
8137 c
8138 c     formation des 2 cf chacun contenant l'arete ns1-ns2
8139 c     ---------------------------------------------------
8140 c     sauvegarde de l'arete suivante de celle de sommet ns1
8141       na0 = noarcf( 2, nacf1 )
8142       nt1 = noarcf( 3, nacf1 )
8143 c
8144 c     le premier cf
8145       n1arcf( 1 ) = nacf1
8146 c     l'arete suivante dans le premier cf
8147       noarcf( 2, nacf1 ) = nacf2
8148 c     cette arete est celle perdue
8149       noarcf( 3, nacf1 ) = narete
8150 c
8151 c     le second cf
8152 c     l'arete doublee
8153       n1 = nbarcf + 1
8154       n2 = nbarcf + 2
8155 c     le premier sommet de la premiere arete du second cf
8156       noarcf( 1, n1 ) = ns2
8157 c     l'arete suivante dans le second cf
8158       noarcf( 2, n1 ) = n2
8159 c     cette arete est celle perdue
8160       noarcf( 3, n1 ) = narete
8161 c     la seconde arete du second cf
8162       noarcf( 1, n2 ) = ns1
8163       noarcf( 2, n2 ) = na0
8164       noarcf( 3, n2 ) = nt1
8165       n1arcf( 2 ) = n1
8166 c
8167 c     recherche du precedent de nacf2
8168  130  na1 = noarcf( 2, na0 )
8169       if( na1 .ne. nacf2 ) then
8170 c        passage a l'arete suivante
8171          na0 = na1
8172          goto 130
8173       endif
8174 c     na0 precede nacf2 => il precede n1
8175       noarcf( 2, na0 ) = n1
8176 c
8177 c     depart avec 2 cf
8178       nbcf   = 2
8179 c
8180 c     triangulation directe des 2 contours fermes
8181 c     l'arete ns1-ns2 devient une arete de la triangulation des 2 cf
8182 c     ==============================================================
8183       call tridcf( nbcf,   pxyd,   noarst,
8184      %             mosoar, mxsoar, n1soar, nosoar,
8185      %             moartr, n1artr, noartr,
8186      %             mxarcf, n1arcf, noarcf, larmin,
8187      %             nbtrcf, notrcf, ierr )
8188       end
8189
8190
8191       subroutine te4ste( nbsomm, mxsomm, pxyd, ntrp, letree,
8192      &                   ierr )
8193 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8194 c but :    decouper un te ntrp de letree en 4 sous-triangles
8195 c -----    eliminer les sommets de te trop proches des points
8196 c
8197 c entrees:
8198 c --------
8199 c mxsomm : nombre maximal de points declarables dans pxyd
8200 c ntrp   : numero letree du triangle a decouper en 4 sous-triangles
8201 c
8202 c modifies :
8203 c ----------
8204 c nbsomm : nombre actuel de points dans pxyd
8205 c pxyd   : tableau des coordonnees des points
8206 c          par point : x  y  distance_souhaitee
8207 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
8208 c      letree(0,0) :  no du 1-er te vide dans letree
8209 c      letree(0,1) : maximum du 1-er indice de letree (ici 8)
8210 c      letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
8211 c      letree(0:8,1) : racine de l'arbre  (triangle sans sur triangle)
8212 c      si letree(0,.)>0 alors
8213 c         letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
8214 c      sinon
8215 c         letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
8216 c                         0  si pas de point
8217 c                        ( j est alors une feuille de l'arbre )
8218 c      letree(4,j) : no letree du sur-triangle du triangle j
8219 c      letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
8220 c      letree(6:8,j) : no pxyd des 3 sommets du triangle j
8221 c
8222 c sorties :
8223 c ---------
8224 c ierr    : 0 si pas d'erreur, 51 saturation letree, 52 saturation pxyd
8225 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8226 c auteur : alain perronnet  analyse numerique paris upmc    juillet 1994
8227 c2345x7..............................................................012
8228       common / unites / lecteu,imprim,nunite(30)
8229       integer           letree(0:8,0:*)
8230       double precision  pxyd(3,mxsomm)
8231       integer           np(0:3),milieu(3)
8232 c
8233 c     debut par l'arete 2 du triangle ntrp
8234       i1 = 2
8235       i2 = 3
8236       do 30 i=1,3
8237 c
8238 c        le milieu de l'arete i1 existe t il deja ?
8239          call n1trva( ntrp, i1, letree, noteva, niveau )
8240          if( noteva .gt. 0 ) then
8241 c           il existe un te voisin
8242 c           s'il existe 4 sous-triangles le milieu existe deja
8243             if( letree(0,noteva) .gt. 0 ) then
8244 c              le milieu existe
8245                nsot = letree(0,noteva)
8246                milieu(i) = letree( 5+nopre3(i1), nsot )
8247                goto 25
8248             endif
8249          endif
8250 c
8251 c        le milieu n'existe pas. il est cree
8252          nbsomm = nbsomm + 1
8253          if( nbsomm .gt. mxsomm ) then
8254 c           plus assez de place dans pxyd
8255             write(imprim,*) 'te4ste: saturation pxyd'
8256             write(imprim,*)
8257             ierr = 52
8258             return
8259          endif
8260 c        le milieu de l'arete i
8261          milieu(i) = nbsomm
8262 c
8263 c        ntrp est le triangle de milieux d'arete ces 3 sommets
8264          ns1    = letree( 5+i1, ntrp )
8265          ns2    = letree( 5+i2, ntrp )
8266          pxyd(1,nbsomm) = ( pxyd(1,ns1) + pxyd(1,ns2) ) * 0.5
8267          pxyd(2,nbsomm) = ( pxyd(2,ns1) + pxyd(2,ns2) ) * 0.5
8268 c
8269 c        l'arete et milieu suivant
8270  25      i1 = i2
8271          i2 = nosui3( i2 )
8272  30   continue
8273 c
8274       do 50 i=0,3
8275 c
8276 c        le premier triangle vide
8277          nsot = letree(0,0)
8278          if( nsot .le. 0 ) then
8279 c           manque de place. saturation letree
8280             ierr = 51
8281             write(imprim,*) 'te4ste: saturation letree'
8282             write(imprim,*)
8283             return
8284          endif
8285 c
8286 c        mise a jour du premier te libre
8287          letree(0,0) = letree(0,nsot)
8288 c
8289 c        nsot est le i-eme sous triangle
8290          letree(0,nsot) = 0
8291          letree(1,nsot) = 0
8292          letree(2,nsot) = 0
8293          letree(3,nsot) = 0
8294 c
8295 c        le numero des points et sous triangles dans ntrp
8296          np(i) = -letree(i,ntrp)
8297          letree(i,ntrp) = nsot
8298 c
8299 c        le sommet commun avec le triangle ntrp
8300          letree(5+i,nsot) = letree(5+i,ntrp)
8301 c
8302 c        le sur-triangle et numero de sous-triangle de nsot
8303 c        a laisser ici car incorrect sinon pour i=0
8304          letree(4,nsot) = ntrp
8305          letree(5,nsot) = i
8306 c
8307 c        le sous-triangle du triangle
8308          letree(i,ntrp) = nsot
8309  50   continue
8310 c
8311 c     le numero des nouveaux sommets milieux
8312       nsot = letree(0,ntrp)
8313       letree(6,nsot) = milieu(1)
8314       letree(7,nsot) = milieu(2)
8315       letree(8,nsot) = milieu(3)
8316 c
8317       nsot = letree(1,ntrp)
8318       letree(7,nsot) = milieu(3)
8319       letree(8,nsot) = milieu(2)
8320 c
8321       nsot = letree(2,ntrp)
8322       letree(6,nsot) = milieu(3)
8323       letree(8,nsot) = milieu(1)
8324 c
8325       nsot = letree(3,ntrp)
8326       letree(6,nsot) = milieu(2)
8327       letree(7,nsot) = milieu(1)
8328 c
8329 c     repartition des eventuels 4 points np dans ces 4 sous-triangles
8330 c     il y a obligatoirement suffisamment de place
8331       do 110 i=0,3
8332          if( np(i) .gt. 0 ) then
8333             nsot = notrpt( pxyd(1,np(i)), pxyd, ntrp, letree )
8334 c           ajout du point
8335             do 100 i1=0,3
8336                if( letree(i1,nsot) .eq. 0 ) then
8337 c                 place libre a occuper
8338                   letree(i1,nsot) = -np(i)
8339                   goto 110
8340                endif
8341  100        continue
8342          endif
8343  110  continue
8344       end