src/MEFISTO2/trte.f

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