src/MEFISTO2/trte.f

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