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