src/MEFISTO2/trte.f

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