Back to index

salome-smesh  6.5.0
trte.f
Go to the documentation of this file.
00001 c  MEFISTO2: a library to compute 2D triangulation from segmented boundaries
00002 c
00003 c Copyright (C) 2006-2012  CEA/DEN, EDF R&D, OPEN CASCADE
00004 c
00005 c This library is free software; you can redistribute it and/or
00006 c modify it under the terms of the GNU Lesser General Public
00007 c License as published by the Free Software Foundation; either
00008 c version 2.1 of the License.
00009 c
00010 c This library is distributed in the hope that it will be useful,
00011 c but WITHOUT ANY WARRANTY; without even the implied warranty of
00012 c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00013 c Lesser General Public License for more details.
00014 c
00015 c You should have received a copy of the GNU Lesser General Public
00016 c License along with this library; if not, write to the Free Software
00017 c Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
00018 c
00019 c See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com
00020 c
00021 c  File   : trte.f    le Fortran du trianguleur plan
00022 c  Module : SMESH
00023 c  Author : Alain PERRONNET
00024 c  Date   : 13 novembre 2006
00025 
00026       double precision  function diptdr( pt , p1dr , p2dr )
00027 c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++012
00028 c but : calculer la distance entre un point et une droite
00029 c ----- definie par 2 points p1dr et p2dr
00030 c
00031 c entrees :
00032 c ---------
00033 c pt        : le point de R ** 2
00034 c p1dr p2dr : les 2 points de R ** 2  de la droite
00035 c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++012
00036 c programmeur : alain perronnet analyse numrique paris  janvier 1986
00037 c....................................................................012
00038       double precision  pt(2),p1dr(2),p2dr(2), a, b, c
00039 c
00040 c     les coefficients de la droite a x + by + c =0
00041       a = p2dr(2) - p1dr(2)
00042       b = p1dr(1) - p2dr(1)
00043       c = - a * p1dr(1) - b * p1dr(2)
00044 c
00045 c     la distance = | a * x + b * y + c | / sqrt( a*a + b*b )
00046       diptdr = abs( a * pt(1) + b * pt(2) + c ) / sqrt( a*a + b*b )
00047       end
00048 
00049       subroutine qutr2d( p1, p2, p3, qualite )
00050 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00051 c but :     calculer la qualite d'un triangle de r**2
00052 c -----     2 coordonnees des 3 sommets en double precision
00053 c
00054 c entrees :
00055 c ---------
00056 c p1,p2,p3 : les 3 coordonnees des 3 sommets du triangle
00057 c            sens direct pour une surface et qualite >0
00058 c sorties :
00059 c ---------
00060 c qualite: valeur de la qualite du triangle entre 0 et 1 (equilateral)
00061 c          1 etant la qualite optimale
00062 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00063 c auteur : alain perronnet analyse numerique upmc paris     janvier 1995
00064 c2345x7..............................................................012
00065       parameter  ( d2uxr3 = 3.4641016151377544d0 )
00066 c                  d2uxr3 = 2 * sqrt(3)
00067       double precision  p1(2), p2(2), p3(2), qualite, a, b, c, p
00068 c
00069 c     la longueur des 3 cotes
00070       a = sqrt( (p2(1)-p1(1))**2 + (p2(2)-p1(2))**2 )
00071       b = sqrt( (p3(1)-p2(1))**2 + (p3(2)-p2(2))**2 )
00072       c = sqrt( (p1(1)-p3(1))**2 + (p1(2)-p3(2))**2 )
00073 c
00074 c     demi perimetre
00075       p = (a+b+c) * 0.5d0
00076 c
00077       if ( (a*b*c) .ne. 0d0 ) then
00078 c        critere : 2 racine(3) * rayon_inscrit / plus longue arete
00079          qualite = d2uxr3 * sqrt( abs( (p-a) / p * (p-b) * (p-c) ) )
00080      %          / max(a,b,c)
00081       else
00082          qualite = 0d0
00083       endif
00084 c
00085 c
00086 c     autres criteres possibles:
00087 c     critere : 2 * rayon_inscrit / rayon_circonscrit
00088 c     qualite = 8d0 * (p-a) * (p-b) * (p-c) / (a * b * c)
00089 c
00090 c     critere : 3*sqrt(3.) * ray_inscrit / demi perimetre
00091 c     qualite = 3*sqrt(3.) * sqrt ((p-a)*(p-b)*(p-c) / p**3)
00092 c
00093 c     critere : 2*sqrt(3.) * ray_inscrit / max( des aretes )
00094 c     qualite = 2*sqrt(3.) * sqrt( (p-a)*(p-b)*(p-c) / p ) / max(a,b,c)
00095       end
00096 
00097 
00098       double precision function surtd2( p1 , p2 , p3 )
00099 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00100 c but : calcul de la surface d'un triangle defini par 3 points de R**2
00101 c -----
00102 c parametres d entree :
00103 c ---------------------
00104 c p1 p2 p3 : les 3 fois 2 coordonnees des sommets du triangle
00105 c
00106 c parametre resultat :
00107 c --------------------
00108 c surtd2 : surface du triangle
00109 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00110 c auteur : alain perronnet analyse numerique upmc paris     fevrier 1992
00111 c2345x7..............................................................012
00112       double precision  p1(2), p2(2), p3(2)
00113 c
00114 c     la surface du triangle
00115       surtd2 = ( ( p2(1)-p1(1) ) * ( p3(2)-p1(2) )
00116      %         - ( p2(2)-p1(2) ) * ( p3(1)-p1(1) ) ) * 0.5d0
00117       end
00118 
00119       integer function nopre3( i )
00120 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00121 c but :   numero precedent i dans le sens circulaire  1 2 3 1 ...
00122 c -----
00123 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00124 c auteur : alain perronnet  analyse numerique paris upmc    fevrier 1992
00125 c2345x7..............................................................012
00126       if( i .eq. 1 ) then
00127          nopre3 = 3
00128       else
00129          nopre3 = i - 1
00130       endif
00131       end
00132 
00133       integer function nosui3( i )
00134 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00135 c but :   numero suivant i dans le sens circulaire  1 2 3 1 ...
00136 c -----
00137 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00138 c auteur : alain perronnet  analyse numerique paris upmc    fevrier 1992
00139 c2345x7..............................................................012
00140       if( i .eq. 3 ) then
00141          nosui3 = 1
00142       else
00143          nosui3 = i + 1
00144       endif
00145       end
00146 
00147       subroutine provec( v1 , v2 , v3 )
00148 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00149 c but :    v3 vecteur = produit vectoriel de 2 vecteurs de r ** 3
00150 c -----
00151 c entrees:
00152 c --------
00153 c v1, v2 : les 2 vecteurs de 3 composantes
00154 c
00155 c sortie :
00156 c --------
00157 c v3     : vecteur = v1  produit vectoriel v2
00158 cc++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00159 c auteur : perronnet alain upmc analyse numerique paris        mars 1987
00160 c2345x7..............................................................012
00161       double precision    v1(3), v2(3), v3(3)
00162 c
00163       v3( 1 ) = v1( 2 ) * v2( 3 ) - v1( 3 ) * v2( 2 )
00164       v3( 2 ) = v1( 3 ) * v2( 1 ) - v1( 1 ) * v2( 3 )
00165       v3( 3 ) = v1( 1 ) * v2( 2 ) - v1( 2 ) * v2( 1 )
00166 c
00167       return
00168       end
00169 
00170       subroutine norme1( n, v, ierr )
00171 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00172 c but :   normalisation euclidienne a 1 d un vecteur v de n composantes
00173 c -----
00174 c entrees :
00175 c ---------
00176 c n       : nombre de composantes du vecteur
00177 c
00178 c modifie :
00179 c ---------
00180 c v       : le vecteur a normaliser a 1
00181 c
00182 c sortie  :
00183 c ---------
00184 c ierr    : 1 si la norme de v est egale a 0
00185 c           0 si pas d'erreur
00186 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00187 c auteur : alain perronnet analyse numerique paris             mars 1987
00188 c ......................................................................
00189       double precision  v( n ), s, sqrt
00190 c
00191       s = 0.0d0
00192       do 10 i=1,n
00193          s = s + v( i ) * v( i )
00194    10 continue
00195 c
00196 c     test de nullite de la norme du vecteur
00197 c     --------------------------------------
00198       if( s .le. 0.0d0 ) then
00199 c        norme nulle du vecteur non normalisable a 1
00200          ierr = 1
00201          return
00202       endif
00203 c
00204       s = 1.0d0 / sqrt( s )
00205       do 20 i=1,n
00206          v( i ) = v ( i ) * s
00207    20 continue
00208 c
00209       ierr = 0
00210       end
00211 
00212 
00213       subroutine insoar( mxsomm, mosoar, mxsoar, n1soar, nosoar )
00214 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00215 c but :    initialiser le tableau nosoar pour le hachage des aretes
00216 c -----
00217 c
00218 c entrees:
00219 c --------
00220 c mxsomm : plus grand numero de sommet d'une arete au cours du calcul
00221 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
00222 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
00223 c          avec mxsoar>=3*mxsomm
00224 c
00225 c sorties:
00226 c --------
00227 c n1soar : numero de la premiere arete vide dans le tableau nosoar
00228 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
00229 c          chainage des aretes vides amont et aval
00230 c          l'arete vide qui precede=nosoar(4,i)
00231 c          l'arete vide qui suit   =nosoar(5,i)
00232 c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
00233 c          chainage momentan'e d'aretes, chainage du hachage des aretes
00234 c          hachage des aretes = min( nosoar(1), nosoar(2) )
00235 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00236 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
00237 c2345x7..............................................................012
00238       integer   nosoar(mosoar,mxsoar)
00239 c
00240 c     initialisation des aretes 1 a mxsomm
00241       do 10 i=1,mxsomm
00242 c
00243 c        sommet 1 = 0 <=> temoin d'arete vide pour le hachage
00244          nosoar( 1, i ) = 0
00245 c
00246 c        arete sur aucune ligne
00247          nosoar( 3, i ) = 0
00248 c
00249 c        la position de l'arete interne ou frontaliere est inconnue
00250          nosoar( 6, i ) = -2
00251 c
00252 c        fin de chainage du hachage pas d'arete suivante
00253          nosoar( mosoar, i ) = 0
00254 c
00255  10   continue
00256 c
00257 c     la premiere arete vide chainee est la mxsomm+1 du tableau
00258 c     car ces aretes ne sont pas atteignables par le hachage direct
00259       n1soar = mxsomm + 1
00260 c
00261 c     initialisation des aretes vides et des chainages
00262       do 20 i = n1soar, mxsoar
00263 c
00264 c        sommet 1 = 0 <=> temoin d'arete vide pour le hachage
00265          nosoar( 1, i ) = 0
00266 c
00267 c        arete sur aucune ligne
00268          nosoar( 3, i ) = 0
00269 c
00270 c        chainage sur l'arete vide qui precede
00271 c        (si arete occupee cela deviendra le no du triangle 1 de l'arete)
00272          nosoar( 4, i ) = i-1
00273 c
00274 c        chainage sur l'arete vide qui suit
00275 c        (si arete occupee cela deviendra le no du triangle 2 de l'arete)
00276          nosoar( 5, i ) = i+1
00277 c
00278 c        chainages des aretes frontalieres ou internes ou ...
00279          nosoar( 6, i ) = -2
00280 c
00281 c        fin de chainage du hachage
00282          nosoar( mosoar, i ) = 0
00283 c
00284  20   continue
00285 c
00286 c     la premiere arete vide n'a pas de precedent
00287       nosoar( 4, n1soar ) = 0
00288 c
00289 c     la derniere arete vide est mxsoar sans arete vide suivante
00290       nosoar( 5, mxsoar ) = 0
00291       end
00292 
00293 
00294       subroutine azeroi ( l , ntab )
00295 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00296 c but : initialisation a zero d un tableau ntab de l variables entieres
00297 c -----
00298 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00299 c auteur : alain perronnet analyse numerique upmc paris septembre 1988
00300 c23456---------------------------------------------------------------012
00301       integer ntab(l)
00302       do 1 i = 1 , l
00303          ntab( i ) = 0
00304     1 continue
00305       end
00306 
00307 
00308       subroutine fasoar( ns1,    ns2,    nt1,    nt2,    nolign,
00309      %                   mosoar, mxsoar, n1soar, nosoar, noarst,
00310      %                   noar,   ierr )
00311 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00312 c but :    former l'arete de sommet ns1-ns2 dans le hachage du tableau
00313 c -----    nosoar des aretes de la triangulation
00314 c
00315 c entrees:
00316 c --------
00317 c ns1 ns2: numero pxyd des 2 sommets de l'arete
00318 c nt1    : numero du triangle auquel appartient l'arete
00319 c          nt1=-1 si numero inconnu
00320 c nt2    : numero de l'eventuel second triangle de l'arete si connu
00321 c          nt2=-1 si numero inconnu
00322 c nolign : numero de la ligne de l'arete dans ladefi(wulftr-1+nolign)
00323 c          =0 si l'arete n'est une arete de ligne
00324 c          ce numero est ajoute seulement si l'arete est creee
00325 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
00326 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
00327 c
00328 c modifies:
00329 c ---------
00330 c n1soar : numero de la premiere arete vide dans le tableau nosoar
00331 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
00332 c          chainage des aretes vides amont et aval
00333 c          l'arete vide qui precede=nosoar(4,i)
00334 c          l'arete vide qui suit   =nosoar(5,i)
00335 c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
00336 c          chainage momentan'e d'aretes, chainage du hachage des aretes
00337 c          hachage des aretes = min( nosoar(1), nosoar(2) )
00338 c noarst : noarst(np) numero d'une arete du sommet np
00339 c
00340 c ierr   : si < 0  en entree pas d'affichage en cas d'erreur du type
00341 c         "arete appartenant a plus de 2 triangles et a creer!"
00342 c          si >=0  en entree       affichage de ce type d'erreur
00343 c
00344 c sorties:
00345 c --------
00346 c noar   : >0 numero de l'arete retrouvee ou ajoutee
00347 c ierr   : =0 si pas d'erreur
00348 c          =1 si le tableau nosoar est sature
00349 c          =2 si arete a creer et appartenant a 2 triangles distincts
00350 c             des triangles nt1 et nt2
00351 c          =3 si arete appartenant a 2 triangles distincts
00352 c             differents des triangles nt1 et nt2
00353 c          =4 si arete appartenant a 2 triangles distincts
00354 c             dont le second n'est pas le triangle nt2
00355 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00356 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
00357 c2345x7..............................................................012
00358       parameter        (lchain=6)
00359       common / unites / lecteu, imprim, nunite(30)
00360       integer           nosoar(mosoar,mxsoar), noarst(*)
00361       integer           nu2sar(2)
00362 c
00363       ierr = 0
00364 c
00365 c     ajout eventuel de l'arete s1 s2 dans nosoar
00366       nu2sar(1) = ns1
00367       nu2sar(2) = ns2
00368 c
00369 c     hachage de l'arete de sommets nu2sar
00370       call hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar, noar )
00371 c     en sortie: noar>0 => no arete retrouvee
00372 c                    <0 => no arete ajoutee
00373 c                    =0 => saturation du tableau nosoar
00374 c
00375       if( noar .eq. 0 ) then
00376 c
00377 c        saturation du tableau nosoar
00378          write(imprim,*) 'fasoar: tableau nosoar sature'
00379          ierr = 1
00380          return
00381 c
00382       else if( noar .lt. 0 ) then
00383 c
00384 c        l'arete a ete ajoutee. initialisation des autres informations
00385          noar = -noar
00386 c        le numero de la ligne de l'arete
00387          nosoar(3,noar) = nolign
00388 c        le triangle 1 de l'arete => le triangle nt1
00389          nosoar(4,noar) = nt1
00390 c        le triangle 2 de l'arete => le triangle nt2
00391          nosoar(5,noar) = nt2
00392 c        le chainage est mis a -1
00393          nosoar(lchain,noar) = -1
00394 c
00395 c        le sommet appartient a l'arete noar
00396          noarst( nu2sar(1) ) = noar
00397          noarst( nu2sar(2) ) = noar
00398 c
00399       else
00400 c
00401 c        l'arete a ete retrouvee.
00402 c        si elle appartient a 2 triangles differents de nt1 et nt2
00403 c        alors il y a une erreur
00404          if( nosoar(4,noar) .gt. 0 .and.
00405      %       nosoar(5,noar) .gt. 0 ) then
00406              if( nosoar(4,noar) .ne. nt1 .and.
00407      %           nosoar(4,noar) .ne. nt2 .or.
00408      %           nosoar(5,noar) .ne. nt1 .and.
00409      %           nosoar(5,noar) .ne. nt2 ) then
00410 c                arete appartenant a plus de 2 triangles => erreur
00411                  if( ierr .ge. 0 ) then
00412                     write(imprim,*) 'erreur fasoar: arete ',noar,
00413      %              ' dans 2 triangles',nosoar(4,noar),nosoar(5,noar),
00414      %              ' et ajouter',nt1,nt2
00415                 write(imprim,*)'arete',noar,(nosoar(i,noar),i=1,mosoar)
00416                  endif
00417 c
00418 c                ERREUR. CORRECTION POUR VOIR ...
00419                  nosoar(4,noar) = NT1
00420                  nosoar(5,noar) = NT2
00421 ccc                 ierr = 2
00422 ccc                 return
00423              endif
00424          endif
00425 c
00426 c        mise a jour du numero des triangles de l'arete noar
00427 c        le triangle 2 de l'arete => le triangle nt1
00428          if( nosoar(4,noar) .le. 0 ) then
00429 c            pas de triangle connu pour cette arete
00430              n = 4
00431          else
00432 c            deja un triangle connu. ce nouveau est le second
00433              if( nosoar(5,noar) .gt. 0  .and.  nt1 .gt. 0 .and.
00434      %           nosoar(5,noar) .ne. nt1 ) then
00435 c               arete appartenant a plus de 2 triangles => erreur
00436                     write(imprim,*) 'erreur fasoar: arete ',noar,
00437      %              ' dans triangles',nosoar(4,noar),nosoar(5,noar),
00438      %              ' et ajouter triangle',nt1
00439                 ierr = 3
00440                 return
00441              endif
00442              n = 5
00443          endif
00444          nosoar(n,noar) = nt1
00445 c
00446 c        cas de l'arete frontaliere retrouvee comme diagonale d'un quadrangle
00447          if( nt2 .gt. 0 ) then
00448 c           l'arete appartient a 2 triangles
00449             if( nosoar(5,noar) .gt. 0  .and.
00450      %          nosoar(5,noar) .ne. nt2 ) then
00451 c               arete appartenant a plus de 2 triangles => erreur
00452                 write(imprim,*) 'erreur fasoar: arete ',noar,
00453      %         ' de st',nosoar(1,noar),'-',nosoar(2,noar),
00454      %         ' dans plus de 2 triangles'
00455                 ierr = 4
00456                 return
00457             endif
00458             nosoar(5,noar) = nt2
00459          endif
00460 c
00461       endif
00462 c
00463 c     pas d'erreur
00464       ierr = 0
00465       end
00466 
00467       subroutine fq1inv( x, y, s, xc, yc, ierr )
00468 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00469 c but :   calcul des 2 coordonnees (xc,yc) dans le carre (0,1)
00470 c -----   image par f:carre unite-->quadrangle appartenant a q1**2
00471 c         par une resolution directe due a Nicolas Thenault
00472 c
00473 c entrees:
00474 c --------
00475 c x,y   : coordonnees du point image dans le quadrangle de sommets s
00476 c s     : les 2 coordonnees des 4 sommets du quadrangle
00477 c
00478 c sorties:
00479 c --------
00480 c xc,yc : coordonnees dans le carre dont l'image par f vaut (x,y)
00481 c ierr  : 0 si calcul sans erreur, 1 si quadrangle degenere
00482 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00483 c auteurs: thenault tulenew  analyse numerique paris        janvier 1998
00484 c modifs : perronnet alain   analyse numerique paris        janvier 1998
00485 c234567..............................................................012
00486       real             s(1:2,1:4), dist(2)
00487       double precision a,b,c,d,alpha,beta,gamma,delta,x0,y0,t(2),u,v,w
00488 c
00489       a = s(1,1)
00490       b = s(1,2) - s(1,1)
00491       c = s(1,4) - s(1,1)
00492       d = s(1,1) - s(1,2) + s(1,3) - s(1,4)
00493 c
00494       alpha = s(2,1)
00495       beta  = s(2,2) - s(2,1)
00496       gamma = s(2,4) - s(2,1)
00497       delta = s(2,1) - s(2,2) + s(2,3) - s(2,4)
00498 c
00499       u = beta  * c - b * gamma
00500       if( u .eq. 0 ) then
00501 c        quadrangle degenere
00502          ierr = 1
00503          return
00504       endif
00505       v = delta * c - d * gamma
00506       w = b * delta - beta * d
00507 c
00508       x0 = c * (y-alpha) - gamma * (x-a)
00509       y0 = b * (y-alpha) - beta  * (x-a)
00510 c
00511       a = v  * w
00512       b = u  * u - w * x0 - v * y0
00513       c = x0 * y0
00514 c
00515       if( a .ne. 0 ) then
00516 c
00517          delta = sqrt( b*b-4*a*c )
00518          if( b .ge. 0.0 ) then
00519             t(2) = -b - delta
00520          else
00521             t(2) = -b + delta
00522          endif
00523 c        la racine de plus grande valeur absolue
00524 c       (elle donne le plus souvent le point exterieur au carre unite
00525 c        donc a tester en second pour reduire les calculs)
00526          t(2) = t(2) / ( 2 * a )
00527 c        calcul de la seconde racine a partir de la somme => plus stable
00528          t(1) = - b/a - t(2)
00529 c
00530          do 10 i=1,2
00531 c
00532 c           la solution i donne t elle un point interne au carre unite?
00533             xc = ( x0 - v * t(i) ) / u
00534             yc = ( w * t(i) - y0 ) / u
00535             if( 0.0 .le. xc .and. xc .le. 1.0 ) then
00536                if( 0.0 .le. yc .and. yc .le. 1.0 ) goto 9000
00537             endif
00538 c
00539 c           le point (xc,yc) n'est pas dans le carre unite
00540 c           cela peut etre du aux erreurs d'arrondi
00541 c           => choix par le minimum de la distance aux bords du carre
00542             dist(i) = max( 0.0, -xc, xc-1.0, -yc, yc-1.0 )
00543 c
00544  10      continue
00545 c
00546          if( dist(1) .gt. dist(2) ) then
00547 c           f(xc,yc) pour la racine 2 est plus proche de x,y
00548 c           xc yc sont deja calcules
00549             goto 9000
00550          endif
00551 c
00552       else if ( b .ne. 0 ) then
00553          t(1) = - c / b
00554       else
00555          t(1) = 0
00556       endif
00557 c
00558 c     les 2 coordonnees du point dans le carre unite
00559       xc = ( x0 - v * t(1) ) / u
00560       yc = ( w * t(1) - y0 ) / u
00561 c
00562  9000 ierr = 0
00563       return
00564       end
00565 
00566 
00567       subroutine ptdatr( point, pxyd, nosotr, nsigne )
00568 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00569 c but :    le point est il dans le triangle de sommets nosotr
00570 c -----
00571 c
00572 c entrees:
00573 c --------
00574 c point  : les 2 coordonnees du point
00575 c pxyd   : les 2 coordonnees et distance souhaitee des points du maillage
00576 c nosotr : le numero des 3 sommets du triangle
00577 c
00578 c sorties:
00579 c --------
00580 c nsigne : >0 si le point est dans le triangle ou sur une des 3 aretes
00581 c          =0 si le triangle est degenere ou indirect ou ne contient pas le poin
00582 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00583 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
00584 c....................................................................012
00585       integer           nosotr(3)
00586       double precision  point(2), pxyd(3,*)
00587       double precision  xp,yp, x1,x2,x3, y1,y2,y3, d,dd, cb1,cb2,cb3
00588 c
00589       xp = point( 1 )
00590       yp = point( 2 )
00591 c
00592       n1 = nosotr( 1 )
00593       x1 = pxyd( 1 , n1 )
00594       y1 = pxyd( 2 , n1 )
00595 c
00596       n2 = nosotr( 2 )
00597       x2 = pxyd( 1 , n2 )
00598       y2 = pxyd( 2 , n2 )
00599 c
00600       n3 = nosotr( 3 )
00601       x3 = pxyd( 1 , n3 )
00602       y3 = pxyd( 2 , n3 )
00603 c
00604 c     2 fois la surface du triangle = determinant de la matrice
00605 c     de calcul des coordonnees barycentriques du point p
00606       d  = ( x2 - x1 ) * ( y3 - y1 ) - ( x3 - x1 ) * ( y2 - y1 )
00607 c
00608       if( d .gt. 0 ) then
00609 c
00610 c        triangle non degenere
00611 c        =====================
00612 c        calcul des 3 coordonnees barycentriques du
00613 c        point xp yp dans le triangle
00614          cb1 = ( ( x2-xp ) * ( y3-yp ) - ( x3-xp ) * ( y2-yp ) ) / d
00615          cb2 = ( ( x3-xp ) * ( y1-yp ) - ( x1-xp ) * ( y3-yp ) ) / d
00616          cb3 = 1d0 - cb1 -cb2
00617 ccc         cb3 = ( ( x1-xp ) * ( y2-yp ) - ( x2-xp ) * ( y1-yp ) ) / d
00618 c
00619 ccc         if( cb1 .ge. -0.00005d0 .and. cb1 .le. 1.00005d0 .and.
00620          if( cb1 .ge. 0d0 .and. cb1 .le. 1d0 .and.
00621      %       cb2 .ge. 0d0 .and. cb2 .le. 1d0 .and.
00622      %       cb3 .ge. 0d0 .and. cb3 .le. 1d0 ) then
00623 c
00624 c           le triangle nosotr contient le point
00625             nsigne = 1
00626          else
00627             nsigne = 0
00628          endif
00629 c
00630       else
00631 c
00632 c        triangle degenere
00633 c        =================
00634 c        le point est il du meme cote que le sommet oppose de chaque arete?
00635          nsigne = 0
00636          do 10 i=1,3
00637 c           le sinus de l'angle p1 p2-p1 point
00638             x1  = pxyd(1,n1)
00639             y1  = pxyd(2,n1)
00640             d   = ( pxyd(1,n2) - x1 ) * ( point(2) - y1 )
00641      %          - ( pxyd(2,n2) - y1 ) * ( point(1) - x1 )
00642             dd  = ( pxyd(1,n2) - x1 ) * ( pxyd(2,n3) - y1 )
00643      %          - ( pxyd(2,n2) - y1 ) * ( pxyd(1,n3) - x1 )
00644             cb1 = ( pxyd(1,n2) - x1 ) ** 2
00645      %          + ( pxyd(2,n2) - y1 ) ** 2
00646             cb2 = ( point(1) - x1 ) ** 2
00647      %          + ( point(2) - y1 ) ** 2
00648             cb3 = ( pxyd(1,n3) - x1 ) ** 2
00649      %          + ( pxyd(2,n3) - y1 ) ** 2
00650             if( abs( dd ) .le. 1e-4 * sqrt( cb1 * cb3 ) ) then
00651 c              le point 3 est sur l'arete 1-2
00652 c              le point doit y etre aussi
00653                if( abs( d ) .le. 1e-4 * sqrt( cb1 * cb2 ) ) then
00654 c                 point sur l'arete
00655                   nsigne = nsigne + 1
00656                endif
00657             else
00658 c              le point 3 n'est pas sur l'arete . test des signes
00659                if( d * dd .ge. 0 ) then
00660                   nsigne = nsigne + 1
00661                endif
00662             endif
00663 c           permutation circulaire des 3 sommets et aretes
00664             n  = n1
00665             n1 = n2
00666             n2 = n3
00667             n3 = n
00668  10      continue
00669          if( nsigne .ne. 3 ) nsigne = 0
00670       endif
00671       end
00672 
00673       integer function nosstr( p, pxyd, nt, letree )
00674 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00675 c but :    calculer le numero 0 a 3 du sous-triangle te contenant
00676 c -----    le point p
00677 c
00678 c entrees:
00679 c --------
00680 c p      : point de r**2 contenu dans le te nt de letree
00681 c pxyd   : x y distance des points
00682 c nt     : numero letree du te de te voisin a calculer
00683 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
00684 c      letree(0,0)  no du 1-er te vide dans letree
00685 c      letree(0,1) : maximum du 1-er indice de letree (ici 8)
00686 c      letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
00687 c      letree(0:8,1) : racine de l'arbre  (triangle sans sur triangle)
00688 c      si letree(0,.)>0 alors
00689 c         letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
00690 c      sinon
00691 c         letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
00692 c                         0  si pas de point
00693 c                       ( j est alors une feuille de l'arbre )
00694 c      letree(4,j) : no letree du sur-triangle du triangle j
00695 c      letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
00696 c      letree(6:8,j) : no pxyd des 3 sommets du triangle j
00697 c
00698 c sorties :
00699 c ---------
00700 c nosstr : 0 si le sous-triangle central contient p
00701 c          i =1,2,3 numero du sous-triangle contenant p
00702 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00703 c auteur : alain perronnet  analyse numerique paris upmc    fevrier 1992
00704 c2345x7..............................................................012
00705       integer           letree(0:8,0:*)
00706       double precision  pxyd(3,*), p(2),
00707      %                  x1, y1, x21, y21, x31, y31, d, xe, ye
00708 c
00709 c     le numero des 3 sommets du triangle
00710       ns1 = letree( 6, nt )
00711       ns2 = letree( 7, nt )
00712       ns3 = letree( 8, nt )
00713 c
00714 c     les coordonnees entre 0 et 1 du point p
00715       x1  = pxyd(1,ns1)
00716       y1  = pxyd(2,ns1)
00717 c
00718       x21 = pxyd(1,ns2) - x1
00719       y21 = pxyd(2,ns2) - y1
00720 c
00721       x31 = pxyd(1,ns3) - x1
00722       y31 = pxyd(2,ns3) - y1
00723 c
00724       d   = 1.0 / ( x21 * y31 - x31 * y21 )
00725 c
00726       xe  = ( ( p(1) - x1 ) * y31 - ( p(2) - y1 ) * x31 ) * d
00727       ye  = ( ( p(2) - y1 ) * x21 - ( p(1) - x1 ) * y21 ) * d
00728 c
00729       if( xe .gt. 0.5d0 ) then
00730 c        sous-triangle droit
00731          nosstr = 2
00732       else if( ye .gt. 0.5d0 ) then
00733 c        sous-triangle haut
00734          nosstr = 3
00735       else if( xe+ye .lt. 0.5d0 ) then
00736 c        sous-triangle gauche
00737          nosstr = 1
00738       else
00739 c        sous-triangle central
00740          nosstr = 0
00741       endif
00742       end
00743 
00744 
00745       integer function notrpt( p, pxyd, notrde, letree )
00746 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00747 c but :    calculer le numero letree du sous-triangle feuille contenant
00748 c -----    le point p a partir du te notrde de letree
00749 c
00750 c entrees:
00751 c --------
00752 c p      : point de r**2 contenu dans le te nt de letree
00753 c pxyd   : x y distance des points
00754 c notrde : numero letree du triangle depart de recherche (1=>racine)
00755 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
00756 c      letree(0,0)  no du 1-er te vide dans letree
00757 c      letree(0,1) : maximum du 1-er indice de letree (ici 8)
00758 c      letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
00759 c      letree(0:8,1) : racine de l'arbre  (triangle sans sur triangle)
00760 c      si letree(0,.)>0 alors
00761 c         letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
00762 c      sinon
00763 c         letree(0:3,j) :-no pxyd des 1  4 points internes au triangle j
00764 c                         0  si pas de point
00765 c                        ( j est alors une feuille de l'arbre )
00766 c      letree(4,j) : no letree du sur-triangle du triangle j
00767 c      letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
00768 c      letree(6:8,j) : no pxyd des 3 sommets du triangle j
00769 c
00770 c sorties :
00771 c ---------
00772 c notrpt : numero letree du triangle contenant le point p
00773 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00774 c auteur : alain perronnet  analyse numerique paris upmc    fevrier 1992
00775 c2345x7..............................................................012
00776       integer           letree(0:8,0:*)
00777       double precision  pxyd(1:3,*), p(2)
00778 c
00779 c     la racine depart de la recherche
00780       notrpt = notrde
00781 c
00782 c     tant que la feuille n'est pas atteinte descendre l'arbre
00783  10   if( letree(0,notrpt) .gt. 0 ) then
00784 c
00785 c        recherche du sous-triangle contenant p
00786          nsot = nosstr( p, pxyd, notrpt, letree )
00787 c
00788 c        le numero letree du sous-triangle
00789          notrpt = letree( nsot, notrpt )
00790          goto 10
00791 c
00792       endif
00793       end
00794 
00795 
00796       subroutine teajpt( ns,   nbsomm, mxsomm, pxyd, letree,
00797      &                   ntrp, ierr )
00798 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00799 c but :    ajout du point ns de pxyd dans letree
00800 c -----
00801 c
00802 c entrees:
00803 c --------
00804 c ns     : numero du point a ajouter dans letree
00805 c mxsomm : nombre maximal de points declarables dans pxyd
00806 c pxyd   : tableau des coordonnees des points
00807 c          par point : x  y  distance_souhaitee
00808 c
00809 c modifies :
00810 c ----------
00811 c nbsomm : nombre actuel de points dans pxyd
00812 c
00813 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
00814 c      letree(0,0) : no du 1-er te vide dans letree
00815 c      letree(0,1) : maximum du 1-er indice de letree (ici 8)
00816 c      letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
00817 c      letree(0:8,1) : racine de l'arbre  (triangle sans sur triangle)
00818 c      si letree(0,.)>0 alors
00819 c         letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
00820 c      sinon
00821 c         letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
00822 c                         0  si pas de point
00823 c                        ( j est alors une feuille de l'arbre )
00824 c      letree(4,j) : no letree du sur-triangle du triangle j
00825 c      letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
00826 c      letree(6:8,j) : no pxyd des 3 sommets du triangle j
00827 c
00828 c sorties :
00829 c ---------
00830 c ntrp    : numero letree du triangle te ou a ete ajoute le point
00831 c ierr    : 0 si pas d'erreur,  51 saturation letree, 52 saturation pxyd
00832 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00833 c auteur : alain perronnet  analyse numerique paris upmc    fevrier 1992
00834 c2345x7..............................................................012
00835       integer           letree(0:8,0:*)
00836       double precision  pxyd(3,mxsomm)
00837 c
00838 c     depart de la racine
00839       ntrp = 1
00840 c
00841 c     recherche du triangle contenant le point pxyd(ns)
00842  1    ntrp = notrpt( pxyd(1,ns), pxyd, ntrp, letree )
00843 c
00844 c     existe t il un point libre
00845       do 10 i=0,3
00846          if( letree(i,ntrp) .eq. 0 ) then
00847 c           la place i est libre
00848             letree(i,ntrp) = -ns
00849             ierr = 0
00850             return
00851          endif
00852  10   continue
00853 c
00854 c     pas de place libre => 4 sous-triangles sont crees
00855 c                           a partir des 3 milieux des aretes
00856       call te4ste( nbsomm, mxsomm, pxyd, ntrp, letree, ierr )
00857       if( ierr .ne. 0 ) return
00858 c
00859 c     ajout du point ns
00860       goto 1
00861       end
00862 
00863       subroutine n1trva( nt, lar, letree, notrva, lhpile )
00864 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00865 c but :    calculer le numero letree du triangle voisin du te nt
00866 c -----    par l'arete lar (1 a 3 ) de nt
00867 c          attention : notrva n'est pas forcement minimal
00868 c
00869 c entrees:
00870 c --------
00871 c nt     : numero letree du te de te voisin a calculer
00872 c lar    : numero 1 a 3 de l'arete du triangle nt
00873 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
00874 c   letree(0,0)  no du 1-er te vide dans letree
00875 c   letree(0,1) : maximum du 1-er indice de letree (ici 8)
00876 c   letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
00877 c   letree(0:8,1) : racine de l'arbre  (triangle sans sur-triangle)
00878 c   si letree(0,.)>0 alors
00879 c      letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
00880 c   sinon
00881 c      letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
00882 c                      0  si pas de point
00883 c                     ( j est alors une feuille de l'arbre )
00884 c   letree(4,j) : no letree du sur-triangle du triangle j
00885 c   letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
00886 c   letree(6:8,j) : no pxyd des 3 sommets du triangle j
00887 c
00888 c sorties :
00889 c ---------
00890 c notrva  : >0 numero letree du te voisin par l'arete lar
00891 c           =0 si pas de te voisin (racine , ... )
00892 c lhpile  : =0 si nt et notrva ont meme taille
00893 c           >0 nt est 4**lhpile fois plus petit que notrva
00894 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00895 c auteur : alain perronnet  analyse numerique paris upmc    fevrier 1992
00896 c2345x7..............................................................012
00897       integer   letree(0:8,0:*)
00898       integer   lapile(1:64)
00899 c
00900 c     initialisation de la pile
00901 c     le triangle est empile
00902       lapile(1) = nt
00903       lhpile = 1
00904 c
00905 c     tant qu'il existe un sur-triangle
00906  10   ntr  = lapile( lhpile )
00907       if( ntr .eq. 1 ) then
00908 c        racine atteinte => pas de triangle voisin
00909          notrva = 0
00910          lhpile = lhpile - 1
00911          return
00912       endif
00913 c
00914 c     le type du triangle ntr
00915       nty  = letree( 5, ntr )
00916 c     l'eventuel sur-triangle
00917       nsut = letree( 4, ntr )
00918 c
00919       if( nty .eq. 0 ) then
00920 c
00921 c        triangle de type 0 => triangle voisin de type precedent(lar)
00922 c                              dans le sur-triangle de ntr
00923 c                              ce triangle remplace ntr dans lapile
00924          lapile( lhpile ) = letree( nopre3(lar), nsut )
00925          goto 20
00926       endif
00927 c
00928 c     triangle ntr de type nty>0
00929       if( nosui3(nty) .eq. lar ) then
00930 c
00931 c        le triangle voisin par lar est le triangle 0
00932          lapile( lhpile ) = letree( 0, nsut )
00933          goto 20
00934       endif
00935 c
00936 c     triangle sans voisin direct => passage par le sur-triangle
00937       if( nsut .eq. 0 ) then
00938 c
00939 c        ntr est la racine => pas de triangle voisin par cette arete
00940          notrva = 0
00941          return
00942       else
00943 c
00944 c        le sur-triangle est empile
00945          lhpile = lhpile + 1
00946          lapile(lhpile) = nsut
00947          goto 10
00948       endif
00949 c
00950 c     descente aux sous-triangles selon la meme arete
00951  20   notrva = lapile( lhpile )
00952 c
00953  30   lhpile = lhpile - 1
00954       if( letree(0,notrva) .le. 0 ) then
00955 c        le triangle est une feuille de l'arbre 0 sous-triangle
00956 c        lhpile = nombre de differences de niveaux dans l'arbre
00957          return
00958       else
00959 c        le triangle a 4 sous-triangles
00960          if( lhpile .gt. 0 ) then
00961 c
00962 c           bas de pile non atteint
00963             nty  = letree( 5, lapile(lhpile) )
00964             if( nty .eq. lar ) then
00965 c              l'oppose est suivant(nty) de notrva
00966                notrva = letree( nosui3(nty) , notrva )
00967             else
00968 c              l'oppose est precedent(nty) de notrva
00969                notrva = letree( nopre3(nty) , notrva )
00970             endif
00971             goto 30
00972          endif
00973       endif
00974 c
00975 c     meme niveau dans l'arbre lhpile = 0
00976       end
00977 
00978 
00979       subroutine cenced( xy1, xy2, xy3, cetria, ierr )
00980 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00981 c but : calcul des coordonnees du centre du cercle circonscrit
00982 c ----- du triangle defini par ses 3 sommets de coordonnees
00983 c       xy1 xy2 xy3 ainsi que le carre du rayon de ce cercle
00984 c
00985 c entrees :
00986 c ---------
00987 c xy1 xy2 xy3 : les 2 coordonnees des 3 sommets du triangle
00988 c ierr   : <0  => pas d'affichage si triangle degenere
00989 c          >=0 =>       affichage si triangle degenere
00990 c
00991 c sortie :
00992 c --------
00993 c cetria : cetria(1)=abcisse  du centre
00994 c          cetria(2)=ordonnee du centre
00995 c          cetria(3)=carre du rayon   1d28 si triangle degenere
00996 c ierr   : 0 si triangle non degenere
00997 c          1 si triangle degenere
00998 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00999 c auteur : perronnet alain upmc analyse numerique paris        juin 1995
01000 c2345x7..............................................................012
01001       parameter        (epsurf=1d-7)
01002       common / unites / lecteu,imprim,nunite(30)
01003       double precision  x1,y1,x21,y21,x31,y31,
01004      %                  aire2,xc,yc,rot,
01005      %                  xy1(2),xy2(2),xy3(2),cetria(3)
01006 c
01007 c     le calcul de 2 fois l'aire du triangle
01008 c     attention l'ordre des 3 sommets est direct ou non
01009       x1  = xy1(1)
01010       x21 = xy2(1) - x1
01011       x31 = xy3(1) - x1
01012 c
01013       y1  = xy1(2)
01014       y21 = xy2(2) - y1
01015       y31 = xy3(2) - y1
01016 c
01017       aire2  = x21 * y31 - x31 * y21
01018 c
01019 c     recherche d'un test relatif peu couteux
01020 c     pour reperer la degenerescence du triangle
01021       if( abs(aire2) .le.
01022      %    epsurf*(abs(x21)+abs(x31))*(abs(y21)+abs(y31)) ) then
01023 c        triangle de qualite trop faible
01024          if( ierr .ge. 0 ) then
01025 c            nblgrc(nrerr) = 1
01026 c            kerr(1) = 'erreur cenced: triangle degenere'
01027 c            call lereur
01028             write(imprim,*) 'erreur cenced: triangle degenere'
01029             write(imprim,10000)  xy1,xy2,xy3,aire2
01030          endif
01031 10000 format( 3(' x=',g24.16,' y=',g24.16/),' aire*2=',g24.16)
01032          cetria(1) = 0d0
01033          cetria(2) = 0d0
01034          cetria(3) = 1d28
01035          ierr = 1
01036          return
01037       endif
01038 c
01039 c     les 2 coordonnees du centre intersection des 2 mediatrices
01040 c     x = (x1+x2)/2 + lambda * (y2-y1)
01041 c     y = (y1+y2)/2 - lambda * (x2-x1)
01042 c     x = (x1+x3)/2 + rot    * (y3-y1)
01043 c     y = (y1+y3)/2 - rot    * (x3-x1)
01044 c     ==========================================================
01045       rot = ((xy2(1)-xy3(1))*x21 + (xy2(2)-xy3(2))*y21) / (2 * aire2)
01046 c
01047       xc = ( x1 + xy3(1) ) * 0.5d0 + rot * y31
01048       yc = ( y1 + xy3(2) ) * 0.5d0 - rot * x31
01049 c
01050       cetria(1) = xc
01051       cetria(2) = yc
01052 c
01053 c     le carre du rayon
01054       cetria(3) = (x1-xc) ** 2 + (y1-yc) ** 2
01055 c
01056 c     pas d'erreur rencontree
01057       ierr = 0
01058       end
01059 
01060 
01061       double precision function angled( p1, p2, p3 )
01062 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01063 c but :   calculer l'angle (p1p2,p1p3) en radians
01064 c -----
01065 c
01066 c entrees :
01067 c ---------
01068 c p1,p2,p3 : les 2 coordonnees des 3 sommets de l'angle
01069 c               sens direct pour une surface >0
01070 c sorties :
01071 c ---------
01072 c angled :  angle (p1p2,p1p3) en radians entre [0 et 2pi]
01073 c           0 si p1=p2 ou p1=p3
01074 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01075 c auteur : alain perronnet analyse numerique upmc paris     fevrier 1992
01076 c2345x7..............................................................012
01077       double precision  p1(2),p2(2),p3(2),x21,y21,x31,y31,a1,a2,d,c
01078 c
01079 c     les cotes
01080       x21 = p2(1) - p1(1)
01081       y21 = p2(2) - p1(2)
01082       x31 = p3(1) - p1(1)
01083       y31 = p3(2) - p1(2)
01084 c
01085 c     longueur des cotes
01086       a1 = x21 * x21 + y21 * y21
01087       a2 = x31 * x31 + y31 * y31
01088       d  = sqrt( a1 * a2 )
01089       if( d .eq. 0 ) then
01090          angled = 0
01091          return
01092       endif
01093 c
01094 c     cosinus de l'angle
01095       c  = ( x21 * x31 + y21 * y31 ) / d
01096       if( c .le. -1.d0 ) then
01097 c        tilt sur apollo si acos( -1 -eps )
01098          angled = atan( 1.d0 ) * 4.d0
01099          return
01100       else if( c .ge. 1.d0 ) then
01101 c        tilt sur apollo si acos( 1 + eps )
01102          angled = 0
01103          return
01104       endif
01105 c
01106       angled = acos( c )
01107       if( x21 * y31 - x31 * y21 .lt. 0 ) then
01108 c        demi plan inferieur
01109          angled = 8.d0 * atan( 1.d0 ) - angled
01110       endif
01111       end
01112 
01113 
01114       subroutine teajte( mxsomm, nbsomm, pxyd,   comxmi,
01115      %                   aretmx, mxtree, letree,
01116      %                   ierr )
01117 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01118 c but :    initialisation des tableaux letree
01119 c -----    ajout des sommets 1 a nbsomm (valeur en entree) dans letree
01120 c
01121 c entrees:
01122 c --------
01123 c mxsomm : nombre maximal de sommets permis pour la triangulation
01124 c mxtree : nombre maximal de triangles equilateraux (te) declarables
01125 c aretmx : longueur maximale des aretes des triangles equilateraux
01126 c
01127 c entrees et sorties :
01128 c --------------------
01129 c nbsomm : nombre de sommets apres identification
01130 c pxyd   : tableau des coordonnees 2d des points
01131 c          par point : x  y  distance_souhaitee
01132 c          tableau reel(3,mxsomm)
01133 c
01134 c sorties:
01135 c --------
01136 c comxmi : coordonnees minimales et maximales des points frontaliers
01137 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
01138 c          letree(0,0) : no du 1-er te vide dans letree
01139 c          letree(0,1) : maximum du 1-er indice de letree (ici 8)
01140 c          letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
01141 c          letree(0:8,1) : racine de l'arbre  (triangle sans sur triangle)
01142 c          si letree(0,.)>0 alors
01143 c             letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
01144 c          sinon
01145 c             letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
01146 c                             0  si pas de point
01147 c                             ( j est alors une feuille de l'arbre )
01148 c          letree(4,j) : no letree du sur-triangle du triangle j
01149 c          letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
01150 c          letree(6:8,j) : no pxyd des 3 sommets du triangle j
01151 c
01152 c ierr   :  0 si pas d'erreur
01153 c          51 saturation letree
01154 c          52 saturation pxyd
01155 c           7 tous les points sont alignes
01156 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01157 c auteur : alain perronnet  analyse numerique paris upmc    juillet 1994
01158 c....................................................................012
01159       integer           letree(0:8,0:mxtree)
01160       double precision  pxyd(3,mxsomm)
01161       double precision  comxmi(3,2)
01162       double precision  a(2),s,aretmx,rac3
01163 c
01164 c     protection du nombre de sommets avant d'ajouter ceux de tetree
01165       ierr   = 0
01166       nbsofr = nbsomm
01167       do 1 i = 1, nbsomm 
01168          comxmi(1,1) = min( comxmi(1,1), pxyd(1,i) )
01169          comxmi(1,2) = max( comxmi(1,2), pxyd(1,i) )
01170          comxmi(2,1) = min( comxmi(2,1), pxyd(2,i) )
01171          comxmi(2,2) = max( comxmi(2,2), pxyd(2,i) )
01172  1    continue
01173 c
01174 c     creation de l'arbre letree
01175 c     ==========================
01176 c     la premiere colonne vide de letree
01177       letree(0,0) = 2
01178 c     chainage des te vides
01179       do 4 i = 2 , mxtree
01180          letree(0,i) = i+1
01181  4    continue
01182       letree(0,mxtree) = 0
01183 c     les maxima des 2 indices de letree
01184       letree(1,0) = 8
01185       letree(2,0) = mxtree
01186 c
01187 c     la racine
01188 c     aucun point interne au triangle equilateral (te) 1
01189       letree(0,1) = 0
01190       letree(1,1) = 0
01191       letree(2,1) = 0
01192       letree(3,1) = 0
01193 c     pas de sur-triangle
01194       letree(4,1) = 0
01195       letree(5,1) = 0
01196 c     le numero pxyd des 3 sommets du te 1
01197       letree(6,1) = nbsomm + 1
01198       letree(7,1) = nbsomm + 2
01199       letree(8,1) = nbsomm + 3
01200 c
01201 c     calcul de la largeur et hauteur du rectangle englobant
01202 c     ======================================================
01203       a(1) = comxmi(1,2) - comxmi(1,1)
01204       a(2) = comxmi(2,2) - comxmi(2,1)
01205 c     la longueur de la diagonale
01206       s = sqrt( a(1)**2 + a(2)**2 )
01207       do 60 k=1,2
01208          if( a(k) .lt. 1e-4 * s ) then
01209 c            nblgrc(nrerr) = 1
01210             write(imprim,*) 'tous les points sont alignes'
01211 c            call lereur
01212             ierr = 7
01213             return
01214          endif
01215  60   continue
01216 c
01217 c     le maximum des ecarts
01218       s = s + s
01219 c
01220 c     le triangle equilateral englobant
01221 c     =================================
01222 c     ecart du rectangle au triangle equilateral
01223       rac3 = sqrt( 3.0d0 )
01224       arete = a(1) + 2 * aretmx + 2 * ( a(2) + aretmx ) / rac3
01225 c
01226 c     le point nbsomm + 1 en bas a gauche
01227       nbsomm = nbsomm + 1
01228       pxyd(1,nbsomm) = (comxmi(1,1)+comxmi(1,2))*0.5d0 - arete*0.5d0
01229       pxyd(2,nbsomm) =  comxmi(2,1) - aretmx
01230       pxyd(3,nbsomm) = s
01231 c
01232 c     le point nbsomm + 2 en bas a droite
01233       nbsomm = nbsomm + 1
01234       pxyd(1,nbsomm) = pxyd(1,nbsomm-1) + arete
01235       pxyd(2,nbsomm) = pxyd(2,nbsomm-1)
01236       pxyd(3,nbsomm) = s
01237 c
01238 c     le point nbsomm + 3 sommet au dessus
01239       nbsomm = nbsomm + 1
01240       pxyd(1,nbsomm) = pxyd(1,nbsomm-2) + arete * 0.5d0
01241       pxyd(2,nbsomm) = pxyd(2,nbsomm-2) + arete * 0.5d0 * rac3
01242       pxyd(3,nbsomm) = s
01243 c
01244 c     ajout des sommets des lignes pour former letree
01245 c     ===============================================
01246       do 150 i=1,nbsofr
01247 c        ajout du point i de pxyd a letree
01248          call teajpt(  i, nbsomm, mxsomm, pxyd, letree,
01249      &                nt, ierr )
01250          if( ierr .ne. 0 ) return
01251  150  continue
01252 c
01253       return
01254       end
01255 
01256 
01257       subroutine tetaid( nutysu, dx, dy, longai, ierr )
01258 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01259 c but :     calculer la longueur de l'arete ideale longai en dx,dy
01260 c -----
01261 c entrees:
01262 c --------
01263 c nutysu : numero de traitement de areteideale() selon le type de surface
01264 c          0 pas d'emploi de la fonction areteideale() => aretmx active
01265 c          1 il existe une fonction areteideale(xyz,xyzdir)
01266 c          ... autres options a definir ...
01267 c dx, dy : abscisse et ordonnee dans le plan du point (reel2!)
01268 c
01269 c sorties:
01270 c --------
01271 c longai : longueur de l'areteideale(xyz,xyzdir) autour du point xyz
01272 c ierr   : 0 si pas d'erreur, <>0 sinon
01273 c          1 calcul incorrect de areteideale(xyz,xyzdir)
01274 c          2 longueur calculee nulle
01275 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01276 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
01277 c2345x7..............................................................012
01278       common / unites / lecteu, imprim, nunite(30)
01279 c
01280       double precision  areteideale
01281       double precision  dx, dy, longai
01282       double precision  xyz(3), xyzd(3), d0
01283 c
01284       ierr = 0
01285       if( nutysu .gt. 0 ) then
01286          d0 = longai
01287 c        le point ou se calcule la longueur
01288          xyz(1) = dx
01289          xyz(2) = dy
01290 c        z pour le calcul de la longueur (inactif ici!)
01291          xyz(3) = 0d0
01292 c        la direction pour le calcul de la longueur (inactif ici!)
01293          xyzd(1) = 0d0
01294          xyzd(2) = 0d0
01295          xyzd(3) = 0d0
01296 
01297          longai = areteideale(xyz,xyzd)
01298 c         (xyz,xyzd)
01299          if( longai .lt. 0d0 ) then
01300             write(imprim,10000) xyz
01301 10000       format('attention: longueur de areteideale(',
01302      %              g14.6,',',g14.6,',',g14.6,')<=0! => rendue >0' )
01303             longai = -longai
01304          endif
01305          if( longai .eq. 0d0 ) then
01306             write(imprim,10001) xyz
01307 10001       format('erreur: longueur de areteideale(',
01308      %              g14.6,',',g14.6,',',g14.6,')=0!' )
01309             ierr = 2
01310             longai = d0
01311          endif
01312       endif
01313       end
01314 
01315 
01316       subroutine tehote( nutysu,
01317      %                   nbarpi, mxsomm, nbsomm, pxyd,
01318      %                   comxmi, aretmx,
01319      %                   letree, mxqueu, laqueu,
01320      %                   ierr )
01321 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01322 c but :     homogeneisation de l'arbre des te a un saut de taille au plus
01323 c -----     prise en compte des distances souhaitees autour des sommets initiaux
01324 c
01325 c entrees:
01326 c --------
01327 c nutysu : numero de traitement de areteideale() selon le type de surface
01328 c          0 pas d'emploi de la fonction areteideale() => aretmx active
01329 c          1 il existe une fonction areteideale()
01330 c            dont seules les 2 premieres composantes de uv sont actives
01331 c          autres options a definir...
01332 c nbarpi : nombre de sommets de la frontiere + nombre de points internes
01333 c          imposes par l'utilisateur
01334 c mxsomm : nombre maximal de sommets permis pour la triangulation  et te
01335 c mxqueu : nombre d'entiers utilisables dans laqueu
01336 c comxmi : minimum et maximum des coordonnees de l'objet
01337 c aretmx : longueur maximale des aretes des triangles equilateraux
01338 c permtr : perimetre de la ligne enveloppe dans le plan
01339 c          avant mise a l'echelle a 2**20
01340 c
01341 c modifies:
01342 c ---------
01343 c nbsomm : nombre de sommets apres identification
01344 c pxyd   : tableau des coordonnees 2d des points
01345 c          par point : x  y  distance_souhaitee
01346 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
01347 c          letree(0,0) : no du 1-er te vide dans letree
01348 c          letree(1,0) : maximum du 1-er indice de letree (ici 8)
01349 c          letree(2,0) : maximum declare du 2-eme indice de letree (ici mxtree)
01350 c          letree(0:8,1) : racine de l'arbre  (triangle sans sur triangle)
01351 c          si letree(0,.)>0 alors
01352 c             letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
01353 c          sinon
01354 c             letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
01355 c                             0  si pas de point
01356 c                             ( j est alors une feuille de l'arbre )
01357 c          letree(4,j) : no letree du sur-triangle du triangle j
01358 c          letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
01359 c          letree(6:8,j) : no pxyd des 3 sommets du triangle j
01360 c
01361 c auxiliaire :
01362 c ------------
01363 c laqueu : mxqueu entiers servant de queue pour le parcours de letree
01364 c
01365 c sorties:
01366 c --------
01367 c ierr   :  0 si pas d'erreur
01368 c          51 si saturation letree dans te4ste
01369 c          52 si saturation pxyd   dans te4ste
01370 c          >0 si autre erreur
01371 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01372 c auteur : alain perronnet  analyse numerique paris upmc      avril 1997
01373 c2345x7..............................................................012
01374       double precision  ampli
01375       parameter        (ampli=1.34d0)
01376       common / unites / lecteu, imprim, intera, nunite(29)
01377 c
01378       double precision  pxyd(3,mxsomm), d2, aretm2
01379       double precision  comxmi(3,2),aretmx,a,s,xrmin,xrmax,yrmin,yrmax
01380       double precision  dmin, dmax
01381       integer           letree(0:8,0:*)
01382 c
01383       integer           laqueu(1:mxqueu),lequeu
01384 c                       lequeu : entree dans la queue
01385 c                       lhqueu : longueur de la queue
01386 c                       gestion circulaire
01387 c
01388       integer           nuste(3)
01389       equivalence      (nuste(1),ns1),(nuste(2),ns2),(nuste(3),ns3)
01390 c
01391       ierr = 0
01392 c
01393 c     existence ou non de la fonction 'taille_ideale' des aretes
01394 c     autour du point.  ici la carte est supposee isotrope
01395 c     ==========================================================
01396 c     attention: si la fonction taille_ideale existe
01397 c                alors pxyd(3,*) est la taille_ideale dans l'espace initial
01398 c                sinon pxyd(3,*) est la distance calculee dans le plan par
01399 c                propagation a partir des tailles des aretes de la frontiere
01400 c
01401       if( nutysu .gt. 0 ) then
01402 c
01403 c        la fonction taille_ideale(x,y,z) existe
01404 c        ---------------------------------------
01405 c        initialisation de la distance souhaitee autour des points 1 a nbsomm
01406          do 1 i=1,nbsomm
01407 c           calcul de pxyzd(3,i)
01408             call tetaid( nutysu, pxyd(1,i), pxyd(2,i),
01409      %                   pxyd(3,i), ierr )
01410             if( ierr .ne. 0 ) goto 9999
01411  1       continue
01412 c
01413       else
01414 c
01415 c        la fonction taille_ideale(x,y,z) n'existe pas
01416 c        ---------------------------------------------
01417 c        prise en compte des distances souhaitees dans le plan
01418 c        autour des points frontaliers et des points internes imposes
01419 c        toutes les autres distances souhaitees ont ete mis a aretmx
01420 c        lors de l'execution du sp teqini
01421          do 3 i=1,nbarpi
01422 c           le sommet i n'est pas un sommet de letree => sommet frontalier
01423 c           recherche du sous-triangle minimal feuille contenant le point i
01424             nte = 1
01425  2          nte = notrpt( pxyd(1,i), pxyd, nte, letree )
01426 c           la distance au sommet le plus eloigne est elle inferieure
01427 c           a la distance souhaitee?
01428             ns1 = letree(6,nte)
01429             ns2 = letree(7,nte)
01430             ns3 = letree(8,nte)
01431             d2  = max( ( pxyd(1,i)-pxyd(1,ns1) )**2 +
01432      %                 ( pxyd(2,i)-pxyd(2,ns1) )**2
01433      %               , ( pxyd(1,i)-pxyd(1,ns2) )**2 +
01434      %                 ( pxyd(2,i)-pxyd(2,ns2) )**2
01435      %               , ( pxyd(1,i)-pxyd(1,ns3) )**2 +
01436      %                 ( pxyd(2,i)-pxyd(2,ns3) )**2 )
01437             if( d2 .gt. pxyd(3,i)**2 ) then
01438 c              le triangle nte trop grand doit etre subdivise en 4 sous-triangle
01439                call te4ste( nbsomm, mxsomm, pxyd, nte, letree,
01440      &                      ierr )
01441                if( ierr .ne. 0 ) return
01442                goto 2
01443             endif
01444  3       continue
01445       endif
01446 c
01447 c     le sous-triangle central de la racine est decoupe systematiquement
01448 c     ==================================================================
01449       nte = 2
01450       if( letree(0,2) .le. 0 ) then
01451 c        le sous-triangle central de la racine n'est pas subdivise
01452 c        il est donc decoupe en 4 soustriangles
01453          nbsom0 = nbsomm
01454          call te4ste( nbsomm, mxsomm, pxyd, nte, letree,
01455      %                ierr )
01456          if( ierr .ne. 0 ) return
01457          do 4 i=nbsom0+1,nbsomm
01458 c           mise a jour de taille_ideale des nouveaux sommets de te
01459             call tetaid( nutysu, pxyd(1,i), pxyd(2,i),
01460      %                   pxyd(3,i), ierr )
01461             if( ierr .ne. 0 ) goto 9999
01462  4       continue
01463       endif
01464 c
01465 c     le carre de la longueur de l'arete de triangles equilateraux
01466 c     souhaitee pour le fond de la triangulation
01467       aretm2 = (aretmx*ampli) ** 2
01468 c
01469 c     tout te contenu dans le rectangle englobant doit avoir un
01470 c     cote < aretmx et etre de meme taille que les te voisins
01471 c     s'il contient un point; sinon un seul saut de taille est permis
01472 c     ===============================================================
01473 c     le rectangle englobant pour selectionner les te "internes"
01474 c     le numero des 3 sommets du te englobant racine de l'arbre des te
01475       ns1 = letree(6,1)
01476       ns2 = letree(7,1)
01477       ns3 = letree(8,1)
01478       a   = aretmx * 0.01d0
01479 c     abscisse du milieu de l'arete gauche du te 1
01480       s      = ( pxyd(1,ns1) + pxyd(1,ns3) ) / 2
01481       xrmin  = min( s, comxmi(1,1) - aretmx ) - a
01482 c     abscisse du milieu de l'arete droite du te 1
01483       s      = ( pxyd(1,ns2) + pxyd(1,ns3) ) / 2
01484       xrmax  = max( s, comxmi(1,2) + aretmx ) + a
01485       yrmin  = comxmi(2,1) - aretmx
01486 c     ordonnee de la droite passant par les milieus des 2 aretes
01487 c     droite gauche du te 1
01488       s      = ( pxyd(2,ns1) + pxyd(2,ns3) ) / 2
01489       yrmax  = max( s, comxmi(2,2) + aretmx ) + a
01490 c
01491 c     cas particulier de 3 ou 4 ou peu d'aretes frontalieres
01492       if( nbarpi .le. 8 ) then
01493 c        tout le triangle englobant (racine) est a prendre en compte
01494          xrmin = pxyd(1,ns1) - a
01495          xrmax = pxyd(1,ns2) + a
01496          yrmin = pxyd(2,ns1) - a
01497          yrmax = pxyd(2,ns3) + a
01498       endif
01499 c
01500       nbs0   = nbsomm
01501       nbiter = -1
01502 c
01503 c     initialisation de la queue
01504   5   nbiter = nbiter + 1
01505       lequeu = 1
01506       lhqueu = 0
01507 c     la racine de letree initialise la queue
01508       laqueu(1) = 1
01509 c
01510 c     tant que la longueur de la queue est >=0 traiter le debut de queue
01511  10   if( lhqueu .ge. 0 ) then
01512 c
01513 c        le triangle te a traiter
01514          i   = lequeu - lhqueu
01515          if( i .le. 0 ) i = mxqueu + i
01516          nte = laqueu( i )
01517 c        la longueur de la queue est reduite
01518          lhqueu = lhqueu - 1
01519 c
01520 c        nte est il un sous-triangle feuille minimal ?
01521  15      if( letree(0,nte) .gt. 0 ) then
01522 c
01523 c           non les 4 sous-triangles sont mis dans la queue
01524             if( lhqueu + 4 .ge. mxqueu ) then
01525                write(imprim,*) 'tehote: saturation de la queue'
01526                ierr = 7
01527                return
01528             endif
01529             do 20 i=3,0,-1
01530 c              ajout du sous-triangle i
01531                lhqueu = lhqueu + 1
01532                lequeu = lequeu + 1
01533                if( lequeu .gt. mxqueu ) lequeu = lequeu - mxqueu
01534                laqueu( lequeu ) = letree( i, nte )
01535  20         continue
01536             goto 10
01537 c
01538          endif
01539 c
01540 c        ici nte est un triangle minimal non subdivise
01541 c        ---------------------------------------------
01542 c        le te est il dans le cadre englobant de l'objet ?
01543          ns1 = letree(6,nte)
01544          ns2 = letree(7,nte)
01545          ns3 = letree(8,nte)
01546          if( pxyd(1,ns1) .gt. pxyd(1,ns2) ) then
01547             dmin = pxyd(1,ns2)
01548             dmax = pxyd(1,ns1)
01549          else
01550             dmin = pxyd(1,ns1)
01551             dmax = pxyd(1,ns2)
01552          endif
01553          if( (xrmin .le. dmin .and. dmin .le. xrmax) .or.
01554      %       (xrmin .le. dmax .and. dmax .le. xrmax) ) then
01555             if( pxyd(2,ns1) .gt. pxyd(2,ns3) ) then
01556                dmin = pxyd(2,ns3)
01557                dmax = pxyd(2,ns1)
01558             else
01559                dmin = pxyd(2,ns1)
01560                dmax = pxyd(2,ns3)
01561             endif
01562             if( (yrmin .le. dmin .and. dmin .le. yrmax) .or.
01563      %          (yrmin .le. dmax .and. dmax .le. yrmax) ) then
01564 c
01565 c              nte est un te feuille et interne au rectangle englobant
01566 c              =======================================================
01567 c              le carre de la longueur de l'arete du te de numero nte
01568                d2 = (pxyd(1,ns1)-pxyd(1,ns2)) ** 2 +
01569      %              (pxyd(2,ns1)-pxyd(2,ns2)) ** 2
01570 c
01571                if( nutysu .eq. 0 ) then
01572 c
01573 c                 il n'existe pas de fonction 'taille_ideale'
01574 c                 -------------------------------------------
01575 c                 si la taille effective de l'arete du te est superieure a aretmx
01576 c                 alors le te est decoupe
01577                   if( d2 .gt. aretm2 ) then
01578 c                    le triangle nte trop grand doit etre subdivise
01579 c                    en 4 sous-triangles
01580                      call te4ste( nbsomm,mxsomm, pxyd,
01581      %                            nte, letree, ierr )
01582                      if( ierr .ne. 0 ) return
01583                      goto 15
01584                   endif
01585 c
01586                else
01587 c
01588 c                 il existe ici une fonction 'taille_ideale'
01589 c                 ------------------------------------------
01590 c                 si la taille effective de l'arete du te est superieure au mini
01591 c                 des 3 tailles_ideales aux sommets  alors le te est decoupe
01592                   do 28 i=1,3
01593                      if( d2 .gt. (pxyd(3,nuste(i))*ampli)**2 ) then
01594 c                       le triangle nte trop grand doit etre subdivise
01595 c                       en 4 sous-triangles
01596                         nbsom0 = nbsomm
01597                         call te4ste( nbsomm, mxsomm, pxyd,
01598      &                               nte, letree, ierr )
01599                         if( ierr .ne. 0 ) return
01600                         do 27 j=nbsom0+1,nbsomm
01601 c                          mise a jour de taille_ideale des nouveaux sommets de
01602                            call tetaid( nutysu, pxyd(1,j), pxyd(2,j),
01603      %                                  pxyd(3,j), ierr )
01604                            if( ierr .ne. 0 ) goto 9999
01605  27                     continue
01606                         goto 15
01607                      endif
01608  28               continue
01609                endif
01610 c
01611 c              recherche du nombre de niveaux entre nte et les te voisins par se
01612 c              si la difference de subdivisions excede 1 alors le plus grand des
01613 c              =================================================================
01614  29            do 30 i=1,3
01615 c
01616 c                 noteva triangle voisin de nte par l'arete i
01617                   call n1trva( nte, i, letree, noteva, niveau )
01618                   if( noteva .le. 0 ) goto 30
01619 c                 il existe un te voisin
01620                   if( niveau .gt. 0 ) goto 30
01621 c                 nte a un te voisin plus petit ou egal
01622                   if( letree(0,noteva) .le. 0 ) goto 30
01623 c                 nte a un te voisin noteva subdivise au moins une fois
01624 c
01625                   if( nbiter .gt. 0 ) then
01626 c                    les 2 sous triangles voisins sont-ils subdivises?
01627                      ns2 = letree(i,noteva)
01628                      if( letree(0,ns2) .le. 0 ) then
01629 c                       ns2 n'est pas subdivise
01630                         ns2 = letree(nosui3(i),noteva)
01631                         if( letree(0,ns2) .le. 0 ) then
01632 c                          les 2 sous-triangles ne sont pas subdivises
01633                            goto 30
01634                         endif
01635                      endif
01636                   endif
01637 c
01638 c                 saut>1 => le triangle nte doit etre subdivise en 4 sous-triang
01639 c                 --------------------------------------------------------------
01640                   nbsom0 = nbsomm
01641                   call te4ste( nbsomm,mxsomm, pxyd, nte, letree,
01642      &                         ierr )
01643                   if( ierr .ne. 0 ) return
01644                   if( nutysu .gt. 0 ) then
01645                      do 32 j=nbsom0+1,nbsomm
01646 c                       mise a jour de taille_ideale des nouveaux sommets de te
01647                         call tetaid( nutysu, pxyd(1,j), pxyd(2,j),
01648      %                               pxyd(3,j), ierr )
01649                         if( ierr .ne. 0 ) goto 9999
01650  32                  continue
01651                   endif
01652                   goto 15
01653 c
01654  30            continue
01655             endif
01656          endif
01657          goto 10
01658       endif
01659       if( nbs0 .lt. nbsomm ) then
01660          nbs0 = nbsomm
01661          goto 5
01662       endif
01663       return
01664 c
01665 c     pb dans le calcul de la fonction taille_ideale
01666 
01667  9999 write(imprim,*) 'pb dans le calcul de taille_ideale'
01668 c      nblgrc(nrerr) = 1
01669 c      kerr(1) = 'pb dans le calcul de taille_ideale'
01670 c      call lereur
01671       return
01672       end
01673 
01674 
01675       subroutine tetrte( comxmi, aretmx, nbarpi, mxsomm, pxyd,
01676      %                   mxqueu, laqueu, letree,
01677      %                   mosoar, mxsoar, n1soar, nosoar,
01678      %                   moartr, mxartr, n1artr, noartr, noarst,
01679      %                   ierr  )
01680 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01681 c but :    trianguler les triangles equilateraux feuilles et
01682 c -----    les points de la frontiere et les points internes imposes
01683 c
01684 c attention: la triangulation finale n'est pas de type delaunay!
01685 c
01686 c entrees:
01687 c --------
01688 c comxmi : minimum et maximum des coordonnees de l'objet
01689 c aretmx : longueur maximale des aretes des triangles equilateraux
01690 c nbarpi : nombre de sommets de la frontiere + nombre de points internes
01691 c          imposes par l'utilisateur
01692 c mxsomm : nombre maximal de sommets declarables dans pxyd
01693 c pxyd   : tableau des coordonnees 2d des points
01694 c          par point : x  y  distance_souhaitee
01695 c
01696 c mxqueu : nombre d'entiers utilisables dans laqueu
01697 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
01698 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
01699 c moartr : nombre maximal d'entiers par arete du tableau noartr
01700 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
01701 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
01702 c          letree(0,0) : no du 1-er te vide dans letree
01703 c          letree(0,1) : maximum du 1-er indice de letree (ici 8)
01704 c          letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
01705 c          letree(0:8,1) : racine de l'arbre  (triangle sans sur triangle)
01706 c          si letree(0,.)>0 alors
01707 c             letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
01708 c          sinon
01709 c             letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
01710 c                             0  si pas de point
01711 c                             ( j est alors une feuille de l'arbre )
01712 c          letree(4,j) : no letree du sur-triangle du triangle j
01713 c          letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
01714 c          letree(6:8,j) : no pxyd des 3 sommets du triangle j
01715 c
01716 c modifies:
01717 c ---------
01718 c n1soar : numero de la premiere arete vide dans le tableau nosoar
01719 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
01720 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
01721 c          chainage des aretes frontalieres, chainage du hachage des aretes
01722 c          hachage des aretes = nosoar(1)+nosoar(2)*2
01723 c noarst : noarst(i) numero d'une arete de sommet i
01724 c
01725 c auxiliaire :
01726 c ------------
01727 c laqueu : mxqueu entiers servant de queue pour le parcours de letree
01728 c
01729 c sorties:
01730 c --------
01731 c n1artr : numero du premier triangle vide dans le tableau noartr
01732 c          le chainage des triangles vides se fait sur noartr(2,.)
01733 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
01734 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
01735 c ierr   : =0 si pas d'erreur
01736 c          =1 si le tableau nosoar est sature
01737 c          =2 si le tableau noartr est sature
01738 c          =3 si aucun des triangles ne contient l'un des points internes d'un t
01739 c          =5 si saturation de la queue de parcours de l'arbre des te
01740 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01741 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
01742 c2345x7..............................................................012
01743       common / unites / lecteu, imprim, intera, nunite(29)
01744 c
01745       double precision  pxyd(3,mxsomm)
01746       double precision  comxmi(3,2),aretmx,a,s,xrmin,xrmax,yrmin,yrmax
01747       double precision  dmin, dmax
01748 c
01749       integer           nosoar(mosoar,mxsoar),
01750      %                  noartr(moartr,mxartr),
01751      %                  noarst(mxsomm)
01752 c
01753       integer           letree(0:8,0:*)
01754       integer           laqueu(1:mxqueu)
01755 c                       lequeu:entree dans la queue en gestion circulaire
01756 c                       lhqueu:longueur de la queue en gestion circulaire
01757 c
01758       integer           milieu(3), nutr(1:13)
01759 c
01760 c     le rectangle englobant pour selectionner les te "internes"
01761 c     le numero des 3 sommets du te englobant racine de l'arbre des te
01762       ns1 = letree(6,1)
01763       ns2 = letree(7,1)
01764       ns3 = letree(8,1)
01765       a   = aretmx * 0.01d0
01766 c     abscisse du milieu de l'arete gauche du te 1
01767       s      = ( pxyd(1,ns1) + pxyd(1,ns3) ) / 2
01768       xrmin  = min( s, comxmi(1,1) - aretmx ) - a
01769 c     abscisse du milieu de l'arete droite du te 1
01770       s      = ( pxyd(1,ns2) + pxyd(1,ns3) ) / 2
01771       xrmax  = max( s, comxmi(1,2) + aretmx ) + a
01772       yrmin  = comxmi(2,1) - aretmx
01773 c     ordonnee de la droite passant par les milieus des 2 aretes
01774 c     droite gauche du te 1
01775       s      = ( pxyd(2,ns1) + pxyd(2,ns3) ) / 2
01776       yrmax  = max( s, comxmi(2,2) + aretmx ) + a
01777 c
01778 c     cas particulier de 3 ou 4 ou peu d'aretes frontalieres
01779       if( nbarpi .le. 8 ) then
01780 c        tout le triangle englobant (racine) est a prendre en compte
01781          xrmin = pxyd(1,ns1) - a
01782          xrmax = pxyd(1,ns2) + a
01783          yrmin = pxyd(2,ns1) - a
01784          yrmax = pxyd(2,ns3) + a
01785       endif
01786 c
01787 c     initialisation du tableau noartr
01788       do 5 i=1,mxartr
01789 c        le numero de l'arete est inconnu
01790          noartr(1,i) = 0
01791 c        le chainage sur le triangle vide suivant
01792          noartr(2,i) = i+1
01793  5    continue
01794       noartr(2,mxartr) = 0
01795       n1artr = 1
01796 c
01797 c     parcours des te jusqu'a trianguler toutes les feuilles (triangles eq)
01798 c     =====================================================================
01799 c     initialisation de la queue sur les te
01800       ierr   = 0
01801       lequeu = 1
01802       lhqueu = 0
01803 c     la racine de letree initialise la queue
01804       laqueu(1) = 1
01805 c
01806 c     tant que la longueur de la queue est >=0 traiter le debut de queue
01807  10   if( lhqueu .ge. 0 ) then
01808 c
01809 c        le triangle te a traiter
01810          i   = lequeu - lhqueu
01811          if( i .le. 0 ) i = mxqueu + i
01812          nte = laqueu( i )
01813 c        la longueur est reduite
01814          lhqueu = lhqueu - 1
01815 c
01816 c        nte est il un sous-triangle feuille (minimal) ?
01817  15      if( letree(0,nte) .gt. 0 ) then
01818 c           non les 4 sous-triangles sont mis dans la queue
01819             if( lhqueu + 4 .ge. mxqueu ) then
01820                write(imprim,*) 'tetrte: saturation de la queue'
01821                ierr = 5
01822                return
01823             endif
01824             do 20 i=3,0,-1
01825 c              ajout du sous-triangle i
01826                lhqueu = lhqueu + 1
01827                lequeu = lequeu + 1
01828                if( lequeu .gt. mxqueu ) lequeu = lequeu - mxqueu
01829                laqueu( lequeu ) = letree( i, nte )
01830  20         continue
01831             goto 10
01832          endif
01833 c
01834 c        ici nte est un triangle minimal non subdivise
01835 c        ---------------------------------------------
01836 c        le te est il dans le cadre englobant de l'objet ?
01837          ns1 = letree(6,nte)
01838          ns2 = letree(7,nte)
01839          ns3 = letree(8,nte)
01840          if( pxyd(1,ns1) .gt. pxyd(1,ns2) ) then
01841             dmin = pxyd(1,ns2)
01842             dmax = pxyd(1,ns1)
01843          else
01844             dmin = pxyd(1,ns1)
01845             dmax = pxyd(1,ns2)
01846          endif
01847          if( (xrmin .le. dmin .and. dmin .le. xrmax) .or.
01848      %       (xrmin .le. dmax .and. dmax .le. xrmax) ) then
01849             if( pxyd(2,ns1) .gt. pxyd(2,ns3) ) then
01850                dmin = pxyd(2,ns3)
01851                dmax = pxyd(2,ns1)
01852             else
01853                dmin = pxyd(2,ns1)
01854                dmax = pxyd(2,ns3)
01855             endif
01856             if( (yrmin .le. dmin .and. dmin .le. yrmax) .or.
01857      %          (yrmin .le. dmax .and. dmax .le. yrmax) ) then
01858 c
01859 c              te minimal et interne au rectangle englobant
01860 c              --------------------------------------------
01861 c              recherche du nombre de niveaux entre nte et les te voisins
01862 c              par ses aretes
01863                nbmili = 0
01864                do 30 i=1,3
01865 c
01866 c                 a priori pas de milieu de l'arete i du te nte
01867                   milieu(i) = 0
01868 c
01869 c                 recherche de noteva te voisin de nte par l'arete i
01870                   call n1trva( nte, i, letree, noteva, niveau )
01871 c                 noteva  : >0 numero letree du te voisin par l'arete i
01872 c                           =0 si pas de te voisin (racine , ... )
01873 c                 niveau  : =0 si nte et noteva ont meme taille
01874 c                           >0 nte est 4**niveau fois plus petit que noteva
01875                   if( noteva .gt. 0 ) then
01876 c                    il existe un te voisin
01877                      if( letree(0,noteva) .gt. 0 ) then
01878 c                       noteva est plus petit que nte
01879 c                       => recherche du numero du milieu du cote=sommet du te no
01880 c                       le sous-te 0 du te noteva
01881                         nsot = letree(0,noteva)
01882 c                       le numero dans pxyd du milieu de l'arete i de nte
01883                         milieu( i ) = letree( 5+nopre3(i), nsot )
01884                         nbmili = nbmili + 1
01885                      endif
01886                   endif
01887 c
01888  30            continue
01889 c
01890 c              triangulation du te nte en fonction du nombre de ses milieux
01891                goto( 50, 100, 200, 300 ) , nbmili + 1
01892 c
01893 c              0 milieu => 1 triangle = le te nte
01894 c              ----------------------------------
01895  50            call f0trte( letree(0,nte),  pxyd,
01896      %                      mosoar, mxsoar, n1soar, nosoar,
01897      %                      moartr, mxartr, n1artr, noartr,
01898      %                      noarst,
01899      %                      nbtr,   nutr,   ierr )
01900                if( ierr .ne. 0 ) return
01901                goto 10
01902 c
01903 c              1 milieu => 2 triangles = 2 demi te
01904 c              -----------------------------------
01905  100           call f1trte( letree(0,nte),  pxyd,   milieu,
01906      %                      mosoar, mxsoar, n1soar, nosoar,
01907      %                      moartr, mxartr, n1artr, noartr,
01908      %                      noarst,
01909      %                      nbtr,   nutr,   ierr )
01910                if( ierr .ne. 0 ) return
01911                goto 10
01912 c
01913 c              2 milieux => 3 triangles
01914 c              -----------------------------------
01915  200           call f2trte( letree(0,nte),  pxyd,   milieu,
01916      %                      mosoar, mxsoar, n1soar, nosoar,
01917      %                      moartr, mxartr, n1artr, noartr,
01918      %                      noarst,
01919      %                      nbtr,   nutr,   ierr )
01920                if( ierr .ne. 0 ) return
01921                goto 10
01922 c
01923 c              3 milieux => 4 triangles = 4 quart te
01924 c              -------------------------------------
01925  300           call f3trte( letree(0,nte),  pxyd,   milieu,
01926      %                      mosoar, mxsoar, n1soar, nosoar,
01927      %                      moartr, mxartr, n1artr, noartr,
01928      %                      noarst,
01929      %                      nbtr,   nutr,   ierr )
01930                if( ierr .ne. 0 ) return
01931                goto 10
01932             endif
01933          endif
01934          goto 10
01935       endif
01936       end
01937 
01938 
01939       subroutine aisoar( mosoar, mxsoar, nosoar, na1 )
01940 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01941 c but :    chainer en colonne lchain les aretes non vides et
01942 c -----    non frontalieres du tableau nosoar
01943 c
01944 c entrees:
01945 c --------
01946 c mosoar : nombre maximal d'entiers par arete dans le tableau nosoar
01947 c mxsoar : nombre maximal d'aretes frontalieres declarables
01948 c
01949 c modifies :
01950 c ----------
01951 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
01952 c          nosoar(lchain,i)=arete interne suivante
01953 c
01954 c sortie :
01955 c --------
01956 c na1    : numero dans nosoar de la premiere arete interne
01957 c          les suivantes sont nosoar(lchain,na1), ...
01958 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01959 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
01960 c....................................................................012
01961       parameter (lchain=6)
01962       integer    nosoar(mosoar,mxsoar)
01963 c
01964 c     formation du chainage des aretes internes a echanger eventuellement
01965 c     recherche de la premiere arete non vide et non frontaliere
01966       do 10 na1=1,mxsoar
01967          if( nosoar(1,na1) .gt. 0 .and. nosoar(3,na1) .le. 0 ) goto 15
01968  10   continue
01969 c
01970 c     protection de la premiere arete non vide et non frontaliere
01971  15   na0 = na1
01972       do 20 na=na1+1,mxsoar
01973          if( nosoar(1,na) .gt. 0 .and. nosoar(3,na) .le. 0 ) then
01974 c           arete interne => elle est chainee a partir de la precedente
01975             nosoar(lchain,na0) = na
01976             na0 = na
01977          endif
01978  20   continue
01979 c
01980 c     la derniere arete interne n'a pas de suivante
01981       nosoar(lchain,na0) = 0
01982       end
01983 
01984 
01985       subroutine tedela( pxyd,   noarst,
01986      %                   mosoar, mxsoar, n1soar, nosoar, n1ardv,
01987      %                   moartr, mxartr, n1artr, noartr, modifs )
01988 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01989 c but :    pour toutes les aretes chainees dans nosoar(lchain,*)
01990 c -----    du tableau nosoar
01991 c          echanger la diagonale des 2 triangles si le sommet oppose
01992 c          a un triangle ayant en commun une arete appartient au cercle
01993 c          circonscrit de l'autre (violation boule vide delaunay)
01994 c
01995 c entrees:
01996 c --------
01997 c pxyd   : tableau des x  y  distance_souhaitee de chaque sommet
01998 c
01999 c modifies :
02000 c ----------
02001 c noarst : noarst(i) numero d'une arete de sommet i
02002 c mosoar : nombre maximal d'entiers par arete dans le tableau nosoar
02003 c mxsoar : nombre maximal d'aretes frontalieres declarables
02004 c n1soar : numero de la premiere arete vide dans le tableau nosoar
02005 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
02006 c n1ardv : numero dans nosoar de la premiere arete du chainage
02007 c          des aretes a rendre delaunay
02008 c
02009 c moartr : nombre d'entiers par triangle dans le tableau noartr
02010 c mxartr : nombre maximal de triangles declarables dans noartr
02011 c n1artr : numero du premier triangle vide dans le tableau noartr
02012 c          le chainage des triangles vides se fait sur noartr(2,.)
02013 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
02014 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
02015 c modifs : nombre d'echanges de diagonales pour maximiser la qualite
02016 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
02017 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
02018 c....................................................................012
02019       parameter        (lchain=6)
02020       common / unites / lecteu, imprim, nunite(30)
02021       double precision  pxyd(3,*), surtd2, s123, s142, s143, s234,
02022      %                  s12, s34, a12, cetria(3), r0
02023       integer           nosoar(mosoar,mxsoar),
02024      %                  noartr(moartr,mxartr),
02025      %                  noarst(*)
02026 c
02027 c     le nombre d'echanges de diagonales pour minimiser l'aire
02028       modifs = 0
02029       r0     = 0
02030 c
02031 c     la premiere arete du chainage des aretes a rendre delaunay
02032       na0 = n1ardv
02033 c
02034 c     tant que la pile des aretes a echanger eventuellement est non vide
02035 c     ==================================================================
02036  20   if( na0 .gt. 0 ) then
02037 c
02038 c        l'arete a traiter
02039          na  = na0
02040 c        la prochaine arete a traiter
02041          na0 = nosoar(lchain,na0)
02042 c
02043 c        l'arete est marquee traitee avec le numero -1
02044          nosoar(lchain,na) = -1
02045 c
02046 c        l'arete est elle active?
02047          if( nosoar(1,na) .eq. 0 ) goto 20
02048 c
02049 c        si arete frontaliere pas d'echange possible
02050          if( nosoar(3,na) .gt. 0 ) goto 20
02051 c
02052 c        existe-t-il 2 triangles ayant cette arete commune?
02053          if( nosoar(4,na) .le. 0 .or. nosoar(5,na) .le. 0 ) goto 20
02054 c
02055 c        aucun des 2 triangles est-il desactive?
02056          if( noartr(1,nosoar(4,na)) .eq. 0 .or.
02057      %       noartr(1,nosoar(5,na)) .eq. 0 ) goto 20
02058 c
02059 c        l'arete appartient a deux triangles actifs
02060 c        le numero des 4 sommets du quadrangle des 2 triangles
02061          call mt4sqa( na, moartr, noartr, mosoar, nosoar,
02062      %                ns1, ns2, ns3, ns4 )
02063          if( ns4 .eq. 0 ) goto 20
02064 c
02065 c        carre de la longueur de l'arete ns1 ns2
02066          a12 = (pxyd(1,ns2)-pxyd(1,ns1))**2+(pxyd(2,ns2)-pxyd(2,ns1))**2
02067 c
02068 c        comparaison de la somme des aires des 2 triangles
02069 c        -------------------------------------------------
02070 c        calcul des surfaces des triangles 123 et 142 de cette arete
02071          s123=surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
02072          s142=surtd2( pxyd(1,ns1), pxyd(1,ns4), pxyd(1,ns2) )
02073          s12 = abs( s123 ) + abs( s142 )
02074          if( s12 .le. 0.001*a12 ) goto 20
02075 c
02076 c        calcul des surfaces des triangles 143 et 234 de cette arete
02077          s143=surtd2( pxyd(1,ns1), pxyd(1,ns4), pxyd(1,ns3) )
02078          s234=surtd2( pxyd(1,ns2), pxyd(1,ns3), pxyd(1,ns4) )
02079          s34 = abs( s234 ) + abs( s143 )
02080 c
02081          if( abs(s34-s12) .gt. 1d-15*s34 ) goto 20
02082 c
02083 c        quadrangle convexe : le critere de delaunay intervient
02084 c        ------------------   ---------------------------------
02085 c        calcul du centre et rayon de la boule circonscrite a ns123
02086 c        pas d'affichage si le triangle est degenere
02087          ierr = -1
02088          call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), cetria,
02089      %                ierr )
02090          if( ierr .gt. 0 ) then
02091 c           ierr=1 si triangle degenere  => abandon
02092             goto 20
02093          endif
02094 c
02095          if( (cetria(1)-pxyd(1,ns4))**2+(cetria(2)-pxyd(2,ns4))**2
02096      %       .lt. cetria(3) ) then
02097 c
02098 c           protection contre une boucle infinie sur le meme cercle
02099             if( r0 .eq. cetria(3) ) goto 20
02100 c
02101 c           oui: ns4 est dans le cercle circonscrit a ns1 ns2 ns3
02102 c           => ns3 est aussi dans le cercle circonscrit de ns1 ns2 ns4
02103 c           echange de la diagonale 12 par 34 des 2 triangles
02104             call te2t2t( na,     mosoar, n1soar, nosoar, noarst,
02105      %                   moartr, noartr, na34 )
02106             if( na34 .eq. 0 ) goto 20
02107             r0 = cetria(3)
02108 c
02109 c           l'arete na34 est marquee traitee
02110             nosoar(lchain,na34) = -1
02111             modifs = modifs + 1
02112 c
02113 c           les aretes internes peripheriques des 2 triangles sont enchainees
02114             do 60 j=4,5
02115                nt = nosoar(j,na34)
02116                do 50 i=1,3
02117                   n = abs( noartr(i,nt) )
02118                   if( n .ne. na34 ) then
02119                      if( nosoar(3,n)      .eq.  0  .and.
02120      %                   nosoar(lchain,n) .eq. -1 ) then
02121 c                        cette arete marquee est chainee pour etre traitee
02122                          nosoar(lchain,n) = na0
02123                          na0 = n
02124                      endif
02125                   endif
02126  50            continue
02127  60         continue
02128             goto 20
02129          endif
02130 c
02131 c        retour en haut de la pile des aretes a traiter
02132          goto 20
02133       endif
02134 c
02135       return
02136       end
02137 
02138 
02139       subroutine terefr( nbarpi, pxyd,
02140      %                   mosoar, mxsoar, n1soar, nosoar,
02141      %                   moartr, mxartr, n1artr, noartr, noarst,
02142      %                   mxarcf, n1arcf, noarcf, larmin, notrcf,
02143      %                   nbarpe, ierr )
02144 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
02145 c but :   recherche des aretes de la frontiere non dans la triangulation
02146 c -----   triangulation frontale pour les reobtenir
02147 c
02148 c         attention: le chainage lchain de nosoar devient celui des cf
02149 c
02150 c entrees:
02151 c --------
02152 c          le tableau nosoar
02153 c nbarpi : numero du dernier point interne impose par l'utilisateur
02154 c pxyd   : tableau des coordonnees 2d des points
02155 c          par point : x  y  distance_souhaitee
02156 c mosoar : nombre maximal d'entiers par arete et
02157 c          indice dans nosoar de l'arete suivante dans le hachage
02158 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
02159 c          attention: mxsoar>3*mxsomm obligatoire!
02160 c moartr : nombre maximal d'entiers par arete du tableau noartr
02161 c mxartr : nombre maximal de triangles declarables dans noartr
02162 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
02163 c
02164 c modifies:
02165 c ---------
02166 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
02167 c          chainage des vides suivant en 3 et precedant en 2 de nosoar
02168 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
02169 c          chainage des aretes frontalieres, chainage du hachage des aretes
02170 c          hachage des aretes = nosoar(1)+nosoar(2)*2
02171 c          avec mxsoar>=3*mxsomm
02172 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
02173 c          nosoar(2,arete vide)=l'arete vide qui precede
02174 c          nosoar(3,arete vide)=l'arete vide qui suit
02175 c n1artr : numero du premier triangle vide dans le tableau noartr
02176 c          le chainage des triangles vides se fait sur noartr(2,.)
02177 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
02178 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
02179 c noarst : noarst(i) numero d'une arete de sommet i
02180 c
02181 c
02182 c auxiliaires :
02183 c -------------
02184 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
02185 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
02186 c larmin : tableau (mxarcf)   auxiliaire d'entiers
02187 c notrcf : tableau (mxarcf)   auxiliaire d'entiers
02188 c
02189 c sortie :
02190 c --------
02191 c nbarpe : nombre d'aretes perdues puis retrouvees
02192 c ierr   : =0 si pas d'erreur
02193 c          >0 si une erreur est survenue
02194 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
02195 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
02196 c....................................................................012
02197       parameter        (lchain=6)
02198       common / unites / lecteu,imprim,intera,nunite(29)
02199       double precision  pxyd(3,*)
02200       integer           nosoar(mosoar,mxsoar),
02201      %                  noartr(moartr,mxartr),
02202      %                  noarst(*),
02203      %                  n1arcf(0:mxarcf),
02204      %                  noarcf(3,mxarcf),
02205      %                  larmin(mxarcf),
02206      %                  notrcf(mxarcf)
02207 c
02208       ierr = 0
02209 c
02210 c     le nombre d'aretes de la frontiere non arete de la triangulation
02211       nbarpe = 0
02212 c
02213 c     initialisation du chainage des aretes des cf => 0 arete de cf
02214       do 10 narete=1,mxsoar
02215          nosoar( lchain, narete) = -1
02216  10   continue
02217 c
02218 c     boucle sur l'ensemble des aretes actuelles
02219 c     ==========================================
02220       do 30 narete=1,mxsoar
02221 c
02222          if( nosoar(3,narete) .gt. 0 ) then
02223 c           arete appartenant a une ligne => frontaliere
02224 c
02225             if(nosoar(4,narete) .le. 0 .or. nosoar(5,narete) .le. 0)then
02226 c              l'arete narete frontaliere n'appartient pas a 2 triangles
02227 c              => elle est perdue
02228                nbarpe = nbarpe + 1
02229 c
02230 c              le numero des 2 sommets de l'arete frontaliere perdue
02231                ns1 = nosoar( 1, narete )
02232                ns2 = nosoar( 2, narete )
02233 c               write(imprim,10000) ns1,(pxyd(j,ns1),j=1,2),
02234 c     %                             ns2,(pxyd(j,ns2),j=1,2)
02235 10000          format(' arete perdue a forcer',
02236      %               (t24,'sommet=',i6,' x=',g13.5,' y=',g13.5))
02237 c
02238 c              traitement de cette arete perdue ns1-ns2
02239                call tefoar( narete, nbarpi, pxyd,
02240      %                      mosoar, mxsoar, n1soar, nosoar,
02241      %                      moartr, mxartr, n1artr, noartr, noarst,
02242      %                      mxarcf, n1arcf, noarcf, larmin, notrcf,
02243      %                      ierr )
02244                if( ierr .ne. 0 ) return
02245 c
02246 c              fin du traitement de cette arete perdue et retrouvee
02247             endif
02248          endif
02249 c
02250  30   continue
02251       end
02252 
02253 
02254       subroutine tesuex( nblftr, nulftr,
02255      %                   ndtri0, nbsomm, pxyd, nslign,
02256      %                   mosoar, mxsoar, nosoar,
02257      %                   moartr, mxartr, n1artr, noartr, noarst,
02258      %                   nbtria, letrsu, ierr  )
02259 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
02260 c but :    supprimer du tableau noartr les triangles externes au domaine
02261 c -----    en annulant le numero de leur 1-ere arete dans noartr
02262 c          et en les chainant comme triangles vides
02263 c
02264 c entrees:
02265 c --------
02266 c nblftr : nombre de  lignes fermees definissant la surface
02267 c nulftr : numero des lignes fermees definissant la surface
02268 c ndtri0 : plus grand numero dans noartr d'un triangle
02269 c pxyd   : tableau des coordonnees 2d des points
02270 c          par point : x  y  distance_souhaitee
02271 c nslign : tableau du numero de sommet dans sa ligne pour chaque
02272 c          sommet frontalier
02273 c          numero du point dans le lexique point si interne impose
02274 c          0 si le point est interne non impose par l'utilisateur
02275 c         -1 si le sommet est externe au domaine
02276 c mosoar : nombre maximal d'entiers par arete et
02277 c          indice dans nosoar de l'arete suivante dans le hachage
02278 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
02279 c          attention: mxsoar>3*mxsomm obligatoire!
02280 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
02281 c          chainage des aretes frontalieres, chainage du hachage des aretes
02282 c          hachage des aretes = nosoar(1)+nosoar(2)*2
02283 c          avec mxsoar>=3*mxsomm
02284 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
02285 c          nosoar(2,arete vide)=l'arete vide qui precede
02286 c          nosoar(3,arete vide)=l'arete vide qui suit
02287 c moartr : nombre maximal d'entiers par arete du tableau noartr
02288 c mxartr : nombre maximal de triangles declarables
02289 c n1artr : numero du premier triangle vide dans le tableau noartr
02290 c          le chainage des triangles vides se fait sur noartr(2,.)
02291 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
02292 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
02293 c noarst : noarst(i) numero nosoar d'une arete de sommet i
02294 c
02295 c sorties:
02296 c --------
02297 c nbtria : nombre de triangles internes au domaine
02298 c letrsu : letrsu(nt)=numero du triangle interne, 0 sinon
02299 c noarst : noarst(i) numero nosoar d'une arete du sommet i (modifi'e)
02300 c ierr   : 0 si pas d'erreur, >0 sinon
02301 cc++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
02302 c auteur : alain perronnet  analyse numerique paris upmc        mai 1999
02303 c2345x7..............................................................012
02304       common / unites / lecteu,imprim,intera,nunite(29)
02305       double precision  pxyd(3,*)
02306       integer           nulftr(nblftr),nslign(nbsomm),
02307      %                  nosoar(mosoar,mxsoar),
02308      %                  noartr(moartr,mxartr),
02309      %                  noarst(*)
02310       integer           letrsu(1:ndtri0)
02311       double precision  dmin
02312 c
02313 c     les triangles sont a priori non marques
02314       do 5 nt=1,ndtri0
02315          letrsu(nt) = 0
02316  5    continue
02317 c
02318 c     les aretes sont marquees non chainees
02319       do 10 noar1=1,mxsoar
02320          nosoar(6,noar1) = -2
02321  10   continue
02322 c
02323 c     recherche du sommet de la triangulation de plus petite abscisse
02324 c     ===============================================================
02325       ntmin = 0
02326       dmin  = 1d38
02327       do 20 i=1,nbsomm
02328          if( pxyd(1,i) .lt. dmin ) then
02329 c           le nouveau minimum
02330             noar1 = noarst(i)
02331             if( noar1 .gt. 0 ) then
02332 c              le sommet appartient a une arete de triangle
02333                if( nosoar(4,noar1) .gt. 0 ) then
02334 c                 le nouveau minimum
02335                   dmin  = pxyd(1,i)
02336                   ntmin = i
02337                endif
02338             endif
02339          endif
02340  20   continue
02341 c
02342 c     une arete de sommet ntmin
02343       noar1 = noarst( ntmin )
02344 c     un triangle d'arete noar1
02345       ntmin = nosoar( 4, noar1 )
02346       if( ntmin .le. 0 ) then
02347 c         nblgrc(nrerr) = 1
02348 c         kerr(1) = 'pas de triangle d''abscisse minimale'
02349 c         call lereur
02350          write(imprim,*) 'pas de triangle d''abscisse minimale'
02351          ierr = 2
02352          goto 9990
02353       endif
02354 c
02355 c     chainage des 3 aretes du triangle ntmin
02356 c     =======================================
02357 c     la premiere arete du chainage des aretes traitees
02358       noar1 = abs( noartr(1,ntmin) )
02359       na0   = abs( noartr(2,ntmin) )
02360 c     elle est chainee sur la seconde arete du triangle ntmin
02361       nosoar(6,noar1) = na0
02362 c     les 2 autres aretes du triangle ntmin sont chainees
02363       na1 = abs( noartr(3,ntmin) )
02364 c     la seconde est chainee sur la troisieme arete
02365       nosoar(6,na0) = na1
02366 c     la troisieme n'a pas de suivante
02367       nosoar(6,na1) = 0
02368 c
02369 c     le triangle ntmin est a l'exterieur du domaine
02370 c     tous les triangles externes sont marques -123 456 789
02371 c     les triangles de l'autre cote d'une arete sur une ligne
02372 c     sont marques: no de la ligne de l'arete * signe oppose
02373 c     =======================================================
02374       ligne0 = 0
02375       ligne  = -123 456 789
02376 c
02377  40   if( noar1 .ne. 0 ) then
02378 c
02379 c        l'arete noar1 du tableau nosoar est a traiter
02380 c        ---------------------------------------------
02381          noar = noar1
02382 c        l'arete suivante devient la premiere a traiter ensuite
02383          noar1 = nosoar(6,noar1)
02384 c        l'arete noar est traitee
02385          nosoar(6,noar) = -3
02386 c
02387          do 60 i=4,5
02388 c
02389 c           l'un des 2 triangles de l'arete
02390             nt = nosoar(i,noar)
02391             if( nt .gt. 0 ) then
02392 c
02393 c              triangle deja traite pour une ligne anterieure?
02394                if(     letrsu(nt)  .ne. 0      .and.
02395      %             abs(letrsu(nt)) .ne. ligne ) goto 60
02396 c
02397 c              le triangle est marque avec la valeur de ligne
02398                letrsu(nt) = ligne
02399 c
02400 c              chainage eventuel des autres aretes de ce triangle
02401 c              si ce n'est pas encore fait
02402                do 50 j=1,3
02403 c
02404 c                 le numero na de l'arete j du triangle nt dans nosoar
02405                   na = abs( noartr(j,nt) )
02406                   if( nosoar(6,na) .ne. -2 ) goto 50
02407 c
02408 c                 le numero de 1 a nblftr dans nulftr de la ligne de l'arete
02409                   nl = nosoar(3,na)
02410 c
02411 c                 si l'arete est sur une ligne fermee differente de celle envelo
02412 c                 et non marquee alors examen du triangle oppose
02413                   if( nl .gt. 0 ) then
02414 c
02415                      if( nl .eq. ligne0 ) goto 50
02416 c
02417 c                    arete frontaliere de ligne non traitee
02418 c                    => passage de l'autre cote de la ligne
02419 c                    le triangle de l'autre cote de la ligne est recherche
02420                      if( nt .eq. abs( nosoar(4,na) ) ) then
02421                         nt2 = 5
02422                      else
02423                         nt2 = 4
02424                      endif
02425                      nt2 = abs( nosoar(nt2,na) )
02426                      if( nt2 .gt. 0 ) then
02427 c
02428 c                       le triangle nt2 de l'autre cote est marque avec le
02429 c                       avec le signe oppose de celui de ligne
02430                         if( ligne .ge. 0 ) then
02431                            lsigne = -1
02432                         else
02433                            lsigne =  1
02434                         endif
02435                         letrsu(nt2) = lsigne * nl
02436 c
02437 c                       temoin de ligne a traiter ensuite dans nulftr
02438                         nulftr(nl) = -abs( nulftr(nl) )
02439 c
02440 c                       l'arete est traitee
02441                         nosoar(6,na) = -3
02442 c
02443                      endif
02444 c
02445 c                    l'arete est traitee
02446                      goto 50
02447 c
02448                   endif
02449 c
02450 c                 arete non traitee => elle est chainee
02451                   nosoar(6,na) = noar1
02452                   noar1 = na
02453 c
02454  50            continue
02455 c
02456             endif
02457  60      continue
02458 c
02459          goto 40
02460       endif
02461 c     les triangles de la ligne fermee ont tous ete marques
02462 c     plus d'arete chainee
02463 c
02464 c     recherche d'une nouvelle ligne fermee a traiter
02465 c     ===============================================
02466  65   do 70 nl=1,nblftr
02467          if( nulftr(nl) .lt. 0 ) goto 80
02468  70   continue
02469 c     plus de ligne fermee a traiter
02470       goto 110
02471 c
02472 c     tous les triangles de cette composante connexe
02473 c     entre ligne et ligne0 vont etre marques
02474 c     ==============================================
02475 c     remise en etat du numero de ligne
02476 c     nl est le numero de la ligne dans nulftr a traiter
02477  80   nulftr(nl) = -nulftr(nl)
02478       do 90 nt2=1,ndtri0
02479          if( abs(letrsu(nt2)) .eq. nl ) goto 92
02480  90   continue
02481 c
02482 c     recherche de l'arete j du triangle nt2 avec ce numero de ligne nl
02483  92   do 95 j=1,3
02484 c
02485 c        le numero de l'arete j du triangle dans nosoar
02486          noar1 = 0
02487          na0   = abs( noartr(j,nt2) )
02488          if( nl .eq. nosoar(3,na0) ) then
02489 c
02490 c           na0 est l'arete de ligne nl
02491 c           l'arete suivante du triangle nt2
02492             i   = mod(j,3) + 1
02493 c           le numero dans nosoar de l'arete i de nt2
02494             na1 = abs( noartr(i,nt2) )
02495             if( nosoar(6,na1) .eq. -2 ) then
02496 c              arete non traitee => elle est la premiere du chainage
02497                noar1 = na1
02498 c              pas de suivante dans ce chainage
02499                nosoar(6,na1) = 0
02500             else
02501                na1 = 0
02502             endif
02503 c
02504 c           l'eventuelle seconde arete suivante
02505             i  = mod(i,3) + 1
02506             na = abs( noartr(i,nt2) )
02507             if( nosoar(6,na) .eq. -2 ) then
02508                if( na1 .eq. 0 ) then
02509 c                 1 arete non traitee et seule a chainer
02510                   noar1 = na
02511                   nosoar(6,na) = 0
02512                else
02513 c                 2 aretes a chainer
02514                   noar1 = na
02515                   nosoar(6,na) = na1
02516                endif
02517             endif
02518 c
02519             if( noar1 .gt. 0 ) then
02520 c
02521 c              il existe au moins une arete a visiter pour ligne
02522 c              marquage des triangles internes a la ligne nl
02523                ligne  = letrsu(nt2)
02524                ligne0 = nl
02525                goto 40
02526 c
02527             else
02528 c
02529 c              nt2 est le seul triangle de la ligne fermee
02530                goto 65
02531 c
02532             endif
02533          endif
02534  95   continue
02535 c
02536 c     reperage des sommets internes ou externes dans nslign
02537 c     nslign(sommet externe au domaine)=-1
02538 c     nslign(sommet interne au domaine)= 0
02539 c     =====================================================
02540  110  do 170 ns1=1,nbsomm
02541 c        tout sommet non sur la frontiere ou interne impose
02542 c        est suppose externe
02543          if( nslign(ns1) .eq. 0 ) nslign(ns1) = -1
02544  170  continue
02545 c
02546 c     les triangles externes sont marques vides dans le tableau noartr
02547 c     ================================================================
02548       nbtria = 0
02549       do 200 nt=1,ndtri0
02550 c
02551          if( letrsu(nt) .le. 0 ) then
02552 c
02553 c           triangle nt externe
02554             if( noartr(1,nt) .ne. 0 ) then
02555 c              la premiere arete est annulee
02556                noartr(1,nt) = 0
02557 c              le triangle nt est considere comme etant vide
02558                noartr(2,nt) = n1artr
02559                n1artr = nt
02560             endif
02561 c
02562          else
02563 c
02564 c           triangle nt interne
02565             nbtria = nbtria + 1
02566             letrsu(nt) = nbtria
02567 c
02568 c           marquage des 3 sommets du triangle nt
02569             do 190 i=1,3
02570 c              le numero nosoar de l'arete i du triangle nt
02571                noar = abs( noartr(i,nt) )
02572 c              le numero des 2 sommets
02573                ns1 = nosoar(1,noar)
02574                ns2 = nosoar(2,noar)
02575 c              mise a jour du numero d'une arete des 2 sommets de l'arete
02576                noarst( ns1 ) = noar
02577                noarst( ns2 ) = noar
02578 c              ns1 et ns2 sont des sommets de la triangulation du domaine
02579                if( nslign(ns1) .lt. 0 ) nslign(ns1)=0
02580                if( nslign(ns2) .lt. 0 ) nslign(ns2)=0
02581  190        continue
02582 c
02583          endif
02584 c
02585  200  continue
02586 c     ici tout sommet externe ns verifie nslign(ns)=-1
02587 c
02588 c     les triangles externes sont mis a zero dans nosoar
02589 c     ==================================================
02590       do 300 noar=1,mxsoar
02591 c
02592          if( nosoar(1,noar) .gt. 0 ) then
02593 c
02594 c           le second triangle de l'arete noar
02595             nt = nosoar(5,noar)
02596             if( nt .gt. 0 ) then
02597 c              si le triangle nt est externe
02598 c              alors il est supprime pour l'arete noar
02599                if( letrsu(nt) .le. 0 ) nosoar(5,noar)=0
02600             endif
02601 c
02602 c           le premier triangle de l'arete noar
02603             nt = nosoar(4,noar)
02604             if( nt .gt. 0 ) then
02605                if( letrsu(nt) .le. 0 ) then
02606 c                 si le triangle nt est externe
02607 c                 alors il est supprime pour l'arete noar
02608 c                 et l'eventuel triangle oppose prend sa place
02609 c                 en position 4 de nosoar
02610                   if( nosoar(5,noar) .gt. 0 ) then
02611                      nosoar(4,noar)=nosoar(5,noar)
02612                      nosoar(5,noar)=0
02613                   else
02614                      nosoar(4,noar)=0
02615                   endif
02616                endif
02617             endif
02618          endif
02619 c
02620  300  continue
02621 c
02622 c     remise en etat pour eviter les modifications de ladefi
02623  9990 do 9991 nl=1,nblftr
02624          if( nulftr(nl) .lt. 0 ) nulftr(nl)=-nulftr(nl)
02625  9991 continue
02626       return
02627       end
02628 
02629 
02630       subroutine trp1st( ns,     noarst, mosoar, nosoar,
02631      %                   moartr, mxartr, noartr,
02632      %                   mxpile, lhpile, lapile )
02633 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
02634 c but :   recherche des triangles de noartr partageant le sommet ns
02635 c -----
02636 c         limite: un camembert de centre ns entame 2 fois
02637 c                 ne donne que l'une des parties
02638 c
02639 c entrees:
02640 c --------
02641 c ns     : numero du sommet
02642 c noarst : noarst(i) numero d'une arete de sommet i
02643 c mosoar : nombre maximal d'entiers par arete et
02644 c          indice dans nosoar de l'arete suivante dans le hachage
02645 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
02646 c          chainage des aretes frontalieres, chainage du hachage des aretes
02647 c moartr : nombre maximal d'entiers par arete du tableau noartr
02648 c mxartr : nombre de triangles declares dans noartr
02649 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
02650 c mxpile : nombre maximal de triangles empilables
02651 c
02652 c sorties :
02653 c ---------
02654 c lhpile : >0 nombre de triangles empiles
02655 c          =0       si impossible de tourner autour du point
02656 c                   ou zero triangle contenant le sommet ns
02657 c          =-lhpile si apres butee sur la frontiere il y a a nouveau
02658 c          butee sur la frontiere . a ce stade on ne peut dire si tous
02659 c          les triangles ayant ce sommet ont ete recenses
02660 c          ce cas arrive seulement si le sommet est sur la frontiere
02661 c          par un balayage de tous les triangles, lhpile donne le
02662 c          nombre de triangles de sommet ns
02663 c          remarque: si la pile est saturee recherche de tous les
02664 c          triangles de sommet ns par balayage de tous les triangles
02665 c lapile : numero dans noartr des triangles de sommet ns
02666 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
02667 c auteur: alain perronnet analyse numerique paris upmc         mars 1997
02668 c modifs: alain perronnet Laboratoire J-L. Lions UPMC Paris octobre 2006
02669 c....................................................................012
02670       common / unites / lecteu, imprim, nunite(30)
02671       integer           noartr(moartr,mxartr),
02672      %                  nosoar(mosoar,*),
02673      %                  noarst(*)
02674       integer           lapile(1:mxpile)
02675       integer           nosotr(3)
02676 c
02677       lhpile = 0
02678 c
02679 c     la premiere arete de sommet ns
02680       nar = noarst( ns )
02681       if( nar .le. 0 ) then
02682 ccc         write(imprim,*) 'trp1st: sommet',ns,' sans arete'
02683          goto 100
02684       endif
02685 c
02686 c     l'arete nar est elle active?
02687       if( nosoar(1,nar) .le. 0 ) then
02688 ccc         write(imprim,*) 'trp1st: arete vide',nar,
02689 ccc     %                  ' st1:', nosoar(1,nar),' st2:',nosoar(2,nar)
02690          goto 100
02691       endif
02692 c
02693 c     le premier triangle de sommet ns
02694       nt0 = abs( nosoar(4,nar) )
02695       if( nt0 .le. 0 ) then
02696          write(imprim,*) 'trp1st: sommet',ns,' dans aucun triangle'
02697          goto 100
02698       endif
02699 c
02700 c     le triangle est il actif?
02701       if( noartr(1,nt0) .eq. 0 ) goto 100
02702 c
02703 c     le numero des 3 sommets du triangle nt0 dans le sens direct
02704       call nusotr( nt0, mosoar, nosoar, moartr, noartr, nosotr )
02705 c
02706 c     reperage du sommet ns dans le triangle nt0
02707       do 5 nar=1,3
02708          if( nosotr(nar) .eq. ns ) goto 10
02709  5    continue
02710 c     pas de sommet ns dans le triangle nt0
02711       goto 100
02712 c
02713 c     ns retrouve : le triangle nt0 de sommet ns est empile
02714  10   lhpile = 1
02715       lapile(1) = nt0
02716       nta = nt0
02717 c
02718 c     recherche dans le sens des aiguilles d'une montre
02719 c     (sens indirect) du triangle nt1 de l'autre cote de l'arete
02720 c     nar du triangle et en tournant autour du sommet ns
02721 c     ==========================================================
02722       noar = abs( noartr(nar,nt0) )
02723 c     le triangle nt1 oppose du triangle nt0 par l'arete noar
02724       if( nosoar(4,noar) .eq. nt0 ) then
02725          nt1 = nosoar(5,noar)
02726       else if( nosoar(5,noar) .eq. nt0 ) then
02727          nt1 = nosoar(4,noar)
02728       else
02729        write(imprim,*)'trp1st: anomalie arete',noar,' sans triangle',nt0
02730          goto 100
02731       endif
02732 c
02733 c     la boucle sur les triangles nt1 de sommet ns dans le sens indirect
02734 c     ==================================================================
02735       if( nt1 .gt. 0 ) then
02736 c
02737          if( noartr(1,nt1) .eq. 0 ) goto 30
02738 c
02739 c        le triangle nt1 n'a pas ete detruit. il est actif
02740 c        le triangle oppose par l'arete noar existe
02741 c        le numero des 3 sommets du triangle nt1 dans le sens direct
02742  15      call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
02743 c
02744 c        reperage du sommet ns dans nt1
02745          do 20 nar=1,3
02746             if( nosotr(nar) .eq. ns ) goto 25
02747  20      continue
02748 c        pas de sommet ns dans le triangle nt1
02749          goto 100
02750 c
02751 c        nt1 est empile
02752  25      if( lhpile .ge. mxpile ) goto 100
02753          lhpile = lhpile + 1
02754          lapile(lhpile) = nt1
02755 c
02756 c        le triangle nt1 de l'autre cote de l'arete de sommet ns
02757 c        sauvegarde du precedent triangle dans nta
02758          nta  = nt1
02759          noar = abs( noartr(nar,nt1) )
02760          if( nosoar(4,noar) .eq. nt1 ) then
02761             nt1 = nosoar(5,noar)
02762          else if( nosoar(5,noar) .eq. nt1 ) then
02763             nt1 = nosoar(4,noar)
02764          else
02765             write(imprim,*)'trp1st: Anomalie arete',noar,
02766      %                     ' sans triangle',nt1
02767             goto 100
02768          endif
02769 c
02770 c        le triangle suivant est il a l'exterieur?
02771          if( nt1 .le. 0 ) goto 30
02772 c
02773 c        non: est il le premier triangle de sommet ns?
02774          if( nt1 .ne. nt0 ) goto 15
02775 c
02776 c        oui: recherche terminee par arrivee sur nt0
02777 c        les triangles forment un "cercle" de "centre" ns
02778 c        lhpile ressort avec le signe +
02779          return
02780 c
02781       endif
02782 c
02783 c     pas de triangle voisin a nt1 qui doit etre frontalier
02784 c     =====================================================
02785 c     le parcours passe par 1 des triangles exterieurs
02786 c     le parcours est inverse par l'arete de gauche
02787 c     le triangle nta est le premier triangle empile
02788  30   lhpile = 1
02789       lapile(lhpile) = nta
02790 c
02791 c     le numero des 3 sommets du triangle nta dans le sens direct
02792       call nusotr( nta, mosoar, nosoar, moartr, noartr, nosotr )
02793       do 32 nar=1,3
02794          if( nosotr(nar) .eq. ns ) goto 33
02795  32   continue
02796       goto 100
02797 c
02798 c     l'arete qui precede (rotation / ns dans le sens direct)
02799  33   if( nar .eq. 1 ) then
02800          nar = 3
02801       else
02802          nar = nar - 1
02803       endif
02804 c
02805 c     le triangle voisin de nta dans le sens direct
02806       noar = abs( noartr(nar,nta) )
02807       if( nosoar(4,noar) .eq. nta ) then
02808          nt1 = nosoar(5,noar)
02809       else if( nosoar(5,noar) .eq. nta ) then
02810          nt1 = nosoar(4,noar)
02811       else
02812          write(imprim,*)'trp1st: Anomalie arete',noar,
02813      %                  ' SANS triangle',nta
02814          goto 100
02815       endif
02816       if( nt1 .le. 0 ) then
02817 c        un seul triangle contient ns
02818 c        parcours de tous les triangles pour lever le doute
02819          goto 100
02820       endif
02821 c
02822 c     boucle sur les triangles de sommet ns dans le sens direct
02823 c     ==========================================================
02824  40   if( noartr(1,nt1) .eq. 0 ) goto 70
02825 c
02826 c     le triangle nt1 n'a pas ete detruit. il est actif
02827 c     le numero des 3 sommets du triangle nt1 dans le sens direct
02828       call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
02829 c
02830 c     reperage du sommet ns dans nt1
02831       do 50 nar=1,3
02832          if( nosotr(nar) .eq. ns ) goto 60
02833  50   continue
02834       goto 100
02835 c
02836 c     nt1 est empile
02837  60   if( lhpile .ge. mxpile ) goto 70
02838       lhpile = lhpile + 1
02839       lapile(lhpile) = nt1
02840 c
02841 c     l'arete qui precede dans le sens direct
02842       if( nar .eq. 1 ) then
02843          nar = 3
02844       else
02845          nar = nar - 1
02846       endif
02847 c
02848 c     l'arete de sommet ns dans nosoar
02849       noar = abs( noartr(nar,nt1) )
02850 c
02851 c     le triangle voisin de nta dans le sens direct
02852       nta = nt1
02853       if( nosoar(4,noar) .eq. nt1 ) then
02854          nt1 = nosoar(5,noar)
02855       else if( nosoar(5,noar) .eq. nt1 ) then
02856          nt1 = nosoar(4,noar)
02857       else
02858          write(imprim,*)'trp1st: anomalie arete',noar,
02859      %                  ' SANS triangle',nt1
02860          goto 100
02861       endif
02862       if( nt1 .gt. 0 ) goto 40
02863 c
02864 c     butee sur le trou => fin des triangles de sommet ns
02865 c     ----------------------------------------------------
02866 c     impossible ici de trouver tous les triangles de sommet ns directement
02867 c     les triangles de sommet ns ne forment pas une boule de centre ns
02868 c     au moins 1, voire 2 triangles frontaliers de sommet ns
02869  70   lhpile = -lhpile
02870       return
02871 c
02872 c     Balayage de tous les triangles actifs et de sommet ns
02873 c     methode lourde et couteuse mais a priori tres fiable
02874 c     -----------------------------------------------------
02875  100  lhpile = 0
02876       do 120 nt1=1,mxartr
02877          if( noartr(1,nt1) .ne. 0 ) then
02878 c           le numero des 3 sommets du triangle i
02879             call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
02880             do 110 j=1,3
02881                if( nosotr(j) .eq. ns ) then
02882 c                 le triangle contient le sommet ns
02883                   lhpile = lhpile + 1
02884                   if( lhpile .gt. mxpile ) goto 9990
02885                   lapile( lhpile ) = nt1
02886                endif
02887  110        continue
02888          endif
02889  120  continue
02890 c     il n'est pas sur que ces triangles forment une boule de centre ns
02891       lhpile = -lhpile
02892       return
02893 c
02894 c     saturation de la pile des triangles
02895 c     -----------------------------------
02896  9990 write(imprim,*)
02897 'trp1st: saturation pile des triangles autour du so     %mmet',ns
02898       write(imprim,*) 'Plus de',mxpile,' triangles de sommet',ns
02899       write(imprim,19990) (ii,lapile(ii),ii=1,mxpile)
02900 19990 format(5(' triangle',i9))
02901 c
02902  9999 lhpile = 0
02903       return
02904       end
02905 
02906 
02907 
02908       subroutine nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
02909 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
02910 c but :    calcul du numero des 3 sommets du triangle nt de noartr
02911 c -----    dans le sens direct (aire>0 si non degenere)
02912 c
02913 c entrees:
02914 c --------
02915 c nt     : numero du triangle dans le tableau noartr
02916 c mosoar : nombre maximal d'entiers par arete
02917 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
02918 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
02919 c moartr : nombre maximal d'entiers par arete du tableau noartr
02920 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
02921 c          arete1=0 si triangle vide => arete2=triangle vide suivant
02922 c
02923 c sorties:
02924 c --------
02925 c nosotr : numero (dans le tableau pxyd) des 3 sommets du triangle
02926 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
02927 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
02928 c2345x7..............................................................012
02929       integer     nosoar(mosoar,*), noartr(moartr,*), nosotr(3)
02930 c
02931 c     les 2 sommets de l'arete 1 du triangle nt dans le sens direct
02932       na = noartr( 1, nt )
02933       if( na .gt. 0 ) then
02934          nosotr(1) = 1
02935          nosotr(2) = 2
02936       else
02937          nosotr(1) = 2
02938          nosotr(2) = 1
02939          na = -na
02940       endif
02941       nosotr(1) = nosoar( nosotr(1), na )
02942       nosotr(2) = nosoar( nosotr(2), na )
02943 c
02944 c     l'arete suivante
02945       na = abs( noartr(2,nt) )
02946 c
02947 c     le sommet nosotr(3 du triangle 123
02948       nosotr(3) = nosoar( 1, na )
02949       if( nosotr(3) .eq. nosotr(1) .or. nosotr(3) .eq. nosotr(2) ) then
02950          nosotr(3) = nosoar(2,na)
02951       endif
02952       end
02953 
02954 
02955       subroutine tesusp( quamal, nbarpi, pxyd,   noarst,
02956      %                   mosoar, mxsoar, n1soar, nosoar,
02957      %                   moartr, mxartr, n1artr, noartr,
02958      %                   mxarcf, n1arcf, noarcf, larmin, notrcf, liarcf,
02959      %                   ierr )
02960 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
02961 c but :   supprimer de la triangulation les sommets de te trop proches
02962 c -----   soit d'un sommet frontalier ou point interne impose
02963 c         soit d'une arete frontaliere si la qualite minimale des triangles
02964 c         est inferieure a quamal
02965 c
02966 c         attention: le chainage lchain de nosoar devient celui des cf
02967 c
02968 c entrees:
02969 c --------
02970 c quamal : qualite des triangles au dessous de laquelle supprimer des sommets
02971 c nbarpi : numero du dernier point interne impose par l'utilisateur
02972 c pxyd   : tableau des coordonnees 2d des points
02973 c          par point : x  y  distance_souhaitee
02974 c mosoar : nombre maximal d'entiers par arete et
02975 c          indice dans nosoar de l'arete suivante dans le hachage
02976 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
02977 c          attention: mxsoar>3*mxsomm obligatoire!
02978 c moartr : nombre maximal d'entiers par arete du tableau noartr
02979 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
02980 c
02981 c modifies:
02982 c ---------
02983 c noarst : noarst(i) numero d'une arete de sommet i
02984 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
02985 c          chainage des vides suivant en 3 et precedant en 2 de nosoar
02986 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
02987 c          chainage des aretes frontalieres, chainage du hachage des aretes
02988 c          hachage des aretes = nosoar(1)+nosoar(2)*2
02989 c          avec mxsoar>=3*mxsomm
02990 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
02991 c          nosoar(2,arete vide)=l'arete vide qui precede
02992 c          nosoar(3,arete vide)=l'arete vide qui suit
02993 c n1artr : numero du premier triangle vide dans le tableau noartr
02994 c          le chainage des triangles vides se fait sur noartr(2,.)
02995 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
02996 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
02997 c
02998 c
02999 c auxiliaires :
03000 c -------------
03001 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
03002 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
03003 c larmin : tableau ( mxarcf ) auxiliaire d'entiers
03004 c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
03005 c liarcf : tableau ( mxarcf ) auxiliaire d'entiers
03006 c
03007 c sortie :
03008 c --------
03009 c ierr   : =0 si pas d'erreur
03010 c          >0 si une erreur est survenue
03011 c          11 algorithme defaillant
03012 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03013 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
03014 c....................................................................012
03015       parameter       ( lchain=6 )
03016       common / unites / lecteu,imprim,intera,nunite(29)
03017       double precision  pxyd(3,*), quamal, qualit, quaopt, quamin
03018       integer           nosoar(mosoar,mxsoar),
03019      %                  noartr(moartr,mxartr),
03020      %                  noarst(*),
03021      %                  n1arcf(0:mxarcf),
03022      %                  noarcf(3,mxarcf),
03023      %                  larmin(mxarcf),
03024      %                  notrcf(mxarcf),
03025      %                  liarcf(mxarcf)
03026 c
03027       integer           nosotr(3)
03028       equivalence      (nosotr(1),ns1), (nosotr(2),ns2),
03029      %                 (nosotr(3),ns3)
03030 c
03031 c     le nombre de sommets de te supprimes
03032       nbstsu = 0
03033       ierr   = 0
03034 c
03035 c     initialisation du chainage des aretes des cf => 0 arete de cf
03036       do 10 narete=1,mxsoar
03037          nosoar( lchain, narete ) = -1
03038  10   continue
03039 c
03040 c     boucle sur l'ensemble des sommets frontaliers ou points internes
03041 c     ================================================================
03042       do 100 ns = 1, nbarpi
03043 c
03044 c        le nombre de sommets supprimes pour ce sommet ns
03045          nbsuns = 0
03046 c        la qualite minimale au dessous de laquelle le point proche
03047 c        interne est supprime
03048          quaopt = quamal
03049 c
03050 c        une arete de sommet ns
03051  15      narete = noarst( ns )
03052          if( narete .le. 0 ) then
03053 c           erreur: le point appartient a aucune arete
03054             write(imprim,*) 'sommet ',ns,' dans aucune arete'
03055             ierr = 11
03056             return
03057          endif
03058 c
03059 c        recherche des triangles de sommet ns
03060          call trp1st( ns, noarst, mosoar, nosoar,
03061      %                moartr, mxartr, noartr,
03062      %                mxarcf, nbtrcf, notrcf )
03063          if( nbtrcf .eq. 0 ) goto 100
03064          if( nbtrcf .lt. 0 ) then
03065 c           impossible de trouver tous les triangles de sommet ns
03066 c           seule une partie est a priori retrouvee ce qui est normal
03067 c           si ns est un sommet frontalier 
03068             nbtrcf = -nbtrcf
03069          endif
03070 c
03071 c        boucle sur les triangles de l'etoile du sommet ns
03072 c        recherche du triangle de sommet ns ayant la plus basse qualite
03073          quamin = 2.0d0
03074          do 20 i=1,nbtrcf
03075 c           le numero des 3 sommets du triangle nt
03076             nt = notrcf(i)
03077             call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
03078 c           nosotr(1:3) est en equivalence avec ns1, ns2, ns3
03079 c           la qualite du triangle ns1 ns2 ns3
03080             call qutr2d( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), qualit )
03081             if( qualit .lt. quamin ) then
03082                quamin = qualit
03083                ntqmin = nt
03084             endif
03085  20      continue
03086 c
03087 c        bilan sur la qualite des triangles de sommet ns
03088          if( quamin .lt. quaopt ) then
03089 c
03090 c           recherche du sommet de ntqmin le plus proche et non frontalier
03091 c           ==============================================================
03092 c           le numero des 3 sommets du triangle ntqmin
03093             call nusotr(ntqmin, mosoar, nosoar, moartr, noartr, nosotr)
03094             nste = 0
03095             d0   = 1e28
03096             do 30 j=1,3
03097                nst = nosotr(j)
03098                if( nst .ne. ns .and. nst .gt. nbarpi ) then
03099                   d = (pxyd(1,nst)-pxyd(1,ns))**2
03100      %              + (pxyd(2,nst)-pxyd(2,ns))**2
03101                   if( d .lt. d0 ) then
03102                      d0   = d
03103                      nste = j
03104                   endif
03105                endif
03106  30         continue
03107 c
03108             if( nste .gt. 0 ) then
03109 c
03110 c              nste est le sommet le plus proche de ns de ce
03111 c              triangle de mauvaise qualite et sommet non encore traite
03112                nste = nosotr( nste )
03113 c
03114 c              nste est un sommet de triangle equilateral
03115 c              => le sommet nste va etre supprime
03116 c              ==========================================
03117                call te1stm( nste,   nbarpi, pxyd,   noarst,
03118      %                      mosoar, mxsoar, n1soar, nosoar,
03119      %                      moartr, mxartr, n1artr, noartr,
03120      %                      mxarcf, n1arcf, noarcf,
03121      %                      larmin, notrcf, liarcf, ierr )
03122                if( ierr .eq. 0 ) then
03123 c                 un sommet de te supprime de plus
03124                   nbstsu = nbstsu + 1
03125 c
03126 c                 boucle jusqu'a obtenir une qualite suffisante
03127 c                 si triangulation tres irreguliere =>
03128 c                 destruction de beaucoup de points internes
03129 c                 les 2 variables suivantes brident ces destructions massives
03130                   nbsuns = nbsuns + 1
03131                   quaopt = quaopt * 0.8
03132                   if( nbsuns .lt. 5 ) goto 15
03133                else
03134                   if( ierr .lt. 0 ) then
03135 c                    le sommet nste est externe donc non supprime
03136 c                    ou bien le sommet nste est le centre d'un cf dont toutes
03137 c                    les aretes simples sont frontalieres
03138 c                    dans les 2 cas le sommet n'est pas supprime
03139                      ierr = 0
03140                      goto 100
03141                   else
03142 c                    erreur motivant un arret de la triangulation
03143                      return
03144                   endif
03145                endif
03146             endif
03147          endif
03148 c
03149  100  continue
03150 c
03151       write(imprim,*)'tesusp: suppression de',nbstsu,
03152      %               ' sommets de te trop proches de la frontiere'
03153       return
03154       end
03155 
03156 
03157       subroutine teamqa( nutysu, airemx,
03158      %                   noarst, mosoar, mxsoar, n1soar, nosoar,
03159      %                   moartr, mxartr, n1artr, noartr,
03160      %                   mxtrcf, notrcf, nostbo,
03161      %                   n1arcf, noarcf, larmin,
03162      %                   nbarpi, nbsomm, mxsomm, pxyd, nslign,
03163      %                   ierr )
03164 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03165 c but:    Boucles sur les aretes actives de la triangulation actuelle
03166 c ----    si la taille de l'arete moyenne est >ampli*taille souhaitee
03167 c         alors ajout d'un sommet barycentre du plus grand triangle
03168 c               de sommet ns
03169 c         si la taille de l'arete moyenne est <ampli/2*taille souhaitee
03170 c         alors suppression du sommet ns
03171 c         sinon le sommet ns devient le barycentre pondere de ses voisins
03172 c
03173 c         remarque: ampli est defini dans $mefisto/mail/tehote.f
03174 c         et doit avoir la meme valeur pour eviter trop de modifications
03175 c
03176 c entrees:
03177 c --------
03178 c nutysu : numero de traitement de areteideale() selon le type de surface
03179 c          0 pas d'emploi de la fonction areteideale() => aretmx active
03180 c          1 il existe une fonction areteideale()
03181 c            dont seules les 2 premieres composantes de uv sont actives
03182 c          autres options a definir...
03183 c airemx : aire maximale d'un triangle
03184 c noarst : noarst(i) numero d'une arete de sommet i
03185 c mosoar : nombre maximal d'entiers par arete et
03186 c          indice dans nosoar de l'arete suivante dans le hachage
03187 c mxsoar : nombre maximal d'aretes frontalieres declarables
03188 c n1soar : numero de la premiere arete vide dans le tableau nosoar
03189 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
03190 c          chainage des aretes frontalieres, chainage du hachage des aretes
03191 c moartr : nombre maximal d'entiers par arete du tableau noartr
03192 c mxartr : nombre maximal de triangles declarables dans noartr
03193 c n1artr : numero du premier triangle vide dans le tableau noartr
03194 c          le chainage des triangles vides se fait sur noartr(2,.)
03195 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
03196 c mxtrcf : nombre maximal de triangles empilables
03197 c nbarpi : numero du dernier sommet frontalier ou interne impose
03198 c nslign : tableau du numero de sommet dans sa ligne pour chaque
03199 c          sommet frontalier
03200 c          numero du point dans le lexique point si interne impose
03201 c          0 si le point est interne non impose par l'utilisateur
03202 c         -1 si le sommet est externe au domaine
03203 c
03204 c modifies :
03205 c ----------
03206 c nbsomm : nombre actuel de sommets de la triangulation
03207 c          (certains sommets internes ont ete desactives ou ajoutes)
03208 c pxyd   : tableau des coordonnees 2d des points
03209 c
03210 c auxiliaires:
03211 c ------------
03212 c notrcf : tableau ( mxtrcf ) auxiliaire d'entiers
03213 c          numero dans noartr des triangles de sommet ns
03214 c nostbo : tableau ( mxtrcf ) auxiliaire d'entiers
03215 c          numero dans pxyd des sommets des aretes simples de la boule
03216 c n1arcf : tableau (0:mxtrcf) auxiliaire d'entiers
03217 c noarcf : tableau (3,mxtrcf) auxiliaire d'entiers
03218 c larmin : tableau ( mxtrcf ) auxiliaire d'entiers
03219 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03220 c auteur : alain perronnet  analyse numerique paris upmc       juin 1997
03221 c....................................................................012
03222       double precision  ampli,ampli2
03223       parameter        (ampli=1.34d0,ampli2=ampli/2d0)
03224       parameter        (lchain=6)
03225       common / unites / lecteu, imprim, nunite(30)
03226       double precision  pxyd(3,*), airemx
03227       double precision  ponder, ponde1, xbar, ybar, x, y, surtd2,
03228      %                  xns, yns, airetm
03229       double precision  d, dmoy, dmax, dmin, dns, xyzns(3), s0, s1
03230       integer           noartr(moartr,mxartr),
03231      %                  nosoar(mosoar,mxsoar),
03232      %                  noarst(*),
03233      %                  notrcf(mxtrcf),
03234      %                  nslign(*),
03235      %                  nostbo(*),
03236      %                  n1arcf(0:mxtrcf),
03237      %                  noarcf(3,mxtrcf),
03238      %                  larmin(mxtrcf)
03239       integer           nosotr(3)
03240 c
03241 c     initialisation du chainage des aretes des cf => 0 arete de cf
03242       do 1 noar=1,mxsoar
03243          nosoar( lchain, noar ) = -1
03244  1    continue
03245       noar0 = 0
03246 c
03247 c     le nombre d'iterations pour ameliorer la qualite
03248       nbitaq = 5
03249       ier    = 0
03250 c
03251 c     initialisation du parcours
03252       nbs1 = nbsomm
03253       nbs2 = nbarpi + 1
03254       nbs3 = -1
03255 c
03256       do 5000 iter=1,nbitaq
03257 c
03258 cccc        le nombre de barycentres ajoutes
03259 ccc         nbbaaj = 0
03260 c
03261 c        coefficient de ponderation croissant avec les iterations
03262          ponder = 0.1d0 + iter * 0.5d0 / nbitaq
03263 ccc 9 octobre 2006 ponder = min( 1d0, 0.1d0 + iter * 0.9d0 / nbitaq )
03264 ccc 9 mars    2006 ponder = min( 1d0, ( 50 + (50*iter)/nbitaq ) * 0.01d0 )
03265          ponde1 = 1d0 - ponder
03266 c
03267 c        l'ordre du parcours dans le sens croissant ou decroissant
03268 c        alternance du parcours
03269          nt   = nbs1
03270          nbs1 = nbs2
03271          nbs2 = nt
03272          nbs3 =-nbs3
03273 c
03274          do 1000 ns = nbs1, nbs2, nbs3
03275 c
03276 c           le sommet est il interne au domaine?
03277             if( nslign(ns) .ne. 0 ) goto 1000
03278 c
03279 c           existe-t-il une arete de sommet ns ?
03280             noar = noarst( ns )
03281             if( noar .le. 0 ) goto 1000
03282             if( nosoar(1,noar) .le. 0 ) goto 1000
03283 c
03284 c           le 1-er triangle de l'arete noar
03285             nt = nosoar( 4, noar )
03286             if( nt .le. 0 ) goto 1000
03287 c
03288 c           recherche des triangles de sommet ns
03289 c           ils doivent former un contour ferme de type etoile
03290             call trp1st( ns, noarst, mosoar, nosoar,
03291      %                   moartr, mxartr, noartr,
03292      %                   mxtrcf, nbtrcf, notrcf )
03293             if( nbtrcf .le. 0 ) goto 1000
03294 c
03295 c           mise a jour de la distance souhaitee autour de ns
03296             xns =  pxyd(1,ns)
03297             yns =  pxyd(2,ns)
03298             if( nutysu .gt. 0 ) then
03299 c              la fonction taille_ideale(x,y,z) existe
03300                call tetaid( nutysu, xns, yns,
03301      %                      pxyd(3,ns), ier )
03302             endif
03303 c
03304 c           boucle sur les triangles qui forment une etoile autour du sommet ns
03305 c           chainage des aretes simples de l'etoile formee par ces triangles
03306 c
03307 c           remise a zero du lien nosoar des aretes a rendre Delaunay
03308  19         if( noar0 .gt. 0 ) then
03309                noar = nosoar(lchain,noar0)
03310                nosoar(lchain,noar0) = -1
03311                noar0 = noar
03312                goto 19
03313             endif
03314 c              
03315             noar0  = 0
03316             nbstbo = 0
03317             airetm = 0d0
03318             do 40 i=1,nbtrcf
03319 c              recherche du triangle de plus grande aire
03320                nt = notrcf(i)
03321                call nusotr( nt, mosoar, nosoar,
03322      %                      moartr, noartr, nosotr )
03323                d = surtd2( pxyd(1,nosotr(1)),
03324      %                     pxyd(1,nosotr(2)),
03325      %                     pxyd(1,nosotr(3)) )
03326                if( d .gt. airetm ) then
03327                   airetm = d
03328                   imax   = i
03329                else if( d .le. 0 ) then
03330                   write(imprim,*)'teamqa: triangle notrcf(',i,')=',
03331      %            notrcf(i),' st', nosotr,' AIRE=',d,'<=0'
03332                   goto 1000
03333                endif
03334 c
03335 c              le no de l'arete du triangle nt ne contenant pas le sommet ns
03336                do 20 na=1,3
03337 c                 le numero de l'arete na dans le tableau nosoar
03338                   noar = abs( noartr(na,nt) )
03339                   if( nosoar(1,noar) .ne. ns   .and.
03340      %                nosoar(2,noar) .ne. ns ) goto 25
03341  20            continue
03342                write(imprim,*)'teamqa: ERREUR triangle',nt,
03343      %                        ' SANS sommet',ns
03344 c
03345 c              construction de la liste des sommets des aretes simples
03346 c              de la boule des triangles de sommet ns
03347 c              -------------------------------------------------------
03348  25            do 35 na=1,2
03349                   ns1 = nosoar(na,noar)
03350                   do 30 j=nbstbo,1,-1
03351                      if( ns1 .eq. nostbo(j) ) goto 35
03352  30               continue
03353 c                 ns1 est un nouveau sommet a ajouter a l'etoile
03354                   nbstbo = nbstbo + 1
03355                   nostbo(nbstbo) = ns1
03356  35            continue
03357 c
03358 c              noar est une arete potentielle a rendre Delaunay
03359                if( nosoar(3,noar) .eq. 0 ) then
03360 c                 arete non frontaliere
03361                   nosoar(lchain,noar) = noar0
03362                   noar0 = noar
03363                endif
03364 c
03365  40         continue
03366 c
03367 c           calcul des 2 coordonnees du barycentre de la boule du sommet ns
03368 c           calcul de la longueur moyenne des aretes issues du sommet ns
03369 c           ---------------------------------------------------------------
03370             xbar = 0d0
03371             ybar = 0d0
03372             dmoy = 0d0
03373             dmax = 0d0
03374             dmin = 1d124
03375             dns  = 0d0
03376             do 50 i=1,nbstbo
03377                nst  = nostbo(i)
03378                x    = pxyd(1,nst)
03379                y    = pxyd(2,nst)
03380                xbar = xbar + x
03381                ybar = ybar + y
03382                d    = sqrt( (x-xns)**2 + (y-yns)**2 )
03383                dmoy = dmoy + d
03384                dmax = max( dmax, d )
03385                dmin = min( dmin, d )
03386                dns  = dns + pxyd(3,nst)
03387  50         continue
03388             xbar = xbar / nbstbo
03389             ybar = ybar / nbstbo
03390             dmoy = dmoy / nbstbo
03391             dns  = dns  / nbstbo
03392 c
03393 c           pas de modification de la topologie lors de la derniere iteration
03394 c           =================================================================
03395             if( iter .eq. nbitaq ) goto 200
03396 c
03397 c           si la taille de l'arete maximale est >ampli*taille souhaitee
03398 c           alors ajout d'un sommet barycentre du plus grand triangle
03399 c                 de sommet ns
03400 c           ============================================================
03401             if( airetm .gt. airemx .or. dmax .gt. ampli*dns ) then
03402 c
03403 c              ajout du barycentre du triangle notrcf(imax)
03404                nt = notrcf( imax )
03405                call nusotr( nt, mosoar, nosoar,
03406      %                      moartr, noartr, nosotr )
03407                if( nbsomm .ge. mxsomm ) then
03408                   write(imprim,*) 'saturation du tableau pxyd'
03409 c                 abandon de l'amelioration du sommet ns
03410                   goto 9999
03411                endif
03412                nbsomm = nbsomm + 1
03413                do 160 i=1,3
03414                   pxyd(i,nbsomm) = ( pxyd(i,nosotr(1))
03415      %                             + pxyd(i,nosotr(2))
03416      %                             + pxyd(i,nosotr(3)) ) / 3d0
03417  160           continue
03418                if( nutysu .gt. 0 ) then
03419 c                 la fonction taille_ideale(x,y,z) existe
03420                   call tetaid( nutysu, pxyd(1,nbsomm), pxyd(2,nbsomm),
03421      %                         pxyd(3,nbsomm), ier )
03422                endif
03423 c
03424 c              sommet interne a la triangulation
03425                nslign(nbsomm) = 0
03426 c
03427 c              les 3 aretes du triangle nt sont a rendre delaunay
03428                do 170 i=1,3
03429                   noar = abs( noartr(i,nt) )
03430                   if( nosoar(3,noar) .eq. 0 ) then
03431 c                    arete non frontaliere
03432                      if( nosoar(lchain,noar) .lt. 0 ) then
03433 c                       arete non encore chainee
03434                         nosoar(lchain,noar) = noar0
03435                         noar0 = noar
03436                      endif
03437                   endif
03438  170           continue
03439 c
03440 c              triangulation du triangle de barycentre nbsomm
03441 c              protection a ne pas modifier sinon erreur!
03442                call tr3str( nbsomm, nt,
03443      %                      mosoar, mxsoar, n1soar, nosoar,
03444      %                      moartr, mxartr, n1artr, noartr,
03445      %                      noarst, nosotr, ierr )
03446                if( ierr .ne. 0 ) goto 9999
03447 c
03448 cccc              un barycentre ajoute de plus
03449 ccc               nbbaaj = nbbaaj + 1
03450 c
03451 c              les aretes chainees de la boule sont rendues delaunay
03452                goto 900
03453 c
03454             endif
03455 c
03456 c           les 2 coordonnees du barycentre des sommets des aretes
03457 c           simples de la boule du sommet ns
03458 c           ======================================================
03459 C DEBUT AJOUT 10 octobre 2006
03460 C           PONDERATION POUR EVITER LES DEGENERESCENSES AVEC PROTECTION
03461 C           SI UN TRIANGLE DE SOMMET NS A UNE AIRE NEGATIVE APRES BARYCENTRAGE
03462 C           ALORS LE SOMMET NS N'EST PAS BOUGE
03463 c
03464 c           protection des XY du point initial
03465  200        xyzns(1) = pxyd(1,ns)
03466             xyzns(2) = pxyd(2,ns)
03467             xyzns(3) = pxyd(3,ns)
03468 c
03469 c           ponderation pour eviter les degenerescenses
03470             pxyd(1,ns) = ponde1 * pxyd(1,ns) + ponder * xbar
03471             pxyd(2,ns) = ponde1 * pxyd(2,ns) + ponder * ybar
03472             if( nutysu .gt. 0 ) then
03473 c              la fonction taille_ideale(x,y,z) existe
03474                call tetaid( nutysu, pxyd(1,ns), pxyd(2,ns),
03475      %                      pxyd(3,ns), ier )
03476             endif
03477 c
03478 c           calcul des surfaces avant et apres deplacement de ns
03479             s0 = 0d0
03480             s1 = 0d0
03481             do 210 i=1,nbtrcf
03482 c              le numero de l'arete du triangle nt ne contenant pas le sommet ns
03483                nt = notrcf(i)
03484                do 204 na=1,3
03485 c                 le numero de l'arete na dans le tableau nosoar
03486                   noar = abs( noartr(na,nt) )
03487                   if( nosoar(1,noar) .ne. ns   .and.
03488      %                nosoar(2,noar) .ne. ns ) then
03489                      ns2 = nosoar(1,noar)
03490                      ns3 = nosoar(2,noar)
03491                      goto 206
03492                   endif
03493  204           continue
03494 c              aire signee des 2 triangles
03495  206           s0 = s0 + abs(surtd2(xyzns,     pxyd(1,ns2),pxyd(1,ns3)))
03496                s1 = s1 + abs(surtd2(pxyd(1,ns),pxyd(1,ns2),pxyd(1,ns3)))
03497  210        continue
03498             if( abs(s0-s1) .gt. 1d-10*abs(s0) ) then
03499 c              retour a la position initiale
03500 c              car le point est passe au dela d'une arete de son etoile
03501                pxyd(1,ns) = xyzns(1)
03502                pxyd(2,ns) = xyzns(2)
03503                pxyd(3,ns) = xyzns(3)
03504 c              la ponderation est reduite  10 octobre 2006
03505                ponder = max( 0.1d0, ponder*0.5d0 )
03506                ponde1 = 1d0 - ponder
03507                goto 1000
03508             endif
03509 c
03510 c           les aretes chainees de la boule sont rendues delaunay
03511  900        call tedela( pxyd,   noarst,
03512      %                   mosoar, mxsoar, n1soar, nosoar, noar0,
03513      %                   moartr, mxartr, n1artr, noartr, modifs )
03514 c
03515  1000    continue
03516 c
03517 ccc         write(imprim,11000) iter, nbbaaj
03518 ccc11000 format('teamqa: iteration',i3,' =>',i6,' barycentres ajoutes')
03519 c
03520 c        mise a jour pour ne pas oublier les nouveaux sommets
03521          if( nbs1 .gt. nbs2 ) then
03522             nbs1 = nbsomm
03523          else
03524             nbs2 = nbsomm
03525          endif
03526 c
03527  5000 continue
03528 c
03529  9999 return
03530       end
03531 
03532 
03533       subroutine teamqt( nutysu, aretmx, airemx,
03534      %                   noarst, mosoar, mxsoar, n1soar, nosoar,
03535      %                   moartr, mxartr, n1artr, noartr,
03536      %                   mxarcf, notrcf, nostbo,
03537      %                   n1arcf, noarcf, larmin,
03538      %                   nbarpi, nbsomm, mxsomm, pxyd, nslign,
03539      %                   ierr )
03540 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03541 c but :    amelioration de la qualite de la triangulation
03542 c -----
03543 c
03544 c entrees:
03545 c --------
03546 c nutysu : numero de traitement de areteideale() selon le type de surface
03547 c          0 pas d'emploi de la fonction areteideale() => aretmx active
03548 c          1 il existe une fonction areteideale()
03549 c            dont seules les 2 premieres composantes de uv sont actives
03550 c          autres options a definir...
03551 c aretmx : longueur maximale des aretes de la future triangulation
03552 c airemx : aire maximale souhaitee des triangles
03553 c noarst : noarst(i) numero d'une arete de sommet i
03554 c mosoar : nombre maximal d'entiers par arete et
03555 c          indice dans nosoar de l'arete suivante dans le hachage
03556 c mxsoar : nombre maximal d'aretes frontalieres declarables
03557 c n1soar : numero de la premiere arete vide dans le tableau nosoar
03558 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
03559 c          chainage des aretes frontalieres, chainage du hachage des aretes
03560 c moartr : nombre maximal d'entiers par arete du tableau noartr
03561 c mxartr : nombre maximal de triangles declarables dans noartr
03562 c n1artr : numero du premier triangle vide dans le tableau noartr
03563 c          le chainage des triangles vides se fait sur noartr(2,.)
03564 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
03565 c mxarcf : nombre maximal de triangles empilables
03566 c nbarpi : numero du dernier sommet frontalier ou interne impose
03567 c nslign : tableau du numero de sommet dans sa ligne pour chaque
03568 c          sommet frontalier
03569 c          numero du point dans le lexique point si interne impose
03570 c          0 si le point est interne non impose par l'utilisateur
03571 c         -1 si le sommet est externe au domaine
03572 c
03573 c modifies :
03574 c ----------
03575 c nbsomm : nombre actuel de sommets de la triangulation
03576 c          (certains sommets internes ont ete desactives ou ajoutes)
03577 c pxyd   : tableau des coordonnees 2d des points
03578 c
03579 c auxiliaires:
03580 c ------------
03581 c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
03582 c          numero dans noartr des triangles de sommet ns
03583 c nostbo : tableau ( mxarcf ) auxiliaire d'entiers
03584 c          numero dans pxyd des sommets des aretes simples de la boule
03585 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
03586 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
03587 c larmin : tableau ( mxarcf ) auxiliaire d'entiers
03588 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03589 c auteur : alain perronnet  analyse numerique paris upmc       juin 1997
03590 c....................................................................012
03591       double precision  quamal
03592 c     parameter       ( quamal=0.3d0 ) => ok
03593 c     parameter       ( quamal=0.4d0 ) => pb pour le test ocean
03594 c     parameter       ( quamal=0.5d0 ) => pb pour le test ocean
03595       parameter       ( quamal=0.1d0 )
03596 c     quamal=0.1d0 est choisi pour ne pas trop detruire de sommets
03597 c
03598       common / unites / lecteu, imprim, nunite(30)
03599       double precision  pxyd(3,*)
03600       integer           noartr(moartr,*),
03601      %                  nosoar(mosoar,*),
03602      %                  noarst(*),
03603      %                  notrcf(mxarcf),
03604      %                  nslign(*),
03605      %                  nostbo(mxarcf),
03606      %                  n1arcf(0:mxarcf),
03607      %                  noarcf(3,mxarcf),
03608      %                  larmin(mxarcf)
03609       double precision  aretmx, airemx
03610       double precision  quamoy, quamin
03611 c
03612       ierr = 0
03613 c
03614 c     supprimer de la triangulation les triangles de qualite
03615 c     inferieure a quamal
03616 c     ======================================================
03617       call tesuqm( quamal, nbarpi, pxyd,   noarst,
03618      %             mosoar, mxsoar, n1soar, nosoar,
03619      %             moartr, mxartr, n1artr, noartr,
03620      %             mxarcf, n1arcf, noarcf,
03621      %             larmin, notrcf, nostbo,
03622      %             quamin )
03623       call qualitetrte( pxyd,   mosoar, mxsoar, nosoar,
03624      %                  moartr, mxartr, noartr,
03625      %                  nbtria, quamoy, quamin )
03626 c
03627 c     suppression des sommets de triangles equilateraux trop proches
03628 c     d'un sommet frontalier ou d'un point interne impose par
03629 c     triangulation frontale de l'etoile et mise en delaunay
03630 c     ==============================================================
03631       if( quamin .le. quamal ) then
03632          call tesusp( quamal, nbarpi, pxyd,   noarst,
03633      %                mosoar, mxsoar, n1soar, nosoar,
03634      %                moartr, mxartr, n1artr, noartr,
03635      %                mxarcf, n1arcf, noarcf,
03636      %                larmin, notrcf, nostbo,
03637      %                ierr )
03638          if( ierr .ne. 0 ) goto 9999
03639       endif
03640 c
03641 c     ajustage des tailles moyennes des aretes avec ampli=1.34d0 entre
03642 c     ampli/2 x taille_souhaitee et ampli x taille_souhaitee 
03643 c     + barycentrage des sommets et mise en triangulation delaunay
03644 c     ================================================================
03645       call teamqa( nutysu, airemx,
03646      %             noarst, mosoar, mxsoar, n1soar, nosoar,
03647      %             moartr, mxartr, n1artr, noartr,
03648      %             mxarcf, notrcf, nostbo,
03649      %             n1arcf, noarcf, larmin,
03650      %             nbarpi, nbsomm, mxsomm, pxyd, nslign,
03651      %             ierr )
03652       call qualitetrte( pxyd,   mosoar, mxsoar, nosoar,
03653      %                  moartr, mxartr, noartr,
03654      %                  nbtria, quamoy, quamin )
03655       if( ierr .ne. 0 ) goto 9999
03656 c
03657  9999 return
03658       end
03659 
03660       subroutine trfrcf( nscent, mosoar, nosoar, moartr, noartr,
03661      %                   nbtrcf, notrcf, nbarfr )
03662 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03663 c but :    calculer le nombre d'aretes simples du contour ferme des
03664 c -----    nbtrcf triangles de numeros stockes dans le tableau notrcf
03665 c          ayant tous le sommet nscent
03666 c
03667 c entrees:
03668 c --------
03669 c nscent : numero du sommet appartenant a tous les triangles notrcf
03670 c mosoar : nombre maximal d'entiers par arete et
03671 c          indice dans nosoar de l'arete suivante dans le hachage
03672 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
03673 c          chainage des aretes frontalieres, chainage du hachage des aretes
03674 c moartr : nombre maximal d'entiers par arete du tableau noartr
03675 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
03676 c nbtrcf : >0 nombre de triangles empiles
03677 c          =0       si impossible de tourner autour du point
03678 c          =-nbtrcf si apres butee sur la frontiere il y a a nouveau
03679 c          butee sur la frontiere . a ce stade on ne peut dire si tous
03680 c          les triangles ayant ce sommet ont ete recenses
03681 c          ce cas arrive seulement si le sommet est sur la frontiere
03682 c notrcf : numero dans noartr des triangles de sommet ns
03683 c
03684 c sortie :
03685 c --------
03686 c nbarfr : nombre d'aretes simples frontalieres
03687 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03688 c auteur : alain perronnet  analyse numerique paris upmc       juin 1997
03689 c....................................................................012
03690       integer           noartr(moartr,*),
03691      %                  nosoar(mosoar,*),
03692      %                  notrcf(1:nbtrcf)
03693 c
03694       nbarfr = 0
03695       do 50 n=1,nbtrcf
03696 c        le numero du triangle n dans le tableau noartr
03697          nt = notrcf( n )
03698 c        parcours des 3 aretes du triangle nt
03699          do 40 i=1,3
03700 c           le numero de l'arete i dans le tableau nosoar
03701             noar = abs( noartr( i, nt ) )
03702             do 30 j=1,2
03703 c              le numero du sommet j de l'arete noar
03704                ns = nosoar( j, noar )
03705                if( ns .eq. nscent ) goto 40
03706  30         continue
03707 c           l'arete noar (sans sommet nscent) est elle frontaliere?
03708             if( nosoar( 5, noar ) .le. 0 ) then
03709 c              l'arete appartient au plus a un triangle
03710 c              une arete simple frontaliere de plus
03711                nbarfr = nbarfr + 1
03712             endif
03713 c           le triangle a au plus une arete sans sommet nscent
03714             goto 50
03715  40      continue
03716  50   continue
03717       end
03718 
03719       subroutine int2ar( p1, p2, p3, p4, oui )
03720 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03721 c but :    les 2 aretes de r**2 p1-p2  p3-p4 s'intersectent elles
03722 c -----    entre leurs sommets?
03723 c
03724 c entrees:
03725 c --------
03726 c p1,p2,p3,p4 : les 2 coordonnees reelles des sommets des 2 aretes
03727 c
03728 c sortie :
03729 c --------
03730 c oui    : .true. si intersection, .false. sinon
03731 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03732 c auteur : alain perronnet  analyse numerique paris upmc    octobre 1991
03733 c2345x7..............................................................012
03734       double precision  p1(2),p2(2),p3(2),p4(2)
03735       double precision  x21,y21,d21,x43,y43,d43,d,x,y,xx
03736       logical  oui
03737 c
03738 c     longueur des aretes
03739       x21 = p2(1)-p1(1)
03740       y21 = p2(2)-p1(2)
03741       d21 = x21**2 + y21**2
03742 c
03743       x43 = p4(1)-p3(1)
03744       y43 = p4(2)-p3(2)
03745       d43 = x43**2 + y43**2
03746 c
03747 c     les 2 aretes sont-elles jugees paralleles ?
03748       d = x43 * y21 - y43 * x21
03749       if( abs(d) .le. 0.001 * sqrt(d21 * d43) ) then
03750 c        aretes paralleles . pas d'intersection
03751          oui = .false.
03752          return
03753       endif
03754 c
03755 c     les 2 coordonnees du point d'intersection
03756       x = ( p1(1)*x43*y21 - p3(1)*x21*y43 - (p1(2)-p3(2))*x21*x43 ) / d
03757       y =-( p1(2)*y43*x21 - p3(2)*y21*x43 - (p1(1)-p3(1))*y21*y43 ) / d
03758 c
03759 c     coordonnees de x,y dans le repere ns1-ns2
03760       xx  = ( x - p1(1) ) * x21 + ( y - p1(2) ) * y21
03761 c     le point est il entre p1 et p2 ?
03762       oui = -0.00001d0*d21 .le. xx .and. xx .le. 1.00001d0*d21
03763 c
03764 c     coordonnees de x,y dans le repere ns3-ns4
03765       xx  = ( x - p3(1) ) * x43 + ( y - p3(2) ) * y43
03766 c     le point est il entre p3 et p4 ?
03767       oui = oui .and. -0.00001d0*d43 .le. xx .and. xx .le. 1.00001d0*d43
03768       end
03769 
03770 
03771       subroutine trchtd( pxyd,   nar00, nar0,  noarcf,
03772      %                   namin0, namin, larmin )
03773 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03774 c but :    recherche dans le contour ferme du sommet qui joint a la plus
03775 c -----    courte arete nar00 donne le triangle sans intersection
03776 c          avec le contour ferme de meilleure qualite
03777 c
03778 c entrees:
03779 c --------
03780 c pxyd   : tableau des coordonnees des sommets et distance_souhaitee
03781 c
03782 c entrees et sorties:
03783 c -------------------
03784 c nar00  : numero dans noarcf de l'arete avant nar0
03785 c nar0   : numero dans noarcf de la plus petite arete du contour ferme
03786 c          a joindre a noarcf(1,namin) pour former le triangle ideal
03787 c noarcf : numero du sommet , numero de l'arete suivante
03788 c          numero du triangle exterieur a l'etoile
03789 c
03790 c sortie :
03791 c --------
03792 c namin0 : numero dans noarcf de l'arete avant namin
03793 c namin  : numero dans noarcf du sommet choisi
03794 c          0 si contour ferme reduit a moins de 3 aretes
03795 c larmin : tableau auxiliaire pour stocker la liste des numeros des
03796 c          aretes de meilleure qualite pour faire le choix final
03797 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03798 c auteur : alain perronnet  analyse numerique paris upmc    fevrier 1992
03799 c2345x7..............................................................012
03800       double precision dmaxim, precision
03801       parameter        (dmaxim=1.7d+308, precision=1d-16)
03802 c     ATTENTION:variables a ajuster selon la machine!
03803 c     ATTENTION:dmaxim : le plus grand reel machine
03804 c     ATTENTION:sur dec-alpha la precision est de 10**-14 seulement
03805 
03806       common / unites / lecteu,imprim,nunite(30)
03807       double precision  pxyd(1:3,1:*)
03808       integer           noarcf(1:3,1:*),
03809      %                  larmin(1:*)
03810       double precision  q, dd, dmima,
03811      %                  unpeps, rayon, surtd2
03812       logical           oui
03813       double precision  centre(3)
03814 c
03815 c     initialisations
03816 c     dmaxim : le plus grand reel machine
03817       unpeps = 1d0 + 100d0 * precision
03818 c
03819 c     recherche de la plus courte arete du contour ferme
03820       nbmin = 0
03821       na00  = nar00
03822       dmima = dmaxim
03823       nbar  = 0
03824 c
03825  2    na0  = noarcf( 2, na00 )
03826       na1  = noarcf( 2, na0  )
03827       nbar = nbar + 1
03828 c     les 2 sommets de l'arete na0 du cf
03829       ns1  = noarcf( 1, na0 )
03830       ns2  = noarcf( 1, na1 )
03831       dd   = (pxyd(1,ns2)-pxyd(1,ns1))**2 + (pxyd(2,ns2)-pxyd(2,ns1))**2
03832       if( dd .lt. dmima ) then
03833          dmima = dd
03834          larmin(1) = na00
03835       endif
03836       na00 = na0
03837       if( na00 .ne. nar00 ) then
03838 c        derniere arete non atteinte
03839          goto 2
03840       endif
03841 c
03842       if( nbar .eq. 3 ) then
03843 c
03844 c        contour ferme reduit a un triangle
03845 c        ----------------------------------
03846          namin  = nar00
03847          nar0   = noarcf( 2, nar00 )
03848          namin0 = noarcf( 2, nar0  )
03849          return
03850 c
03851       else if( nbar .le. 2 ) then
03852          write(imprim,*) 'erreur trchtd: cf<3 aretes'
03853          namin  = 0
03854          namin0 = 0
03855          return
03856       endif
03857 c
03858 c     cf non reduit a un triangle
03859 c     la plus petite arete est nar0 dans noarcf
03860       nar00 = larmin( 1 )
03861       nar0  = noarcf( 2, nar00 )
03862       nar   = noarcf( 2, nar0  )
03863 c
03864       ns1   = noarcf( 1, nar0 )
03865       ns2   = noarcf( 1, nar  )
03866 c
03867 c     recherche dans cette etoile du sommet offrant la meilleure qualite
03868 c     du triangle ns1-ns2 ns3 sans intersection avec le contour ferme
03869 c     ==================================================================
03870       nar3  = nar
03871       qmima = -1
03872 c
03873 c     parcours des sommets possibles ns3
03874  10   nar3  = noarcf( 2, nar3 )
03875       if( nar3 .ne. nar0 ) then
03876 c
03877 c        il existe un sommet ns3 different de ns1 et ns2
03878          ns3 = noarcf( 1, nar3 )
03879 c
03880 c        les aretes ns1-ns3 et ns2-ns3 intersectent-elles une arete
03881 c        du contour ferme ?
03882 c        ----------------------------------------------------------
03883 c        intersection de l'arete ns2-ns3 et des aretes du cf
03884 c        jusqu'au sommet ns3
03885          nar1 = noarcf( 2, nar )
03886 c
03887  15      if( nar1 .ne. nar3 .and. noarcf( 2, nar1 ) .ne. nar3 ) then
03888 c           l'arete suivante
03889             nar2 = noarcf( 2, nar1 )
03890 c           le numero des 2 sommets de l'arete
03891             np1  = noarcf( 1, nar1 )
03892             np2  = noarcf( 1, nar2 )
03893             call int2ar( pxyd(1,ns2), pxyd(1,ns3),
03894      %                   pxyd(1,np1), pxyd(1,np2), oui )
03895             if( oui ) goto 10
03896 c           les 2 aretes ne s'intersectent pas entre leurs sommets
03897             nar1 = nar2
03898             goto 15
03899          endif
03900 c
03901 c        intersection de l'arete ns3-ns1 et des aretes du cf
03902 c        jusqu'au sommet de l'arete nar0
03903          nar1 = noarcf( 2, nar3 )
03904 c
03905  18      if( nar1 .ne. nar0 .and. noarcf( 2, nar1 ) .ne. nar0 ) then
03906 c           l'arete suivante
03907             nar2 = noarcf( 2, nar1 )
03908 c           le numero des 2 sommets de l'arete
03909             np1  = noarcf( 1, nar1 )
03910             np2  = noarcf( 1, nar2 )
03911             call int2ar( pxyd(1,ns1), pxyd(1,ns3),
03912      %                   pxyd(1,np1), pxyd(1,np2), oui )
03913             if( oui ) goto 10
03914 c           les 2 aretes ne s'intersectent pas entre leurs sommets
03915             nar1 = nar2
03916             goto 18
03917          endif
03918 c
03919 c        le triangle ns1-ns2-ns3 n'intersecte pas une arete du contour ferme
03920 c        le calcul de la surface du triangle
03921          dd = surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
03922          if( dd .le. 0d0 ) then
03923 c           surface negative => triangle a rejeter
03924             q = 0
03925          else
03926 c           calcul de la qualite du  triangle  ns1-ns2-ns3
03927             call qutr2d( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3), q )
03928          endif
03929 c
03930          if( q .ge. qmima*1.00001 ) then
03931 c           q est un vrai maximum de la qualite
03932             qmima = q
03933             nbmin = 1
03934             larmin(1) = nar3
03935          else if( q .ge. qmima*0.999998 ) then
03936 c           q est voisin de qmima
03937 c           il est empile
03938             nbmin = nbmin + 1
03939             larmin( nbmin ) = nar3
03940          endif
03941          goto 10
03942       endif
03943 c
03944 c     bilan : existe t il plusieurs sommets de meme qualite?
03945 c     ======================================================
03946       if( nbmin .gt. 1 ) then
03947 c
03948 c        oui:recherche de ceux de cercle ne contenant pas d'autres sommets
03949          do 80 i=1,nbmin
03950 c           le sommet
03951             nar = larmin( i )
03952             if( nar .le. 0 ) goto 80
03953             ns3 = noarcf(1,nar)
03954 c           les coordonnees du centre du cercle circonscrit
03955 c           et son rayon
03956             ier = -1
03957             call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3),
03958      %                   centre, ier )
03959             if( ier .ne. 0 ) then
03960 c              le sommet ns3 ne convient pas
03961                larmin( i ) = 0
03962                goto 80
03963             endif
03964             rayon = centre(3) * unpeps
03965             do 70 j=1,nbmin
03966                if( j .ne. i ) then
03967 c                 l'autre sommet
03968                   nar1 = larmin(j)
03969                   if( nar1 .le. 0 ) goto 70
03970                   ns4 = noarcf(1,nar1)
03971 c                 appartient t il au cercle ns1 ns2 ns3 ?
03972                   dd = (centre(1)-pxyd(1,ns4))**2 +
03973      %                 (centre(2)-pxyd(2,ns4))**2
03974                   if( dd .le. rayon ) then
03975 c                    ns4 est dans le cercle circonscrit  ns1 ns2 ns3
03976 c                    le sommet ns3 ne convient pas
03977                      larmin( i ) = 0
03978                      goto 80
03979                   endif
03980                endif
03981  70         continue
03982  80      continue
03983 c
03984 c        existe t il plusieurs sommets ?
03985          j = 0
03986          do 90 i=1,nbmin
03987             if( larmin( i ) .gt. 0 ) then
03988 c              compactage des min
03989                j = j + 1
03990                larmin(j) = larmin(i)
03991             endif
03992  90      continue
03993 c
03994          if( j .gt. 1 ) then
03995 c           oui : choix du plus petit rayon de cercle circonscrit
03996             dmima = dmaxim
03997             do 120 i=1,nbmin
03998                ns3 = noarcf(1,larmin(i))
03999 c
04000 c              les coordonnees du centre de cercle circonscrit
04001 c              au triangle nt et son rayon
04002                ier = -1
04003                call cenced( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3),
04004      %                      centre, ier )
04005                if( ier .ne. 0 ) then
04006 c                 le sommet ns3 ne convient pas
04007                   goto 120
04008                endif
04009                rayon = sqrt( centre(3) )
04010                if( rayon .lt. dmima ) then
04011                   dmima = rayon
04012                   larmin(1) = larmin(i)
04013                endif
04014  120        continue
04015          endif
04016       endif
04017 c
04018 c     le choix final
04019 c     ==============
04020       namin = larmin(1)
04021 c
04022 c     recherche de l'arete avant namin ( nar0 <> namin )
04023 c     ==================================================
04024       nar1 = nar0
04025  200  if( nar1 .ne. namin ) then
04026          namin0 = nar1
04027          nar1   = noarcf( 2, nar1 )
04028          goto 200
04029       endif
04030       end
04031 
04032       subroutine trcf0a( nbcf,   na01,   na1, na2, na3,
04033      %                   noar1,  noar2,  noar3,
04034      %                   mosoar, mxsoar, n1soar, nosoar,
04035      %                   moartr, n1artr, noartr, noarst,
04036      %                   mxarcf, n1arcf, noarcf, nt )
04037 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
04038 c but :    modification de la triangulation du contour ferme nbcf
04039 c -----    par ajout d'un triangle ayant 0 arete sur le contour
04040 c          creation des 3 aretes dans le tableau nosoar
04041 c          modification du contour par ajout de la 3-eme arete
04042 c          creation d'un contour ferme a partir de la seconde arete
04043 c
04044 c entrees:
04045 c --------
04046 c nbcf    : numero dans n1arcf du cf traite ici
04047 c na01    : numero noarcf de l'arete precedent l'arete na1 de noarcf
04048 c na1     : numero noarcf du 1-er sommet du triangle
04049 c           implicitement l'arete na1 n'est pas une arete du triangle
04050 c na2     : numero noarcf du 2-eme sommet du triangle
04051 c           implicitement l'arete na1 n'est pas une arete du triangle
04052 c na3     : numero noarcf du 3-eme sommet du triangle
04053 c           implicitement l'arete na1 n'est pas une arete du triangle
04054 c
04055 c mosoar : nombre maximal d'entiers par arete et
04056 c          indice dans nosoar de l'arete suivante dans le hachage
04057 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
04058 c          attention: mxsoar>3*mxsomm obligatoire!
04059 c moartr : nombre maximal d'entiers par arete du tableau noartr
04060 c
04061 c entrees et sorties :
04062 c --------------------
04063 c n1soar : numero de la premiere arete vide dans le tableau nosoar
04064 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
04065 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
04066 c          chainage des aretes frontalieres, chainage du hachage des aretes
04067 c          hachage des aretes = nosoar(1)+nosoar(2)*2
04068 c n1artr : numero du premier triangle vide dans le tableau noartr
04069 c          le chainage des triangles vides se fait sur noartr(2,.)
04070 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
04071 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
04072 c
04073 c noarst : noarst(i) numero d'une arete de sommet i
04074 c n1arcf : numero d'une arete de chaque contour
04075 c noarcf : numero des aretes de la ligne du contour ferme
04076 c          attention : chainage circulaire des aretes
04077 c
04078 c sortie :
04079 c --------
04080 c noar1  : numero dans le tableau nosoar de l'arete 1 du triangle
04081 c noar2  : numero dans le tableau nosoar de l'arete 2 du triangle
04082 c noar3  : numero dans le tableau nosoar de l'arete 3 du triangle
04083 c nt     : numero du triangle ajoute dans noartr
04084 c          0 si saturation du tableau noartr ou noarcf ou n1arcf
04085 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
04086 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
04087 c2345x7..............................................................012
04088       common / unites / lecteu, imprim, nunite(30)
04089       integer           nosoar(mosoar,*),
04090      %                  noartr(moartr,*),
04091      %                  noarst(*),
04092      %                  n1arcf(0:*),
04093      %                  noarcf(3,*)
04094 c
04095       ierr = 0
04096 c
04097 c     2 contours fermes peuvent ils etre ajoutes ?
04098       if( nbcf+2 .gt. mxarcf ) goto 9100
04099 c
04100 c     creation des 3 aretes du triangle dans le tableau nosoar
04101 c     ========================================================
04102 c     la formation de l'arete sommet1-sommet2 dans le tableau nosoar
04103       call fasoar( noarcf(1,na1), noarcf(1,na2), -1, -1,  0,
04104      %             mosoar, mxsoar, n1soar, nosoar, noarst,
04105      %             noar1,  ierr )
04106       if( ierr .ne. 0 ) goto 9900
04107 c
04108 c     la formation de l'arete sommet2-sommet3 dans le tableau nosoar
04109       call fasoar( noarcf(1,na2), noarcf(1,na3), -1, -1,  0,
04110      %             mosoar, mxsoar, n1soar, nosoar, noarst,
04111      %             noar2,  ierr )
04112       if( ierr .ne. 0 ) goto 9900
04113 c
04114 c     la formation de l'arete sommet3-sommet1 dans le tableau nosoar
04115       call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1,  0,
04116      %             mosoar, mxsoar, n1soar, nosoar, noarst,
04117      %             noar3,  ierr )
04118       if( ierr .ne. 0 ) goto 9900
04119 c
04120 c     ajout dans noartr de ce triangle nt
04121 c     ===================================
04122       call trcf3a( noarcf(1,na1),  noarcf(1,na2), noarcf(1,na3),
04123      %             noar1,  noar2,  noar3,
04124      %             mosoar, nosoar,
04125      %             moartr, n1artr, noartr,
04126      %             nt )
04127       if( nt .le. 0 ) return
04128 c
04129 c     modification du contour nbcf existant
04130 c     chainage de l'arete na2 vers l'arete na1
04131 c     ========================================
04132 c     modification du cf en pointant na2 sur na1
04133       na2s = noarcf( 2, na2 )
04134       noarcf( 2, na2 ) = na1
04135 c     le numero de l'arete dans le tableau nosoar
04136       noar2s = noarcf( 3, na2 )
04137 c     le numero de l'arete dans le tableau nosoar
04138       noarcf( 3, na2 ) = noar1
04139 c     debut du cf
04140       n1arcf( nbcf ) = na2
04141 c
04142 c     creation d'un nouveau contour ferme na2 - na3
04143 c     =============================================
04144       nbcf = nbcf + 1
04145 c     recherche d'une arete de cf vide
04146       nav = n1arcf(0)
04147       if( nav .le. 0 ) goto 9100
04148 c     la 1-ere arete vide est mise a jour
04149       n1arcf(0) = noarcf( 2, nav )
04150 c
04151 c     ajout de l'arete nav pointant sur na2s
04152 c     le numero du sommet
04153       noarcf( 1, nav ) = noarcf( 1, na2 )
04154 c     l'arete suivante
04155       noarcf( 2, nav ) = na2s
04156 c     le numero nosoar de cette arete
04157       noarcf( 3, nav ) = noar2s
04158 c
04159 c     l'arete na3 se referme sur nav
04160       na3s = noarcf( 2, na3 )
04161       noarcf( 2, na3 ) = nav
04162 c     le numero de l'arete dans le tableau nosoar
04163       noar3s = noarcf( 3, na3 )
04164       noarcf( 3, na3 ) = noar2
04165 c     debut du cf+1
04166       n1arcf( nbcf ) = na3
04167 c
04168 c     creation d'un nouveau contour ferme na3 - na1
04169 c     =============================================
04170       nbcf = nbcf + 1
04171 c     recherche d'une arete de cf vide
04172       nav = n1arcf(0)
04173       if( nav .le. 0 ) goto 9100
04174 c     la 1-ere arete vide est mise a jour
04175       n1arcf(0) = noarcf( 2, nav )
04176 c
04177 c     ajout de l'arete nav pointant sur na3s
04178 c     le numero du sommet
04179       noarcf( 1, nav ) = noarcf( 1, na3 )
04180 c     l'arete suivante
04181       noarcf( 2, nav ) = na3s
04182 c     le numero de l'arete dans le tableau nosoar
04183       noarcf( 3, nav ) = noar3s
04184 c
04185 c     recherche d'une arete de cf vide
04186       nav1 = n1arcf(0)
04187       if( nav1 .le. 0 ) goto 9100
04188 c     la 1-ere arete vide est mise a jour
04189       n1arcf(0) = noarcf( 2, nav1 )
04190 c
04191 c     l'arete precedente na01 de na1 pointe sur la nouvelle nav1
04192       noarcf( 2, na01 ) = nav1
04193 c
04194 c     ajout de l'arete nav1 pointant sur nav
04195 c     le numero du sommet
04196       noarcf( 1, nav1 ) = noarcf( 1, na1 )
04197 c     l'arete suivante
04198       noarcf( 2, nav1 ) = nav
04199 c     le numero de l'arete dans le tableau nosoar
04200       noarcf( 3, nav1 ) = noar3
04201 c
04202 c     debut du cf+2
04203       n1arcf( nbcf ) = nav1
04204       return
04205 c
04206 c     erreur
04207  9100 write(imprim,*) 'saturation du tableau mxarcf'
04208       nt = 0
04209       return
04210 c
04211 c     erreur tableau nosoar sature
04212  9900 write(imprim,*) 'saturation du tableau nosoar'
04213       nt = 0
04214       return
04215       end
04216 
04217 
04218       subroutine trcf1a( nbcf,   na01,   na1,    na2, noar1, noar3,
04219      %                   mosoar, mxsoar, n1soar, nosoar,
04220      %                   moartr, n1artr, noartr, noarst,
04221      %                   mxarcf, n1arcf, noarcf, nt )
04222 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
04223 c but :    modification de la triangulation du contour ferme nbcf
04224 c -----    par ajout d'un triangle ayant 1 arete sur le contour
04225 c          modification du contour par ajout de la 3-eme arete
04226 c          creation d'un contour ferme a partir de la seconde arete
04227 c
04228 c entrees:
04229 c --------
04230 c nbcf    : numero dans n1arcf du cf traite ici
04231 c na01    : numero noarcf de l'arete precedant l'arete na1 de noarcf
04232 c na1     : numero noarcf du 1-er sommet du triangle
04233 c           implicitement l'arete na1 n'est pas une arete du triangle
04234 c na2     : numero noarcf du 2-eme sommet du triangle
04235 c           cette arete est l'arete 2 du triangle a ajouter
04236 c           son arete suivante dans noarcf n'est pas sur le contour
04237 c mosoar : nombre maximal d'entiers par arete et
04238 c          indice dans nosoar de l'arete suivante dans le hachage
04239 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
04240 c          attention: mxsoar>3*mxsomm obligatoire!
04241 c moartr : nombre maximal d'entiers par arete du tableau noartr
04242 c
04243 c entrees et sorties :
04244 c --------------------
04245 c n1soar : numero de la premiere arete vide dans le tableau nosoar
04246 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
04247 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
04248 c          chainage des aretes frontalieres, chainage du hachage des aretes
04249 c          hachage des aretes = nosoar(1)+nosoar(2)*2
04250 c n1artr : numero du premier triangle vide dans le tableau noartr
04251 c          le chainage des triangles vides se fait sur noartr(2,.)
04252 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
04253 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
04254 c
04255 c noarst : noarst(i) numero d'une arete de sommet i
04256 c n1arcf : numero d'une arete de chaque contour
04257 c noarcf : numero des aretes de la ligne du contour ferme
04258 c          attention : chainage circulaire des aretes
04259 c
04260 c sortie :
04261 c --------
04262 c noar1  : numero nosoar de l'arete 1 du triangle cree
04263 c noar3  : numero nosoar de l'arete 3 du triangle cree
04264 c nt     : numero du triangle ajoute dans notria
04265 c          0 si saturation du tableau notria ou noarcf ou n1arcf
04266 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
04267 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
04268 c2345x7..............................................................012
04269       common / unites / lecteu, imprim, nunite(30)
04270       integer           nosoar(mosoar,mxsoar),
04271      %                  noartr(moartr,*),
04272      %                  noarst(*),
04273      %                  n1arcf(0:*),
04274      %                  noarcf(3,*)
04275 c
04276 c     un cf supplementaire peut il etre ajoute ?
04277       if( nbcf .ge. mxarcf ) then
04278          write(imprim,*) 'saturation du tableau noarcf'
04279          nt = 0
04280          return
04281       endif
04282 c
04283       ierr = 0
04284 c
04285 c     l' arete suivante du triangle non sur le cf
04286       na3 = noarcf( 2, na2 )
04287 c
04288 c     creation des 2 nouvelles aretes du triangle dans le tableau nosoar
04289 c     ==================================================================
04290 c     la formation de l'arete sommet1-sommet2 dans le tableau nosoar
04291       call fasoar( noarcf(1,na1), noarcf(1,na2), -1, -1,  0,
04292      %             mosoar, mxsoar, n1soar, nosoar, noarst,
04293      %             noar1,  ierr )
04294       if( ierr .ne. 0 ) goto 9900
04295 c
04296 c     la formation de l'arete sommet1-sommet3 dans le tableau nosoar
04297       call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1,  0,
04298      %             mosoar, mxsoar, n1soar, nosoar, noarst,
04299      %             noar3,  ierr )
04300       if( ierr .ne. 0 ) goto 9900
04301 c
04302 c     le triangle nt de noartr a l'arete 2 comme arete du contour na2
04303 c     ===============================================================
04304       call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
04305      %             noar1, noarcf(3,na2), noar3,
04306      %             mosoar, nosoar,
04307      %             moartr, n1artr, noartr,
04308      %             nt )
04309       if( nt .le. 0 ) return
04310 c
04311 c     modification du contour ferme existant
04312 c     suppression de l'arete na2 du cf
04313 c     ======================================
04314 c     modification du cf en pointant na2 sur na1
04315       noarcf( 2, na2 ) = na1
04316       noarcf( 3, na2 ) = noar1
04317 c     debut du cf
04318       n1arcf( nbcf ) = na2
04319 c
04320 c     creation d'un nouveau contour ferme na3 - na1
04321 c     =============================================
04322       nbcf = nbcf + 1
04323 c
04324 c     recherche d'une arete de cf vide
04325       nav = n1arcf(0)
04326       if( nav .le. 0 ) then
04327          write(imprim,*) 'saturation du tableau noarcf'
04328          nt = 0
04329          return
04330       endif
04331 c
04332 c     la 1-ere arete vide est mise a jour
04333       n1arcf(0) = noarcf( 2, nav )
04334 c
04335 c     ajout de l'arete nav pointant sur na3
04336 c     le numero du sommet
04337       noarcf( 1, nav ) = noarcf( 1, na1 )
04338 c     l'arete suivante
04339       noarcf( 2, nav ) = na3
04340 c     le numero de l'arete dans le tableau nosoar
04341       noarcf( 3, nav ) = noar3
04342 c
04343 c     l'arete precedente na01 de na1 pointe sur la nouvelle nav
04344       noarcf( 2, na01 ) = nav
04345 c
04346 c     debut du cf
04347       n1arcf( nbcf ) = nav
04348       return
04349 c
04350 c     erreur tableau nosoar sature
04351  9900 write(imprim,*) 'saturation du tableau nosoar'
04352       nt = 0
04353       return
04354       end
04355 
04356 
04357       subroutine trcf2a( nbcf,   na1,    noar3,
04358      %                   mosoar, mxsoar, n1soar, nosoar,
04359      %                   moartr, n1artr, noartr, noarst,
04360      %                   n1arcf, noarcf, nt )
04361 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
04362 c but :    modification de la triangulation du contour ferme nbcf
04363 c -----    par ajout d'un triangle ayant 2 aretes sur le contour
04364 c          creation d'une arete dans nosoar (sommet3-sommet1)
04365 c          et modification du contour par ajout de la 3-eme arete
04366 c
04367 c entrees:
04368 c --------
04369 c nbcf   : numero dans n1arcf du cf traite ici
04370 c na1    : numero noarcf de la premiere arete sur le contour
04371 c          implicitement sa suivante est sur le contour
04372 c          la suivante de la suivante n'est pas sur le contour
04373 c mosoar : nombre maximal d'entiers par arete et
04374 c          indice dans nosoar de l'arete suivante dans le hachage
04375 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
04376 c          attention: mxsoar>3*mxsomm obligatoire!
04377 c moartr : nombre maximal d'entiers par arete du tableau noartr
04378 c
04379 c entrees et sorties :
04380 c --------------------
04381 c n1soar : numero de la premiere arete vide dans le tableau nosoar
04382 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
04383 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
04384 c          chainage des aretes frontalieres, chainage du hachage des aretes
04385 c          hachage des aretes = nosoar(1)+nosoar(2)*2
04386 c n1artr : numero du premier triangle vide dans le tableau noartr
04387 c          le chainage des triangles vides se fait sur noartr(2,.)
04388 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
04389 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
04390 c
04391 c noarst : noarst(i) numero d'une arete de sommet i
04392 c n1arcf : numero d'une arete de chaque contour
04393 c noarcf : numero des aretes de la ligne du contour ferme
04394 c          attention : chainage circulaire des aretes
04395 c
04396 c sortie :
04397 c --------
04398 c noar3  : numero de l'arete 3 dans le tableau nosoar
04399 c nt     : numero du triangle ajoute dans noartr
04400 c          0 si saturation du tableau noartr ou nosoar
04401 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
04402 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
04403 c2345x7..............................................................012
04404       common / unites / lecteu, imprim, nunite(30)
04405       integer           nosoar(mosoar,*),
04406      %                  noartr(moartr,*),
04407      %                  noarst(*)
04408       integer           n1arcf(0:*),
04409      %                  noarcf(3,*)
04410 c
04411       ierr = 0
04412 c
04413 c     l'arete suivante de l'arete na1 dans noarcf
04414       na2 = noarcf( 2, na1 )
04415 c     l'arete suivante de l'arete na2 dans noarcf
04416       na3 = noarcf( 2, na2 )
04417 c
04418 c     la formation de l'arete sommet3-sommet1 dans le tableau nosoar
04419       call fasoar( noarcf(1,na3), noarcf(1,na1), -1, -1,  0,
04420      %             mosoar, mxsoar, n1soar, nosoar, noarst,
04421      %             noar3,  ierr )
04422       if( ierr .ne. 0 ) then
04423          if( ierr .eq. 1 ) then
04424             write(imprim,*) 'saturation des aretes (tableau nosoar)'
04425          endif
04426          nt = 0
04427          return
04428       endif
04429 c
04430 c     le triangle a ses 2 aretes na1 na2 sur le contour ferme
04431 c     ajout dans noartr de ce triangle nt
04432       call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
04433      %             noarcf(3,na1), noarcf(3,na2), noar3,
04434      %             mosoar, nosoar,
04435      %             moartr, n1artr, noartr,
04436      %             nt )
04437       if( nt .le. 0 ) return
04438 c
04439 c     suppression des 2 aretes (na1 na2) du cf
04440 c     ces 2 aretes se suivent dans le chainage du cf
04441 c     ajout de la 3-eme arete  (noar3) dans le cf
04442 c     l'arete suivante de na1 devient la suivante de na2
04443       noarcf(2,na1) = na3
04444       noarcf(3,na1) = noar3
04445 c
04446 c     l'arete na2 devient vide dans noarcf
04447       noarcf(2,na2) = n1arcf( 0 )
04448       n1arcf( 0 )   = na2
04449 c
04450 c     la premiere pointee dans noarcf est na1
04451 c     chainage circulaire => ce peut etre n'importe laquelle
04452       n1arcf(nbcf) = na1
04453       end
04454 
04455 
04456       subroutine trcf3a( ns1,    ns2,    ns3,
04457      %                   noar1,  noar2,  noar3,
04458      %                   mosoar, nosoar,
04459      %                   moartr, n1artr, noartr,
04460      %                   nt )
04461 c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
04462 c but :    ajouter dans le tableau noartr le triangle
04463 c -----    de sommets ns1   ns2   ns3
04464 c          d'aretes   noar1 noar2 noar3 deja existantes
04465 c                     dans le tableau nosoar des aretes
04466 c
04467 c entrees:
04468 c --------
04469 c ns1,  ns2,  ns3   : le numero dans pxyd   des 3 sommets du triangle
04470 c noar1,noar2,noar3 : le numero dans nosoar des 3 aretes  du triangle
04471 c mosoar : nombre maximal d'entiers par arete et
04472 c          indice dans nosoar de l'arete suivante dans le hachage
04473 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
04474 c          attention: mxsoar>3*mxsomm obligatoire!
04475 c moartr : nombre maximal d'entiers par arete du tableau noartr
04476 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
04477 c
04478 c modifies :
04479 c ----------
04480 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
04481 c          chainage des aretes frontalieres, chainage du hachage des aretes
04482 c          hachage des aretes = nosoar(1)+nosoar(2)*2
04483 c n1artr : numero du premier triangle vide dans le tableau noartr
04484 c          le chainage des triangles vides se fait sur noartr(2,.)
04485 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
04486 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
04487 c
04488 c sorties:
04489 c --------
04490 c nt     : numero dans noartr du triangle ajoute
04491 c          =0 si le tableau noartr est sature
04492 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
04493 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
04494 c....................................................................012
04495       common / unites / lecteu,imprim,nunite(30)
04496       integer           nosoar(mosoar,*),
04497      %                  noartr(moartr,*)
04498 c
04499 c     recherche d'un triangle libre dans le tableau noartr
04500       if( n1artr .le. 0 ) then
04501          write(imprim,*) 'saturation du tableau noartr des aretes'
04502          nt = 0
04503          return
04504       endif
04505 c
04506 c     le numero dans noartr du nouveau triangle
04507       nt = n1artr
04508 c
04509 c     le nouveau premier triangle vide dans le tableau noartr
04510       n1artr = noartr(2,n1artr)
04511 c
04512 c     arete 1 du triangle nt
04513 c     ======================
04514 c     orientation des 3 aretes du triangle pour qu'il soit direct
04515       if( ns1 .eq. nosoar(1,noar1) ) then
04516          n =  1
04517       else
04518          n = -1
04519       endif
04520 c     le numero de l'arete 1 du triangle nt
04521       noartr(1,nt) = n * noar1
04522 c
04523 c     le numero du triangle nt pour l'arete
04524       if( nosoar(4,noar1) .le. 0 ) then
04525          n = 4
04526       else
04527          n = 5
04528       endif
04529       nosoar(n,noar1) = nt
04530 c
04531 c     arete 2 du triangle nt
04532 c     ======================
04533 c     orientation des 3 aretes du triangle pour qu'il soit direct
04534       if( ns2 .eq. nosoar(1,noar2) ) then
04535          n =  1
04536       else
04537          n = -1
04538       endif
04539 c     le numero de l'arete 2 du triangle nt
04540       noartr(2,nt) = n * noar2
04541 c
04542 c     le numero du triangle nt pour l'arete
04543       if( nosoar(4,noar2) .le. 0 ) then
04544          n = 4
04545       else
04546          n = 5
04547       endif
04548       nosoar(n,noar2) = nt
04549 c
04550 c     arete 3 du triangle nt
04551 c     ======================
04552 c     orientation des 3 aretes du triangle pour qu'il soit direct
04553       if( ns3 .eq. nosoar(1,noar3) ) then
04554          n =  1
04555       else
04556          n = -1
04557       endif
04558 c     le numero de l'arete 3 du triangle nt
04559       noartr(3,nt) = n * noar3
04560 c
04561 c     le numero du triangle nt pour l'arete
04562       if( nosoar(4,noar3) .le. 0 ) then
04563          n = 4
04564       else
04565          n = 5
04566       endif
04567       nosoar(n,noar3) = nt
04568       end
04569 
04570 
04571 
04572       subroutine trcf3s( nbcf,   na01,   na1,    na02,  na2, na03, na3,
04573      %                   mosoar, mxsoar, n1soar, nosoar,
04574      %                   moartr, n1artr, noartr, noarst,
04575      %                   mxarcf, n1arcf, noarcf, nt )
04576 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
04577 c but :     ajout d'un triangle d'aretes na1 2 3 du tableau noarcf
04578 c -----     a la triangulation d'un contour ferme (cf)
04579 c
04580 c entrees:
04581 c --------
04582 c nbcf    : numero dans n1arcf du cf traite ici
04583 c           mais aussi nombre actuel de cf avant ajout du triangle
04584 c na01    : numero noarcf de l'arete precedent l'arete na1 de noarcf
04585 c na1     : numero noarcf du 1-er sommet du triangle
04586 c na02    : numero noarcf de l'arete precedent l'arete na2 de noarcf
04587 c na2     : numero noarcf du 2-eme sommet du triangle
04588 c na03    : numero noarcf de l'arete precedent l'arete na3 de noarcf
04589 c na3     : numero noarcf du 3-eme sommet du triangle
04590 c
04591 c mosoar : nombre maximal d'entiers par arete et
04592 c          indice dans nosoar de l'arete suivante dans le hachage
04593 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
04594 c          attention: mxsoar>3*mxsomm obligatoire!
04595 c moartr : nombre maximal d'entiers par arete du tableau noartr
04596 c mxarcf : nombre maximal d'aretes declarables dans noarcf, n1arcf
04597 c
04598 c modifies:
04599 c ---------
04600 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
04601 c          chainage des vides suivant en 3 et precedant en 2 de nosoar
04602 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
04603 c          chainage des aretes frontalieres, chainage du hachage des aretes
04604 c          hachage des aretes = nosoar(1)+nosoar(2)*2
04605 c          avec mxsoar>=3*mxsomm
04606 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
04607 c          nosoar(2,arete vide)=l'arete vide qui precede
04608 c          nosoar(3,arete vide)=l'arete vide qui suit
04609 c
04610 c n1artr : numero du premier triangle vide dans le tableau noartr
04611 c          le chainage des triangles vides se fait sur noartr(2,.)
04612 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
04613 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
04614 c noarst : noarst(i) numero d'une arete de sommet i
04615 c
04616 c n1arcf : numero d'une arete de chaque contour ferme
04617 c noarcf : numero du sommet , numero de l'arete suivante
04618 c          numero de l'arete dans le tableau nosoar
04619 c          attention : chainage circulaire des aretes
04620 c
04621 c sortie :
04622 c --------
04623 c nbcf   : nombre actuel de cf apres ajout du triangle
04624 c nt     : numero du triangle ajoute dans noartr
04625 c          0 si saturation du tableau nosoar ou noartr ou noarcf ou n1arcf
04626 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
04627 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
04628 c2345x7..............................................................012
04629       integer        nosoar(mosoar,*),
04630      %               noartr(moartr,*),
04631      %               noarst(*),
04632      %               n1arcf(0:mxarcf),
04633      %               noarcf(3,mxarcf)
04634 c
04635 c     combien y a t il d'aretes nbascf sur le cf ?
04636 c     ============================================
04637 c     la premiere arete est elle sur le cf?
04638       if( noarcf(2,na1) .eq. na2 ) then
04639 c        la 1-ere arete est sur le cf
04640          na1cf  = 1
04641       else
04642 c        la 1-ere arete n'est pas sur le cf
04643          na1cf  = 0
04644       endif
04645 c
04646 c     la seconde arete est elle sur le cf?
04647       if( noarcf(2,na2) .eq. na3 ) then
04648 c        la 2-eme arete est sur le cf
04649          na2cf = 1
04650       else
04651          na2cf = 0
04652       endif
04653 c
04654 c     la troisieme arete est elle sur le cf?
04655       if( noarcf(2,na3) .eq. na1 ) then
04656 c        la 3-eme arete est sur le cf
04657          na3cf = 1
04658       else
04659          na3cf = 0
04660       endif
04661 c
04662 c     le nombre d'aretes sur le cf
04663       nbascf = na1cf + na2cf + na3cf
04664 c
04665 c     traitement selon le nombre d'aretes sur le cf
04666 c     =============================================
04667       if( nbascf .eq. 3 ) then
04668 c
04669 c        le contour ferme se reduit a un triangle avec 3 aretes sur le cf
04670 c        ----------------------------------------------------------------
04671 c        ajout dans noartr de ce nouveau triangle
04672          call trcf3a( noarcf(1,na1), noarcf(1,na2), noarcf(1,na3),
04673      %                noarcf(3,na1), noarcf(3,na2), noarcf(3,na3),
04674      %                mosoar, nosoar,
04675      %                moartr, n1artr, noartr,
04676      %                nt )
04677          if( nt .le. 0 ) return
04678 c
04679 c        le cf est supprime et chaine vide
04680          noarcf(2,na3) = n1arcf(0)
04681          n1arcf( 0 )   = na1
04682 c
04683 c        ce cf a ete traite => un cf de moins a traiter
04684          nbcf = nbcf - 1
04685 c
04686       else if( nbascf .eq. 2 ) then
04687 c
04688 c        le triangle a 2 aretes sur le contour
04689 c        -------------------------------------
04690 c        les 2 aretes sont la 1-ere et 2-eme du triangle
04691          if( na1cf .eq. 0 ) then
04692 c           l'arete 1 n'est pas sur le cf
04693             naa1 = na2
04694          else if( na2cf .eq. 0 ) then
04695 c           l'arete 2 n'est pas sur le cf
04696             naa1 = na3
04697          else
04698 c           l'arete 3 n'est pas sur le cf
04699             naa1 = na1
04700          endif
04701 c        le triangle oppose a l'arete 3 est inconnu
04702 c        modification du contour apres integration du
04703 c        triangle ayant ses 2-eres aretes sur le cf
04704          call trcf2a( nbcf,   naa1,   naor3,
04705      %                mosoar, mxsoar, n1soar, nosoar,
04706      %                moartr, n1artr, noartr, noarst,
04707      %                n1arcf, noarcf, nt )
04708 c
04709       else if( nbascf .eq. 1 ) then
04710 c
04711 c        le triangle a 1 arete sur le contour
04712 c        ------------------------------------
04713 c        cette arete est la seconde du triangle
04714          if( na3cf .ne. 0 ) then
04715 c           l'arete 3 est sur le cf
04716             naa01 = na02
04717             naa1  = na2
04718             naa2  = na3
04719          else if( na1cf .ne. 0 ) then
04720 c           l'arete 1 est sur le cf
04721             naa01 = na03
04722             naa1  = na3
04723             naa2  = na1
04724          else
04725 c           l'arete 2 est sur le cf
04726             naa01 = na01
04727             naa1  = na1
04728             naa2  = na2
04729          endif
04730 c        le triangle oppose a l'arete 1 et 3 est inconnu
04731 c        modification du contour apres integration du
04732 c        triangle ayant 1 arete sur le cf avec creation
04733 c        d'un nouveau contour ferme
04734          call trcf1a( nbcf, naa01, naa1, naa2, naor1, naor3,
04735      %                mosoar, mxsoar, n1soar, nosoar,
04736      %                moartr, n1artr, noartr, noarst,
04737      %                mxarcf, n1arcf, noarcf, nt )
04738 c
04739       else
04740 c
04741 c        le triangle a 0 arete sur le contour
04742 c        ------------------------------------
04743 c        modification du contour apres integration du
04744 c        triangle ayant 0 arete sur le cf avec creation
04745 c        de 2 nouveaux contours fermes
04746          call trcf0a( nbcf, na01,  na1, na2, na3,
04747      %                naa1, naa2, naa01,
04748      %                mosoar, mxsoar, n1soar, nosoar,
04749      %                moartr, n1artr, noartr, noarst,
04750      %                mxarcf, n1arcf, noarcf, nt )
04751       endif
04752       end
04753 
04754 
04755       subroutine tridcf( nbcf0,  nbstpe, nostpe, pxyd,   noarst,
04756      %                   mosoar, mxsoar, n1soar, nosoar,
04757      %                   moartr, n1artr, noartr,
04758      %                   mxarcf, n1arcf, noarcf, larmin,
04759      %                   nbtrcf, notrcf, ierr )
04760 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
04761 c but :    triangulation directe de nbcf0 contours fermes (cf)
04762 c -----    definis par la liste circulaire de leurs aretes peripheriques
04763 c          avec integration de nbstpe sommets isoles a l'un des cf initiaux
04764 c
04765 c entrees:
04766 c --------
04767 c nbcf0  : nombre initial de cf a trianguler
04768 c nbstpe : nombre de sommets isoles a l'interieur des cf et
04769 c          a devenir sommets de la triangulation
04770 c nostpe : numero dans pxyd des nbstpe sommets isoles
04771 c pxyd   : tableau des coordonnees 2d des points
04772 c          par point : x  y  distance_souhaitee
04773 c mosoar : nombre maximal d'entiers par arete et
04774 c          indice dans nosoar de l'arete suivante dans le hachage
04775 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
04776 c          attention: mxsoar>3*mxsomm obligatoire!
04777 c moartr : nombre maximal d'entiers par arete du tableau noartr
04778 c mxarcf  : nombre maximal d'aretes declarables dans noarcf, n1arcf, larmin, not
04779 c
04780 c modifies:
04781 c ---------
04782 c noarst : noarst(i) numero d'une arete de sommet i
04783 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
04784 c          chainage des vides suivant en 3 et precedant en 2 de nosoar
04785 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
04786 c          chainage des aretes frontalieres, chainage du hachage des aretes
04787 c          hachage des aretes = nosoar(1)+nosoar(2)*2
04788 c          avec mxsoar>=3*mxsomm
04789 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
04790 c          nosoar(2,arete vide)=l'arete vide qui precede
04791 c          nosoar(3,arete vide)=l'arete vide qui suit
04792 c
04793 c n1artr : numero du premier triangle vide dans le tableau noartr
04794 c          le chainage des triangles vides se fait sur noartr(2,.)
04795 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
04796 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
04797 c
04798 c n1arcf : numero de la premiere arete de chacun des nbcf0 cf
04799 c          n1arcf(0)   no de la premiere arete vide du tableau noarcf
04800 c          noarcf(2,i) no de l'arete suivante
04801 c noarcf : numero du sommet , numero de l'arete suivante du cf
04802 c          numero de l'arete dans le tableau nosoar
04803 c
04804 c auxiliaires :
04805 c -------------
04806 c larmin : tableau (mxarcf)   auxiliaire
04807 c          stocker la liste des numeros des meilleures aretes
04808 c          lors de la selection du meilleur sommet du cf a trianguler
04809 c          cf le sp trchtd
04810 c
04811 c sortie :
04812 c --------
04813 c nbtrcf : nombre de  triangles des nbcf0 cf
04814 c notrcf : numero des triangles des nbcf0 cf dans le tableau noartr
04815 c ierr   : 0 si pas d'erreur
04816 c          2 saturation de l'un des des tableaux nosoar, noartr, ...
04817 c          3 si contour ferme reduit a moins de 3 aretes
04818 c          4 saturation du tableau notrcf
04819 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
04820 c auteur : alain perronnet  analyse numerique paris upmc    mars    1997
04821 c modifs : alain perronnet laboratoire jl lions upmc paris  octobre 2006
04822 c....................................................................012
04823       common / unites / lecteu, imprim, nunite(30)
04824       double precision  pxyd(3,*)
04825       integer           nostpe(nbstpe),
04826      %                  noartr(moartr,*),
04827      %                  nosoar(mosoar,mxsoar),
04828      %                  noarst(*),
04829      %                  n1arcf(0:mxarcf),
04830      %                  noarcf(3,mxarcf),
04831      %                  larmin(mxarcf),
04832      %                  notrcf(mxarcf)
04833 c
04834       integer           nosotr(3)
04835       double precision  d, diptdr, surtd2, dmin, s
04836 c
04837 c     depart avec nbcf0 cf a trianguler
04838       nbcf   = nbcf0
04839 c
04840 c     le nombre de triangles formes dans l'ensemble des cf
04841       nbtrcf = 0
04842 c
04843 c     le nombre restant de sommets isoles a integrer au cf
04844       nbstp = nbstpe
04845 c
04846  1    if( nbstp .le. 0 ) goto 10
04847 c
04848 c     il existe au moins un sommet isole
04849 c     recherche d'un cf dont la premiere arete forme un triangle
04850 c     d'aire>0 avec un sommet isole et recherche du sommet isole
04851 c     le plus proche de cette arete
04852 c     ==========================================================
04853       imin = 0
04854       dmin = 1d123
04855       do 6 ncf=1,nbcf
04856 c        le cf en haut de pile a pour arete avant la premiere arete
04857          na1 = n1arcf( ncf )
04858          na2 = na1
04859 c        recherche de l'arete qui precede la premiere arete
04860  2       if( noarcf( 2, na2 ) .ne. na1 ) then
04861             na2 = noarcf( 2, na2 )
04862             goto 2
04863          endif
04864 c        l'arete na0 dans noarcf qui precede n1arcf( ncf )
04865          na0 = na2
04866 c        la premiere arete du cf
04867          na1   = noarcf( 2, na0 )
04868 c        son numero dans nosoar
04869          noar1 = noarcf( 3, na1 )
04870 c        l'arete suivante
04871          na2   = noarcf( 2, na1 )
04872 c        le no pxyd des 2 sommets de l'arete na1
04873          ns1   = noarcf( 1, na1 )
04874          ns2   = noarcf( 1, na2  )
04875          do 3 i=1,nbstpe
04876 c           le sommet isole ns3
04877             ns3 = nostpe( i )
04878             if( ns3 .le. 0 ) goto 3
04879 c           aire du triangle arete na1 et sommet ns3
04880             d = surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
04881             if( d .gt. 0d0 ) then
04882 c              distance de ce sommet ns3 a l'arete na1
04883                d = diptdr( pxyd(1,ns3),  pxyd(1,ns1), pxyd(1,ns2) )
04884                if( d .lt. dmin ) then
04885                   dmin = d
04886                   imin = i
04887                endif
04888             endif
04889  3       continue
04890          if( imin .gt. 0 ) then
04891 c           le sommet imin de nostpe est a distance minimale de
04892 c           la premiere arete du cf de numero ncf
04893 c           la formation de l'arete ns2-ns3 dans le tableau nosoar
04894             call fasoar( ns2, ns3, -1, -1,  0,
04895      %                   mosoar, mxsoar, n1soar, nosoar, noarst,
04896      %                   noar2,  ierr )
04897             if( ierr .ne. 0 ) goto 9900
04898 c           la formation de l'arete ns3-ns1 dans le tableau nosoar
04899             call fasoar( ns3, ns1, -1, -1,  0,
04900      %                   mosoar, mxsoar, n1soar, nosoar, noarst,
04901      %                   noar3,  ierr )
04902             if( ierr .ne. 0 ) goto 9900
04903 c
04904 c           ajout dans noartr du triangle de sommets ns1 ns2 ns3
04905 c           et d'aretes na1, noar2, noar3 dans nosoar
04906             call trcf3a( ns1,   ns2,   ns3,
04907      %                   noar1, noar2, noar3,
04908      %                   mosoar, nosoar,
04909      %                   moartr, n1artr, noartr,
04910      %                   nt )
04911             s = surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
04912             if( s .le. 0 ) then
04913                write(imprim,*)'tridcf: trcf3a produit tr',nt,' st',
04914      %                         ns1,ns2,ns3
04915                write(imprim,*)'tridcf: triangle AIRE<0'
04916             endif
04917             if( nt .le. 0 ) then
04918                ierr = 7
04919                return
04920             endif
04921             if( nbtrcf .ge. mxarcf ) then
04922                write(imprim,*) 'saturation du tableau notrcf'
04923                ierr = 8
04924                return
04925             endif
04926             nbtrcf = nbtrcf + 1
04927             notrcf( nbtrcf ) = nt
04928 c
04929 c           modification du cf. creation d'une arete dans noarcf
04930             na12 = n1arcf(0)
04931             if( na12 .le. 0 ) then
04932                write(imprim,*) 'saturation du tableau noarcf'
04933                ierr = 10
04934                return
04935             endif
04936 c           la 1-ere arete vide de noarcf est mise a jour
04937             n1arcf(0) = noarcf( 2, na12 )
04938 c
04939 c           l'arete suivante de na0
04940             noarcf( 1, na1 ) = ns1
04941             noarcf( 2, na1 ) = na12
04942             noarcf( 3, na1 ) = noar3
04943 c           l'arete suivante de na1
04944             noarcf( 1, na12 ) = ns3
04945             noarcf( 2, na12 ) = na2
04946             noarcf( 3, na12 ) = noar2
04947 c
04948 c           un sommet isole traite
04949             nbstp = nbstp - 1
04950             nostpe( imin ) = - nostpe( imin )
04951             goto 1
04952          endif
04953 c
04954  6    continue
04955 c
04956       if( imin .eq. 0 ) then
04957          write(imprim,*) 'tridcf: il reste',nbstp,
04958      %                   ' sommets isoles non triangules'
04959          write(imprim,*) 'ameliorer l''algorithme'
04960 ccc         pause
04961          ierr = 9
04962          return
04963       endif
04964 c
04965 c     tant qu'il existe un cf a trianguler faire
04966 c     la triangulation directe du cf
04967 c     ==========================================
04968  10   if( nbcf .gt. 0 ) then
04969 c
04970 c        le cf en haut de pile a pour premiere arete
04971          na01 = n1arcf( nbcf )
04972          na1  = noarcf( 2, na01 )
04973 c
04974 c        choix du sommet du cf a relier a l'arete na1
04975 c        --------------------------------------------
04976          call trchtd( pxyd, na01, na1, noarcf,
04977      %                na03, na3,  larmin )
04978          if( na3 .eq. 0 ) then
04979             ierr = 3
04980             return
04981          endif
04982 c
04983 c        l'arete suivante de na1
04984          na02 = na1
04985          na2  = noarcf( 2, na1 )
04986 c
04987 c        formation du triangle arete na1 - sommet noarcf(1,na3)
04988 c        ------------------------------------------------------
04989          call trcf3s( nbcf,   na01, na1, na02, na2, na03, na3,
04990      %                mosoar, mxsoar, n1soar, nosoar,
04991      %                moartr, n1artr, noartr, noarst,
04992      %                mxarcf, n1arcf, noarcf, nt )
04993          if( nt .le. 0 ) then
04994 c           saturation du tableau noartr ou noarcf ou n1arcf
04995             ierr = 2
04996             return
04997          endif
04998          call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr)
04999          s = surtd2( pxyd(1,nosotr(1)),
05000      %               pxyd(1,nosotr(2)),
05001      %               pxyd(1,nosotr(3)) )
05002          if( s .le. 0 ) then
05003             write(imprim,*)'tridcf: trcf3s produit tr',nt,' st',nosotr
05004             write(imprim,*)'tridcf: triangle AIRE<0'
05005          endif
05006 c
05007 c        ajout du triangle cree a sa pile
05008          if( nbtrcf .ge. mxarcf ) then
05009             write(imprim,*) 'saturation du tableau notrcf'
05010             ierr = 4
05011             return
05012          endif
05013          nbtrcf = nbtrcf + 1
05014          notrcf( nbtrcf ) = nt
05015          goto 10
05016       endif
05017 c
05018 c     mise a jour du chainage des triangles des aretes
05019 c     ================================================
05020       do 30 ntp0 = 1, nbtrcf
05021 c
05022 c        le numero du triangle ajoute dans le tableau noartr
05023          nt0 = notrcf( ntp0 )
05024 c
05025 c        boucle sur les 3 aretes du triangle nt0
05026          do 20 i=1,3
05027 c
05028 c           le numero de l'arete i du triangle dans le tableau nosoar
05029             noar = abs( noartr(i,nt0) )
05030 c
05031 c           ce triangle est il deja chaine dans cette arete?
05032             nt1 = nosoar(4,noar)
05033             nt2 = nosoar(5,noar)
05034             if( nt1 .eq. nt0 .or. nt2 .eq. nt0 ) goto 20
05035 c
05036 c           ajout de ce triangle nt0 a l'arete noar
05037             if( nt1 .le. 0 ) then
05038 c               le triangle est ajoute a l'arete
05039                 nosoar( 4, noar ) = nt0
05040             else if( nt2 .le. 0 ) then
05041 c               le triangle est ajoute a l'arete
05042                 nosoar( 5, noar ) = nt0
05043             else
05044 c              l'arete appartient a 2 triangles differents de nt0
05045 c              anomalie. chainage des triangles des aretes defectueux
05046 c              a corriger
05047                write(imprim,*) 'tridcf: erreur 1 arete dans 3 triangles'
05048                write(imprim,*) 'tridcf: arete nosoar(',noar,')=',
05049      %                          (nosoar(k,noar),k=1,mosoar)
05050                call nusotr( nt0, mosoar, nosoar, moartr, noartr, nosotr)
05051                write(imprim,*) 'tridcf: triangle nt0=',nt0,' st:',
05052      %                          (nosotr(k),k=1,3)
05053                call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr)
05054                write(imprim,*) 'tridcf: triangle nt1=',nt1,' st:',
05055      %                          (nosotr(k),k=1,3)
05056                call nusotr( nt2, mosoar, nosoar, moartr, noartr, nosotr)
05057                write(imprim,*) 'tridcf: triangle nt2=',nt2,' st:',
05058      %                          (nosotr(k),k=1,3)
05059 ccc               pause
05060                ierr = 5
05061                return
05062             endif
05063 c
05064  20      continue
05065 c
05066  30   continue
05067       return
05068 c
05069 c     erreur tableau nosoar sature
05070  9900 write(imprim,*) 'saturation du tableau nosoar'
05071       ierr = 6
05072       return
05073       end
05074 
05075       subroutine te1stm( nsasup, nbarpi, pxyd,   noarst,
05076      %                   mosoar, mxsoar, n1soar, nosoar,
05077      %                   moartr, mxartr, n1artr, noartr,
05078      %                   mxarcf, n1arcf, noarcf, larmin, notrcf, liarcf,
05079      %                   ierr )
05080 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
05081 c but :    supprimer de la triangulation le sommet nsasup qui doit
05082 c -----    etre un sommet interne ("centre" d'une boule de triangles)
05083 c
05084 c          attention: le chainage lchain de nosoar devient celui des cf
05085 c
05086 c entrees:
05087 c --------
05088 c nsasup : numero dans le tableau pxyd du sommet a supprimer
05089 c nbarpi : numero du dernier sommet frontalier ou interne impose
05090 c pxyd   : tableau des coordonnees 2d des points
05091 c          par point : x  y  distance_souhaitee
05092 c mosoar : nombre maximal d'entiers par arete et
05093 c          indice dans nosoar de l'arete suivante dans le hachage
05094 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
05095 c          attention: mxsoar>3*mxsomm obligatoire!
05096 c moartr : nombre maximal d'entiers par arete du tableau noartr
05097 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
05098 c
05099 c modifies:
05100 c ---------
05101 c noarst : noarst(i) numero d'une arete de sommet i
05102 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
05103 c          chainage des vides suivant en 3 et precedant en 2 de nosoar
05104 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
05105 c          chainage des aretes frontalieres, chainage du hachage des aretes
05106 c          hachage des aretes = nosoar(1)+nosoar(2)*2
05107 c          avec mxsoar>=3*mxsomm
05108 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
05109 c          nosoar(2,arete vide)=l'arete vide qui precede
05110 c          nosoar(3,arete vide)=l'arete vide qui suit
05111 c n1artr : numero du premier triangle vide dans le tableau noartr
05112 c          le chainage des triangles vides se fait sur noartr(2,.)
05113 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
05114 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
05115 c
05116 c
05117 c auxiliaires :
05118 c -------------
05119 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
05120 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
05121 c larmin : tableau ( mxarcf ) auxiliaire d'entiers
05122 c notrcf : tableau ( mxarcf ) auxiliaire d'entiers
05123 c liarcf : tableau ( mxarcf ) auxiliaire d'entiers
05124 c
05125 c sortie :
05126 c --------
05127 c ierr   : =0 si pas d'erreur
05128 c          -1 le sommet a supprimer n'est pas le centre d'une boule
05129 c             de triangles. il est suppose externe
05130 c             ou bien le sommet est centre d'un cf dont toutes les
05131 c             aretes sont frontalieres
05132 c             dans les 2 cas => retour sans modifs
05133 c          >0 si une erreur est survenue
05134 c          =11 algorithme defaillant
05135 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
05136 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
05137 c....................................................................012
05138       parameter       ( lchain=6, mxstpe=512)
05139       common / unites / lecteu,imprim,intera,nunite(29)
05140       double precision  pxyd(3,*), s0, s1, surtd2, s
05141       integer           nosoar(mosoar,mxsoar),
05142      %                  noartr(moartr,mxartr),
05143      %                  noarst(*),
05144      %                  n1arcf(0:mxarcf),
05145      %                  noarcf(3,mxarcf),
05146      %                  larmin(mxarcf),
05147      %                  notrcf(mxarcf),
05148      %                  liarcf(mxarcf),
05149      %                  nostpe(mxstpe),
05150      %                  nosotr(3)
05151 c
05152       if( nsasup .le. nbarpi ) then
05153 c        sommet frontalier non destructible
05154          ierr = -1
05155          return
05156       endif
05157       ierr = 0
05158 c
05159 c     nsasup est il un sommet interne, "centre" d'une boule de triangles?
05160 c     => le sommet nsasup peut etre supprime
05161 c     ===================================================================
05162 c     formation du cf de ''centre'' le sommet nsasup
05163       call trp1st( nsasup, noarst, mosoar, nosoar,
05164      %             moartr, mxartr, noartr,
05165      %             mxarcf, nbtrcf, notrcf )
05166 c
05167       if( nbtrcf .le. 2 ) then
05168 c        erreur: impossible de trouver tous les triangles de sommet nsasup
05169 c        ou pas assez de triangles de sommet nsasup
05170 c        le sommet nsasup n'est pas supprime de la triangulation
05171          ierr = -1
05172          return
05173       endif
05174 c
05175       if( nbtrcf*3 .gt. mxarcf ) then
05176          write(imprim,*) 'saturation du tableau noarcf'
05177          ierr = 10
05178          return
05179       endif
05180 c
05181 c     si toutes les aretes du cf sont frontalieres, alors il est
05182 c     interdit de detruire le sommet "centre" du cf
05183 c     calcul du nombre nbarfr des aretes simples des nbtrcf triangles
05184       call trfrcf( nsasup, mosoar, nosoar, moartr, noartr,
05185      %             nbtrcf, notrcf, nbarfr )
05186       if( nbarfr .ge. nbtrcf ) then
05187 c        toutes les aretes simples sont frontalieres
05188 c        le sommet nsasup ("centre" de la cavite) n'est pas supprime
05189          ierr = -1
05190          return
05191       endif
05192 c
05193 c     calcul des surfaces avant suppression du point
05194       s0 = 0d0
05195       do 10 i=1,nbtrcf
05196          nt = notrcf(i)
05197 c        les numeros des 3 sommets du triangle nt
05198          call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
05199          s = surtd2( pxyd(1,nosotr(1)),
05200      %               pxyd(1,nosotr(2)),
05201      %               pxyd(1,nosotr(3)) )
05202          s0 = s0 + abs( s )
05203  10   continue
05204 c
05205 c     formation du contour ferme (liste chainee des aretes simples)
05206 c     forme a partir des aretes des triangles de l'etoile du sommet nsasup
05207 c     les aretes doubles sont detruites
05208 c     les triangles du cf sont detruits
05209       call focftr( nbtrcf, notrcf, nbarpi, pxyd,   noarst,
05210      %             mosoar, mxsoar, n1soar, nosoar,
05211      %             moartr, n1artr, noartr,
05212      %             nbarcf, n1arcf, noarcf, nbstpe, nostpe,
05213      %             ierr )
05214       if( ierr .ne. 0 ) then
05215 c        modification de ierr pour continuer le calcul
05216          ierr = -543
05217          return
05218       endif
05219 c
05220 c     ici le sommet nsasup n'appartient plus a aucune arete
05221       noarst( nsasup ) = 0
05222 c
05223 c     chainage des aretes vides dans le tableau noarcf
05224       n1arcf(0) = nbarcf+1
05225       mmarcf = min(8*nbarcf,mxarcf)
05226       do 40 i=nbarcf+1,mmarcf
05227          noarcf(2,i) = i+1
05228  40   continue
05229       noarcf(2,mmarcf) = 0
05230 c
05231 c     sauvegarde du chainage des aretes peripheriques
05232 c     pour la mise en delaunay du maillage
05233       nbcf = n1arcf(1)
05234       do 50 i=1,nbarcf
05235 c        le numero de l'arete dans le tableau nosoar
05236          liarcf( i ) = noarcf( 3, nbcf )
05237 c        l'arete suivante dans le cf
05238          nbcf = noarcf( 2, nbcf )
05239  50   continue
05240 c
05241 c     triangulation directe du contour ferme sans le sommet nsasup
05242 c     ============================================================
05243       nbcf = 1
05244       call tridcf( nbcf,   nbstpe, nostpe, pxyd,   noarst,
05245      %             mosoar, mxsoar, n1soar, nosoar,
05246      %             moartr, n1artr, noartr,
05247      %             mxarcf, n1arcf, noarcf, larmin,
05248      %             nbtrcf, notrcf, ierr )
05249       if( ierr .ne. 0 ) return
05250 c     calcul des surfaces apres suppression du point
05251       s1 = 0d0
05252       do 55 i=1,nbtrcf
05253          nt = notrcf(i)
05254 c        les numeros des 3 sommets du triangle nt
05255          call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
05256          s = surtd2( pxyd(1,nosotr(1)),
05257      %               pxyd(1,nosotr(2)),
05258      %               pxyd(1,nosotr(3)) )
05259          if( s .le. 0 ) then
05260             write(imprim,*)'te1stm: apres tridcf le triangle',nt,
05261      %                     ' st',nosotr,' AIRE<0'
05262          endif
05263          s1 = s1 + abs( s )
05264  55   continue
05265 c
05266       if( abs(s0-s1) .gt. 1d-10*s0 ) then
05267       write(imprim,*)
05268       write(imprim,*)'te1stm: difference des aires lors suppression st',
05269      %   nsasup
05270       write(imprim,10055) s0, s1
05271 10055 format('aire0=',d25.16,' aire1=',d25.16)
05272       endif
05273 c
05274 c     transformation des triangles du cf en triangles delaunay
05275 c     ========================================================
05276 c     construction du chainage lchain dans nosoar
05277 c     des aretes peripheriques du cf a partir de la sauvegarde liarcf
05278       noar0 = liarcf(1)
05279       do 60 i=2,nbarcf
05280 c        le numero de l'arete peripherique du cf dans nosoar
05281          noar = liarcf( i )
05282          if( nosoar(3,noar) .le. 0 ) then
05283 c           arete interne => elle est chainee a partir de la precedente
05284             nosoar( lchain, noar0 ) = noar
05285             noar0 = noar
05286          endif
05287  60   continue
05288 c     la derniere arete peripherique n'a pas de suivante
05289       nosoar(lchain,noar0) = 0
05290 c
05291 c     mise en delaunay des aretes chainees
05292       call tedela( pxyd,   noarst,
05293      %             mosoar, mxsoar, n1soar, nosoar, liarcf(1),
05294      %             moartr, mxartr, n1artr, noartr, modifs )
05295       return
05296       end
05297 
05298 
05299       subroutine tr3str( np,     nt,
05300      %                   mosoar, mxsoar, n1soar, nosoar,
05301      %                   moartr, mxartr, n1artr, noartr,
05302      %                   noarst, nutr,   ierr )
05303 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
05304 c but :    former les 3 sous-triangles du triangle nt a partir
05305 c -----    du point interne np
05306 c
05307 c entrees:
05308 c --------
05309 c np     : numero dans le tableau pxyd du point
05310 c nt     : numero dans le tableau noartr du triangle a trianguler
05311 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
05312 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
05313 c moartr : nombre maximal d'entiers par arete du tableau noartr
05314 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
05315 c
05316 c modifies:
05317 c ---------
05318 c n1soar : numero de la premiere arete vide dans le tableau nosoar
05319 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
05320 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages
05321 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
05322 c          hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
05323 c n1artr : numero du premier triangle vide dans le tableau noartr
05324 c          le chainage des triangles vides se fait sur noartr(2,.)
05325 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
05326 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
05327 c noarst : noarst(i) numero d'une arete de sommet i
05328 c
05329 c sorties:
05330 c --------
05331 c nutr   : le numero des 3 sous-triangles du triangle nt
05332 c nt     : en sortie le triangle initial n'est plus actif dans noartr
05333 c          c'est en fait le premier triangle vide de noartr
05334 c ierr   : =0 si pas d'erreur
05335 c          =1 si le tableau nosoar est sature
05336 c          =2 si le tableau noartr est sature
05337 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
05338 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
05339 c....................................................................012
05340       integer    nosoar(mosoar,mxsoar),
05341      %           noartr(moartr,mxartr),
05342      %           noarst(*),
05343      %           nutr(3)
05344 c
05345       integer    nosotr(3), nu2sar(2), nuarco(3)
05346 c
05347 c     reservation des 3 nouveaux triangles dans le tableau noartr
05348 c     ===========================================================
05349       do 10 i=1,3
05350 c        le numero du sous-triangle i dans le tableau noartr
05351          if( n1artr .le. 0 ) then
05352 c           tableau noartr sature
05353             ierr = 2
05354             return
05355          endif
05356          nutr(i) = n1artr
05357 c        le nouveau premier triangle libre dans noartr
05358          n1artr = noartr(2,n1artr)
05359  10   continue
05360 c
05361 c     les numeros des 3 sommets du triangle nt
05362       call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
05363 c
05364 c     formation des 3 aretes nosotr(i)-np dans le tableau nosoar
05365 c     ==========================================================
05366       nt0 = nutr(3)
05367       do 20 i=1,3
05368 c
05369 c        le triangle a creer
05370          nti = nutr(i)
05371 c
05372 c        les 2 sommets du cote i du triangle nosotr
05373          nu2sar(1) = nosotr(i)
05374          nu2sar(2) = np
05375          call hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar, noar )
05376 c        en sortie: noar>0 => no arete retrouvee
05377 c                       <0 => no arete ajoutee
05378 c                       =0 => saturation du tableau nosoar
05379 c
05380          if( noar .eq. 0 ) then
05381 c           saturation du tableau nosoar
05382             ierr = 1
05383             return
05384          else if( noar .lt. 0 ) then
05385 c           l'arete a ete ajoutee. initialisation des autres informations
05386             noar = -noar
05387 c           le numero des 2 sommets a ete initialise par hasoar
05388 c           et (nosoar(1,noar)<nosoar(2,noar))
05389 c           le numero de la ligne de l'arete: ici arete interne
05390             nosoar(3,noar) = 0
05391 c        else
05392 c           l'arete a ete retrouvee
05393 c           le numero des 2 sommets a ete retrouve par hasoar
05394 c           et (nosoar(1,noar)<nosoar(2,noar))
05395 c           le numero de ligne reste inchange
05396          endif
05397 c
05398 c        le triangle 1 de l'arete noar => le triangle nt0
05399          nosoar(4,noar) = nt0
05400 c        le triangle 2 de l'arete noar => le triangle nti
05401          nosoar(5,noar) = nti
05402 c
05403 c        le sommet nosotr(i) appartient a l'arete noar
05404          noarst( nosotr(i) ) = noar
05405 c
05406 c        le numero d'arete nosotr(i)-np
05407          nuarco(i) = noar
05408 c
05409 c        le triangle qui precede le suivant
05410          nt0 = nti
05411  20   continue
05412 c
05413 c     le numero d'une arete du point np
05414       noarst( np ) = noar
05415 c
05416 c     les 3 sous-triangles du triangle nt sont formes dans le tableau noartr
05417 c     ======================================================================
05418       do 30 i=1,3
05419 c
05420 c        le numero suivant i => i mod 3 + 1
05421          if( i .ne. 3 ) then
05422             i1 = i + 1
05423          else
05424             i1 = 1
05425          endif
05426 c
05427 c        le numero dans noartr du sous-triangle a ajouter
05428          nti = nutr( i )
05429 c
05430 c        le numero de l'arete i du triangle initial nt
05431 c        est l'arete 1 du sous-triangle i
05432          noar = noartr(i,nt)
05433          noartr( 1, nti ) = noar
05434 c
05435 c        mise a jour du numero de triangle de cette arete
05436          noar = abs( noar )
05437          if( nosoar(4,noar) .eq. nt ) then
05438 c           le sous-triangle nti remplace le triangle nt
05439             nosoar(4,noar) = nti
05440          else
05441 c           le sous-triangle nti remplace le triangle nt
05442             nosoar(5,noar) = nti
05443          endif
05444 c
05445 c        l'arete 2 du sous-triangle i est l'arete i1 ajoutee
05446          if( nosotr(i1) .eq. nosoar(1,nuarco(i1)) ) then
05447 c           l'arete ns i1-np dans nosoar est dans le sens direct
05448             noartr( 2, nti ) = nuarco(i1)
05449          else
05450 c           l'arete ns i1-np dans nosoar est dans le sens indirect
05451             noartr( 2, nti ) = -nuarco(i1)
05452          endif
05453 c
05454 c        l'arete 3 du sous-triangle i est l'arete i ajoutee
05455          if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
05456 c           l'arete ns i1-np dans nosoar est dans le sens indirect
05457             noartr( 3, nti ) = -nuarco(i)
05458          else
05459 c           l'arete ns i1-np dans nosoar est dans le sens direct
05460             noartr( 3, nti ) = nuarco(i)
05461          endif
05462  30   continue
05463 c
05464 c     le triangle nt est rendu libre
05465 c     ==============================
05466 c     il devient n1artr le premier triangle libre
05467       noartr( 1, nt ) = 0
05468       noartr( 2, nt ) = n1artr
05469       n1artr = nt
05470       end
05471 
05472 
05473       subroutine mt4sqa( na,  moartr, noartr, mosoar, nosoar,
05474      %                   ns1, ns2, ns3, ns4)
05475 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
05476 c but :    calcul du numero des 4 sommets de l'arete na de nosoar
05477 c -----    formant un quadrangle
05478 c
05479 c entrees:
05480 c --------
05481 c na     : numero de l'arete dans nosoar a traiter
05482 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
05483 c          arete1=0 si triangle vide => arete2=triangle vide suivant
05484 c mosoar : nombre maximal d'entiers par arete
05485 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
05486 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
05487 c
05488 c sorties:
05489 c --------
05490 c ns1,ns2,ns3 : les 3 numeros des sommets du triangle t1 en sens direct
05491 c ns1,ns4,ns2 : les 3 numeros des sommets du triangle t2 en sens direct
05492 c
05493 c si erreur rencontree => ns4 = 0
05494 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
05495 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
05496 c2345x7..............................................................012
05497       common / unites / lecteu, imprim, nunite(30)
05498       integer           noartr(moartr,*), nosoar(mosoar,*)
05499 c
05500 c     le numero de triangle est il correct  ?
05501 c     a supprimer apres mise au point
05502       if( na .le. 0 ) then
05503 c         nblgrc(nrerr) = 1
05504 c         write(kerr(mxlger)(1:6),'(i6)') na
05505 c         kerr(1) = kerr(mxlger)(1:6) //
05506 c     %           ' no incorrect arete dans nosoar'
05507 c         call lereur
05508           write(imprim,*) na, ' no incorrect arete dans nosoar'
05509          ns4 = 0
05510          return
05511       endif
05512 c
05513       if( nosoar(1,na) .le. 0 ) then
05514 c         nblgrc(nrerr) = 1
05515 c         write(kerr(mxlger)(1:6),'(i6)') na
05516 c         kerr(1) = kerr(mxlger)(1:6) //
05517 c     %           ' arete non active dans nosoar'
05518 c         call lereur
05519          write(imprim,*) na, ' arete non active dans nosoar'
05520          ns4 = 0
05521          return
05522       endif
05523 c
05524 c     recherche de l'arete na dans le premier triangle
05525       nt = nosoar(4,na)
05526       if( nt .le. 0 ) then
05527 c         nblgrc(nrerr) = 1
05528 c         write(kerr(mxlger)(1:6),'(i6)') na
05529 c         kerr(1) =  'triangle 1 incorrect pour l''arete ' //
05530 c     %               kerr(mxlger)(1:6)
05531 c         call lereur
05532          write(imprim,*) 'triangle 1 incorrect pour l''arete ', na
05533          ns4 = 0
05534          return
05535       endif
05536 c
05537       do 5 i=1,3
05538          if( abs( noartr(i,nt) ) .eq. na ) goto 8
05539  5    continue
05540 c     si arrivee ici => bogue avant
05541       write(imprim,*) 'mt4sqa: arete',na,' non dans le triangle',nt
05542       ns4 = 0
05543       return
05544 c
05545 c     les 2 sommets de l'arete na
05546  8    if( noartr(i,nt) .gt. 0 ) then
05547          ns1 = 1
05548          ns2 = 2
05549       else
05550          ns1 = 2
05551          ns2 = 1
05552       endif
05553       ns1 = nosoar(ns1,na)
05554       ns2 = nosoar(ns2,na)
05555 c
05556 c     l'arete suivante
05557       if( i .lt. 3 ) then
05558          i = i + 1
05559       else
05560          i = 1
05561       endif
05562       naa = abs( noartr(i,nt) )
05563 c
05564 c     le sommet ns3 du triangle 123
05565       ns3 = nosoar(1,naa)
05566       if( ns3 .eq. ns1 .or. ns3 .eq. ns2 ) then
05567          ns3 = nosoar(2,naa)
05568       endif
05569 c
05570 c     le triangle de l'autre cote de l'arete na
05571 c     =========================================
05572       nt = nosoar(5,na)
05573       if( nt .le. 0 ) then
05574 c         nblgrc(nrerr) = 1
05575 c         write(kerr(mxlger)(1:6),'(i6)') na
05576 c         kerr(1) =  'triangle 2 incorrect pour l''arete ' //
05577 c     %               kerr(mxlger)(1:6)
05578 c         call lereur
05579           write(imprim,*) 'triangle 2 incorrect pour l''arete ',na
05580          ns4 = 0
05581          return
05582       endif
05583 c
05584 c     le numero de l'arete naa du triangle nt
05585       naa = abs( noartr(1,nt) )
05586       if( naa .eq. na ) naa = abs( noartr(2,nt) )
05587       ns4 = nosoar(1,naa)
05588       if( ns4 .eq. ns1 .or. ns4 .eq. ns2 ) then
05589          ns4 = nosoar(2,naa)
05590       endif
05591       end
05592 
05593 
05594       subroutine te2t2t( noaret, mosoar, n1soar, nosoar, noarst,
05595      %                   moartr, noartr, noar34 )
05596 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
05597 c but :    echanger la diagonale des 2 triangles ayant en commun
05598 c -----    l'arete noaret du tableau nosoar si c'est possible
05599 c
05600 c entrees:
05601 c --------
05602 c noaret : numero de l'arete a echanger entre les 2 triangles
05603 c mosoar : nombre maximal d'entiers par arete
05604 c moartr : nombre maximal d'entiers par triangle
05605 c
05606 c modifies :
05607 c ----------
05608 c n1soar : numero de la premiere arete vide dans le tableau nosoar
05609 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
05610 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
05611 c noarst : noarst(i) numero d'une arete de sommet i
05612 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
05613 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
05614 c
05615 c sortie :
05616 c --------
05617 c noar34 : numero nosoar de la nouvelle arete diagonale
05618 c          0 si pas d'echange des aretes diagonales
05619 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
05620 c auteur : alain perronnet  analyse numerique paris upmc      avril 1997
05621 c....................................................................012
05622       common / unites / lecteu,imprim,intera,nunite(29)
05623       integer     nosoar(mosoar,*),
05624      %            noartr(moartr,*),
05625      %            noarst(*)
05626 c
05627 c     une arete frontaliere ne peut etre echangee
05628       noar34 = 0
05629       if( nosoar(3,noaret) .gt. 0 ) return
05630 c
05631 c     les 4 sommets des 2 triangles ayant l'arete noaret en commun
05632       call mt4sqa( noaret, moartr, noartr, mosoar, nosoar,
05633      %             ns1, ns2, ns3, ns4)
05634 c     ns1,ns2,ns3 : les 3 numeros des sommets du triangle nt1 en sens direct
05635 c     ns1,ns4,ns2 : les 3 numeros des sommets du triangle nt2 en sens direct
05636 c
05637 c     recherche du numero de l'arete noaret dans le triangle nt1
05638       nt1 = nosoar(4,noaret)
05639       do 10 n1 = 1, 3
05640          if( abs(noartr(n1,nt1)) .eq. noaret ) goto 15
05641  10   continue
05642 c     impossible d'arriver ici sans bogue!
05643       write(imprim,*) 'anomalie dans te2t2t 1'
05644 c
05645 c     l'arete de sommets 2 et 3
05646  15   if( n1 .lt. 3 ) then
05647          n2 = n1 + 1
05648       else
05649          n2 = 1
05650       endif
05651       na23 = noartr(n2,nt1)
05652 c
05653 c     l'arete de sommets 3 et 1
05654       if( n2 .lt. 3 ) then
05655          n3 = n2 + 1
05656       else
05657          n3 = 1
05658       endif
05659       na31 = noartr(n3,nt1)
05660 c
05661 c     recherche du numero de l'arete noaret dans le triangle nt2
05662       nt2 = nosoar(5,noaret)
05663       do 20 n1 = 1, 3
05664          if( abs(noartr(n1,nt2)) .eq. noaret ) goto 25
05665  20   continue
05666 c     impossible d'arriver ici sans bogue!
05667       write(imprim,*) 'Anomalie dans te2t2t 2'
05668 c
05669 c     l'arete de sommets 1 et 4
05670  25   if( n1 .lt. 3 ) then
05671          n2 = n1 + 1
05672       else
05673          n2 = 1
05674       endif
05675       na14 = noartr(n2,nt2)
05676 c
05677 c     l'arete de sommets 4 et 2
05678       if( n2 .lt. 3 ) then
05679          n3 = n2 + 1
05680       else
05681          n3 = 1
05682       endif
05683       na42 = noartr(n3,nt2)
05684 c
05685 c     les triangles 123 142 deviennent 143 234
05686 c     ========================================
05687 c     ajout de l'arete ns3-ns4
05688 c     on evite l'affichage de l'erreur
05689       ierr = -1
05690       call fasoar( ns3,    ns4,    nt1,    nt2,    0,
05691      %             mosoar, mxsoar, n1soar, nosoar, noarst,
05692      %             noar34, ierr )
05693       if( ierr .gt. 0 ) then
05694 c        ierr=1 si le tableau nosoar est sature
05695 c            =2 si arete a creer et appartenant a 2 triangles distincts
05696 c               des triangles nt1 et nt2
05697 c            =3 si arete appartenant a 2 triangles distincts
05698 c               differents des triangles nt1 et nt2
05699 c            =4 si arete appartenant a 2 triangles distincts
05700 c               dont le second n'est pas le triangle nt2
05701 c        => pas d'echange
05702          noar34 = 0
05703          return
05704       endif
05705 c
05706 c     suppression de l'arete noaret
05707       call sasoar( noaret, mosoar, mxsoar, n1soar, nosoar, noarst )
05708 c
05709 c     nt1 = triangle 143
05710       noartr(1,nt1) =  na14
05711 c     sens de stockage de l'arete ns3-ns4 dans nosoar?
05712       if( nosoar(1,noar34) .eq. ns3 ) then
05713          n1 = -1
05714       else
05715          n1 =  1
05716       endif
05717       noartr(2,nt1) = noar34 * n1
05718       noartr(3,nt1) = na31
05719 c
05720 c     nt2 = triangle 234
05721       noartr(1,nt2) =  na23
05722       noartr(2,nt2) = -noar34 * n1
05723       noartr(3,nt2) =  na42
05724 c
05725 c     echange nt1 -> nt2 pour l'arete na23
05726       na23 = abs( na23 )
05727       if( nosoar(4,na23) .eq. nt1 ) then
05728          n1 = 4
05729       else
05730          n1 = 5
05731       endif
05732       nosoar(n1,na23) = nt2
05733 c
05734 c     echange nt2 -> nt1 pour l'arete na14
05735       na14 = abs( na14 )
05736       if( nosoar(4,na14) .eq. nt2 ) then
05737          n1 = 4
05738       else
05739          n1 = 5
05740       endif
05741       nosoar(n1,na14) = nt1
05742 c
05743 c     numero d'une arete de chacun des 4 sommets
05744       noarst(ns1) = na14
05745       noarst(ns2) = na23
05746       noarst(ns3) = noar34
05747       noarst(ns4) = noar34
05748       end
05749 
05750 
05751       subroutine f0trte( letree, pxyd,
05752      %                   mosoar, mxsoar, n1soar, nosoar,
05753      %                   moartr, mxartr, n1artr, noartr,
05754      %                   noarst,
05755      %                   nbtr,   nutr,   ierr )
05756 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
05757 c but :    former le ou les triangles du triangle equilateral letree
05758 c -----    les points internes au te deviennent des sommets des
05759 c          sous-triangles du te
05760 c
05761 c entrees:
05762 c --------
05763 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
05764 c          si letree(0)>0 alors
05765 c             letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
05766 c          sinon
05767 c             letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
05768 c                           0  si pas de point
05769 c                         ( le te est une feuille de l'arbre )
05770 c          letree(4) : no letree du sur-triangle du triangle j
05771 c          letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
05772 c          letree(6:8) : no pxyd des 3 sommets du triangle j
05773 c pxyd   : tableau des x  y  distance_souhaitee de chaque sommet
05774 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
05775 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
05776 c moartr : nombre maximal d'entiers par arete du tableau noartr
05777 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
05778 c
05779 c modifies:
05780 c ---------
05781 c n1soar : numero de la premiere arete vide dans le tableau nosoar
05782 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
05783 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
05784 c          chainage des aretes frontalieres, chainage du hachage des aretes
05785 c          hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
05786 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
05787 c n1artr : numero du premier triangle vide dans le tableau noartr
05788 c          le chainage des triangles vides se fait sur noartr(2,.)
05789 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
05790 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
05791 c noarst : noarst(i) numero d'une arete de sommet i
05792 c
05793 c sorties:
05794 c --------
05795 c nbtr   : nombre de sous-triangles du te, triangulation du te
05796 c nutr   : numero des nbtr sous-triangles du te dans le tableau noartr
05797 c ierr   : =0 si pas d'erreur
05798 c          =1 si le tableau nosoar est sature
05799 c          =2 si le tableau noartr est sature
05800 c          =3 si aucun des triangles ne contient l'un des points internes au te
05801 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
05802 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
05803 c....................................................................012
05804       common / unites / lecteu, imprim, nunite(30)
05805       double precision  pxyd(3,*)
05806       integer           letree(0:8),
05807      %                  nosoar(mosoar,mxsoar),
05808      %                  noartr(moartr,mxartr),
05809      %                  noarst(*),
05810      %                  nutr(1:nbtr)
05811       integer           nuarco(3)
05812 c
05813 c     le numero nt du triangle dans le tableau noartr
05814       if( n1artr .le. 0 ) then
05815 c        tableau noartr sature
05816          write(imprim,*) 'f0trte: tableau noartr sature'
05817          ierr = 2
05818          return
05819       endif
05820       nt = n1artr
05821 c     le numero du nouveau premier triangle libre dans noartr
05822       n1artr = noartr( 2, n1artr )
05823 c
05824 c     formation du triangle = le triangle equilateral letree
05825       do 10 i=1,3
05826          if( i .ne. 3 ) then
05827             i1 = i + 1
05828          else
05829             i1 = 1
05830          endif
05831 c        ajout eventuel de l'arete si si+1 dans le tableau nosoar
05832          call fasoar( letree(5+i), letree(5+i1), nt, -1, 0,
05833      %                mosoar, mxsoar, n1soar, nosoar, noarst,
05834      %                nuarco(i), ierr )
05835          if( ierr .ne. 0 ) return
05836  10   continue
05837 c
05838 c     le triangle nt est forme dans le tableau noartr
05839       do 20 i=1,3
05840 c        letree(5+i) est le numero du sommet 1 de l'arete i du te
05841          if( letree(5+i) .eq. nosoar(1,nuarco(i)) ) then
05842             lesign =  1
05843          else
05844             lesign = -1
05845          endif
05846 c        l'arete ns1-ns2 dans nosoar est celle du cote du te
05847          noartr( i, nt ) = lesign * nuarco(i)
05848  20   continue
05849 c
05850 c     triangulation du te=triangle nt par ajout des points internes du te
05851       nbtr    = 1
05852       nutr(1) = nt
05853       call trpite( letree, pxyd,
05854      %             mosoar, mxsoar, n1soar, nosoar,
05855      %             moartr, mxartr, n1artr, noartr, noarst,
05856      %             nbtr,   nutr,   ierr )
05857       end
05858 
05859 
05860       subroutine f1trte( letree, pxyd,   milieu,
05861      %                   mosoar, mxsoar, n1soar, nosoar,
05862      %                   moartr, mxartr, n1artr, noartr,
05863      %                   noarst,
05864      %                   nbtr,   nutr,   ierr )
05865 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
05866 c but :    former les triangles du triangle equilateral letree
05867 c -----    a partir de l'un des 3 milieux des cotes du te
05868 c          et des points internes au te
05869 c          ils deviennent tous des sommets des sous-triangles du te
05870 c
05871 c entrees:
05872 c --------
05873 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
05874 c          si letree(0)>0 alors
05875 c             letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
05876 c          sinon
05877 c             letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
05878 c                           0  si pas de point
05879 c                         ( le te est une feuille de l'arbre )
05880 c          letree(4) : no letree du sur-triangle du triangle j
05881 c          letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
05882 c          letree(6:8) : no pxyd des 3 sommets du triangle j
05883 c pxyd   : tableau des x  y  distance_souhaitee de chaque sommet
05884 c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
05885 c                    0 si pas de milieu du cote i a ajouter
05886 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
05887 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
05888 c moartr : nombre maximal d'entiers par arete du tableau noartr
05889 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
05890 c
05891 c modifies:
05892 c ---------
05893 c n1soar : numero de la premiere arete vide dans le tableau nosoar
05894 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
05895 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
05896 c          chainage des aretes frontalieres, chainage du hachage des aretes
05897 c          hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
05898 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
05899 c n1artr : numero du premier triangle vide dans le tableau noartr
05900 c          le chainage des triangles vides se fait sur noartr(2,.)
05901 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
05902 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
05903 c noarst : noarst(np) numero d'une arete du sommet np
05904 c
05905 c sorties:
05906 c --------
05907 c nbtr   : nombre de sous-triangles du te, triangulation du te
05908 c nutr   : numero des nbtr sous-triangles du te dans le tableau noartr
05909 c ierr   : =0 si pas d'erreur
05910 c          =1 si le tableau nosoar est sature
05911 c          =2 si le tableau noartr est sature
05912 c          =3 si aucun des triangles ne contient l'un des points internes au te
05913 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
05914 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
05915 c....................................................................012
05916       double precision  pxyd(3,*)
05917       integer           letree(0:8),
05918      %                  milieu(3),
05919      %                  nosoar(mosoar,mxsoar),
05920      %                  noartr(moartr,mxartr),
05921      %                  noarst(*),
05922      %                  nutr(1:nbtr)
05923 c
05924       integer           nosotr(3), nuarco(5)
05925 c
05926 c     le numero des 2 triangles (=2 demi te) a creer dans le tableau noartr
05927       do 5 nbtr=1,2
05928          if( n1artr .le. 0 ) then
05929 c           tableau noartr sature
05930             ierr = 2
05931             return
05932          endif
05933          nutr(nbtr) = n1artr
05934 c        le nouveau premier triangle libre dans noartr
05935          n1artr = noartr(2,n1artr)
05936  5    continue
05937       nbtr = 2
05938 c
05939 c     recherche du milieu a creer
05940       do 7 i=1,3
05941          if( milieu(i) .ne. 0 ) goto 9
05942  7    continue
05943 c     le numero pxyd du point milieu du cote i
05944  9    nm = milieu( i )
05945 c
05946 c     on se ramene au seul cas i=3 c-a-d le milieu est sur le cote 3
05947       if( i .eq. 1 ) then
05948 c        milieu sur le cote 1
05949          nosotr(1) = letree(7)
05950          nosotr(2) = letree(8)
05951          nosotr(3) = letree(6)
05952       else if( i .eq. 2 ) then
05953 c        milieu sur le cote 2
05954          nosotr(1) = letree(8)
05955          nosotr(2) = letree(6)
05956          nosotr(3) = letree(7)
05957       else
05958 c        milieu sur le cote 3
05959          nosotr(1) = letree(6)
05960          nosotr(2) = letree(7)
05961          nosotr(3) = letree(8)
05962       endif
05963 c
05964 c     formation des 2 aretes s1 s2 et s2 s3
05965       do 10 i=1,2
05966          if( i .ne. 3 ) then
05967             i1 = i + 1
05968          else
05969             i1 = 1
05970          endif
05971 c        ajout eventuel de l'arete dans nosoar
05972          call fasoar( nosotr(i), nosotr(i1), nutr(i), -1, 0,
05973      %                mosoar, mxsoar, n1soar, nosoar, noarst,
05974      %                nuarco(i), ierr )
05975          if( ierr .ne. 0 ) return
05976  10   continue
05977 c
05978 c     ajout eventuel de l'arete s3 milieu dans nosoar
05979       call fasoar( nosotr(3), nm, nutr(2), -1, 0,
05980      %             mosoar, mxsoar, n1soar, nosoar, noarst,
05981      %             nuarco(3), ierr )
05982       if( ierr .ne. 0 ) return
05983 c
05984 c     ajout eventuel de l'arete milieu s1 dans nosoar
05985       call fasoar( nosotr(1), nm, nutr(1), -1, 0,
05986      %             mosoar, mxsoar, n1soar, nosoar, noarst,
05987      %             nuarco(4), ierr )
05988       if( ierr .ne. 0 ) return
05989 c
05990 c     ajout eventuel de l'arete milieu s2 dans nosoar
05991       call fasoar( nosotr(2), nm, nutr(1), nutr(2), 0,
05992      %             mosoar, mxsoar, n1soar, nosoar, noarst,
05993      %             nuarco(5), ierr )
05994       if( ierr .ne. 0 ) return
05995 c
05996 c     les aretes s1 s2 et s2 s3 dans le tableau noartr
05997       do 20 i=1,2
05998 c        nosotr(i) est le numero du sommet 1 de l'arete i du te
05999          if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
06000             lesign = 1
06001          else
06002             lesign = -1
06003          endif
06004 c        l'arete ns1-ns2 dans nosoar est celle du cote du te
06005          noartr( 1, nutr(i) ) = lesign * nuarco(i)
06006  20   continue
06007 c
06008 c     l'arete mediane s2 milieu
06009       if( nm .eq. nosoar(1,nuarco(5)) ) then
06010          lesign = -1
06011       else
06012          lesign =  1
06013       endif
06014       noartr( 2, nutr(1) ) =  lesign * nuarco(5)
06015       noartr( 3, nutr(2) ) = -lesign * nuarco(5)
06016 c
06017 c     l'arete s1 milieu
06018       if( nm .eq. nosoar(1,nuarco(4)) ) then
06019          lesign =  1
06020       else
06021          lesign = -1
06022       endif
06023       noartr( 3, nutr(1) ) = lesign * nuarco(4)
06024 c
06025 c     l'arete s3 milieu
06026       if( nm .eq. nosoar(1,nuarco(3)) ) then
06027          lesign = -1
06028       else
06029          lesign =  1
06030       endif
06031       noartr( 2, nutr(2) ) = lesign * nuarco(3)
06032 c
06033 c     triangulation des 2 demi te par ajout des points internes du te
06034       call trpite( letree, pxyd,
06035      %             mosoar, mxsoar, n1soar, nosoar,
06036      %             moartr, mxartr, n1artr, noartr, noarst,
06037      %             nbtr,   nutr,   ierr )
06038       end
06039 
06040 
06041       subroutine f2trte( letree, pxyd,   milieu,
06042      %                   mosoar, mxsoar, n1soar, nosoar,
06043      %                   moartr, mxartr, n1artr, noartr,
06044      %                   noarst,
06045      %                   nbtr,   nutr,   ierr )
06046 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
06047 c but :    former les triangles du triangle equilateral letree
06048 c -----    a partir de 2 milieux des cotes du te
06049 c          et des points internes au te
06050 c          ils deviennent tous des sommets des sous-triangles du te
06051 c
06052 c entrees:
06053 c --------
06054 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
06055 c          si letree(0)>0 alors
06056 c             letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
06057 c          sinon
06058 c             letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
06059 c                           0  si pas de point
06060 c                         ( le te est une feuille de l'arbre )
06061 c          letree(4) : no letree du sur-triangle du triangle j
06062 c          letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
06063 c          letree(6:8) : no pxyd des 3 sommets du triangle j
06064 c pxyd   : tableau des x  y  distance_souhaitee de chaque sommet
06065 c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
06066 c                    0 si pas de milieu du cote i a ajouter
06067 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
06068 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
06069 c moartr : nombre maximal d'entiers par arete du tableau noartr
06070 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
06071 c
06072 c modifies:
06073 c ---------
06074 c n1soar : numero de la premiere arete vide dans le tableau nosoar
06075 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
06076 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
06077 c          chainage des aretes frontalieres, chainage du hachage des aretes
06078 c          hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
06079 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
06080 c n1artr : numero du premier triangle vide dans le tableau noartr
06081 c          le chainage des triangles vides se fait sur noartr(2,.)
06082 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
06083 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
06084 c noarst : noarst(np) numero d'une arete du sommet np
06085 c
06086 c sorties:
06087 c --------
06088 c nbtr   : nombre de sous-triangles du te, triangulation du te
06089 c nutr   : numero des nbtr sous-triangles du te dans le tableau noartr
06090 c ierr   : =0 si pas d'erreur
06091 c          =1 si le tableau nosoar est sature
06092 c          =2 si le tableau noartr est sature
06093 c          =3 si aucun des triangles ne contient l'un des points internes au te
06094 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
06095 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
06096 c....................................................................012
06097       common / unites / lecteu, imprim, nunite(30)
06098       double precision  pxyd(3,*)
06099       integer           letree(0:8),
06100      %                  milieu(3),
06101      %                  nosoar(mosoar,mxsoar),
06102      %                  noartr(moartr,mxartr),
06103      %                  noarst(*),
06104      %                  nutr(1:nbtr)
06105 c
06106       integer           nosotr(3), nuarco(7)
06107 c
06108 c     le numero des 3 triangles a creer dans le tableau noartr
06109       do 5 nbtr=1,3
06110          if( n1artr .le. 0 ) then
06111 c           tableau noartr sature
06112             ierr = 2
06113             return
06114          endif
06115          nutr(nbtr) = n1artr
06116 c        le nouveau premier triangle libre dans noartr
06117          n1artr = noartr(2,n1artr)
06118  5    continue
06119       nbtr = 3
06120 c
06121 c     recherche du premier milieu a creer
06122       do 7 i=1,3
06123          if( milieu(i) .ne. 0 ) goto 9
06124  7    continue
06125 c
06126 c     on se ramene au seul cas i=2 c-a-d le cote 1 n'a pas de milieu
06127  9    if( i .eq. 2 ) then
06128 c        pas de milieu sur le cote 1
06129          nosotr(1) = letree(6)
06130          nosotr(2) = letree(7)
06131          nosotr(3) = letree(8)
06132 c        le numero pxyd du milieu du cote 2
06133          nm2 = milieu( 2 )
06134 c        le numero pxyd du milieu du cote 3
06135          nm3 = milieu( 3 )
06136       else if( milieu(2) .ne. 0 ) then
06137 c        pas de milieu sur le cote 3
06138          nosotr(1) = letree(8)
06139          nosotr(2) = letree(6)
06140          nosotr(3) = letree(7)
06141 c        le numero pxyd du milieu du cote 2
06142          nm2 = milieu( 1 )
06143 c        le numero pxyd du milieu du cote 3
06144          nm3 = milieu( 2 )
06145       else
06146 c        pas de milieu sur le cote 2
06147          nosotr(1) = letree(7)
06148          nosotr(2) = letree(8)
06149          nosotr(3) = letree(6)
06150 c        le numero pxyd du milieu du cote 2
06151          nm2 = milieu( 3 )
06152 c        le numero pxyd du milieu du cote 3
06153          nm3 = milieu( 1 )
06154       endif
06155 c
06156 c     ici seul le cote 1 n'a pas de milieu
06157 c     nm2 est le milieu du cote 2
06158 c     nm3 est le milieu du cote 3
06159 c
06160 c     ajout eventuel de l'arete s1 s2 dans nosoar
06161       call fasoar( nosotr(1), nosotr(2), nutr(1), -1, 0,
06162      %             mosoar, mxsoar, n1soar, nosoar, noarst,
06163      %             nuarco(1), ierr )
06164       if( ierr .ne. 0 ) return
06165 c
06166 c     ajout eventuel de l'arete s1 s2 dans nosoar
06167       call fasoar( nosotr(2), nm2, nutr(1), -1, 0,
06168      %             mosoar, mxsoar, n1soar, nosoar, noarst,
06169      %             nuarco(2), ierr )
06170       if( ierr .ne. 0 ) return
06171 c
06172 c     ajout eventuel de l'arete s1 nm2 dans nosoar
06173       call fasoar( nosotr(1), nm2, nutr(1), nutr(2), 0,
06174      %             mosoar, mxsoar, n1soar, nosoar, noarst,
06175      %             nuarco(3), ierr )
06176       if( ierr .ne. 0 ) return
06177 c
06178 c     ajout eventuel de l'arete nm2 nm3 dans nosoar
06179       call fasoar( nm3, nm2, nutr(2), nutr(3), 0,
06180      %             mosoar, mxsoar, n1soar, nosoar, noarst,
06181      %             nuarco(4), ierr )
06182       if( ierr .ne. 0 ) return
06183 c
06184 c     ajout eventuel de l'arete s1 nm3 dans nosoar
06185       call fasoar( nosotr(1), nm3, nutr(2), -1, 0,
06186      %             mosoar, mxsoar, n1soar, nosoar, noarst,
06187      %             nuarco(5), ierr )
06188       if( ierr .ne. 0 ) return
06189 c
06190 c     ajout eventuel de l'arete nm2 s3 dans nosoar
06191       call fasoar( nm2, nosotr(3), nutr(3), -1, 0,
06192      %             mosoar, mxsoar, n1soar, nosoar, noarst,
06193      %             nuarco(6), ierr )
06194 c
06195 c     ajout eventuel de l'arete nm3 s3 dans nosoar
06196       call fasoar( nosotr(3), nm3, nutr(3), -1, 0,
06197      %             mosoar, mxsoar, n1soar, nosoar, noarst,
06198      %             nuarco(7), ierr )
06199       if( ierr .ne. 0 ) return
06200 c
06201 c     le triangle s1 s2 nm2  ou arete1 arete2 arete3
06202       do 20 i=1,2
06203 c        nosotr(i) est le numero du sommet 1 de l'arete i du te
06204          if( nosotr(i) .eq. nosoar(1,nuarco(i)) ) then
06205             lesign = 1
06206          else
06207             lesign = -1
06208          endif
06209 c        l'arete ns1-ns2 dans nosoar est celle du cote du te
06210          noartr( i, nutr(1) ) = lesign * nuarco(i)
06211  20   continue
06212       if( nm2 .eq. nosoar(1,nuarco(3)) ) then
06213          lesign =  1
06214       else
06215          lesign = -1
06216       endif
06217       noartr( 3, nutr(1) ) = lesign * nuarco(3)
06218 c
06219 c     le triangle s1 nm2 nm3
06220       noartr( 1, nutr(2) ) = -lesign * nuarco(3)
06221       if( nm2 .eq. nosoar(1,nuarco(4)) ) then
06222          lesign =  1
06223       else
06224          lesign = -1
06225       endif
06226       noartr( 2, nutr(2) ) =  lesign * nuarco(4)
06227       noartr( 1, nutr(3) ) = -lesign * nuarco(4)
06228       if( nm3 .eq. nosoar(1,nuarco(5)) ) then
06229          lesign =  1
06230       else
06231          lesign = -1
06232       endif
06233       noartr( 3, nutr(2) ) = lesign * nuarco(5)
06234 c
06235 c     le triangle nm2 nm3 s3
06236       if( nm2 .eq. nosoar(1,nuarco(6)) ) then
06237          lesign =  1
06238       else
06239          lesign = -1
06240       endif
06241       noartr( 2, nutr(3) ) =  lesign * nuarco(6)
06242       if( nm3 .eq. nosoar(1,nuarco(7)) ) then
06243          lesign = -1
06244       else
06245          lesign =  1
06246       endif
06247       noartr( 3, nutr(3) ) = lesign * nuarco(7)
06248 c
06249 c     triangulation des 3 sous-te par ajout des points internes du te
06250       call trpite( letree, pxyd,
06251      %             mosoar, mxsoar, n1soar, nosoar,
06252      %             moartr, mxartr, n1artr, noartr, noarst,
06253      %             nbtr,   nutr,   ierr )
06254       end
06255 
06256 
06257       subroutine f3trte( letree, pxyd,   milieu,
06258      %                   mosoar, mxsoar, n1soar, nosoar,
06259      %                   moartr, mxartr, n1artr, noartr,
06260      %                   noarst,
06261      %                   nbtr,   nutr,   ierr )
06262 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
06263 c but :    former les triangles du triangle equilateral letree
06264 c -----    a partir de 3 milieux des cotes du te
06265 c          et des points internes au te
06266 c          ils deviennent tous des sommets des sous-triangles du te
06267 c
06268 c entrees:
06269 c --------
06270 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
06271 c          si letree(0)>0 alors
06272 c             letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j
06273 c          sinon
06274 c             letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j
06275 c                           0  si pas de point
06276 c                         ( le te est une feuille de l'arbre )
06277 c          letree(4) : no letree du sur-triangle du triangle j
06278 c          letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
06279 c          letree(6:8) : no pxyd des 3 sommets du triangle j
06280 c pxyd   : tableau des x  y  distance_souhaitee de chaque sommet
06281 c milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te
06282 c                    0 si pas de milieu du cote i a ajouter
06283 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
06284 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
06285 c moartr : nombre maximal d'entiers par arete du tableau noartr
06286 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
06287 c
06288 c modifies:
06289 c ---------
06290 c n1soar : numero de la premiere arete vide dans le tableau nosoar
06291 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
06292 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
06293 c          chainage des aretes frontalieres, chainage du hachage des aretes
06294 c          hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
06295 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
06296 c n1artr : numero du premier triangle vide dans le tableau noartr
06297 c          le chainage des triangles vides se fait sur noartr(2,.)
06298 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
06299 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
06300 c noarst : noarst(np) numero d'une arete du sommet np
06301 c
06302 c sorties:
06303 c --------
06304 c nbtr   : nombre de sous-triangles du te, triangulation du te
06305 c nutr   : numero des nbtr sous-triangles du te dans le tableau noartr
06306 c ierr   : =0 si pas d'erreur
06307 c          =1 si le tableau nosoar est sature
06308 c          =2 si le tableau noartr est sature
06309 c          =3 si aucun des triangles ne contient l'un des points internes au te
06310 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
06311 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
06312 c....................................................................012
06313       double precision  pxyd(3,*)
06314       integer           letree(0:8),
06315      %                  milieu(3),
06316      %                  nosoar(mosoar,mxsoar),
06317      %                  noartr(moartr,mxartr),
06318      %                  noarst(*),
06319      %                  nutr(1:nbtr)
06320 c
06321       integer           nuarco(9)
06322 c
06323 c     le numero des 4 triangles a creer dans le tableau noartr
06324       do 5 nbtr=1,4
06325          if( n1artr .le. 0 ) then
06326 c           tableau noartr sature
06327             ierr = 2
06328             return
06329          endif
06330          nutr(nbtr) = n1artr
06331 c        le nouveau premier triangle libre dans noartr
06332          n1artr = noartr(2,n1artr)
06333  5    continue
06334       nbtr = 4
06335 c
06336       do 10 i=1,3
06337 c        le sommet suivant
06338          if( i .ne. 3 ) then
06339             i1 = i + 1
06340          else
06341             i1 = 1
06342          endif
06343 c        le sommet precedant
06344          if( i .ne. 1 ) then
06345             i0 = i - 1
06346          else
06347             i0 = 3
06348          endif
06349          i3 = 3 * i
06350 c
06351 c        ajout eventuel de l'arete si mi dans nosoar
06352          call fasoar( letree(5+i), milieu(i), nutr(i), -1, 0,
06353      %                mosoar, mxsoar, n1soar, nosoar, noarst,
06354      %                nuarco(i3-2), ierr )
06355          if( ierr .ne. 0 ) return
06356 c
06357 c        ajout eventuel de l'arete mi mi-1 dans nosoar
06358          call fasoar( milieu(i), milieu(i0), nutr(i), nutr(4), 0,
06359      %                mosoar, mxsoar, n1soar, nosoar, noarst,
06360      %                nuarco(i3-1), ierr )
06361          if( ierr .ne. 0 ) return
06362 c
06363 c        ajout eventuel de l'arete m i-1  si dans nosoar
06364          call fasoar( milieu(i0), letree(5+i), nutr(i), -1, 0,
06365      %                mosoar, mxsoar, n1soar, nosoar, noarst,
06366      %                nuarco(i3), ierr )
06367          if( ierr .ne. 0 ) return
06368 c
06369  10   continue
06370 c
06371 c     les 3 sous-triangles pres des sommets
06372       do 20 i=1,3
06373 c        le sommet suivant
06374          if( i .ne. 3 ) then
06375             i1 = i + 1
06376          else
06377             i1 = 1
06378          endif
06379 c        le sommet precedant
06380          if( i .ne. 1 ) then
06381             i0 = i - 1
06382          else
06383             i0 = 3
06384          endif
06385          i3 = 3 * i
06386 c
06387 c        ajout du triangle  arete3i-2 arete3i-1 arete3i
06388          if( letree(5+i) .eq. nosoar(1,nuarco(i3-2)) ) then
06389             lesign =  1
06390          else
06391             lesign = -1
06392          endif
06393          noartr( 1, nutr(i) ) = lesign * nuarco(i3-2)
06394 c
06395          if( milieu(i) .eq. nosoar(1,nuarco(i3-1)) ) then
06396             lesign =  1
06397          else
06398             lesign = -1
06399          endif
06400          noartr( 2, nutr(i) ) = lesign * nuarco(i3-1)
06401 c
06402          if( milieu(i0) .eq. nosoar(1,nuarco(i3)) ) then
06403             lesign =  1
06404          else
06405             lesign = -1
06406          endif
06407          noartr( 3, nutr(i) ) = lesign * nuarco(i3)
06408 c
06409  20   continue
06410 c
06411 c     le sous triangle central
06412       i3 = -1
06413       do 30 i=1,3
06414          i3 = i3 + 3
06415          if( milieu(i) .eq. nosoar(1,nuarco(i3)) ) then
06416             lesign = -1
06417          else
06418             lesign =  1
06419          endif
06420          noartr( i, nutr(4) ) = lesign * nuarco(i3)
06421  30   continue
06422 c
06423 c     triangulation des 3 sous-te par ajout des points internes du te
06424       call trpite( letree, pxyd,
06425      %             mosoar, mxsoar, n1soar, nosoar,
06426      %             moartr, mxartr, n1artr, noartr, noarst,
06427      %             nbtr,   nutr,   ierr )
06428       end
06429 
06430 
06431 
06432       subroutine hasoar( mosoar, mxsoar, n1soar, nosoar, nu2sar,
06433      %                   noar )
06434 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
06435 c but :    rechercher le numero des 2 sommets d'une arete parmi
06436 c -----    les numeros des 2 sommets des aretes du tableau nosoar
06437 c          s ils n y sont pas stockes les y ajouter
06438 c          dans tous les cas retourner le numero de l'arete dans nosoar
06439 c
06440 c          la methode employee ici est celle du hachage
06441 c          avec pour fonction d'adressage h(ns1,ns2)=min(ns1,ns2)
06442 c
06443 c          remarque: h(ns1,ns2)=ns1 + 2*ns2
06444 c                    ne marche pas si des aretes sont detruites
06445 c                    et ajoutees aux aretes vides
06446 c                    le chainage est commun a plusieurs hachages!
06447 c                    d'ou ce choix du minimum pour le hachage
06448 c
06449 c entrees:
06450 c --------
06451 c mosoar : nombre maximal d'entiers par arete et
06452 c          indice dans nosoar de l'arete suivante dans le hachage
06453 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
06454 c          attention: mxsoar>3*mxsomm obligatoire!
06455 c
06456 c modifies:
06457 c ---------
06458 c n1soar : numero de la premiere arete vide dans le tableau nosoar
06459 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
06460 c          chainage des aretes vides amont et aval
06461 c          l'arete vide qui precede=nosoar(4,i)
06462 c          l'arete vide qui suit   =nosoar(5,i)
06463 c nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete,
06464 c          chainage momentan'e d'aretes, chainage du hachage des aretes
06465 c          hachage des aretes = min( nosoar(1), nosoar(2) )
06466 c nu2sar : en entree les 2 numeros des sommets de l'arete
06467 c          en sortie nu2sar(1)<nu2sar(2) numeros des 2 sommets de l'arete
06468 c
06469 c sorties:
06470 c --------
06471 c noar   : numero dans nosoar de l'arete apres hachage
06472 c          =0 si saturation du tableau nosoar
06473 c          >0 si le tableau nu2sar est l'arete noar retrouvee
06474 c             dans le tableau nosoar
06475 c          <0 si le tableau nu2sar a ete ajoute et forme l'arete
06476 c             -noar du tableau nosoar avec nosoar(1,noar)<nosoar(2,noar)
06477 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
06478 c auteur : alain perronnet  analyse numerique upmc paris       mars 1997
06479 c ...................................................................012
06480       integer  nu2sar(2), nosoar(mosoar,mxsoar)
06481 c
06482       if( nu2sar(1) .gt. nu2sar(2) ) then
06483 c
06484 c        permutation des numeros des 2 sommets pour
06485 c        amener le plus petit dans nu2sar(1)
06486          i         = nu2sar(1)
06487          nu2sar(1) = nu2sar(2)
06488          nu2sar(2) = i
06489       endif
06490 c
06491 c     la fonction d'adressage du hachage des aretes : h(ns1,ns2)=min(ns1,ns2)
06492 c     ===============================================
06493       noar = nu2sar(1)
06494 c
06495 c     la recherche de l'arete dans le chainage du hachage
06496 c     ---------------------------------------------------
06497  10   if( nu2sar(1) .eq. nosoar(1,noar) ) then
06498          if( nu2sar(2) .eq. nosoar(2,noar) ) then
06499 c
06500 c           l'arete est retrouvee
06501 c           .....................
06502             return
06503          endif
06504       endif
06505 c
06506 c     l'arete suivante parmi celles ayant meme fonction d'adressage
06507       i = nosoar( mosoar, noar )
06508       if( i .gt. 0 ) then
06509          noar = i
06510          goto 10
06511       endif
06512 c
06513 c     noar est ici la derniere arete (sans suivante) du chainage
06514 c     a partir de l'adressage du hachage
06515 c
06516 c     l'arete non retrouvee doit etre ajoutee
06517 c     .......................................
06518       if( nosoar( 1, nu2sar(1) ) .eq. 0 ) then
06519 c
06520 c        l'adresse de hachage est libre => elle devient la nouvelle arete
06521 c        retouche des chainages de cette arete noar qui ne sera plus vide
06522          noar = nu2sar(1)
06523 c        l'eventuel chainage du hachage n'est pas modifie
06524 c
06525       else
06526 c
06527 c        la premiere arete dans l'adressage du hachage n'est pas libre
06528 c        => choix quelconque d'une arete vide pour ajouter cette arete
06529          if( n1soar .le. 0 ) then
06530 c
06531 c           le tableau nosoar est sature avec pour temoin d'erreur
06532             noar = 0
06533             return
06534 c
06535          else
06536 c
06537 c           l'arete n1soar est vide => c'est la nouvelle arete
06538 c           mise a jour du chainage de la derniere arete noar du chainage
06539 c           sa suivante est la nouvelle arete n1soar
06540             nosoar( mosoar, noar ) = n1soar
06541 c
06542 c           l'arete ajoutee est n1soar
06543             noar = n1soar
06544 c
06545 c           la nouvelle premiere arete vide
06546             n1soar = nosoar( 5, n1soar )
06547 c
06548 c           la premiere arete vide n1soar n'a pas d'arete vide precedente
06549             nosoar( 4, n1soar ) = 0
06550 c
06551 c           noar la nouvelle arete est la derniere du chainage du hachage
06552             nosoar( mosoar, noar ) = 0
06553 c
06554          endif
06555 c
06556       endif
06557 c
06558 c     les 2 sommets de la nouvelle arete noar
06559       nosoar( 1, noar ) = nu2sar(1)
06560       nosoar( 2, noar ) = nu2sar(2)
06561 c
06562 c     le tableau nu2sar a ete ajoute avec l'indice -noar
06563       noar = - noar
06564       end
06565 
06566 
06567       subroutine mt3str( nt, moartr, noartr, mosoar, nosoar,
06568      %                   ns1, ns2, ns3 )
06569 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
06570 c but : calcul du numero des 3 sommets du triangle nt du tableau noartr
06571 c -----
06572 c
06573 c entrees:
06574 c --------
06575 c nt     : numero du triangle de noartr a traiter
06576 c moartr : nombre maximal d'entiers par triangle
06577 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
06578 c          arete1=0 si triangle vide => arete2=triangle vide suivant
06579 c mosoar : nombre maximal d'entiers par arete
06580 c nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en +
06581 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
06582 c
06583 c sorties:
06584 c --------
06585 c ns1,ns2,ns3 : les 3 numeros des sommets du triangle en sens direct
06586 c
06587 c si erreur rencontree => ns1 = 0
06588 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
06589 c auteur : alain perronnet  analyse numerique paris upmc    juillet 1995
06590 c2345x7..............................................................012
06591       common / unites / lecteu, imprim, nunite(30)
06592       integer    noartr(moartr,*), nosoar(mosoar,*)
06593 c
06594 c     le numero de triangle est il correct  ?
06595 c     a supprimer apres mise au point
06596       if( nt .le. 0 ) then
06597 c         nblgrc(nrerr) = 1
06598 c         write(kerr(mxlger)(1:6),'(i6)') nt
06599 c         kerr(1) = kerr(mxlger)(1:6) //
06600 c     %           ' no triangle dans noartr incorrect'
06601 c         call lereur
06602          write(imprim,*) nt,' no triangle dans noartr incorrect'
06603          ns1 = 0
06604          return
06605       endif
06606 c
06607       na = noartr(1,nt)
06608       if( na .gt. 0 ) then
06609 c        arete dans le sens direct
06610          ns1 = nosoar(1,na)
06611          ns2 = nosoar(2,na)
06612       else
06613 c        arete dans le sens indirect
06614          ns1 = nosoar(2,-na)
06615          ns2 = nosoar(1,-na)
06616       endif
06617 c
06618       na = noartr(2,nt)
06619       if( na .gt. 0 ) then
06620 c        arete dans le sens direct => ns3 est le second sommet de l'arete
06621          ns3 = nosoar(2,na)
06622       else
06623 c        arete dans le sens indirect => ns3 est le premier sommet de l'arete
06624          ns3 = nosoar(1,-na)
06625       endif
06626       end
06627 
06628       subroutine trpite( letree, pxyd,
06629      %                   mosoar, mxsoar, n1soar, nosoar,
06630      %                   moartr, mxartr, n1artr, noartr,
06631      %                   noarst,
06632      %                   nbtr,   nutr,   ierr )
06633 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
06634 c but :    former le ou les sous-triangles des nbtr triangles nutr
06635 c -----    qui forment le triangle equilateral letree par ajout
06636 c          des points internes au te qui deviennent des sommets des
06637 c          sous-triangles des nbtr triangles
06638 c
06639 c entrees:
06640 c --------
06641 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
06642 c          letree(0:3):-no pxyd des 1 a 4 points internes au triangle j
06643 c                       0  si pas de point
06644 c                     ( le te est ici une feuille de l'arbre )
06645 c          letree(4) : no letree du sur-triangle du triangle j
06646 c          letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
06647 c          letree(6:8) : no pxyd des 3 sommets du triangle j
06648 c pxyd   : tableau des x  y  distance_souhaitee de chaque sommet
06649 c mosoar : nombre maximal d'entiers par arete du tableau nosoar
06650 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
06651 c moartr : nombre maximal d'entiers par arete du tableau noartr
06652 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
06653 c
06654 c modifies:
06655 c ---------
06656 c n1soar : numero de la premiere arete vide dans le tableau nosoar
06657 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
06658 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
06659 c          chainage des aretes frontalieres, chainage du hachage des aretes
06660 c          hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar
06661 c          sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante
06662 c n1artr : numero du premier triangle vide dans le tableau noartr
06663 c          le chainage des triangles vides se fait sur noartr(2,.)
06664 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
06665 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
06666 c noarst : noarst(i) numero d'une arete de sommet i
06667 c
06668 c sorties:
06669 c --------
06670 c nbtr   : nombre de sous-triangles du te
06671 c nutr   : numero des nbtr sous-triangles du te dans le tableau noartr
06672 c ierr   : =0 si pas d'erreur
06673 c          =1 si le tableau nosoar est sature
06674 c          =2 si le tableau noartr est sature
06675 c          =3 si aucun des triangles ne contient l'un des points internes au te
06676 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
06677 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
06678 c....................................................................012
06679       common / unites / lecteu, imprim, nunite(30)
06680       double precision  pxyd(3,*)
06681       integer           letree(0:8),
06682      %                  nosoar(mosoar,mxsoar),
06683      %                  noartr(moartr,mxartr),
06684      %                  noarst(*),
06685      %                  nutr(1:nbtr)
06686 c
06687       integer           nosotr(3)
06688 c
06689       ierr = 0
06690 c
06691 c     si pas de point interne alors retour
06692       if( letree(0) .eq. 0 ) goto 150
06693 c
06694 c     il existe au moins un point interne a trianguler
06695 c     dans les nbtr triangles
06696       do 100 k=0,3
06697 c
06698 c        le numero du point
06699          np = -letree(k)
06700          if( np .eq. 0 ) goto 150
06701 c
06702 c        le point np dans pxyd est a traiter
06703          do 10 n = 1, nbtr
06704 c
06705 c           les numeros des 3 sommets du triangle nt=nutr(n)
06706             nt = nutr(n)
06707             call nusotr( nt, mosoar, nosoar, moartr, noartr,  nosotr )
06708 c
06709 c           le triangle nt contient il le point np?
06710             call ptdatr( pxyd(1,np), pxyd, nosotr, nsigne )
06711 c           nsigne>0 si le point est dans le triangle ou sur une des 3 aretes
06712 c                 =0 si triangle degenere ou indirect ou ne contient pas le poin
06713 c
06714             if( nsigne .gt. 0 ) then
06715 c
06716 c              le triangle nt est triangule en 3 sous-triangles
06717                call tr3str( np, nt,
06718      %                      mosoar, mxsoar, n1soar, nosoar,
06719      %                      moartr, mxartr, n1artr, noartr,
06720      %                      noarst,
06721      %                      nutr(nbtr+1),  ierr )
06722                if( ierr .ne. 0 ) return
06723 c
06724 c              reamenagement des 3 triangles crees dans nutr
06725 c              en supprimant le triangle nt
06726                nutr( n ) = nutr( nbtr + 3 )
06727                nbtr = nbtr + 2
06728 c              le point np est triangule
06729                goto 100
06730 c
06731             endif
06732  10      continue
06733 c
06734 c        erreur: le point np n'est pas dans l'un des nbtr triangles
06735          write(imprim,10010) np
06736          ierr = 3
06737          return
06738 c
06739  100  continue
06740 10010 format(' erreur trpite: pas de triangle contenant le point',i7)
06741 c
06742  150  continue
06743       end
06744 
06745 
06746       subroutine sasoar( noar, mosoar, mxsoar, n1soar, nosoar, noarst )
06747 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
06748 c but :    supprimer l'arete noar du tableau nosoar
06749 c -----    si celle ci n'est pas une arete des lignes de la fontiere
06750 c
06751 c          la methode employee ici est celle du hachage
06752 c          avec pour fonction d'adressage h = min( nu2sar(1), nu2sar(2) )
06753 c
06754 c          attention: il faut mettre a jour le no d'arete des 2 sommets
06755 c                     de l'arete supprimee dans le tableau noarst!
06756 c
06757 c entrees:
06758 c --------
06759 c noar   : numero de l'arete de nosoar a supprimer
06760 c mosoar : nombre maximal d'entiers par arete et
06761 c          indice dans nosoar de l'arete suivante dans le hachage h
06762 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
06763 c          attention: mxsoar>3*mxsomm obligatoire!
06764 c
06765 c modifies:
06766 c ---------
06767 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
06768 c          chainage des vides suivant en 3 et precedant en 2 de nosoar
06769 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
06770 c          chainage des aretes frontalieres, chainage du hachage des aretes
06771 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
06772 c          nosoar(4,arete vide)=l'arete vide qui precede
06773 c          nosoar(5,arete vide)=l'arete vide qui suit
06774 c noarst : numero d'une arete de nosoar pour chaque sommet
06775 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
06776 c auteur : alain perronnet analyse numerique    upmc paris  mars    1997
06777 c modifs : alain perronnet laboratoire jl lions upmc paris  octobre 2006
06778 c ...................................................................012
06779       common / unites / lecteu, imprim, nunite(30)
06780       integer           nosoar(mosoar,mxsoar), noarst(*), ns(2)
06781 c
06782 c     13/10/2006
06783 c     mise a jour de noarst pour les 2 sommets de l'arete a supprimer
06784 c     necessaire uniquement pour les sommets frontaliers et internes imposes
06785 c     le numero des 2 sommets de l'arete noar a supprimer
06786       ns(1) = nosoar(1,noar)
06787       ns(2) = nosoar(2,noar)
06788       do 8 k=1,2
06789          if( noarst(ns(k)) .eq. noar ) then
06790 c           il faut remettre a jour le pointeur sur une arete
06791             if(nosoar(1,ns(k)).eq.ns(k) .and. nosoar(2,ns(k)).gt.0
06792      %         .and. nosoar(4,ns(k)) .gt. 0 ) then
06793 c              arete active de sommet ns(k)
06794                noarst( ns(k) ) = ns(k)
06795             else
06796                do 5 i=1,mxsoar
06797                   if( nosoar(1,i).gt.0 .and. nosoar(4,i).gt.0 ) then
06798 c                    arete non vide
06799                      if( nosoar(2,i).eq.ns(k) .or.
06800      %                  (nosoar(1,i).eq.ns(k).and.nosoar(2,i).gt.0))then
06801 c                       arete active de sommet ns(k)
06802                         noarst( ns(k) ) = i
06803                         goto 8
06804                      endif
06805                   endif
06806  5             continue
06807             endif
06808          endif
06809  8    continue
06810 c     13/10/2006
06811 c
06812       if( nosoar(3,noar) .le. 0 ) then
06813 c
06814 c        l'arete n'est pas frontaliere => elle devient une arete vide
06815 c
06816 c        recherche de l'arete qui precede dans le chainage du hachage
06817          noar1 = nosoar(1,noar)
06818 c
06819 c        parcours du chainage du hachage jusqu'a retrouver l'arete noar
06820  10      if( noar1 .ne. noar ) then
06821 c
06822 c           l'arete suivante parmi celles ayant meme fonction d'adressage
06823             noar0 = noar1
06824             noar1 = nosoar( mosoar, noar1 )
06825             if( noar1 .gt. 0 ) goto 10
06826 c
06827 c           l'arete noar n'a pas ete retrouvee dans le chainage => erreur
06828             write(imprim,*) 'erreur sasoar:arete non dans le chainage '
06829      %                      ,noar
06830             write(imprim,*) 'arete de st1=',nosoar(1,noar),
06831      %      ' st2=',nosoar(2,noar),' ligne=',nosoar(3,noar),
06832      %      ' tr1=',nosoar(4,noar),' tr2=',nosoar(5,noar)
06833             write(imprim,*) 'chainages=',(nosoar(i,noar),i=6,mosoar)
06834 ccc            pause
06835 c           l'arete n'est pas detruite
06836             return
06837 c
06838          endif
06839 c
06840          if( noar .ne. nosoar(1,noar) ) then
06841 c
06842 c           saut de l'arete noar dans le chainage du hachage
06843 c           noar0 initialisee est ici l'arete qui precede noar dans ce chainage
06844             nosoar( mosoar, noar0 ) = nosoar( mosoar, noar )
06845 c
06846 c           le chainage du hachage n'existe plus pour noar
06847 c           pas utile car mise a zero faite dans le sp hasoar
06848 ccc         nosoar( mosoar, noar ) = 0
06849 c
06850 c           noar devient la nouvelle premiere arete du chainage des vides
06851             nosoar( 4, noar ) = 0
06852             nosoar( 5, noar ) = n1soar
06853 c           la nouvelle precede l'ancienne premiere
06854             nosoar( 4, n1soar ) = noar
06855             n1soar = noar
06856 c
06857 ccc      else
06858 c
06859 c           noar est la premiere arete du chainage du hachage h
06860 c           cette arete ne peut etre consideree dans le chainage des vides
06861 c           car le chainage du hachage doit etre conserve (sinon perte...)
06862 c
06863          endif
06864 c
06865 c        le temoin d'arete vide
06866          nosoar( 1, noar ) = 0
06867       endif
06868       end
06869 
06870 
06871       subroutine caetoi( noar,   mosoar, mxsoar, n1soar, nosoar, noarst,
06872      %                   n1aeoc, nbtrar  )
06873 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
06874 c but :    ajouter (ou retirer) l'arete noar de nosoar de l'etoile
06875 c -----    des aretes simples chainees en position lchain de nosoar
06876 c          detruire du tableau nosoar les aretes doubles
06877 c
06878 c          attention: le chainage lchain de nosoar devient celui des cf
06879 c
06880 c entree :
06881 c --------
06882 c noar   : numero dans le tableau nosoar de l'arete a traiter
06883 c mosoar : nombre maximal d'entiers par arete et
06884 c          indice dans nosoar de l'arete suivante dans le hachage
06885 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
06886 c          attention: mxsoar>3*mxsomm obligatoire!
06887 c
06888 c entrees et sorties:
06889 c -------------------
06890 c n1soar : numero de la premiere arete vide dans le tableau nosoar
06891 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
06892 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
06893 c          chainage des aretes frontalieres, chainage du hachage des aretes
06894 c n1aeoc : numero dans nosoar de la premiere arete simple de l'etoile
06895 c
06896 c sortie :
06897 c --------
06898 c nbtrar : 1 si arete ajoutee, 2 si arete double supprimee, 0 si erreur
06899 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
06900 c auteur : alain perronnet  analyse numerique paris upmc       mars 1997
06901 c2345x7..............................................................012
06902       parameter        (lchain=6)
06903       common / unites / lecteu, imprim, nunite(30)
06904       integer           nosoar(mosoar,mxsoar), noarst(*)
06905 c
06906 c     si    l'arete n'appartient pas aux aretes de l'etoile naetoi
06907 c     alors elle est ajoutee a l'etoile dans naetoi
06908 c     sinon elle est empilee dans npile pour etre detruite ensuite
06909 c           elle est supprimee de l'etoile naetoi
06910 c
06911       if( nosoar( lchain, noar ) .lt. 0 ) then
06912 c
06913 c        arete de l'etoile vue pour la premiere fois
06914 c        elle est ajoutee au chainage
06915          nosoar( lchain, noar ) = n1aeoc
06916 c        elle devient la premiere du chainage
06917          n1aeoc = noar
06918 c        arete simple
06919          nbtrar = 1
06920 c
06921       else
06922 c
06923 c        arete double de l'etoile. elle est supprimee du chainage
06924          na0 = 0
06925          na  = n1aeoc
06926          nbpass = 0
06927 c        parcours des aretes chainees jusqu'a trouver l'arete noar
06928  10      if( na .ne. noar ) then
06929 c           passage a la suivante
06930             na0 = na
06931             na  = nosoar( lchain, na )
06932             if( na .le. 0 ) then
06933                nbtrar = 0
06934                return
06935             endif
06936             nbpass = nbpass + 1
06937             if( nbpass .gt. 512 ) then
06938                write(imprim,*)'Pb dans caetoi: boucle infinie evitee'
06939                nbtrar = 0
06940                return
06941             endif
06942             goto 10
06943          endif
06944 c
06945 c        suppression de noar du chainage des aretes simples de l'etoile
06946          if( na0 .gt. 0 ) then
06947 c           il existe une arete qui precede
06948             nosoar( lchain, na0 ) = nosoar( lchain, noar )
06949          else
06950 c           noar est en fait n1aeoc la premiere du chainage
06951             n1aeoc = nosoar( lchain, noar )
06952          endif
06953 c        noar n'est plus une arete simple de l'etoile
06954          nosoar( lchain, noar ) = -1
06955 c
06956 c        destruction du tableau nosoar de l'arete double noar
06957          call sasoar( noar, mosoar, mxsoar, n1soar, nosoar, noarst )
06958 c
06959 c        arete double
06960          nbtrar = 2
06961       endif
06962       end
06963 
06964 
06965       subroutine focftr( nbtrcf, notrcf, nbarpi, pxyd,   noarst,
06966      %                   mosoar, mxsoar, n1soar, nosoar,
06967      %                   moartr, n1artr, noartr,
06968      %                   nbarcf, n1arcf, noarcf, nbstpe, nostpe,
06969      %                   ierr )
06970 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
06971 c but :    former un contour ferme (cf) avec les aretes simples des
06972 c -----    nbtrcf triangles du tableau notrcf
06973 c          destruction des nbtrcf triangles du tableau noartr
06974 c          destruction des aretes doubles   du tableau nosoar
06975 c
06976 c          attention: le chainage lchain de nosoar devient celui des cf
06977 c
06978 c entrees:
06979 c --------
06980 c nbtrcf : nombre de  triangles du cf a former
06981 c notrcf : numero des triangles dans le tableau noartr
06982 c nbarpi : numero du dernier sommet frontalier ou interne impose
06983 c pxyd   : tableau des coordonnees 2d des points
06984 c          par point : x  y  distance_souhaitee
06985 c
06986 c mosoar : nombre maximal d'entiers par arete et
06987 c          indice dans nosoar de l'arete suivante dans le hachage
06988 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
06989 c          attention: mxsoar>3*mxsomm obligatoire!
06990 c moartr : nombre maximal d'entiers par arete du tableau noartr
06991 c
06992 c entrees et sorties :
06993 c --------------------
06994 c noarst : noarst(i) numero d'une arete de sommet i
06995 c n1soar : numero de la premiere arete vide dans le tableau nosoar
06996 c          une arete i de nosoar est vide  <=>  nosoar(1,i)=0
06997 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
06998 c          chainage des aretes frontalieres, chainage du hachage des aretes
06999 c          hachage des aretes = nosoar(1)+nosoar(2)*2
07000 c n1artr : numero du premier triangle vide dans le tableau noartr
07001 c          le chainage des triangles vides se fait sur noartr(2,.)
07002 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
07003 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
07004 c
07005 c sorties:
07006 c --------
07007 c nbarcf : nombre d'aretes du cf
07008 c n1arcf : numero d'une arete de chaque contour
07009 c noarcf : numero des aretes de la ligne du contour ferme
07010 c attention: chainage circulaire des aretes
07011 c            les aretes vides pointes par n1arcf(0) ne sont pas chainees
07012 c nbstpe : nombre de  sommets perdus dans la suppression des triangles
07013 c nostpe : numero des sommets perdus dans la suppression des triangles 
07014 c ierr   :  0 si pas d'erreur
07015 c          14 si les lignes fermees se coupent => donnees a revoir
07016 c          15 si une seule arete simple frontaliere
07017 c          16 si boucle infinie car toutes les aretes simples
07018 c                de la boule sont frontalieres!
07019 c          17 si boucle infinie dans caetoi
07020 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
07021 c auteur : alain perronnet analyse numerique    upmc paris  mars    1997
07022 c modifs : alain perronnet laboratoire jl lions upmc paris  octobre 2006
07023 c....................................................................012
07024       parameter        (lchain=6, mxstpe=512)
07025       common / unites / lecteu, imprim, nunite(30)
07026       double precision  pxyd(3,*)
07027       integer           notrcf(1:nbtrcf)
07028       integer           nosoar(mosoar,mxsoar),
07029      %                  noartr(moartr,*),
07030      %                  n1arcf(0:*),
07031      %                  noarcf(3,*),
07032      %                  noarst(*),
07033      %                  nostpe(mxstpe),
07034      %                  nosotr(3)
07035 c
07036 c     formation des aretes simples du cf autour de l'arete ns1-ns2
07037 c     attention: le chainage lchain du tableau nosoar devient actif
07038 c     ============================================================
07039 c     ici toutes les aretes du tableau nosoar verifient nosoar(lchain,i) = -1
07040 c     ce qui equivaut a dire que l'etoile des aretes simples est vide
07041 c     (initialisation dans le sp insoar puis remise a -1 dans la suite!)
07042       n1aeoc = 0
07043       ierr   = 0
07044 c
07045 c     13/10/2006
07046 c     nombre de sommets des triangles a supprimer sans repetition
07047       nbst = 0
07048 c     13/10/2006
07049 c
07050 c     ajout a l'etoile des aretes simples des 3 aretes des triangles a supprimer
07051 c     suppression des triangles de l'etoile pour les aretes simples de l'etoile
07052       do 10 i=1,nbtrcf
07053 c
07054 c        ajout ou retrait des 3 aretes du triangle notrcf(i) de l'etoile
07055          nt = notrcf( i )
07056 c
07057 c        13/10/2006  ...............................................
07058          call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
07059 c
07060 c        ajout des numeros de sommets non encore vus dans l'etoile
07061          do 3 k=1,3
07062             do 2 j=1,nbst
07063                if( nosotr(k) .eq. nostpe(j) ) goto 3
07064  2          continue
07065 c           ajout du sommet
07066             nbst = nbst + 1
07067             nostpe( nbst ) = nosotr(k)
07068  3       continue
07069 c        13/10/2006 ................................................
07070 c
07071          do 5 j=1,3
07072 c           l'arete de nosoar a traiter
07073             noar = abs( noartr(j,nt) )
07074             call caetoi( noar,   mosoar, mxsoar, n1soar, nosoar, noarst,
07075      %                   n1aeoc, nbtrar  )
07076             if( nbtrar .le. 0 ) then
07077                write(imprim,*)'focftr: erreur dans caetoi noar=',noar
07078                ierr = 17
07079                return
07080             endif
07081 c           si arete simple alors suppression du numero de triangle
07082 c           pour cette arete
07083             if( nbtrar .eq. 1 ) then
07084                if( nosoar(4,noar) .eq. nt ) then
07085                   nosoar(4,noar) = nosoar(5,noar)
07086                else if( nosoar(5,noar) .eq. nt ) then
07087                   nosoar(5,noar) = -1
07088                else
07089                   write(imprim,*)'focftr: anomalie arete',noar,
07090      %                           ' sans triangle',nt
07091                   write(imprim,*)'focftr: nosoar(',noar,')=',
07092      %                            (nosoar(kk,noar),kk=1,mosoar)
07093                   nosoar(5,noar) = -1
07094                endif
07095 c           else
07096 c              l'arete appartient a aucun triangle => elle est vide
07097 c              les positions 4 et 5 servent maintenant aux chainages des vides
07098             endif
07099   5      continue
07100  10   continue
07101 c
07102 c     les aretes simples de l'etoile sont reordonnees pour former une
07103 c     ligne fermee = un contour ferme peripherique de l'etoile encore dit 1 cf
07104 c     ========================================================================
07105       n1ae00 = n1aeoc
07106  12   na1    = n1aeoc
07107 c     la premiere arete du contour ferme
07108       ns0 = nosoar(1,na1)
07109       ns1 = nosoar(2,na1)
07110 c
07111 c     l'arete est-elle dans le sens direct?
07112 c     recherche de l'arete du triangle exterieur nt d'arete na1
07113       nt = nosoar(4,na1)
07114       if( nt .le. 0 ) nt = nosoar(5,na1)
07115 c
07116 c     attention au cas de l'arete initiale frontaliere de no de triangles 0 et -
07117       if( nt .le. 0 ) then
07118 c        permutation circulaire des aretes simples chainees
07119 c        la premiere arete doit devenir la derniere du chainage,
07120 c        la 2=>1, la 3=>2, ... , la derniere=>l'avant derniere, 1=>derniere
07121          n1aeoc = nosoar( lchain, n1aeoc )
07122          if( n1aeoc .eq. n1ae00 ) then
07123 c           attention: boucle infinie si toutes les aretes simples
07124 c           de la boule sont frontalieres!... arretee par ce test
07125             ierr = 16
07126             write(imprim,*)'focftr: boucle dans les aretes de l etoile'
07127             return
07128          endif
07129          noar = n1aeoc
07130          na0  = 0
07131  14      if( noar .gt. 0 ) then
07132 c           la sauvegarde de l'arete et l'arete suivante
07133             na0  = noar
07134             noar = nosoar(lchain,noar)
07135             goto 14
07136          endif
07137          if( na0 .le. 0 ) then
07138 c           une seule arete simple frontaliere
07139             ierr = 15
07140             write(imprim,*)'focftr: 1 arete seule pour l etoile'
07141             return
07142          endif
07143 c        le suivant de l'ancien dernier est l'ancien premier
07144          nosoar(lchain,na0) = na1
07145 c        le nouveau dernier est l'ancien premier
07146          nosoar(lchain,na1) = 0
07147          goto 12
07148       endif
07149 c
07150 c     ici l'arete na1 est l'une des aretes du triangle nt
07151       do 15 i=1,3
07152          if( abs(noartr(i,nt)) .eq. na1 ) then
07153 c           c'est l'arete
07154             if( noartr(i,nt) .gt. 0 ) then
07155 c              elle est parcourue dans le sens indirect de l'etoile
07156 c             (car c'est en fait le triangle exterieur a la boule)
07157                ns0 = nosoar(2,na1)
07158                ns1 = nosoar(1,na1)
07159             endif
07160             goto 17
07161          endif
07162  15   continue
07163 c
07164 c     le 1-er sommet ou arete du contour ferme
07165  17   n1arcf( 1 ) = 1
07166 c     le nombre de sommets du contour ferme de l'etoile
07167       nbarcf = 1
07168 c     le premier sommet de l'etoile
07169       noarcf( 1, nbarcf ) = ns0
07170 c     l'arete suivante du cf
07171       noarcf( 2, nbarcf ) = nbarcf + 1
07172 c     le numero de cette arete dans le tableau nosoar
07173       noarcf( 3, nbarcf ) = na1
07174 c     mise a jour du numero d'arete du sommet ns0
07175       noarst(ns0) = na1
07176 c
07177 c     l'arete suivante a chainer
07178       n1aeoc = nosoar( lchain, na1 )
07179 c     l'arete na1 n'est plus dans l'etoile
07180       nosoar( lchain, na1 ) = -1
07181 c
07182 c     boucle sur les aretes simples de l'etoile
07183  20   if( n1aeoc .gt. 0 ) then
07184 c
07185 c        recherche de l'arete de 1-er sommet ns1
07186          na0 = -1
07187          na1 = n1aeoc
07188  25      if( na1 .gt. 0 ) then
07189 c
07190 c           le numero du dernier sommet de l'arete precedente
07191 c           est il l'un des 2 sommets de l'arete na1?
07192             if ( ns1 .eq. nosoar(1,na1) ) then
07193 c               l'autre sommet de l'arete na1
07194                 ns2 = nosoar(2,na1)
07195             else if( ns1 .eq. nosoar(2,na1) ) then
07196 c               l'autre sommet de l'arete na1
07197                 ns2 = nosoar(1,na1)
07198             else
07199 c              non: passage a l'arete suivante
07200                na0 = na1
07201                na1 = nosoar( lchain, na1 )
07202                goto 25
07203             endif
07204 c
07205 c           oui: na1 est l'arete peripherique suivante
07206 c                na0 est sa precedente dans le chainage
07207 c           une arete de plus dans le contour ferme (cf)
07208             nbarcf = nbarcf + 1
07209 c           le premier sommet de l'arete nbarcf peripherique
07210             noarcf( 1, nbarcf ) = ns1
07211 c           l'arete suivante du cf
07212             noarcf( 2, nbarcf ) = nbarcf + 1
07213 c           le numero de cette arete dans le tableau nosoar
07214             noarcf( 3, nbarcf ) = na1
07215 c           mise a jour du numero d'arete du sommet ns1
07216             noarst(ns1) = na1
07217 c
07218 c           suppression de l'arete des aretes simples de l'etoile
07219             if( n1aeoc .eq. na1 ) then
07220                 n1aeoc = nosoar( lchain, na1 )
07221             else
07222                 nosoar( lchain, na0 ) = nosoar( lchain, na1 )
07223             endif
07224 c           l'arete n'est plus une arete simple de l'etoile
07225             nosoar( lchain, na1 ) = -1
07226 c
07227 c           le sommet final de l'arete a rechercher ensuite
07228             ns1 = ns2
07229             goto 20
07230          endif
07231       endif
07232 c
07233 c     verification
07234       if( ns1 .ne. ns0 ) then
07235 c        arete non retrouvee : l'etoile ne se referme pas
07236          write(imprim,*)'focftr: revoyez vos donnees du bord'
07237          write(imprim,*)'les lignes fermees doivent etre disjointes'
07238          write(imprim,*)'verifiez si elles ne se coupent pas'
07239          ierr = 14
07240          return
07241       endif
07242 c
07243 c     l'arete suivant la derniere arete du cf est la premiere du cf
07244 c     => realisation d'un chainage circulaire des aretes du cf
07245       noarcf( 2, nbarcf ) = 1
07246 c
07247 c     13/10/2006
07248 c     existe t il des sommets perdus?
07249 c     -------------------------------
07250       if( nbst .gt. mxstpe ) then
07251          write(imprim,*)'focftr: tableau nostfe(',mxstpe,') a augmenter'
07252          ierr = 15
07253          return
07254       endif
07255 c     le nombre de sommets perdus
07256       nbstpe = nbst - nbarcf
07257       if( nbstpe .gt. 0 ) then
07258 c        oui: stockage dans nostpe des sommets perdus
07259 c        tout sommet des aretes de l'etoile est supprime
07260 c        de la liste des sommets
07261          do 40 i=1,nbarcf
07262 c           le numero du sommet de l'arete du cf
07263             ns1 = noarcf( 1, i )
07264             do 30 j=1,nbst
07265                if( ns1 .eq. nostpe(j) ) then
07266 c                 le sommet peripherique est supprime
07267 c                 de la liste des sommets perdus
07268                   nostpe(j) = 0
07269                   goto 40
07270                endif
07271  30         continue
07272  40      continue
07273 c
07274 c        compression
07275          n = 0
07276          do 45 i=1,nbst
07277             if( nostpe(i) .eq. 0 .or. nostpe(i) .gt. nbarpi ) then
07278 c              un sommet de l'etoile ou perdu mais supprimable
07279 c              ce qui apporte plus de qualites aux triangles a former
07280                n = n + 1
07281             else
07282 c              un sommet perdu
07283                nostpe(i-n) = nostpe(i)
07284             endif
07285  45      continue
07286          nbstpe = nbst - n
07287 ccc      write(imprim,*)'focftr:',nbstpe,' sommets isoles:',(nostpe(k),k=1,nbstpe)
07288       endif
07289 c     13/10/2006
07290 c
07291 c     destruction des triangles de l'etoile du tableau noartr
07292 c     -------------------------------------------------------
07293       do 60 n=1,nbtrcf
07294 c        le numero du triangle dans noartr
07295          nt0 = notrcf( n )
07296 c        l'arete 1 de nt0 devient nulle
07297          noartr( 1, nt0 ) = 0
07298 c        chainage de nt0 en tete du chainage des triangles vides de noartr
07299          noartr( 2, nt0 ) = n1artr
07300          n1artr = nt0
07301  60   continue
07302       end
07303 
07304 
07305       subroutine int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x0, y0 )
07306 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
07307 c but :    existence ou non  d'une intersection a l'interieur
07308 c -----    des 2 aretes ns1-ns2 et ns3-ns4
07309 c          attention les intersections au sommet sont comptees
07310 c
07311 c entrees:
07312 c --------
07313 c ns1,...ns4 : numero pxyd des 4 sommets
07314 c pxyd   : les coordonnees des sommets
07315 c
07316 c sortie :
07317 c --------
07318 c linter : -1 si ns3-ns4 parallele a ns1 ns2
07319 c           0 si ns3-ns4 n'intersecte pas ns1-ns2 entre les aretes
07320 c           1 si ns3-ns4   intersecte     ns1-ns2 entre les aretes
07321 c           2 si le point d'intersection est ns1  entre ns3-ns4
07322 c           3 si le point d'intersection est ns3  entre ns1-ns2
07323 c           4 si le point d'intersection est ns4  entre ns1-ns2
07324 c x0,y0  :  2 coordonnees du point d'intersection s'il existe(linter>=1)
07325 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
07326 c auteur : alain perronnet  analyse numerique paris upmc    fevrier 1992
07327 c2345x7..............................................................012
07328       parameter        ( epsmoi=-0.000001d0, eps=0.001d0,
07329      %                   unmeps= 0.999d0, unpeps=1.000001d0 )
07330       double precision  pxyd(3,*), x0, y0
07331       double precision  x1,y1,x21,y21,d21,x43,y43,d43,d,x,y,p21,p43
07332 c
07333       x1  = pxyd(1,ns1)
07334       y1  = pxyd(2,ns1)
07335       x21 = pxyd(1,ns2) - x1
07336       y21 = pxyd(2,ns2) - y1
07337       d21 = x21**2 + y21**2
07338 c
07339       x43 = pxyd(1,ns4) - pxyd(1,ns3)
07340       y43 = pxyd(2,ns4) - pxyd(2,ns3)
07341       d43 = x43**2 + y43**2
07342 c
07343 c     les 2 aretes sont-elles jugees paralleles ?
07344       d = x43 * y21 - y43 * x21
07345       if( d*d .le. 0.000001d0 * d21 * d43 ) then
07346 c        cote i parallele a ns1-ns2
07347          linter = -1
07348          return
07349       endif
07350 c
07351 c     les 2 coordonnees du point d'intersection
07352       x =( x1*x43*y21-pxyd(1,ns3)*x21*y43-(y1-pxyd(2,ns3))*x21*x43)/d
07353       y =(-y1*y43*x21+pxyd(2,ns3)*y21*x43+(x1-pxyd(1,ns3))*y21*y43)/d
07354 c
07355 c     coordonnee barycentrique de x,y dans le repere ns1-ns2
07356       p21 = ( ( x - x1 )       * x21 + ( y - y1 )        * y21 ) / d21
07357 c     coordonnee barycentrique de x,y dans le repere ns3-ns4
07358       p43 = ( (x - pxyd(1,ns3))* x43 + (y - pxyd(2,ns3)) * y43 ) / d43
07359 c
07360 c
07361       if( epsmoi .le. p21 .and. p21 .le. unpeps ) then
07362 c        x,y est entre ns1-ns2
07363          if( (p21 .le. eps)  .and.
07364      %       (epsmoi .le. p43 .and. p43 .le. unpeps) ) then
07365 c           le point x,y est proche de ns1 et interne a ns3-ns4
07366             linter = 2
07367             x0 = pxyd(1,ns1)
07368             y0 = pxyd(2,ns1)
07369             return
07370          else if( epsmoi .le. p43 .and. p43 .le. eps ) then
07371 c           le point x,y est proche de ns3 et entre ns1-ns2
07372             linter = 3
07373             x0 = pxyd(1,ns3)
07374             y0 = pxyd(2,ns3)
07375             return
07376          else if( unmeps .le. p43 .and. p43 .le. unpeps ) then
07377 c           le point x,y est proche de ns4 et entre ns1-ns2
07378             linter = 4
07379             x0 = pxyd(1,ns4)
07380             y0 = pxyd(2,ns4)
07381             return
07382          else if( eps .le. p43 .and. p43 .le. unmeps ) then
07383 c           le point x,y est entre ns3-ns4
07384             linter = 1
07385             x0     = x
07386             y0     = y
07387             return
07388          endif
07389       endif
07390 c
07391 c     pas d'intersection a l'interieur des aretes
07392       linter = 0
07393       end
07394 
07395       subroutine tefoar( narete, nbarpi, pxyd,
07396      %                   mosoar, mxsoar, n1soar, nosoar,
07397      %                   moartr, mxartr, n1artr, noartr, noarst,
07398      %                   mxarcf, n1arcf, noarcf, larmin, notrcf,
07399      %                   ierr )
07400 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
07401 c but :   forcer l'arete narete de nosoar dans la triangulation actuelle
07402 c -----   triangulation frontale pour la reobtenir
07403 c
07404 c         attention: le chainage lchain(=6) de nosoar devient actif
07405 c                    durant la formation des contours fermes (cf)
07406 c
07407 c entrees:
07408 c --------
07409 c narete : numero nosoar de l'arete frontaliere a forcer
07410 c nbarpi : numero du dernier point interne impose par l'utilisateur
07411 c pxyd   : tableau des coordonnees 2d des points
07412 c          par point : x  y  distance_souhaitee
07413 c
07414 c mosoar : nombre maximal d'entiers par arete et
07415 c          indice dans nosoar de l'arete suivante dans le hachage
07416 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
07417 c          attention: mxsoar>3*mxsomm obligatoire!
07418 c moartr : nombre maximal d'entiers par arete du tableau noartr
07419 c mxartr : nombre maximal de triangles stockables dans le tableau noartr
07420 c
07421 c modifies:
07422 c ---------
07423 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
07424 c          chainage des vides suivant en 3 et precedant en 2 de nosoar
07425 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
07426 c          chainage des aretes frontalieres, chainage du hachage des aretes
07427 c          hachage des aretes = nosoar(1)+nosoar(2)*2
07428 c          avec mxsoar>=3*mxsomm
07429 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
07430 c          nosoar(2,arete vide)=l'arete vide qui precede
07431 c          nosoar(3,arete vide)=l'arete vide qui suit
07432 c n1artr : numero du premier triangle vide dans le tableau noartr
07433 c          le chainage des triangles vides se fait sur noartr(2,.)
07434 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
07435 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
07436 c noarst : noarst(i) numero d'une arete de sommet i
07437 c
07438 c mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf
07439 c
07440 c tableaux auxiliaires :
07441 c ----------------------
07442 c n1arcf : tableau (0:mxarcf) auxiliaire
07443 c noarcf : tableau (3,mxarcf) auxiliaire
07444 c larmin : tableau (mxarcf)   auxiliaire
07445 c notrcf : tableau (1:mxarcf) auxiliaire
07446 c
07447 c sortie :
07448 c --------
07449 c ierr   : 0 si pas d'erreur
07450 c          1 saturation des sommets
07451 c          2 ns1 dans aucun triangle
07452 c          9 tableau nosoar de taille insuffisante car trop d'aretes
07453 c            a probleme
07454 c          10 un des tableaux n1arcf, noarcf notrcf est sature
07455 c             augmenter a l'appel mxarcf
07456 c         >11 algorithme defaillant
07457 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
07458 c auteur : alain perronnet analyse numerique paris upmc     mars    1997
07459 c modifs : alain perronnet laboratoire jl lions upmc paris  octobre 2006
07460 c....................................................................012
07461       parameter        (mxpitr=32, mxstpe=512)
07462       common / unites / lecteu,imprim,intera,nunite(29)
07463       double precision  pxyd(3,*)
07464       integer           noartr(moartr,mxartr),
07465      %                  nosoar(mosoar,mxsoar),
07466      %                  noarst(*),
07467      %                  n1arcf(0:mxarcf),
07468      %                  noarcf(3,mxarcf),
07469      %                  larmin(mxarcf),
07470      %                  notrcf(mxarcf),
07471      %                  nostpe(mxstpe)
07472 c
07473       integer           lapitr(mxpitr)
07474       double precision  x1,y1,x2,y2,d12,d3,d4,x,y,d,dmin
07475       integer           nosotr(3), ns(2)
07476       integer           nacf(1:2), nacf1, nacf2
07477       equivalence      (nacf(1),nacf1), (nacf(2),nacf2)
07478 c
07479       ierr = 0
07480 c
07481 c     traitement de cette arete perdue
07482       ns1 = nosoar( 1, narete )
07483       ns2 = nosoar( 2, narete )
07484 c
07485 ccc      write(imprim,*)
07486 ccc      write(imprim,*) 'tefoar reconstruction de l''arete ',ns1,' ', ns2
07487 ccc      write(imprim,*) 'sommet',ns1,' x=',pxyd(1,ns1),' y=',pxyd(2,ns1)
07488 ccc      write(imprim,*) 'sommet',ns2,' x=',pxyd(1,ns2),' y=',pxyd(2,ns2)
07489 c
07490 c     le sommet ns2 est il correct?
07491       na = noarst( ns2 )
07492       if( na .le. 0 ) then
07493          write(imprim,*) 'tefoar: erreur sommet ',ns2,' sans arete'
07494          ierr = 8
07495 ccc         pause
07496          return
07497       endif
07498       if( nosoar(4,na) .le. 0 ) then
07499          write(imprim,*) 'tefoar: erreur sommet ',ns2,
07500      %                   ' dans aucun triangle'
07501          ierr = 8
07502 ccc         pause
07503          return
07504       endif
07505 c
07506 c     le premier passage: recherche dans le sens ns1->ns2
07507       ipas = 0
07508 c
07509 c     recherche des triangles intersectes par le segment ns1-ns2
07510 c     ==========================================================
07511  3    x1  = pxyd(1,ns1)
07512       y1  = pxyd(2,ns1)
07513       x2  = pxyd(1,ns2)
07514       y2  = pxyd(2,ns2)
07515       d12 = (x2-x1)**2 + (y2-y1)**2
07516 c
07517 c     recherche du triangle voisin dans le sens indirect de rotation
07518       nsens = -1
07519 c
07520 c     recherche du no local du sommet ns1 dans l'un de ses triangles
07521  10   na01 = noarst( ns1 )
07522       if( na01 .le. 0 ) then
07523          write(imprim,*) 'tefoar: sommet ',ns1,' sans arete'
07524          ierr = 8
07525 ccc         pause
07526          return
07527       endif
07528       nt0 = nosoar(4,na01)
07529       if( nt0 .le. 0 ) then
07530          write(imprim,*) 'tefoar: sommet ',ns1,' dans aucun triangle'
07531          ierr = 8
07532 ccc         pause
07533          return
07534       endif
07535 c
07536 c     le numero des 3 sommets du triangle nt0 dans le sens direct
07537  20   call nusotr( nt0, mosoar, nosoar, moartr, noartr, nosotr )
07538       do 22 na00=1,3
07539          if( nosotr(na00) .eq. ns1 ) goto 26
07540  22   continue
07541 c
07542  25   if( ipas .eq. 0 ) then
07543 c        le second passage: recherche dans le sens ns2->ns1
07544 c        tentative d'inversion des 2 sommets extremites de l'arete a forcer
07545          na00 = ns1
07546          ns1  = ns2
07547          ns2  = na00
07548          ipas = 1
07549          goto 3
07550       else
07551 c        les sens ns1->ns2 et ns2->ns1 ne donne pas de solution!
07552          write(imprim,*)'tefoar:arete ',ns1,' - ',ns2,' a imposer'
07553          write(imprim,*)'tefoar:anomalie sommet ',ns1,
07554      %   'non dans le triangle de sommets ',(nosotr(i),i=1,3)
07555          ierr = 11
07556 ccc         pause
07557          return
07558       endif
07559 c
07560 c     le numero des aretes suivante et precedente
07561  26   na0 = nosui3( na00 )
07562       na1 = nopre3( na00 )
07563       ns3 = nosotr( na0 )
07564       ns4 = nosotr( na1 )
07565 c
07566 c     point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
07567 c     ------------------------------------------------------------
07568       call int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x1, y1 )
07569       if( linter .le. 0 ) then
07570 c
07571 c        pas d'intersection: rotation autour du point ns1
07572 c        pour trouver le triangle de l'autre cote de l'arete na01
07573          if( nsens .lt. 0 ) then
07574 c           sens indirect de rotation: l'arete de sommet ns1
07575             na01 = abs( noartr(na00,nt0) )
07576          else
07577 c           sens direct de rotation: l'arete de sommet ns1 qui precede
07578             na01 = abs( noartr(na1,nt0) )
07579          endif
07580 c        le triangle de l'autre cote de l'arete na01
07581          if( nosoar(4,na01) .eq. nt0 ) then
07582             nt0 = nosoar(5,na01)
07583          else
07584             nt0 = nosoar(4,na01)
07585          endif
07586          if( nt0 .gt. 0 ) goto 20
07587 c
07588 c        le parcours sort du domaine
07589 c        il faut tourner dans l'autre sens autour de ns1
07590          if( nsens .lt. 0 ) then
07591             nsens = 1
07592             goto 10
07593          endif
07594 c
07595 c        dans les 2 sens, pas d'intersection => impossible
07596 c        essai avec l'arete inversee ns1 <-> ns2
07597          if( ipas .eq. 0 ) goto 25
07598          write(imprim,*) 'tefoar: arete ',ns1,' ',ns2,
07599      %  ' sans intersection avec les triangles actuels'
07600          write(imprim,*) 'revoyez les lignes du contour'
07601          ierr = 12
07602 ccc         pause
07603          return
07604       endif
07605 c
07606 c     il existe une intersection avec l'arete opposee au sommet ns1
07607 c     =============================================================
07608 c     nbtrcf : nombre de triangles du cf
07609       nbtrcf = 1
07610       notrcf( 1 ) = nt0
07611 c
07612 c     le triangle oppose a l'arete na0 de nt0
07613  30   noar = abs( noartr(na0,nt0) )
07614       if( nosoar(4,noar) .eq. nt0 ) then
07615          nt1 = nosoar(5,noar)
07616       else
07617          nt1 = nosoar(4,noar)
07618       endif
07619       if( nt1 .le. 0 ) then
07620          write(imprim,*) 'erreur dans tefoar nt1=',nt1
07621          read(lecteu,*) j
07622       endif
07623 c
07624 c     le numero des 3 sommets du triangle nt1 dans le sens direct
07625       call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr )
07626 c
07627 c     le triangle nt1 contient il ns2 ?
07628       do 32 j=1,3
07629          if( nosotr(j) .eq. ns2 ) goto 70
07630  32   continue
07631 c
07632 c     recherche de l'arete noar, na1 dans nt1 qui est l'arete na0 de nt0
07633       do 34 na1=1,3
07634          if( abs( noartr(na1,nt1) ) .eq. noar ) goto 35
07635  34   continue
07636 c
07637 c     recherche de l'intersection de ns1-ns2 avec les 2 autres aretes de nt1
07638 c     ======================================================================
07639  35   na2 = na1
07640       do 50 i1 = 1,2
07641 c        l'arete suivante
07642          na2 = nosui3(na2)
07643 c
07644 c        les 2 sommets de l'arete na2 de nt1
07645          noar = abs( noartr(na2,nt1) )
07646          ns3  = nosoar( 1, noar )
07647          ns4  = nosoar( 2, noar )
07648 c
07649 c        point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
07650 c        ------------------------------------------------------------
07651          call int1sd( ns1, ns2, ns3, ns4, pxyd, linter, x , y )
07652          if( linter .gt. 0 ) then
07653 c
07654 c           les 2 aretes s'intersectent en (x,y)
07655 c           distance de (x,y) a ns3 et ns4
07656             d3 = (pxyd(1,ns3)-x)**2 + (pxyd(2,ns3)-y)**2
07657             d4 = (pxyd(1,ns4)-x)**2 + (pxyd(2,ns4)-y)**2
07658 c           nsp est le point le plus proche de (x,y)
07659             if( d3 .lt. d4 ) then
07660                nsp = ns3
07661                d   = d3
07662             else
07663                nsp = ns4
07664                d   = d4
07665             endif
07666             if( d .gt. 1d-5*d12 ) goto 60
07667 c
07668 c           ici le sommet nsp est trop proche de l'arete perdue ns1-ns2
07669             if( nsp .le. nbarpi ) then
07670 c              point utilisateur ou frontalier donc non supprimable
07671                write(imprim,*) 'tefoar: sommet nsp=',nsp,
07672      %' frontalier trop proche de l''arete perdue ns1=',ns1,'-ns2=',ns2
07673            write(imprim,*)'s',nsp,': x=', pxyd(1,nsp),' y=', pxyd(2,nsp)
07674            write(imprim,*)'s',ns1,': x=', pxyd(1,ns1),' y=', pxyd(2,ns1)
07675            write(imprim,*)'s',ns2,': x=', pxyd(1,ns2),' y=', pxyd(2,ns2)
07676            write(imprim,*)'arete s',ns1,'-s',ns2,
07677      %                    ' coupe arete s',ns3,'-s',ns4,' en (x,y)'
07678           write(imprim,*) 's',ns3,': x=', pxyd(1,ns3),' y=', pxyd(2,ns3)
07679           write(imprim,*) 's',ns4,': x=', pxyd(1,ns4),' y=', pxyd(2,ns4)
07680           write(imprim,*) 'intersection en: x=', x, ' y=', y
07681           write(imprim,*) 'distance ns1-ns2=', sqrt(d12)
07682           write(imprim,*) 'distance (x,y) au plus proche',ns3,ns4,'=',
07683      %                     sqrt(d)
07684                ierr = 13
07685 ccc               pause
07686                return
07687             endif
07688 c
07689 c           le sommet interne nsp est supprime en mettant tous les triangles
07690 c           l'ayant comme sommet dans la pile notrcf des triangles a supprimer
07691 c           ------------------------------------------------------------------
07692 ccc            write(imprim,*) 'tefoar: le sommet ',nsp,' est supprime'
07693 c           construction de la liste des triangles de sommet nsp
07694             call trp1st( nsp,    noarst, mosoar, nosoar,
07695      %                   moartr, mxartr, noartr,
07696      %                   mxpitr, nbt, lapitr )
07697             if( nbt .le. 0 ) then
07698 c              les triangles de sommet nsp ne forme pas une "boule"
07699 c              avec ce sommet nsp pour "centre"
07700                write(imprim,*)
07701      %        'tefoar: les triangles autour du sommet ',nsp,
07702      %        ' ne forme pas une etoile'
07703                nbt = -nbt
07704             endif
07705 c
07706 c           ajout des triangles de sommet nsp a notrcf
07707             nbtrc0 = nbtrcf
07708             do 38 j=1,nbt
07709                nt = lapitr(j)
07710                do 37 k=nbtrcf,1,-1
07711                   if( nt .eq. notrcf(k) ) goto 38
07712  37            continue
07713 c              triangle ajoute
07714                nbtrcf = nbtrcf + 1
07715                notrcf( nbtrcf ) = nt
07716  38         continue
07717 c
07718 c           ce sommet supprime n'appartient plus a aucun triangle
07719             noarst( nsp ) = 0
07720 c
07721 c           ns2 est-il un sommet des triangles empiles?
07722 c           -------------------------------------------
07723             do 40 nt=nbtrc0+1,nbtrcf
07724 c              le triangle a supprimer nt
07725                nt1 = notrcf( nt )
07726 c              le numero des 3 sommets du triangle nt1 dans le sens direct
07727                call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr)
07728                do 39 k=1,3
07729 c                 le sommet k de nt1
07730                   if( nosotr( k ) .eq. ns2 ) then
07731 c                    but atteint
07732                      goto 80
07733                   endif
07734  39            continue
07735  40         continue
07736 c
07737 c           recherche du plus proche point d'intersection de ns1-ns2
07738 c           par rapport a ns2 avec les aretes des triangles ajoutes
07739             nt0  = 0
07740             dmin = d12 * 10000
07741             do 48 nt=nbtrc0+1,nbtrcf
07742                nt1 = notrcf( nt )
07743 c              le numero des 3 sommets du triangle nt1 dans le sens direct
07744                call nusotr( nt1, mosoar, nosoar, moartr, noartr, nosotr)
07745                do 45 k=1,3
07746 c                 les 2 sommets de l'arete k de nt
07747                   ns3 = nosotr( k )
07748                   ns4 = nosotr( nosui3(k) )
07749 c
07750 c                 point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4
07751 c                 ------------------------------------------------------------
07752                   call int1sd( ns1, ns2, ns3, ns4, pxyd,
07753      %                         linter, x , y )
07754                    if( linter .gt. 0 ) then
07755 c                    les 2 aretes s'intersectent en (x,y)
07756                      d = (x-x2)**2+(y-y2)**2
07757                      if( d .lt. dmin ) then
07758                         nt0  = nt1
07759                         na0  = k
07760                         dmin = d
07761                      endif
07762                   endif
07763  45            continue
07764  48         continue
07765 c
07766 c           redemarrage avec le triangle nt0 et l'arete na0
07767             if( nt0 .gt. 0 ) goto 30
07768 c
07769             write(imprim,*) 'tefoar: algorithme defaillant'
07770             ierr = 14
07771 ccc            pause
07772             return
07773          endif
07774  50   continue
07775 c
07776 c     pas d'intersection differente de l'initiale => sommet sur ns1-ns2
07777 c     tentative d'inversion des sommets de l'arete ns1-ns2
07778       if( ipas .eq. 0 ) goto 25
07779       write(imprim,*)
07780       write(imprim,*) 'tefoar 50: revoyez vos donnees'
07781       write(imprim,*) 'les lignes fermees doivent etre disjointes'
07782       write(imprim,*) 'verifiez si elles ne se coupent pas'
07783       ierr = 15
07784 ccc      pause
07785       return
07786 c
07787 c     cas sans probleme : intersection differente de celle initiale
07788 c     =================   =========================================
07789  60   nbtrcf = nbtrcf + 1
07790       notrcf( nbtrcf ) = nt1
07791 c     passage au triangle suivant
07792       na0 = na2
07793       nt0 = nt1
07794       goto 30
07795 c
07796 c     ----------------------------------------------------------
07797 c     ici toutes les intersections de ns1-ns2 ont ete parcourues
07798 c     tous les triangles intersectes ou etendus forment les
07799 c     nbtrcf triangles du tableau notrcf
07800 c     ----------------------------------------------------------
07801  70   nbtrcf = nbtrcf + 1
07802       notrcf( nbtrcf ) = nt1
07803 c
07804 c     formation du cf des aretes simples des triangles de notrcf
07805 c     et destruction des nbtrcf triangles du tableau noartr
07806 c     attention: le chainage lchain du tableau nosoar devient actif
07807 c     =============================================================
07808  80   if( nbtrcf*3 .gt. mxarcf ) then
07809          write(imprim,*) 'saturation du tableau noarcf'
07810          ierr = 10
07811 ccc         pause
07812          return
07813       endif
07814 c
07815       call focftr( nbtrcf, notrcf, nbarpi, pxyd,   noarst,
07816      %             mosoar, mxsoar, n1soar, nosoar,
07817      %             moartr, n1artr, noartr,
07818      %             nbarcf, n1arcf, noarcf, nbstpe, nostpe,
07819      %             ierr )
07820       if( ierr .ne. 0 ) return
07821 c
07822 c     chainage des aretes vides dans le tableau noarcf
07823 c     ------------------------------------------------
07824 c     decalage de 2 aretes car 2 aretes sont necessaires ensuite pour
07825 c     integrer 2 fois l'arete perdue et former ainsi 2 cf
07826 c     comme nbtrcf*3 minore mxarcf il existe au moins 2 places vides
07827 c     derriere => pas de test de debordement
07828       n1arcf(0) = nbarcf+3
07829       mmarcf = min(8*nbarcf,mxarcf)
07830       do 90 i=nbarcf+3,mmarcf
07831          noarcf(2,i) = i+1
07832  90   continue
07833       noarcf(2,mmarcf) = 0
07834 c
07835 c     reperage des sommets ns1 ns2 de l'arete perdue dans le cf
07836 c     ---------------------------------------------------------
07837       ns1   = nosoar( 1, narete )
07838       ns2   = nosoar( 2, narete )
07839       ns(1) = ns1
07840       ns(2) = ns2
07841       do 120 i=1,2
07842 c        la premiere arete dans noarcf du cf
07843          na0 = n1arcf(1)
07844  110     if( noarcf(1,na0) .ne. ns(i) ) then
07845 c           passage a l'arete suivante
07846             na0 = noarcf( 2, na0 )
07847             goto 110
07848          endif
07849 c        position dans noarcf du sommet i de l'arete perdue
07850          nacf(i) = na0
07851  120  continue
07852 c
07853 c     formation des 2 cf chacun contenant l'arete ns1-ns2
07854 c     ---------------------------------------------------
07855 c     sauvegarde de l'arete suivante de celle de sommet ns1
07856       na0 = noarcf( 2, nacf1 )
07857       nt1 = noarcf( 3, nacf1 )
07858 c
07859 c     le premier cf
07860       n1arcf( 1 ) = nacf1
07861 c     l'arete suivante dans le premier cf
07862       noarcf( 2, nacf1 ) = nacf2
07863 c     cette arete est celle perdue
07864       noarcf( 3, nacf1 ) = narete
07865 c
07866 c     le second cf
07867 c     l'arete doublee
07868       n1 = nbarcf + 1
07869       n2 = nbarcf + 2
07870 c     le premier sommet de la premiere arete du second cf
07871       noarcf( 1, n1 ) = ns2
07872 c     l'arete suivante dans le second cf
07873       noarcf( 2, n1 ) = n2
07874 c     cette arete est celle perdue
07875       noarcf( 3, n1 ) = narete
07876 c     la seconde arete du second cf
07877       noarcf( 1, n2 ) = ns1
07878       noarcf( 2, n2 ) = na0
07879       noarcf( 3, n2 ) = nt1
07880       n1arcf( 2 ) = n1
07881 c
07882 c     recherche du precedent de nacf2
07883  130  na1 = noarcf( 2, na0 )
07884       if( na1 .ne. nacf2 ) then
07885 c        passage a l'arete suivante
07886          na0 = na1
07887          goto 130
07888       endif
07889 c     na0 precede nacf2 => il precede n1
07890       noarcf( 2, na0 ) = n1
07891 c
07892 c     depart avec 2 cf
07893       nbcf = 2
07894 c
07895 c     triangulation directe des 2 contours fermes
07896 c     l'arete ns1-ns2 devient une arete de la triangulation des 2 cf
07897 c     ==============================================================
07898       call tridcf( nbcf,   nbstpe, nostpe, pxyd,   noarst,
07899      %             mosoar, mxsoar, n1soar, nosoar,
07900      %             moartr, n1artr, noartr,
07901      %             mxarcf, n1arcf, noarcf, larmin,
07902      %             nbtrcf, notrcf, ierr )
07903 c
07904       return
07905       end
07906 
07907 
07908       subroutine te4ste( nbsomm, mxsomm, pxyd, ntrp, letree,
07909      &                   ierr )
07910 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
07911 c but :    decouper un te ntrp de letree en 4 sous-triangles
07912 c -----    eliminer les sommets de te trop proches des points
07913 c
07914 c entrees:
07915 c --------
07916 c mxsomm : nombre maximal de points declarables dans pxyd
07917 c ntrp   : numero letree du triangle a decouper en 4 sous-triangles
07918 c
07919 c modifies :
07920 c ----------
07921 c nbsomm : nombre actuel de points dans pxyd
07922 c pxyd   : tableau des coordonnees des points
07923 c          par point : x  y  distance_souhaitee
07924 c letree : arbre-4 des triangles equilateraux (te) fond de la triangulation
07925 c      letree(0,0) :  no du 1-er te vide dans letree
07926 c      letree(0,1) : maximum du 1-er indice de letree (ici 8)
07927 c      letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree)
07928 c      letree(0:8,1) : racine de l'arbre  (triangle sans sur triangle)
07929 c      si letree(0,.)>0 alors
07930 c         letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j
07931 c      sinon
07932 c         letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j
07933 c                         0  si pas de point
07934 c                        ( j est alors une feuille de l'arbre )
07935 c      letree(4,j) : no letree du sur-triangle du triangle j
07936 c      letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle
07937 c      letree(6:8,j) : no pxyd des 3 sommets du triangle j
07938 c
07939 c sorties :
07940 c ---------
07941 c ierr    : 0 si pas d'erreur, 51 saturation letree, 52 saturation pxyd
07942 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
07943 c auteur : alain perronnet  analyse numerique paris upmc    juillet 1994
07944 c2345x7..............................................................012
07945       common / unites / lecteu,imprim,nunite(30)
07946       integer           letree(0:8,0:*)
07947       double precision  pxyd(3,mxsomm)
07948       integer           np(0:3),milieu(3)
07949 c
07950 c     debut par l'arete 2 du triangle ntrp
07951       ierr = 0
07952       i1 = 2
07953       i2 = 3
07954       do 30 i=1,3
07955 c
07956 c        le milieu de l'arete i1 existe t il deja ?
07957          call n1trva( ntrp, i1, letree, noteva, niveau )
07958          if( noteva .gt. 0 ) then
07959 c           il existe un te voisin
07960 c           s'il existe 4 sous-triangles le milieu existe deja
07961             if( letree(0,noteva) .gt. 0 ) then
07962 c              le milieu existe
07963                nsot = letree(0,noteva)
07964                milieu(i) = letree( 5+nopre3(i1), nsot )
07965                goto 25
07966             endif
07967          endif
07968 c
07969 c        le milieu n'existe pas. il est cree
07970          nbsomm = nbsomm + 1
07971          if( nbsomm .gt. mxsomm ) then
07972 c           plus assez de place dans pxyd
07973             write(imprim,*) 'te4ste: saturation pxyd'
07974             write(imprim,*)
07975             ierr = 52
07976             return
07977          endif
07978 c        le milieu de l'arete i
07979          milieu(i) = nbsomm
07980 c
07981 c        ntrp est le triangle de milieux d'arete ces 3 sommets
07982          ns1    = letree( 5+i1, ntrp )
07983          ns2    = letree( 5+i2, ntrp )
07984          pxyd(1,nbsomm) = ( pxyd(1,ns1) + pxyd(1,ns2) ) * 0.5
07985          pxyd(2,nbsomm) = ( pxyd(2,ns1) + pxyd(2,ns2) ) * 0.5
07986 c
07987 c        l'arete et milieu suivant
07988  25      i1 = i2
07989          i2 = nosui3( i2 )
07990  30   continue
07991 c
07992       do 50 i=0,3
07993 c
07994 c        le premier triangle vide
07995          nsot = letree(0,0)
07996          if( nsot .le. 0 ) then
07997 c           manque de place. saturation letree
07998             ierr = 51
07999             write(imprim,*) 'te4ste: saturation letree'
08000             write(imprim,*)
08001             return
08002          endif
08003 c
08004 c        mise a jour du premier te libre
08005          letree(0,0) = letree(0,nsot)
08006 c
08007 c        nsot est le i-eme sous triangle
08008          letree(0,nsot) = 0
08009          letree(1,nsot) = 0
08010          letree(2,nsot) = 0
08011          letree(3,nsot) = 0
08012 c
08013 c        le numero des points et sous triangles dans ntrp
08014          np(i) = -letree(i,ntrp)
08015          letree(i,ntrp) = nsot
08016 c
08017 c        le sommet commun avec le triangle ntrp
08018          letree(5+i,nsot) = letree(5+i,ntrp)
08019 c
08020 c        le sur-triangle et numero de sous-triangle de nsot
08021 c        a laisser ici car incorrect sinon pour i=0
08022          letree(4,nsot) = ntrp
08023          letree(5,nsot) = i
08024 c
08025 c        le sous-triangle du triangle
08026          letree(i,ntrp) = nsot
08027  50   continue
08028 c
08029 c     le numero des nouveaux sommets milieux
08030       nsot = letree(0,ntrp)
08031       letree(6,nsot) = milieu(1)
08032       letree(7,nsot) = milieu(2)
08033       letree(8,nsot) = milieu(3)
08034 c
08035       nsot = letree(1,ntrp)
08036       letree(7,nsot) = milieu(3)
08037       letree(8,nsot) = milieu(2)
08038 c
08039       nsot = letree(2,ntrp)
08040       letree(6,nsot) = milieu(3)
08041       letree(8,nsot) = milieu(1)
08042 c
08043       nsot = letree(3,ntrp)
08044       letree(6,nsot) = milieu(2)
08045       letree(7,nsot) = milieu(1)
08046 c
08047 c     repartition des eventuels 4 points np dans ces 4 sous-triangles
08048 c     il y a obligatoirement suffisamment de place
08049       do 110 i=0,3
08050          if( np(i) .gt. 0 ) then
08051             nsot = notrpt( pxyd(1,np(i)), pxyd, ntrp, letree )
08052 c           ajout du point
08053             do 100 i1=0,3
08054                if( letree(i1,nsot) .eq. 0 ) then
08055 c                 place libre a occuper
08056                   letree(i1,nsot) = -np(i)
08057                   goto 110
08058                endif
08059  100        continue
08060          endif
08061  110  continue
08062       end
08063 
08064 
08065       subroutine tesuqm( quamal, nbarpi, pxyd,   noarst,
08066      %                   mosoar, mxsoar, n1soar, nosoar,
08067      %                   moartr, mxartr, n1artr, noartr,
08068      %                   mxarcf, n1arcf, noarcf,
08069      %                   larmin, notrcf, liarcf,
08070      %                   quamin )
08071 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
08072 c but :    supprimer de la triangulation les triangles de qualite
08073 c -----    inferieure a quamal
08074 c
08075 c entrees:
08076 c --------
08077 c quamal : qualite des triangles au dessous de laquelle supprimer des sommets
08078 c nbarpi : numero du dernier point interne impose par l'utilisateur
08079 c pxyd   : tableau des coordonnees 2d des points
08080 c          par point : x  y  distance_souhaitee
08081 c mosoar : nombre maximal d'entiers par arete et
08082 c          indice dans nosoar de l'arete suivante dans le hachage
08083 c mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar
08084 c          attention: mxsoar>3*mxsomm obligatoire!
08085 c moartr : nombre maximal d'entiers par arete du tableau noartr
08086 c
08087 c modifies:
08088 c ---------
08089 c noarst : noarst(i) numero d'une arete de sommet i
08090 c n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar
08091 c          chainage des vides suivant en 3 et precedant en 2 de nosoar
08092 c nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete,
08093 c          chainage des aretes frontalieres, chainage du hachage des aretes
08094 c          hachage des aretes = nosoar(1)+nosoar(2)*2
08095 c          avec mxsoar>=3*mxsomm
08096 c          une arete i de nosoar est vide <=> nosoar(1,i)=0 et
08097 c          nosoar(2,arete vide)=l'arete vide qui precede
08098 c          nosoar(3,arete vide)=l'arete vide qui suit
08099 c n1artr : numero du premier triangle vide dans le tableau noartr
08100 c          le chainage des triangles vides se fait sur noartr(2,.)
08101 c noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3
08102 c          arete1 = 0 si triangle vide => arete2 = triangle vide suivant
08103 c
08104 c auxiliaires :
08105 c -------------
08106 c n1arcf : tableau (0:mxarcf) auxiliaire d'entiers
08107 c noarcf : tableau (3,mxarcf) auxiliaire d'entiers
08108 c larmin : tableau (mxarcf)   auxiliaire d'entiers
08109 c notrcf : tableau (mxarcf)   auxiliaire d'entiers
08110 c liarcf : tableau (mxarcf)   auxiliaire d'entiers
08111 c
08112 c sortie :
08113 c --------
08114 c quamin : qualite minimale des triangles
08115 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
08116 c auteur : alain perronnet Laboratoire JL Lions UPMC Paris  Octobre 2006
08117 c....................................................................012
08118       parameter       ( lchain=6, mxtrqm=1024 )
08119       common / unites / lecteu,imprim,intera,nunite(29)
08120       double precision  pxyd(3,*), quamal, qualit, quamin
08121       integer           nosoar(mosoar,mxsoar),
08122      %                  noartr(moartr,mxartr),
08123      %                  noarst(*)
08124       integer           nosotr(3), notraj(3)
08125       double precision  surtd2, s123, s142, s143, s234,
08126      %                  s12, s34, a12
08127       integer           notrqm(mxtrqm)
08128       double precision  qutrqm(mxtrqm)
08129       integer           n1arcf(0:mxarcf),
08130      %                  noarcf(3,mxarcf),
08131      %                  larmin(mxarcf),
08132      %                  notrcf(mxarcf),
08133      %                  liarcf(mxarcf)
08134 c
08135       ierr = 0
08136 c
08137 c     initialisation du chainage des aretes des cf => 0 arete de cf
08138       do 5 narete=1,mxsoar
08139          nosoar( lchain, narete ) = -1
08140  5    continue
08141 c
08142 c     recherche des triangles de plus basse qualite
08143       quamin = 2.0
08144       nbtrqm = 0
08145       do 10 nt=1,mxartr
08146          if( noartr(1,nt) .eq. 0 ) goto 10
08147 c        le numero des 3 sommets du triangle nt
08148          call nusotr( nt, mosoar, nosoar, moartr, noartr, nosotr )
08149 c        la qualite du triangle ns1 ns2 ns3
08150          call qutr2d( pxyd(1,nosotr(1)), pxyd(1,nosotr(2)),
08151      %                pxyd(1,nosotr(3)), qualit )
08152          if( qualit .lt. quamal ) then
08153             if( nbtrqm .ge. mxtrqm ) goto 10
08154             nbtrqm = nbtrqm + 1
08155             notrqm(nbtrqm) = nt
08156             qutrqm(nbtrqm) = qualit
08157          endif
08158  10   continue
08159 c
08160 c     tri croissant des qualites minimales des triangles
08161       call tritas( nbtrqm, qutrqm, notrqm )
08162 c
08163 c     le plus mauvais triangle
08164       ntqmin = notrqm(1)
08165       quamin = qutrqm(1)
08166 c
08167       do 100 n=1,nbtrqm
08168 c
08169 c        no du triangle de mauvaise qualite
08170          ntqmin = notrqm( n )
08171 c
08172 c        le triangle a t il ete traite?
08173          if( noartr(1,ntqmin) .eq. 0 ) goto 100
08174 c
08175 ccc         print *
08176 ccc         print *,'tesuqm: triangle',ntqmin,' qualite=',qutrqm(n)
08177 ccc         print *,'tesuqm: noartr(',ntqmin,')=',
08178 ccc     %           (noartr(j,ntqmin),j=1,moartr)
08179 cccc
08180 ccc         do 12 j=1,3
08181 ccc            noar = noartr(j,ntqmin)
08182 ccc         print*,'arete',noar,' nosoar=',(nosoar(i,abs(noar)),i=1,mosoar)
08183 ccc 12      continue
08184 c
08185 c        le numero des 3 sommets du triangle ntqmin
08186          call nusotr( ntqmin, mosoar, nosoar, moartr, noartr, nosotr )
08187 c
08188 ccc         do 15 j=1,3
08189 ccc            nbt = nosotr(j)
08190 ccc            print *,'sommet',nbt,':  x=',pxyd(1,nbt),'  y=',pxyd(2,nbt)
08191 ccc 15      continue
08192 c
08193 c        recherche des triangles adjacents par les aretes de ntqmin
08194          nbt = 0
08195          do 20 j=1,3
08196 c           le no de l'arete j dans nosoar
08197             noar = abs( noartr(j,ntqmin) )
08198 c           le triangle adjacent a l'arete j de ntqmin
08199             if( nosoar(4,noar) .eq. ntqmin ) then
08200                notraj(j) = nosoar(5,noar)
08201             else
08202                notraj(j) = nosoar(4,noar)
08203             endif
08204             if( notraj(j) .gt. 0 ) then
08205 c              1 triangle adjacent de plus
08206                naop = j
08207                nbt  = nbt + 1
08208             else
08209 c              pas de triangle adjacent
08210                notraj(j) = 0
08211             endif
08212  20      continue
08213 c
08214          if( nbt .eq. 1 ) then
08215 c
08216 c           ntqmin a un seul triangle oppose par l'arete naop
08217 c           le triangle a 2 aretes frontalieres est plat
08218 c           l'arete commune aux 2 triangles est rendue Delaunay
08219 c           ---------------------------------------------------
08220             noar = abs( noartr(naop,ntqmin) )
08221             if( nosoar(3,noar) .ne. 0 ) then
08222 c              arete frontaliere
08223                goto 100
08224             endif
08225 c
08226 c           l'arete appartient a deux triangles actifs
08227 c           le numero des 4 sommets du quadrangle des 2 triangles
08228             call mt4sqa( noar, moartr, noartr, mosoar, nosoar,
08229      %                   ns1, ns2, ns3, ns4 )
08230             if( ns4 .eq. 0 ) goto 100
08231 c
08232 c           carre de la longueur de l'arete ns1 ns2
08233            a12=(pxyd(1,ns2)-pxyd(1,ns1))**2+(pxyd(2,ns2)-pxyd(2,ns1))**2
08234 c
08235 c           comparaison de la somme des aires des 2 triangles
08236 c           -------------------------------------------------
08237 c           calcul des surfaces des triangles 123 et 142 de cette arete
08238             s123=surtd2( pxyd(1,ns1), pxyd(1,ns2), pxyd(1,ns3) )
08239             s142=surtd2( pxyd(1,ns1), pxyd(1,ns4), pxyd(1,ns2) )
08240 ccc            print *,'tesuqm: ns4=',ns4,' x=',pxyd(1,ns4),
08241 ccc     %                                 ' y=',pxyd(2,ns4)
08242 ccc            print *,'tesuqm: s123=',s123,'  s142=',s142
08243             s12 = abs( s123 ) + abs( s142 )
08244             if( s12 .le. 0.001*a12 ) goto 100
08245 c
08246 c           calcul des surfaces des triangles 143 et 234 de cette arete
08247             s143=surtd2( pxyd(1,ns1), pxyd(1,ns4), pxyd(1,ns3) )
08248             s234=surtd2( pxyd(1,ns2), pxyd(1,ns3), pxyd(1,ns4) )
08249 ccc            print *,'tesuqm: s143=',s143,'  s234=',s234
08250             s34 = abs( s234 ) + abs( s143 )
08251 ccc            print *,'tesuqm: s12=',s12,'  s34=',s34
08252 c
08253             if( abs(s34-s12) .gt. 1d-14*s34 ) goto 100
08254 c
08255 c           quadrangle convexe 
08256 c           echange de la diagonale 12 par 34 des 2 triangles
08257 c           -------------------------------------------------
08258             call te2t2t( noar,   mosoar, n1soar, nosoar, noarst,
08259      %                   moartr, noartr, noar34 )
08260 ccc            print *,'tesuqm: sortie te2t2t avec noar34=',noar34
08261 c
08262 c
08263          else if( nbt .eq. 2 ) then
08264 c
08265 c           ntqmin a 2 triangles opposes par l'arete naop
08266 c           essai de supprimer le sommet non frontalier
08267 c           ---------------------------------------------
08268             do 30 j=1,3
08269                if( notraj(j) .eq. 0 ) goto 33
08270  30         continue
08271 c
08272 c           arete sans triangle adjacent
08273  33         noar = abs( noartr(j,ntqmin) )
08274 ccc            print *,'tesuqm: nosoar(',noar,')=',
08275 ccc     %              (nosoar(j,noar),j=1,mosoar)
08276             if( noar .le. 0 ) goto 100
08277 c
08278 c           ses 2 sommets
08279             ns1 = nosoar(1,noar)
08280             ns2 = nosoar(2,noar)
08281 c
08282 c           ns3 l'autre sommet non frontalier
08283             do 36 j=1,3
08284                ns3 = nosotr(j)
08285                if( ns3 .ne. ns1 .and. ns3 .ne. ns2 ) goto 40
08286  36         continue
08287 c
08288  40         if( ns3 .gt. nbarpi ) then
08289 c
08290 c              le sommet ns3 non frontalier va etre supprime
08291 ccc               print*,'tesuqm: ntqmin=',ntqmin,
08292 ccc     %                ' demande la suppression ns3=',ns3
08293                call te1stm( ns3,    nbarpi, pxyd,   noarst,
08294      %                      mosoar, mxsoar, n1soar, nosoar,
08295      %                      moartr, mxartr, n1artr, noartr,
08296      %                      mxarcf, n1arcf, noarcf,
08297      %                      larmin, notrcf, liarcf, ierr )
08298 ccc               if( ierr .eq. 0 ) then
08299 ccc                  print *,'tesuqm: st supprime ns3=',ns3
08300 ccc               else
08301 ccc                print *,'tesuqm: ST NON SUPPRIME ns3=',ns3,' ierr=',ierr
08302 ccc               endif
08303             endif
08304 c
08305          endif
08306 c
08307  100  continue
08308 c
08309       return
08310       end
08311 
08312 
08313       subroutine tritas( nb, a, noanc )
08314 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
08315 c but :    tri croissant du tableau a de nb reels par la methode du tas
08316 c -----    methode due a williams et floyd     o(n log n )
08317 c          version avec un pointeur sur un tableau dont est extrait a
08318 c entrees:
08319 c --------
08320 c nb     : nombre de termes du tableau a
08321 c a      : les nb reels double precision a trier dans a
08322 c noanc  : numero ancien position de l'information (souvent noanc(i)=i)
08323 c
08324 c sorties:
08325 c --------
08326 c a      : les nb reels croissants dans a
08327 c noanc  : numero ancien position de l'information
08328 c          noanc(1)=no position pointeur sur a(1), ...
08329 c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
08330 c auteur : perronnet alain analyse numerique upmc paris     fevrier 1991
08331 c ...................................................................012
08332       integer           noanc(1:nb)
08333       integer           pere,per,fil,fils1,fils2,fin
08334       double precision  a(1:nb),aux
08335 c
08336 c     formation du tas sous forme d'un arbre binaire
08337       fin = nb + 1
08338 c
08339       do 20 pere = nb/2,1,-1
08340 c
08341 c        descendre pere jusqu'a n dans a  de facon  a respecter
08342 c        a(pere)>a(j) pour j fils ou petit fils de pere
08343 c        c-a-d pour tout j tel que pere <= e(j/2)<j<nb+1
08344 c                                          a(j/2) >= a(j)
08345 c                                                 >= a(j+1)
08346 c
08347 c        protection du pere
08348          per = pere
08349 c
08350 c        le fils 1 du pere
08351  10      fils1 = 2 * per
08352          if( fils1 .lt. fin ) then
08353 c           il existe un fils1
08354             fil   = fils1
08355             fils2 = fils1 + 1
08356             if( fils2 .lt. fin ) then
08357 c              il existe 2 fils . selection du plus grand
08358                if( a(fils2) .gt. a(fils1) ) fil = fils2
08359             endif
08360 c
08361 c           ici fil est le plus grand des fils
08362             if( a(per) .lt. a(fil) ) then
08363 c              permutation de per et fil
08364                aux    = a(per)
08365                a(per) = a(fil)
08366                a(fil) = aux
08367 c              le pointeur est aussi permute
08368                naux       = noanc(per)
08369                noanc(per) = noanc(fil)
08370                noanc(fil) = naux
08371 c              le nouveau pere est le fils permute
08372                per = fil
08373                goto 10
08374             endif
08375          endif
08376  20   continue
08377 c
08378 c     a chaque iteration la racine (plus grande valeur actuelle de a)
08379 c     est mise a sa place (fin actuelle du tableau) et permutee avec
08380 c     la valeur qui occupe cette place, puis descente de cette nouvelle
08381 c     racine pour respecter le fait que tout pere est plus grand que tous
08382 c     ses fils
08383 c     c-a-d pour tout j tel que pere <= e(j/2)<j<nb+1
08384 c                                          a(j/2) >= a(j)
08385 c                                                 >= a(j+1)
08386       do 50 fin=nb,2,-1
08387 c        la permutation premier dernier
08388          aux    = a(fin)
08389          a(fin) = a(1)
08390          a(1)   = aux
08391 c        le pointeur est aussi permute
08392          naux       = noanc(fin)
08393          noanc(fin) = noanc(1)
08394          noanc(1)   = naux
08395 c
08396 c        descendre a(1) entre 1 et fin
08397          per = 1
08398 c
08399 c        le fils 1 du pere
08400  30      fils1 = 2 * per
08401          if( fils1 .lt. fin ) then
08402 c           il existe un fils1
08403             fil   = fils1
08404             fils2 = fils1 + 1
08405             if( fils2 .lt. fin ) then
08406 c              il existe 2 fils . selection du plus grand
08407                if( a(fils2) .gt. a(fils1) ) fil = fils2
08408             endif
08409 c
08410 c           ici fil est le plus grand des fils
08411             if( a(per) .lt. a(fil) ) then
08412 c              permutation de per et fil
08413                aux    = a(per)
08414                a(per) = a(fil)
08415                a(fil) = aux
08416 c              le pointeur est aussi permute
08417                naux       = noanc(per)
08418                noanc(per) = noanc(fil)
08419                noanc(fil) = naux
08420 c              le nouveau pere est le fils permute
08421                per = fil
08422                goto 30
08423             endif
08424          endif
08425  50   continue
08426       end