diff --git a/src/3rdParty/salomesmesh/CMakeLists.txt b/src/3rdParty/salomesmesh/CMakeLists.txt index afdf3abd7..e150f6338 100644 --- a/src/3rdParty/salomesmesh/CMakeLists.txt +++ b/src/3rdParty/salomesmesh/CMakeLists.txt @@ -22,6 +22,7 @@ include_directories( src/DriverDAT src/DriverSTL src/StdMeshers + src/MEFISTO2/f2clib inc ) link_directories(${OCC_LIBRARY_DIR}) @@ -127,7 +128,7 @@ ELSE(UNIX) ######### Windows ########### #MESSAGE("-- Windows system detected") IF(MSVC) - ADD_DEFINITIONS(-DWNT -DWIN32 -D_WINDOWS -DCSFDB /wd4290 /wd4251 /wd4018 /wd4800 /wd4996 /wd4244 /wd4806 /wd4275) + ADD_DEFINITIONS(-DWNT -DWIN32 -D_WINDOWS -DCSFDB -DUSE_CLOCK -DMSDOS -DNO_ONEXIT -DNO_My_ctype -DNO_ISATTY -DNO_FPINIT /wd4290 /wd4251 /wd4018 /wd4800 /wd4996 /wd4244 /wd4806 /wd4275) ELSE(MSVC) ADD_DEFINITIONS(-DWNT -DWIN32 -D_WINDOWS -DCSFDB) ENDIF(MSVC) @@ -269,22 +270,42 @@ endif(WIN32) # MEFISTO2 # ############## if (MSVC) - IF(CMAKE_SIZEOF_VOID_P EQUAL 8) - # Mefisto2f.lib was built using f2c which created - # all function names with an '_' at the end. - FILE(GLOB MEFISTO2_source_files - src/MEFISTO2/*.cpp + #IF(CMAKE_SIZEOF_VOID_P EQUAL 8) + # # Mefisto2f.lib was built using f2c which created + # # all function names with an '_' at the end. + # FILE(GLOB MEFISTO2_source_files + # src/MEFISTO2/*.cpp + # inc/Rn.h + # inc/aptrte.h + # ) + #ELSE(CMAKE_SIZEOF_VOID_P EQUAL 8) + # FILE(GLOB MEFISTO2_source_files + # src/MEFISTO2/*.cpp + # src/MEFISTO2/MEFISTO2F.def + # inc/Rn.h + # inc/aptrte.h + # ) + #ENDIF(CMAKE_SIZEOF_VOID_P EQUAL 8) + + set(MEFISTO2_SMESH_source_files + src/MEFISTO2/aptrte.cpp + src/MEFISTO2/trte.c + src/MEFISTO2/f2clib_part.c inc/Rn.h inc/aptrte.h ) - ELSE(CMAKE_SIZEOF_VOID_P EQUAL 8) - FILE(GLOB MEFISTO2_source_files - src/MEFISTO2/*.cpp - src/MEFISTO2/MEFISTO2F.def - inc/Rn.h - inc/aptrte.h + FILE(GLOB MEFISTO2_f2clib_source_files + #src/MEFISTO2/f2clib/*.c + #src/MEFISTO2/f2clib/*.h ) - ENDIF(CMAKE_SIZEOF_VOID_P EQUAL 8) + set(MEFISTO2_source_files + ${MEFISTO2_SMESH_source_files} + ${MEFISTO2_f2clib_source_files} + ) +SOURCE_GROUP("f2cLib" FILES ${MEFISTO2_f2clib_source_files}) + + + else(MSVC) FILE(GLOB MEFISTO2_source_files src/MEFISTO2/*.cpp diff --git a/src/3rdParty/salomesmesh/inc/aptrte.h b/src/3rdParty/salomesmesh/inc/aptrte.h index 3ebb182c8..c563d15d4 100644 --- a/src/3rdParty/salomesmesh/inc/aptrte.h +++ b/src/3rdParty/salomesmesh/inc/aptrte.h @@ -135,7 +135,22 @@ MEFISTO2D_EXPORT #elif defined(WIN32) && defined (__WATCOM__) #define MEFISTO2D_STDCALL - + #define insoar insoar_ + #define azeroi azeroi_ + #define fasoar fasoar_ + #define teajte teajte_ + #define tehote tehote_ + #define tetrte tetrte_ + #define aisoar aisoar_ + #define tedela tedela_ + #define terefr terefr_ + #define tesuex tesuex_ + #define teamqt teamqt_ + #define nusotr nusotr_ + #define qutr2d qutr2d_ + #define surtd2 surtd2_ + #define qualitetrte qualitetrte_ + #define areteideale areteideale_ #else //Lin and MacOSX use f77 #define MEFISTO2D_STDCALL diff --git a/src/3rdParty/salomesmesh/src/MEFISTO2/MEFISTO2F.def b/src/3rdParty/salomesmesh/src/MEFISTO2/MEFISTO2F.def deleted file mode 100644 index 57104a90c..000000000 --- a/src/3rdParty/salomesmesh/src/MEFISTO2/MEFISTO2F.def +++ /dev/null @@ -1,15 +0,0 @@ -EXPORTS - insoar - azeroi - fasoar - teajte - tehote - tetrte - aisoar - tedela - terefr - tesuex - teamqt - qutr2d - surtd2 - nusotr \ No newline at end of file diff --git a/src/3rdParty/salomesmesh/src/MEFISTO2/aptrte.cpp b/src/3rdParty/salomesmesh/src/MEFISTO2/aptrte.cpp index 4d20194d7..ce1e7bf77 100644 --- a/src/3rdParty/salomesmesh/src/MEFISTO2/aptrte.cpp +++ b/src/3rdParty/salomesmesh/src/MEFISTO2/aptrte.cpp @@ -24,10 +24,12 @@ // Author : Alain PERRONNET // Date : 13 novembre 2006 + #include "Rn.h" #include "aptrte.h" #include "utilities.h" + using namespace std; extern "C" @@ -839,6 +841,6 @@ void MEFISTO2D_STDCALL qualitetrte( R3 *mnpxyd, if( nbtrianeg>0 ) MESSAGE( "ATTENTION: "<< nbtrianeg << " TRIANGLES d'AIRE NEGATIVE" ); - MESSAGE(" "); + MESSAGE("_"); return; } diff --git a/src/3rdParty/salomesmesh/src/MEFISTO2/mefisto.patch b/src/3rdParty/salomesmesh/src/MEFISTO2/mefisto.patch deleted file mode 100644 index 91a09fdcf..000000000 --- a/src/3rdParty/salomesmesh/src/MEFISTO2/mefisto.patch +++ /dev/null @@ -1,217 +0,0 @@ -diff --git a/MEFISTO2F.def b/MEFISTO2F.def -new file mode 100644 -index 0000000..d4a0728 ---- /dev/null -+++ b/MEFISTO2F.def -@@ -0,0 +1,15 @@ -+EXPORTS -+ insoar_ -+ azeroi_ -+ fasoar_ -+ teajte_ -+ tehote_ -+ tetrte_ -+ aisoar_ -+ tedela_ -+ terefr_ -+ tesuex_ -+ teamqt_ -+ qutr2d_ -+ surtd2_ -+ nusotr_ -diff --git a/Mefisto2.def b/Mefisto2.def -new file mode 100644 -index 0000000..844f04f ---- /dev/null -+++ b/Mefisto2.def -@@ -0,0 +1,5 @@ -+LIBRARY MEFISTO2.dll -+EXPORTS -+ areteideale_ -+ qualitetrte_ -+ -diff --git a/Mefisto2d.def b/Mefisto2d.def -new file mode 100644 -index 0000000..dff1325 ---- /dev/null -+++ b/Mefisto2d.def -@@ -0,0 +1,5 @@ -+LIBRARY MEFISTO2d.dll -+EXPORTS -+ areteideale_ -+ qualitetrte_ -+ -diff --git a/arithchk.c b/arithchk.c -index 6a3c2a5..40f1f47 100644 ---- a/arithchk.c -+++ b/arithchk.c -@@ -29,6 +29,7 @@ THIS SOFTWARE. - #include - #include - #include /* another possible place for ssize_t */ -+#include - - #ifdef NO_FPINIT - #define fpinit_ASL() -@@ -42,6 +43,8 @@ extern - #endif /*KR_headers*/ - #endif /*NO_FPINIT*/ - -+ typedef int ssize_t; -+ - static int dalign; - typedef struct - Akind { -diff --git a/derf_.c b/derf_.c -index d935d31..e757916 100644 ---- a/derf_.c -+++ b/derf_.c -@@ -13,6 +13,38 @@ double derf_(doublereal *x) - { - return( erf(*x) ); - } -+ -+/* http://stackoverflow.com/questions/6281020/error-function-erfx-not-found-in-math-h-for-visual-studio-2005 */ -+double erf(double x) -+{ -+ /* constants */ -+ double a1 = 0.254829592; -+ double a2 = -0.284496736; -+ double a3 = 1.421413741; -+ double a4 = -1.453152027; -+ double a5 = 1.061405429; -+ double p = 0.3275911; -+ double t; -+ double y; -+ -+ /* Save the sign of x */ -+ int sign = 1; -+ if (x < 0) -+ sign = -1; -+ x = fabs(x); -+ -+ /* A&S formula 7.1.26 */ -+ t = 1.0/(1.0 + p*x); -+ y = 1.0 - (((((a5*t + a4)*t) + a3)*t + a2)*t + a1)*t*exp(-x*x); -+ -+ return sign*y; -+} -+/* http://www.boost.org/doc/libs/1_39_0/libs/math/doc/sf_and_dist/html/math_toolkit/special/sf_erf/error_function.html*/ -+/* erfc(z) = 1-erf(z) */ -+double erfc(double x) -+{ -+ return 1.0 - erf(x); -+} - #ifdef __cplusplus - } - #endif -diff --git a/libf2c.lbc b/libf2c.lbc -index c51c0aa..b77ae3c 100644 ---- a/libf2c.lbc -+++ b/libf2c.lbc -@@ -1,3 +1,4 @@ -+trte.obj - abort_.obj - backspac.obj - c_abs.obj -diff --git a/main.c b/main.c -index d95fdc9..22d1011 100644 ---- a/main.c -+++ b/main.c -@@ -135,7 +135,7 @@ f_init(); - #ifndef NO_ONEXIT - ONEXIT(f_exit); - #endif --MAIN__(); -+/*MAIN__();*/ - #ifdef NO_ONEXIT - f_exit(); - #endif -diff --git a/makefile.vc b/makefile.vc -index b3dd90c..3e9c82f 100644 ---- a/makefile.vc -+++ b/makefile.vc -@@ -6,12 +6,13 @@ - # to the objects in the "w =" list below. - - CC = cl --CFLAGS = -DUSE_CLOCK -DMSDOS -DNO_ONEXIT -Ot1 -DNO_My_ctype -DNO_ISATTY -+CFLAGS = -DUSE_CLOCK -DMSDOS -DNO_ONEXIT -Ot1 -DNO_My_ctype -DNO_ISATTY -MD - - .c.obj: - $(CC) -c $(CFLAGS) $*.c - - w = \ -+ trte.obj \ - abort_.obj \ - backspac.obj \ - c_abs.obj \ -@@ -166,7 +167,7 @@ w = \ - z_sin.obj \ - z_sqrt.obj - --all: f2c.h math.h signal1.h sysdep1.h vcf2c.lib -+all: f2c.h math.h signal1.h sysdep1.h MEFISTO2F.lib MEFISTO2Fd.lib - - f2c.h: f2c.h0 - copy f2c.h0 f2c.h -@@ -180,8 +181,17 @@ signal1.h: signal1.h0 - sysdep1.h: sysdep1.h0 - copy sysdep1.h0 sysdep1.h - --vcf2c.lib: $w -- lib -out:vcf2c.lib @libf2c.lbc -+MEFISTO2F.lib: $w -+ lib /DEF:Mefisto2.def /OUT:mef.lib -+ link -out:MEFISTO2F.dll @libf2c.lbc -DLL -IMPLIB:MEFISTO2F.lib -DEF:MEFISTO2F.def mef.lib -+ del mef.lib -+ del mef.exp -+ -+MEFISTO2Fd.lib: $w -+ lib /DEF:Mefisto2d.def /OUT:mefd.lib -+ link -out:MEFISTO2Fd.dll @libf2c.lbc -DLL -IMPLIB:MEFISTO2Fd.lib -DEF:MEFISTO2F.def mefd.lib -+ del mefd.lib -+ del mefd.exp - - open.obj: open.c - $(CC) -c $(CFLAGS) -DMSDOS open.c -@@ -189,7 +199,7 @@ open.obj: open.c - signbit.obj uninit.obj: arith.h - - arith.h: arithchk.c -- comptry.bat $(CC) $(CFLAGS) -DNO_FPINIT arithchk.c -+ $(CC) -DUSE_CLOCK -DMSDOS -DNO_ONEXIT -Ot1 -DNO_My_ctype -DNO_ISATTY -DNO_FPINIT arithchk.c - arithchk >arith.h - del arithchk.exe - del arithchk.obj -diff --git a/open.c b/open.c -index a06428d..d1f3da7 100644 ---- a/open.c -+++ b/open.c -@@ -5,7 +5,7 @@ - #ifdef MSDOS - #include "io.h" - #else --#include "unistd.h" /* for access */ -+#include "unistd.h" /* for _access */ - #endif - #endif - -@@ -204,7 +204,7 @@ integer f_open(olist *a) - opnerr(a->oerr,errno,"open") - fclose(tf); - #else -- if (access(buf,0)) -+ if (_access(buf,0)) - opnerr(a->oerr,errno,"open") - #endif - break; -@@ -234,7 +234,7 @@ integer f_open(olist *a) - opnerr(a->oerr,128,"open") - } - #else -- if (!access(buf,0)) -+ if (!_access(buf,0)) - opnerr(a->oerr,128,"open") - #endif - /* no break */ diff --git a/src/3rdParty/salomesmesh/src/MEFISTO2/trte.c b/src/3rdParty/salomesmesh/src/MEFISTO2/trte.c new file mode 100644 index 000000000..fdfb168e1 --- /dev/null +++ b/src/3rdParty/salomesmesh/src/MEFISTO2/trte.c @@ -0,0 +1,11296 @@ +/* trte.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +// start F2c.h content +typedef long int integer; +typedef unsigned long int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef long int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ +typedef long long longint; /* system-dependent */ +typedef unsigned long long ulongint; /* system-dependent */ +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) +#endif + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +#ifdef f2c_i2 +/* for -i2 */ +typedef short flag; +typedef short ftnlen; +typedef short ftnint; +#else +typedef long int flag; +typedef long int ftnlen; +typedef long int ftnint; +#endif + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (doublereal)min(a,b) +#define dmax(a,b) (doublereal)max(a,b) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef NIX +typedef int /* Unknown procedure type */ (*U_fp)(...); +typedef shortint (*J_fp)(...); +typedef integer (*I_fp)(...); +typedef real (*R_fp)(...); +typedef doublereal (*D_fp)(...), (*E_fp)(...); +typedef /* Complex */ VOID (*C_fp)(...); +typedef /* Double Complex */ VOID (*Z_fp)(...); +typedef logical (*L_fp)(...); +typedef shortlogical (*K_fp)(...); +typedef /* Character */ VOID (*H_fp)(...); +typedef /* Subroutine */ int (*S_fp)(...); +#else +typedef int /* Unknown procedure type */ (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef /* Complex */ VOID (*C_fp)(); +typedef /* Double Complex */ VOID (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef /* Character */ VOID (*H_fp)(); +typedef /* Subroutine */ int (*S_fp)(); +#endif +/* E_fp is for real functions when -R is not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +typedef doublereal E_f; /* real function with -R not specified */ + +/* undef any lower-case symbols that your C compiler predefines, e.g.: */ + +#ifndef Skip_f2c_Undefs +#undef cray +#undef gcos +#undef mc68010 +#undef mc68020 +#undef mips +#undef pdp11 +#undef sgi +#undef sparc +#undef sun +#undef sun2 +#undef sun3 +#undef sun4 +#undef u370 +#undef u3b +#undef u3b2 +#undef u3b5 +#undef unix +#undef vax +#endif + +// stop F2c.h content + + +union { + struct { + integer lecteu, imprim, nunite[30]; + } _1; + struct { + integer lecteu, imprim, intera, nunite[29]; + } _2; +} unites_; + +#define unites_1 (unites_._1) +#define unites_2 (unites_._2) + +/* Table of constant values */ + +static integer c__9 = 9; +static integer c__1 = 1; +static integer c__3 = 3; +static integer c__2 = 2; +static integer c__5 = 5; +static doublereal c_b357 = .1; +static integer c_n1 = -1; +static integer c__0 = 0; +static integer c__512 = 512; +static integer c__32 = 32; + +/* MEFISTO2: a library to compute 2D triangulation from segmented boundaries */ + +/* Copyright (C) 2006 Laboratoire J.-L. Lions UPMC Paris */ + +/* This library is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU Lesser General Public */ +/* License as published by the Free Software Foundation; either */ +/* version 2.1 of the License. */ + +/* This library is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU */ +/* Lesser General Public License for more details. */ + +/* You should have received a copy of the GNU Lesser General Public */ +/* License along with this library; if not, write to the Free Software */ +/* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA */ + +/* See http://www.ann.jussieu.fr/~perronnet or email perronnet@ann.jussieu.fr */ + +/* File : trte.f le Fortran du trianguleur plan */ +/* Module : SMESH */ +/* Author : Alain PERRONNET */ +/* Date : 13 novembre 2006 */ +doublereal diptdr_(doublereal *pt, doublereal *p1dr, doublereal *p2dr) +{ + /* System generated locals */ + doublereal ret_val, d__1; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + static doublereal a, b, c__; + +/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++012 */ +/* but : calculer la distance entre un point et une droite */ +/* ----- definie par 2 points p1dr et p2dr */ + +/* entrees : */ +/* --------- */ +/* pt : le point de R ** 2 */ +/* p1dr p2dr : les 2 points de R ** 2 de la droite */ +/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++012 */ +/* programmeur : alain perronnet analyse numrique paris janvier 1986 */ +/* ....................................................................012 */ + +/* les coefficients de la droite a x + by + c =0 */ + /* Parameter adjustments */ + --p2dr; + --p1dr; + --pt; + + /* Function Body */ + a = p2dr[2] - p1dr[2]; + b = p1dr[1] - p2dr[1]; + c__ = -a * p1dr[1] - b * p1dr[2]; + +/* la distance = | a * x + b * y + c | / sqrt( a*a + b*b ) */ + ret_val = (d__1 = a * pt[1] + b * pt[2] + c__, abs(d__1)) / sqrt(a * a + + b * b); + return ret_val; +} /* diptdr_ */ + +/* Subroutine */ int qutr2d_(doublereal *p1, doublereal *p2, doublereal *p3, + doublereal *qualite) +{ + /* System generated locals */ + doublereal d__1, d__2; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + static doublereal a, b, c__, p; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : calculer la qualite d'un triangle de r**2 */ +/* ----- 2 coordonnees des 3 sommets en double precision */ + +/* entrees : */ +/* --------- */ +/* p1,p2,p3 : les 3 coordonnees des 3 sommets du triangle */ +/* sens direct pour une surface et qualite >0 */ +/* sorties : */ +/* --------- */ +/* qualite: valeur de la qualite du triangle entre 0 et 1 (equilateral) */ +/* 1 etant la qualite optimale */ +/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique upmc paris janvier 1995 */ +/* 2345x7..............................................................012 */ +/* d2uxr3 = 2 * sqrt(3) */ + +/* la longueur des 3 cotes */ + /* Parameter adjustments */ + --p3; + --p2; + --p1; + + /* Function Body */ +/* Computing 2nd power */ + d__1 = p2[1] - p1[1]; +/* Computing 2nd power */ + d__2 = p2[2] - p1[2]; + a = sqrt(d__1 * d__1 + d__2 * d__2); +/* Computing 2nd power */ + d__1 = p3[1] - p2[1]; +/* Computing 2nd power */ + d__2 = p3[2] - p2[2]; + b = sqrt(d__1 * d__1 + d__2 * d__2); +/* Computing 2nd power */ + d__1 = p1[1] - p3[1]; +/* Computing 2nd power */ + d__2 = p1[2] - p3[2]; + c__ = sqrt(d__1 * d__1 + d__2 * d__2); + +/* demi perimetre */ + p = (a + b + c__) * .5; + + if (a * b * c__ != 0.) { +/* critere : 2 racine(3) * rayon_inscrit / plus longue arete */ +/* Computing MAX */ + d__2 = max(a,b); + *qualite = sqrt((d__1 = (p - a) / p * (p - b) * (p - c__), abs(d__1))) + * 3.4641016151377544f / max(d__2,c__); + } else { + *qualite = 0.; + } + + +/* autres criteres possibles: */ +/* critere : 2 * rayon_inscrit / rayon_circonscrit */ +/* qualite = 8d0 * (p-a) * (p-b) * (p-c) / (a * b * c) */ + +/* critere : 3*sqrt(3.) * ray_inscrit / demi perimetre */ +/* qualite = 3*sqrt(3.) * sqrt ((p-a)*(p-b)*(p-c) / p**3) */ + +/* critere : 2*sqrt(3.) * ray_inscrit / max( des aretes ) */ +/* qualite = 2*sqrt(3.) * sqrt( (p-a)*(p-b)*(p-c) / p ) / max(a,b,c) */ + return 0; +} /* qutr2d_ */ + +doublereal surtd2_(doublereal *p1, doublereal *p2, doublereal *p3) +{ + /* System generated locals */ + doublereal ret_val; + +/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : calcul de la surface d'un triangle defini par 3 points de R**2 */ +/* ----- */ +/* parametres d entree : */ +/* --------------------- */ +/* p1 p2 p3 : les 3 fois 2 coordonnees des sommets du triangle */ + +/* parametre resultat : */ +/* -------------------- */ +/* surtd2 : surface du triangle */ +/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique upmc paris fevrier 1992 */ +/* 2345x7..............................................................012 */ + +/* la surface du triangle */ + /* Parameter adjustments */ + --p3; + --p2; + --p1; + + /* Function Body */ + ret_val = ((p2[1] - p1[1]) * (p3[2] - p1[2]) - (p2[2] - p1[2]) * (p3[1] - + p1[1])) * .5; + return ret_val; +} /* surtd2_ */ + +integer nopre3_(integer *i__) +{ + /* System generated locals */ + integer ret_val; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : numero precedent i dans le sens circulaire 1 2 3 1 ... */ +/* ----- */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc fevrier 1992 */ +/* 2345x7..............................................................012 */ + if (*i__ == 1) { + ret_val = 3; + } else { + ret_val = *i__ - 1; + } + return ret_val; +} /* nopre3_ */ + +integer nosui3_(integer *i__) +{ + /* System generated locals */ + integer ret_val; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : numero suivant i dans le sens circulaire 1 2 3 1 ... */ +/* ----- */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc fevrier 1992 */ +/* 2345x7..............................................................012 */ + if (*i__ == 3) { + ret_val = 1; + } else { + ret_val = *i__ + 1; + } + return ret_val; +} /* nosui3_ */ + +/* Subroutine */ int provec_(doublereal *v1, doublereal *v2, doublereal *v3) +{ +/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : v3 vecteur = produit vectoriel de 2 vecteurs de r ** 3 */ +/* ----- */ +/* entrees: */ +/* -------- */ +/* v1, v2 : les 2 vecteurs de 3 composantes */ + +/* sortie : */ +/* -------- */ +/* v3 : vecteur = v1 produit vectoriel v2 */ +/* c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : perronnet alain upmc analyse numerique paris mars 1987 */ +/* 2345x7..............................................................012 */ + + /* Parameter adjustments */ + --v3; + --v2; + --v1; + + /* Function Body */ + v3[1] = v1[2] * v2[3] - v1[3] * v2[2]; + v3[2] = v1[3] * v2[1] - v1[1] * v2[3]; + v3[3] = v1[1] * v2[2] - v1[2] * v2[1]; + + return 0; +} /* provec_ */ + +/* Subroutine */ int norme1_(integer *n, doublereal *v, integer *ierr) +{ + /* System generated locals */ + integer i__1; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + static integer i__; + static doublereal s; + +/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : normalisation euclidienne a 1 d un vecteur v de n composantes */ +/* ----- */ +/* entrees : */ +/* --------- */ +/* n : nombre de composantes du vecteur */ + +/* modifie : */ +/* --------- */ +/* v : le vecteur a normaliser a 1 */ + +/* sortie : */ +/* --------- */ +/* ierr : 1 si la norme de v est egale a 0 */ +/* 0 si pas d'erreur */ +/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris mars 1987 */ +/* ...................................................................... */ + + /* Parameter adjustments */ + --v; + + /* Function Body */ + s = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s += v[i__] * v[i__]; +/* L10: */ + } + +/* test de nullite de la norme du vecteur */ +/* -------------------------------------- */ + if (s <= 0.) { +/* norme nulle du vecteur non normalisable a 1 */ + *ierr = 1; + return 0; + } + + s = 1. / sqrt(s); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + v[i__] *= s; +/* L20: */ + } + + *ierr = 0; + return 0; +} /* norme1_ */ + +/* Subroutine */ int insoar_(integer *mxsomm, integer *mosoar, integer * + mxsoar, integer *n1soar, integer *nosoar) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, i__1; + + /* Local variables */ + static integer i__; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : initialiser le tableau nosoar pour le hachage des aretes */ +/* ----- */ + +/* entrees: */ +/* -------- */ +/* mxsomm : plus grand numero de sommet d'une arete au cours du calcul */ +/* mosoar : nombre maximal d'entiers par arete du tableau nosoar */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* avec mxsoar>=3*mxsomm */ + +/* sorties: */ +/* -------- */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 */ +/* chainage des aretes vides amont et aval */ +/* l'arete vide qui precede=nosoar(4,i) */ +/* l'arete vide qui suit =nosoar(5,i) */ +/* nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete, */ +/* chainage momentan'e d'aretes, chainage du hachage des aretes */ +/* hachage des aretes = min( nosoar(1), nosoar(2) ) */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* 2345x7..............................................................012 */ + +/* initialisation des aretes 1 a mxsomm */ + /* Parameter adjustments */ + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + + /* Function Body */ + i__1 = *mxsomm; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* sommet 1 = 0 <=> temoin d'arete vide pour le hachage */ + nosoar[i__ * nosoar_dim1 + 1] = 0; + +/* arete sur aucune ligne */ + nosoar[i__ * nosoar_dim1 + 3] = 0; + +/* la position de l'arete interne ou frontaliere est inconnue */ + nosoar[i__ * nosoar_dim1 + 6] = -2; + +/* fin de chainage du hachage pas d'arete suivante */ + nosoar[*mosoar + i__ * nosoar_dim1] = 0; + +/* L10: */ + } + +/* la premiere arete vide chainee est la mxsomm+1 du tableau */ +/* car ces aretes ne sont pas atteignables par le hachage direct */ + *n1soar = *mxsomm + 1; + +/* initialisation des aretes vides et des chainages */ + i__1 = *mxsoar; + for (i__ = *n1soar; i__ <= i__1; ++i__) { + +/* sommet 1 = 0 <=> temoin d'arete vide pour le hachage */ + nosoar[i__ * nosoar_dim1 + 1] = 0; + +/* arete sur aucune ligne */ + nosoar[i__ * nosoar_dim1 + 3] = 0; + +/* chainage sur l'arete vide qui precede */ +/* (si arete occupee cela deviendra le no du triangle 1 de l'arete) */ + nosoar[i__ * nosoar_dim1 + 4] = i__ - 1; + +/* chainage sur l'arete vide qui suit */ +/* (si arete occupee cela deviendra le no du triangle 2 de l'arete) */ + nosoar[i__ * nosoar_dim1 + 5] = i__ + 1; + +/* chainages des aretes frontalieres ou internes ou ... */ + nosoar[i__ * nosoar_dim1 + 6] = -2; + +/* fin de chainage du hachage */ + nosoar[*mosoar + i__ * nosoar_dim1] = 0; + +/* L20: */ + } + +/* la premiere arete vide n'a pas de precedent */ + nosoar[*n1soar * nosoar_dim1 + 4] = 0; + +/* la derniere arete vide est mxsoar sans arete vide suivante */ + nosoar[*mxsoar * nosoar_dim1 + 5] = 0; + return 0; +} /* insoar_ */ + +/* Subroutine */ int azeroi_(integer *l, integer *ntab) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + static integer i__; + +/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : initialisation a zero d un tableau ntab de l variables entieres */ +/* ----- */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique upmc paris septembre 1988 */ +/* 23456---------------------------------------------------------------012 */ + /* Parameter adjustments */ + --ntab; + + /* Function Body */ + i__1 = *l; + for (i__ = 1; i__ <= i__1; ++i__) { + ntab[i__] = 0; +/* L1: */ + } + return 0; +} /* azeroi_ */ + +/* Subroutine */ int fasoar_(integer *ns1, integer *ns2, integer *nt1, + integer *nt2, integer *nolign, integer *mosoar, integer *mxsoar, + integer *n1soar, integer *nosoar, integer *noarst, integer *noar, + integer *ierr) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static integer i__, n, nu2sar[2]; + extern /* Subroutine */ int hasoar_(integer *, integer *, integer *, + integer *, integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___13 = { 0, 0, 0, 0, 0 }; + static cilist io___14 = { 0, 0, 0, 0, 0 }; + static cilist io___15 = { 0, 0, 0, 0, 0 }; + static cilist io___18 = { 0, 0, 0, 0, 0 }; + static cilist io___19 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : former l'arete de sommet ns1-ns2 dans le hachage du tableau */ +/* ----- nosoar des aretes de la triangulation */ + +/* entrees: */ +/* -------- */ +/* ns1 ns2: numero pxyd des 2 sommets de l'arete */ +/* nt1 : numero du triangle auquel appartient l'arete */ +/* nt1=-1 si numero inconnu */ +/* nt2 : numero de l'eventuel second triangle de l'arete si connu */ +/* nt2=-1 si numero inconnu */ +/* nolign : numero de la ligne de l'arete dans ladefi(wulftr-1+nolign) */ +/* =0 si l'arete n'est une arete de ligne */ +/* ce numero est ajoute seulement si l'arete est creee */ +/* mosoar : nombre maximal d'entiers par arete du tableau nosoar */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ + +/* modifies: */ +/* --------- */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 */ +/* chainage des aretes vides amont et aval */ +/* l'arete vide qui precede=nosoar(4,i) */ +/* l'arete vide qui suit =nosoar(5,i) */ +/* nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete, */ +/* chainage momentan'e d'aretes, chainage du hachage des aretes */ +/* hachage des aretes = min( nosoar(1), nosoar(2) ) */ +/* noarst : noarst(np) numero d'une arete du sommet np */ + +/* ierr : si < 0 en entree pas d'affichage en cas d'erreur du type */ +/* "arete appartenant a plus de 2 triangles et a creer!" */ +/* si >=0 en entree affichage de ce type d'erreur */ + +/* sorties: */ +/* -------- */ +/* noar : >0 numero de l'arete retrouvee ou ajoutee */ +/* ierr : =0 si pas d'erreur */ +/* =1 si le tableau nosoar est sature */ +/* =2 si arete a creer et appartenant a 2 triangles distincts */ +/* des triangles nt1 et nt2 */ +/* =3 si arete appartenant a 2 triangles distincts */ +/* differents des triangles nt1 et nt2 */ +/* =4 si arete appartenant a 2 triangles distincts */ +/* dont le second n'est pas le triangle nt2 */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* 2345x7..............................................................012 */ + + /* Parameter adjustments */ + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + --noarst; + + /* Function Body */ + *ierr = 0; + +/* ajout eventuel de l'arete s1 s2 dans nosoar */ + nu2sar[0] = *ns1; + nu2sar[1] = *ns2; + +/* hachage de l'arete de sommets nu2sar */ + hasoar_(mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], nu2sar, noar); +/* en sortie: noar>0 => no arete retrouvee */ +/* <0 => no arete ajoutee */ +/* =0 => saturation du tableau nosoar */ + + if (*noar == 0) { + +/* saturation du tableau nosoar */ + //io___13.ciunit = unites_1.imprim; + //s_wsle(&io___13); + //do_lio(&c__9, &c__1, "fasoar: tableau nosoar sature", (ftnlen)29); + //e_wsle(); + *ierr = 1; + return 0; + + } else if (*noar < 0) { + +/* l'arete a ete ajoutee. initialisation des autres informations */ + *noar = -(*noar); +/* le numero de la ligne de l'arete */ + nosoar[*noar * nosoar_dim1 + 3] = *nolign; +/* le triangle 1 de l'arete => le triangle nt1 */ + nosoar[*noar * nosoar_dim1 + 4] = *nt1; +/* le triangle 2 de l'arete => le triangle nt2 */ + nosoar[*noar * nosoar_dim1 + 5] = *nt2; +/* le chainage est mis a -1 */ + nosoar[*noar * nosoar_dim1 + 6] = -1; + +/* le sommet appartient a l'arete noar */ + noarst[nu2sar[0]] = *noar; + noarst[nu2sar[1]] = *noar; + + } else { + +/* l'arete a ete retrouvee. */ +/* si elle appartient a 2 triangles differents de nt1 et nt2 */ +/* alors il y a une erreur */ + if (nosoar[*noar * nosoar_dim1 + 4] > 0 && nosoar[*noar * nosoar_dim1 + + 5] > 0) { + if (nosoar[*noar * nosoar_dim1 + 4] != *nt1 && nosoar[*noar * + nosoar_dim1 + 4] != *nt2 || nosoar[*noar * nosoar_dim1 + + 5] != *nt1 && nosoar[*noar * nosoar_dim1 + 5] != *nt2) { +/* arete appartenant a plus de 2 triangles => erreur */ + if (*ierr >= 0) { + // io___14.ciunit = unites_1.imprim; + // s_wsle(&io___14); + // do_lio(&c__9, &c__1, "erreur fasoar: arete ", (ftnlen)21); + // do_lio(&c__3, &c__1, (char *)&(*noar), (ftnlen)sizeof( + // integer)); + // do_lio(&c__9, &c__1, " dans 2 triangles", (ftnlen)17); + // do_lio(&c__3, &c__1, (char *)&nosoar[*noar * nosoar_dim1 + // + 4], (ftnlen)sizeof(integer)); + // do_lio(&c__3, &c__1, (char *)&nosoar[*noar * nosoar_dim1 + // + 5], (ftnlen)sizeof(integer)); + // do_lio(&c__9, &c__1, " et ajouter", (ftnlen)11); + // do_lio(&c__3, &c__1, (char *)&(*nt1), (ftnlen)sizeof( + // integer)); + // do_lio(&c__3, &c__1, (char *)&(*nt2), (ftnlen)sizeof( + // integer)); + // e_wsle(); + // io___15.ciunit = unites_1.imprim; + // s_wsle(&io___15); + // do_lio(&c__9, &c__1, "arete", (ftnlen)5); + // do_lio(&c__3, &c__1, (char *)&(*noar), (ftnlen)sizeof( + // integer)); + // i__1 = *mosoar; + // for (i__ = 1; i__ <= i__1; ++i__) { + //do_lio(&c__3, &c__1, (char *)&nosoar[i__ + *noar * + // nosoar_dim1], (ftnlen)sizeof(integer)); + // } + // e_wsle(); + } + +/* ERREUR. CORRECTION POUR VOIR ... */ + nosoar[*noar * nosoar_dim1 + 4] = *nt1; + nosoar[*noar * nosoar_dim1 + 5] = *nt2; +/* cc ierr = 2 */ +/* cc return */ + } + } + +/* mise a jour du numero des triangles de l'arete noar */ +/* le triangle 2 de l'arete => le triangle nt1 */ + if (nosoar[*noar * nosoar_dim1 + 4] <= 0) { +/* pas de triangle connu pour cette arete */ + n = 4; + } else { +/* deja un triangle connu. ce nouveau est le second */ + if (nosoar[*noar * nosoar_dim1 + 5] > 0 && *nt1 > 0 && nosoar[* + noar * nosoar_dim1 + 5] != *nt1) { +/* arete appartenant a plus de 2 triangles => erreur */ + //io___18.ciunit = unites_1.imprim; + //s_wsle(&io___18); + //do_lio(&c__9, &c__1, "erreur fasoar: arete ", (ftnlen)21); + //do_lio(&c__3, &c__1, (char *)&(*noar), (ftnlen)sizeof(integer) + // ); + //do_lio(&c__9, &c__1, " dans triangles", (ftnlen)15); + //do_lio(&c__3, &c__1, (char *)&nosoar[*noar * nosoar_dim1 + 4], + // (ftnlen)sizeof(integer)); + //do_lio(&c__3, &c__1, (char *)&nosoar[*noar * nosoar_dim1 + 5], + // (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " et ajouter triangle", (ftnlen)20); + //do_lio(&c__3, &c__1, (char *)&(*nt1), (ftnlen)sizeof(integer)) + // ; + //e_wsle(); + *ierr = 3; + return 0; + } + n = 5; + } + nosoar[n + *noar * nosoar_dim1] = *nt1; + +/* cas de l'arete frontaliere retrouvee comme diagonale d'un quadrangle */ + if (*nt2 > 0) { +/* l'arete appartient a 2 triangles */ + if (nosoar[*noar * nosoar_dim1 + 5] > 0 && nosoar[*noar * + nosoar_dim1 + 5] != *nt2) { +/* arete appartenant a plus de 2 triangles => erreur */ + //io___19.ciunit = unites_1.imprim; + //s_wsle(&io___19); + //do_lio(&c__9, &c__1, "erreur fasoar: arete ", (ftnlen)21); + //do_lio(&c__3, &c__1, (char *)&(*noar), (ftnlen)sizeof(integer) + // ); + //do_lio(&c__9, &c__1, " de st", (ftnlen)6); + //do_lio(&c__3, &c__1, (char *)&nosoar[*noar * nosoar_dim1 + 1], + // (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, "-", (ftnlen)1); + //do_lio(&c__3, &c__1, (char *)&nosoar[*noar * nosoar_dim1 + 2], + // (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " dans plus de 2 triangles", (ftnlen)25); + //e_wsle(); + *ierr = 4; + return 0; + } + nosoar[*noar * nosoar_dim1 + 5] = *nt2; + } + + } + +/* pas d'erreur */ + *ierr = 0; + return 0; +} /* fasoar_ */ + +/* Subroutine */ int fq1inv_(real *x, real *y, real *s, real *xc, real *yc, + integer *ierr) +{ + /* System generated locals */ + real r__1, r__2; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + static doublereal a, b, c__, d__; + static integer i__; + static doublereal t[2], u, v, w, x0, y0, beta; + static real dist[2]; + static doublereal gamma, alpha, delta; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : calcul des 2 coordonnees (xc,yc) dans le carre (0,1) */ +/* ----- image par f:carre unite-->quadrangle appartenant a q1**2 */ +/* par une resolution directe due a Nicolas Thenault */ + +/* entrees: */ +/* -------- */ +/* x,y : coordonnees du point image dans le quadrangle de sommets s */ +/* s : les 2 coordonnees des 4 sommets du quadrangle */ + +/* sorties: */ +/* -------- */ +/* xc,yc : coordonnees dans le carre dont l'image par f vaut (x,y) */ +/* ierr : 0 si calcul sans erreur, 1 si quadrangle degenere */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteurs: thenault tulenew analyse numerique paris janvier 1998 */ +/* modifs : perronnet alain analyse numerique paris janvier 1998 */ +/* 234567..............................................................012 */ + + /* Parameter adjustments */ + s -= 3; + + /* Function Body */ + a = s[3]; + b = s[5] - s[3]; + c__ = s[9] - s[3]; + d__ = s[3] - s[5] + s[7] - s[9]; + + alpha = s[4]; + beta = s[6] - s[4]; + gamma = s[10] - s[4]; + delta = s[4] - s[6] + s[8] - s[10]; + + u = beta * c__ - b * gamma; + if (u == 0.) { +/* quadrangle degenere */ + *ierr = 1; + return 0; + } + v = delta * c__ - d__ * gamma; + w = b * delta - beta * d__; + + x0 = c__ * (*y - alpha) - gamma * (*x - a); + y0 = b * (*y - alpha) - beta * (*x - a); + + a = v * w; + b = u * u - w * x0 - v * y0; + c__ = x0 * y0; + + if (a != 0.) { + + delta = sqrt(b * b - a * 4 * c__); + if (b >= 0.f) { + t[1] = -b - delta; + } else { + t[1] = -b + delta; + } +/* la racine de plus grande valeur absolue */ +/* (elle donne le plus souvent le point exterieur au carre unite */ +/* donc a tester en second pour reduire les calculs) */ + t[1] /= a * 2; +/* calcul de la seconde racine a partir de la somme => plus stable */ + t[0] = -b / a - t[1]; + + for (i__ = 1; i__ <= 2; ++i__) { + +/* la solution i donne t elle un point interne au carre unite? */ + *xc = (x0 - v * t[i__ - 1]) / u; + *yc = (w * t[i__ - 1] - y0) / u; + if (0.f <= *xc && *xc <= 1.f) { + if (0.f <= *yc && *yc <= 1.f) { + goto L9000; + } + } + +/* le point (xc,yc) n'est pas dans le carre unite */ +/* cela peut etre du aux erreurs d'arrondi */ +/* => choix par le minimum de la distance aux bords du carre */ +/* Computing MAX */ + r__1 = 0.f, r__2 = -(*xc), r__1 = max(r__1,r__2), r__2 = *xc - + 1.f, r__1 = max(r__1,r__2), r__2 = -(*yc), r__1 = max( + r__1,r__2), r__2 = *yc - 1.f; + dist[i__ - 1] = dmax(r__1,r__2); + +/* L10: */ + } + + if (dist[0] > dist[1]) { +/* f(xc,yc) pour la racine 2 est plus proche de x,y */ +/* xc yc sont deja calcules */ + goto L9000; + } + + } else if (b != 0.) { + t[0] = -c__ / b; + } else { + t[0] = 0.; + } + +/* les 2 coordonnees du point dans le carre unite */ + *xc = (x0 - v * t[0]) / u; + *yc = (w * t[0] - y0) / u; + +L9000: + *ierr = 0; + return 0; +} /* fq1inv_ */ + +/* Subroutine */ int ptdatr_(doublereal *point, doublereal *pxyd, integer * + nosotr, integer *nsigne) +{ + /* System generated locals */ + doublereal d__1, d__2; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + static doublereal d__; + static integer i__, n, n1, n2, n3; + static doublereal x1, x2, x3, y1, y2, y3, dd, xp, yp, cb1, cb2, cb3; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : le point est il dans le triangle de sommets nosotr */ +/* ----- */ + +/* entrees: */ +/* -------- */ +/* point : les 2 coordonnees du point */ +/* pxyd : les 2 coordonnees et distance souhaitee des points du maillage */ +/* nosotr : le numero des 3 sommets du triangle */ + +/* sorties: */ +/* -------- */ +/* nsigne : >0 si le point est dans le triangle ou sur une des 3 aretes */ +/* =0 si le triangle est degenere ou indirect ou ne contient pas le poin */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* ....................................................................012 */ + + /* Parameter adjustments */ + --nosotr; + pxyd -= 4; + --point; + + /* Function Body */ + xp = point[1]; + yp = point[2]; + + n1 = nosotr[1]; + x1 = pxyd[n1 * 3 + 1]; + y1 = pxyd[n1 * 3 + 2]; + + n2 = nosotr[2]; + x2 = pxyd[n2 * 3 + 1]; + y2 = pxyd[n2 * 3 + 2]; + + n3 = nosotr[3]; + x3 = pxyd[n3 * 3 + 1]; + y3 = pxyd[n3 * 3 + 2]; + +/* 2 fois la surface du triangle = determinant de la matrice */ +/* de calcul des coordonnees barycentriques du point p */ + d__ = (x2 - x1) * (y3 - y1) - (x3 - x1) * (y2 - y1); + + if (d__ > 0.) { + +/* triangle non degenere */ +/* ===================== */ +/* calcul des 3 coordonnees barycentriques du */ +/* point xp yp dans le triangle */ + cb1 = ((x2 - xp) * (y3 - yp) - (x3 - xp) * (y2 - yp)) / d__; + cb2 = ((x3 - xp) * (y1 - yp) - (x1 - xp) * (y3 - yp)) / d__; + cb3 = 1. - cb1 - cb2; +/* cc cb3 = ( ( x1-xp ) * ( y2-yp ) - ( x2-xp ) * ( y1-yp ) ) / d */ + +/* cc if( cb1 .ge. -0.00005d0 .and. cb1 .le. 1.00005d0 .and. */ + if (cb1 >= 0. && cb1 <= 1. && cb2 >= 0. && cb2 <= 1. && cb3 >= 0. && + cb3 <= 1.) { + +/* le triangle nosotr contient le point */ + *nsigne = 1; + } else { + *nsigne = 0; + } + + } else { + +/* triangle degenere */ +/* ================= */ +/* le point est il du meme cote que le sommet oppose de chaque arete? */ + *nsigne = 0; + for (i__ = 1; i__ <= 3; ++i__) { +/* le sinus de l'angle p1 p2-p1 point */ + x1 = pxyd[n1 * 3 + 1]; + y1 = pxyd[n1 * 3 + 2]; + d__ = (pxyd[n2 * 3 + 1] - x1) * (point[2] - y1) - (pxyd[n2 * 3 + + 2] - y1) * (point[1] - x1); + dd = (pxyd[n2 * 3 + 1] - x1) * (pxyd[n3 * 3 + 2] - y1) - (pxyd[n2 + * 3 + 2] - y1) * (pxyd[n3 * 3 + 1] - x1); +/* Computing 2nd power */ + d__1 = pxyd[n2 * 3 + 1] - x1; +/* Computing 2nd power */ + d__2 = pxyd[n2 * 3 + 2] - y1; + cb1 = d__1 * d__1 + d__2 * d__2; +/* Computing 2nd power */ + d__1 = point[1] - x1; +/* Computing 2nd power */ + d__2 = point[2] - y1; + cb2 = d__1 * d__1 + d__2 * d__2; +/* Computing 2nd power */ + d__1 = pxyd[n3 * 3 + 1] - x1; +/* Computing 2nd power */ + d__2 = pxyd[n3 * 3 + 2] - y1; + cb3 = d__1 * d__1 + d__2 * d__2; + if (abs(dd) <= sqrt(cb1 * cb3) * 1e-4f) { +/* le point 3 est sur l'arete 1-2 */ +/* le point doit y etre aussi */ + if (abs(d__) <= sqrt(cb1 * cb2) * 1e-4f) { +/* point sur l'arete */ + ++(*nsigne); + } + } else { +/* le point 3 n'est pas sur l'arete . test des signes */ + if (d__ * dd >= 0.) { + ++(*nsigne); + } + } +/* permutation circulaire des 3 sommets et aretes */ + n = n1; + n1 = n2; + n2 = n3; + n3 = n; +/* L10: */ + } + if (*nsigne != 3) { + *nsigne = 0; + } + } + return 0; +} /* ptdatr_ */ + +integer nosstr_(doublereal *p, doublereal *pxyd, integer *nt, integer *letree) +{ + /* System generated locals */ + integer ret_val; + + /* Local variables */ + static doublereal d__, x1, y1, x21, y21, x31, y31, xe, ye; + static integer ns1, ns2, ns3; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : calculer le numero 0 a 3 du sous-triangle te contenant */ +/* ----- le point p */ + +/* entrees: */ +/* -------- */ +/* p : point de r**2 contenu dans le te nt de letree */ +/* pxyd : x y distance des points */ +/* nt : numero letree du te de te voisin a calculer */ +/* letree : arbre-4 des triangles equilateraux (te) fond de la triangulation */ +/* letree(0,0) no du 1-er te vide dans letree */ +/* letree(0,1) : maximum du 1-er indice de letree (ici 8) */ +/* letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree) */ +/* letree(0:8,1) : racine de l'arbre (triangle sans sur triangle) */ +/* si letree(0,.)>0 alors */ +/* letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j */ +/* sinon */ +/* letree(0:3,j) :-no pxyd des 1 …a 4 points internes au triangle j */ +/* 0 si pas de point */ +/* ( j est alors une feuille de l'arbre ) */ +/* letree(4,j) : no letree du sur-triangle du triangle j */ +/* letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle */ +/* letree(6:8,j) : no pxyd des 3 sommets du triangle j */ + +/* sorties : */ +/* --------- */ +/* nosstr : 0 si le sous-triangle central contient p */ +/* i =1,2,3 numero du sous-triangle contenant p */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc fevrier 1992 */ +/* 2345x7..............................................................012 */ + +/* le numero des 3 sommets du triangle */ + /* Parameter adjustments */ + pxyd -= 4; + --p; + + /* Function Body */ + ns1 = letree[*nt * 9 + 6]; + ns2 = letree[*nt * 9 + 7]; + ns3 = letree[*nt * 9 + 8]; + +/* les coordonnees entre 0 et 1 du point p */ + x1 = pxyd[ns1 * 3 + 1]; + y1 = pxyd[ns1 * 3 + 2]; + + x21 = pxyd[ns2 * 3 + 1] - x1; + y21 = pxyd[ns2 * 3 + 2] - y1; + + x31 = pxyd[ns3 * 3 + 1] - x1; + y31 = pxyd[ns3 * 3 + 2] - y1; + + d__ = 1.f / (x21 * y31 - x31 * y21); + + xe = ((p[1] - x1) * y31 - (p[2] - y1) * x31) * d__; + ye = ((p[2] - y1) * x21 - (p[1] - x1) * y21) * d__; + + if (xe > .5) { +/* sous-triangle droit */ + ret_val = 2; + } else if (ye > .5) { +/* sous-triangle haut */ + ret_val = 3; + } else if (xe + ye < .5) { +/* sous-triangle gauche */ + ret_val = 1; + } else { +/* sous-triangle central */ + ret_val = 0; + } + return ret_val; +} /* nosstr_ */ + +integer notrpt_(doublereal *p, doublereal *pxyd, integer *notrde, integer * + letree) +{ + /* System generated locals */ + integer ret_val; + + /* Local variables */ + static integer nsot; + extern integer nosstr_(doublereal *, doublereal *, integer *, integer *); + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : calculer le numero letree du sous-triangle feuille contenant */ +/* ----- le point p a partir du te notrde de letree */ + +/* entrees: */ +/* -------- */ +/* p : point de r**2 contenu dans le te nt de letree */ +/* pxyd : x y distance des points */ +/* notrde : numero letree du triangle depart de recherche (1=>racine) */ +/* letree : arbre-4 des triangles equilateraux (te) fond de la triangulation */ +/* letree(0,0) no du 1-er te vide dans letree */ +/* letree(0,1) : maximum du 1-er indice de letree (ici 8) */ +/* letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree) */ +/* letree(0:8,1) : racine de l'arbre (triangle sans sur triangle) */ +/* si letree(0,.)>0 alors */ +/* letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j */ +/* sinon */ +/* letree(0:3,j) :-no pxyd des 1 … 4 points internes au triangle j */ +/* 0 si pas de point */ +/* ( j est alors une feuille de l'arbre ) */ +/* letree(4,j) : no letree du sur-triangle du triangle j */ +/* letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle */ +/* letree(6:8,j) : no pxyd des 3 sommets du triangle j */ + +/* sorties : */ +/* --------- */ +/* notrpt : numero letree du triangle contenant le point p */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc fevrier 1992 */ +/* 2345x7..............................................................012 */ + +/* la racine depart de la recherche */ + /* Parameter adjustments */ + pxyd -= 4; + --p; + + /* Function Body */ + ret_val = *notrde; + +/* tant que la feuille n'est pas atteinte descendre l'arbre */ +L10: + if (letree[ret_val * 9] > 0) { + +/* recherche du sous-triangle contenant p */ + nsot = nosstr_(&p[1], &pxyd[4], &ret_val, letree); + +/* le numero letree du sous-triangle */ + ret_val = letree[nsot + ret_val * 9]; + goto L10; + + } + return ret_val; +} /* notrpt_ */ + +/* Subroutine */ int teajpt_(integer *ns, integer *nbsomm, integer *mxsomm, + doublereal *pxyd, integer *letree, integer *ntrp, integer *ierr) +{ + static integer i__; + extern /* Subroutine */ int te4ste_(integer *, integer *, doublereal *, + integer *, integer *, integer *); + extern integer notrpt_(doublereal *, doublereal *, integer *, integer *); + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : ajout du point ns de pxyd dans letree */ +/* ----- */ + +/* entrees: */ +/* -------- */ +/* ns : numero du point a ajouter dans letree */ +/* mxsomm : nombre maximal de points declarables dans pxyd */ +/* pxyd : tableau des coordonnees des points */ +/* par point : x y distance_souhaitee */ + +/* modifies : */ +/* ---------- */ +/* nbsomm : nombre actuel de points dans pxyd */ + +/* letree : arbre-4 des triangles equilateraux (te) fond de la triangulation */ +/* letree(0,0) : no du 1-er te vide dans letree */ +/* letree(0,1) : maximum du 1-er indice de letree (ici 8) */ +/* letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree) */ +/* letree(0:8,1) : racine de l'arbre (triangle sans sur triangle) */ +/* si letree(0,.)>0 alors */ +/* letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j */ +/* sinon */ +/* letree(0:3,j) :-no pxyd des 1 …a 4 points internes au triangle j */ +/* 0 si pas de point */ +/* ( j est alors une feuille de l'arbre ) */ +/* letree(4,j) : no letree du sur-triangle du triangle j */ +/* letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle */ +/* letree(6:8,j) : no pxyd des 3 sommets du triangle j */ + +/* sorties : */ +/* --------- */ +/* ntrp : numero letree du triangle te ou a ete ajoute le point */ +/* ierr : 0 si pas d'erreur, 51 saturation letree, 52 saturation pxyd */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc fevrier 1992 */ +/* 2345x7..............................................................012 */ + +/* depart de la racine */ + /* Parameter adjustments */ + pxyd -= 4; + + /* Function Body */ + *ntrp = 1; + +/* recherche du triangle contenant le point pxyd(ns) */ +L1: + *ntrp = notrpt_(&pxyd[*ns * 3 + 1], &pxyd[4], ntrp, letree); + +/* existe t il un point libre */ + for (i__ = 0; i__ <= 3; ++i__) { + if (letree[i__ + *ntrp * 9] == 0) { +/* la place i est libre */ + letree[i__ + *ntrp * 9] = -(*ns); + *ierr = 0; + return 0; + } +/* L10: */ + } + +/* pas de place libre => 4 sous-triangles sont crees */ +/* a partir des 3 milieux des aretes */ + te4ste_(nbsomm, mxsomm, &pxyd[4], ntrp, letree, ierr); + if (*ierr != 0) { + return 0; + } + +/* ajout du point ns */ + goto L1; +} /* teajpt_ */ + +/* Subroutine */ int n1trva_(integer *nt, integer *lar, integer *letree, + integer *notrva, integer *lhpile) +{ + static integer ntr, nty, nsut; + extern integer nopre3_(integer *), nosui3_(integer *); + static integer lapile[64]; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : calculer le numero letree du triangle voisin du te nt */ +/* ----- par l'arete lar (1 a 3 ) de nt */ +/* attention : notrva n'est pas forcement minimal */ + +/* entrees: */ +/* -------- */ +/* nt : numero letree du te de te voisin a calculer */ +/* lar : numero 1 a 3 de l'arete du triangle nt */ +/* letree : arbre-4 des triangles equilateraux (te) fond de la triangulation */ +/* letree(0,0) no du 1-er te vide dans letree */ +/* letree(0,1) : maximum du 1-er indice de letree (ici 8) */ +/* letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree) */ +/* letree(0:8,1) : racine de l'arbre (triangle sans sur-triangle) */ +/* si letree(0,.)>0 alors */ +/* letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j */ +/* sinon */ +/* letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j */ +/* 0 si pas de point */ +/* ( j est alors une feuille de l'arbre ) */ +/* letree(4,j) : no letree du sur-triangle du triangle j */ +/* letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle */ +/* letree(6:8,j) : no pxyd des 3 sommets du triangle j */ + +/* sorties : */ +/* --------- */ +/* notrva : >0 numero letree du te voisin par l'arete lar */ +/* =0 si pas de te voisin (racine , ... ) */ +/* lhpile : =0 si nt et notrva ont meme taille */ +/* >0 nt est 4**lhpile fois plus petit que notrva */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc fevrier 1992 */ +/* 2345x7..............................................................012 */ + +/* initialisation de la pile */ +/* le triangle est empile */ + lapile[0] = *nt; + *lhpile = 1; + +/* tant qu'il existe un sur-triangle */ +L10: + ntr = lapile[*lhpile - 1]; + if (ntr == 1) { +/* racine atteinte => pas de triangle voisin */ + *notrva = 0; + --(*lhpile); + return 0; + } + +/* le type du triangle ntr */ + nty = letree[ntr * 9 + 5]; +/* l'eventuel sur-triangle */ + nsut = letree[ntr * 9 + 4]; + + if (nty == 0) { + +/* triangle de type 0 => triangle voisin de type precedent(lar) */ +/* dans le sur-triangle de ntr */ +/* ce triangle remplace ntr dans lapile */ + lapile[*lhpile - 1] = letree[nopre3_(lar) + nsut * 9]; + goto L20; + } + +/* triangle ntr de type nty>0 */ + if (nosui3_(&nty) == *lar) { + +/* le triangle voisin par lar est le triangle 0 */ + lapile[*lhpile - 1] = letree[nsut * 9]; + goto L20; + } + +/* triangle sans voisin direct => passage par le sur-triangle */ + if (nsut == 0) { + +/* ntr est la racine => pas de triangle voisin par cette arete */ + *notrva = 0; + return 0; + } else { + +/* le sur-triangle est empile */ + ++(*lhpile); + lapile[*lhpile - 1] = nsut; + goto L10; + } + +/* descente aux sous-triangles selon la meme arete */ +L20: + *notrva = lapile[*lhpile - 1]; + +L30: + --(*lhpile); + if (letree[*notrva * 9] <= 0) { +/* le triangle est une feuille de l'arbre 0 sous-triangle */ +/* lhpile = nombre de differences de niveaux dans l'arbre */ + return 0; + } else { +/* le triangle a 4 sous-triangles */ + if (*lhpile > 0) { + +/* bas de pile non atteint */ + nty = letree[lapile[*lhpile - 1] * 9 + 5]; + if (nty == *lar) { +/* l'oppose est suivant(nty) de notrva */ + *notrva = letree[nosui3_(&nty) + *notrva * 9]; + } else { +/* l'oppose est precedent(nty) de notrva */ + *notrva = letree[nopre3_(&nty) + *notrva * 9]; + } + goto L30; + } + } + +/* meme niveau dans l'arbre lhpile = 0 */ + return 0; +} /* n1trva_ */ + +/* Subroutine */ int cenced_(doublereal *xy1, doublereal *xy2, doublereal * + xy3, doublereal *cetria, integer *ierr) +{ + /* Format strings */ + static char fmt_10000[] = "(3(\002 x=\002,g24.16,\002 y=\002,g24.16/)" + ",\002 aire*2=\002,g24.16)"; + + /* System generated locals */ + doublereal d__1, d__2; + + /* Builtin functions */ + /* integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + e_wsle(void), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), + e_wsfe(void);*/ + + /* Local variables */ + static doublereal x1, y1, x21, y21, x31, y31, xc, yc, rot, aire2; + + /* Fortran I/O blocks */ + static cilist io___79 = { 0, 0, 0, 0, 0 }; + static cilist io___80 = { 0, 0, 0, fmt_10000, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : calcul des coordonnees du centre du cercle circonscrit */ +/* ----- du triangle defini par ses 3 sommets de coordonnees */ +/* xy1 xy2 xy3 ainsi que le carre du rayon de ce cercle */ + +/* entrees : */ +/* --------- */ +/* xy1 xy2 xy3 : les 2 coordonnees des 3 sommets du triangle */ +/* ierr : <0 => pas d'affichage si triangle degenere */ +/* >=0 => affichage si triangle degenere */ + +/* sortie : */ +/* -------- */ +/* cetria : cetria(1)=abcisse du centre */ +/* cetria(2)=ordonnee du centre */ +/* cetria(3)=carre du rayon 1d28 si triangle degenere */ +/* ierr : 0 si triangle non degenere */ +/* 1 si triangle degenere */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : perronnet alain upmc analyse numerique paris juin 1995 */ +/* 2345x7..............................................................012 */ + +/* le calcul de 2 fois l'aire du triangle */ +/* attention l'ordre des 3 sommets est direct ou non */ + /* Parameter adjustments */ + --cetria; + --xy3; + --xy2; + --xy1; + + /* Function Body */ + x1 = xy1[1]; + x21 = xy2[1] - x1; + x31 = xy3[1] - x1; + + y1 = xy1[2]; + y21 = xy2[2] - y1; + y31 = xy3[2] - y1; + + aire2 = x21 * y31 - x31 * y21; + +/* recherche d'un test relatif peu couteux */ +/* pour reperer la degenerescence du triangle */ + if (abs(aire2) <= (abs(x21) + abs(x31)) * 1e-7f * (abs(y21) + abs(y31))) { +/* triangle de qualite trop faible */ + if (*ierr >= 0) { +/* nblgrc(nrerr) = 1 */ +/* kerr(1) = 'erreur cenced: triangle degenere' */ +/* call lereur */ + //io___79.ciunit = unites_1.imprim; + //s_wsle(&io___79); + //do_lio(&c__9, &c__1, "erreur cenced: triangle degenere", (ftnlen) + // 32); + //e_wsle(); + //io___80.ciunit = unites_1.imprim; + //s_wsfe(&io___80); + //do_fio(&c__2, (char *)&xy1[1], (ftnlen)sizeof(doublereal)); + //do_fio(&c__2, (char *)&xy2[1], (ftnlen)sizeof(doublereal)); + //do_fio(&c__2, (char *)&xy3[1], (ftnlen)sizeof(doublereal)); + //do_fio(&c__1, (char *)&aire2, (ftnlen)sizeof(doublereal)); + //e_wsfe(); + } + cetria[1] = 0.; + cetria[2] = 0.; + cetria[3] = 1e28; + *ierr = 1; + return 0; + } + +/* les 2 coordonnees du centre intersection des 2 mediatrices */ +/* x = (x1+x2)/2 + lambda * (y2-y1) */ +/* y = (y1+y2)/2 - lambda * (x2-x1) */ +/* x = (x1+x3)/2 + rot * (y3-y1) */ +/* y = (y1+y3)/2 - rot * (x3-x1) */ +/* ========================================================== */ + rot = ((xy2[1] - xy3[1]) * x21 + (xy2[2] - xy3[2]) * y21) / (aire2 * 2); + + xc = (x1 + xy3[1]) * .5 + rot * y31; + yc = (y1 + xy3[2]) * .5 - rot * x31; + + cetria[1] = xc; + cetria[2] = yc; + +/* le carre du rayon */ +/* Computing 2nd power */ + d__1 = x1 - xc; +/* Computing 2nd power */ + d__2 = y1 - yc; + cetria[3] = d__1 * d__1 + d__2 * d__2; + +/* pas d'erreur rencontree */ + *ierr = 0; + return 0; +} /* cenced_ */ + +doublereal angled_(doublereal *p1, doublereal *p2, doublereal *p3) +{ + /* System generated locals */ + doublereal ret_val; + + /* Builtin functions */ + double sqrt(doublereal), atan(doublereal), acos(doublereal); + + /* Local variables */ + static doublereal c__, d__, a1, a2, x21, y21, x31, y31; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : calculer l'angle (p1p2,p1p3) en radians */ +/* ----- */ + +/* entrees : */ +/* --------- */ +/* p1,p2,p3 : les 2 coordonnees des 3 sommets de l'angle */ +/* sens direct pour une surface >0 */ +/* sorties : */ +/* --------- */ +/* angled : angle (p1p2,p1p3) en radians entre [0 et 2pi] */ +/* 0 si p1=p2 ou p1=p3 */ +/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique upmc paris fevrier 1992 */ +/* 2345x7..............................................................012 */ + +/* les cotes */ + /* Parameter adjustments */ + --p3; + --p2; + --p1; + + /* Function Body */ + x21 = p2[1] - p1[1]; + y21 = p2[2] - p1[2]; + x31 = p3[1] - p1[1]; + y31 = p3[2] - p1[2]; + +/* longueur des cotes */ + a1 = x21 * x21 + y21 * y21; + a2 = x31 * x31 + y31 * y31; + d__ = sqrt(a1 * a2); + if (d__ == 0.) { + ret_val = 0.; + return ret_val; + } + +/* cosinus de l'angle */ + c__ = (x21 * x31 + y21 * y31) / d__; + if (c__ <= -1.) { +/* tilt sur apollo si acos( -1 -eps ) */ + ret_val = atan(1.) * 4.; + return ret_val; + } else if (c__ >= 1.) { +/* tilt sur apollo si acos( 1 + eps ) */ + ret_val = 0.; + return ret_val; + } + + ret_val = acos(c__); + if (x21 * y31 - x31 * y21 < 0.) { +/* demi plan inferieur */ + ret_val = atan(1.) * 8. - ret_val; + } + return ret_val; +} /* angled_ */ + +/* Subroutine */ int teajte_(integer *mxsomm, integer *nbsomm, doublereal * + pxyd, doublereal *comxmi, doublereal *aretmx, integer *mxtree, + integer *letree, integer *ierr) +{ + /* System generated locals */ + integer i__1; + doublereal d__1, d__2; + + /* Builtin functions */ + double sqrt(doublereal); + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static doublereal a[2]; + static integer i__, k; + static doublereal s; + static integer nt; + static doublereal rac3; + static real arete; + extern /* Subroutine */ int teajpt_(integer *, integer *, integer *, + doublereal *, integer *, integer *, integer *); + static integer nbsofr, imprim; + + /* Fortran I/O blocks */ + static cilist io___98 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : initialisation des tableaux letree */ +/* ----- ajout des sommets 1 a nbsomm (valeur en entree) dans letree */ + +/* entrees: */ +/* -------- */ +/* mxsomm : nombre maximal de sommets permis pour la triangulation */ +/* mxtree : nombre maximal de triangles equilateraux (te) declarables */ +/* aretmx : longueur maximale des aretes des triangles equilateraux */ + +/* entrees et sorties : */ +/* -------------------- */ +/* nbsomm : nombre de sommets apres identification */ +/* pxyd : tableau des coordonnees 2d des points */ +/* par point : x y distance_souhaitee */ +/* tableau reel(3,mxsomm) */ + +/* sorties: */ +/* -------- */ +/* comxmi : coordonnees minimales et maximales des points frontaliers */ +/* letree : arbre-4 des triangles equilateraux (te) fond de la triangulation */ +/* letree(0,0) : no du 1-er te vide dans letree */ +/* letree(0,1) : maximum du 1-er indice de letree (ici 8) */ +/* letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree) */ +/* letree(0:8,1) : racine de l'arbre (triangle sans sur triangle) */ +/* si letree(0,.)>0 alors */ +/* letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j */ +/* sinon */ +/* letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j */ +/* 0 si pas de point */ +/* ( j est alors une feuille de l'arbre ) */ +/* letree(4,j) : no letree du sur-triangle du triangle j */ +/* letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle */ +/* letree(6:8,j) : no pxyd des 3 sommets du triangle j */ + +/* ierr : 0 si pas d'erreur */ +/* 51 saturation letree */ +/* 52 saturation pxyd */ +/* 7 tous les points sont alignes */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc juillet 1994 */ +/* ....................................................................012 */ + +/* protection du nombre de sommets avant d'ajouter ceux de tetree */ + /* Parameter adjustments */ + pxyd -= 4; + comxmi -= 4; + + /* Function Body */ + *ierr = 0; + nbsofr = *nbsomm; + i__1 = *nbsomm; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MIN */ + d__1 = comxmi[4], d__2 = pxyd[i__ * 3 + 1]; + comxmi[4] = min(d__1,d__2); +/* Computing MAX */ + d__1 = comxmi[7], d__2 = pxyd[i__ * 3 + 1]; + comxmi[7] = max(d__1,d__2); +/* Computing MIN */ + d__1 = comxmi[5], d__2 = pxyd[i__ * 3 + 2]; + comxmi[5] = min(d__1,d__2); +/* Computing MAX */ + d__1 = comxmi[8], d__2 = pxyd[i__ * 3 + 2]; + comxmi[8] = max(d__1,d__2); +/* L1: */ + } + +/* creation de l'arbre letree */ +/* ========================== */ +/* la premiere colonne vide de letree */ + letree[0] = 2; +/* chainage des te vides */ + i__1 = *mxtree; + for (i__ = 2; i__ <= i__1; ++i__) { + letree[i__ * 9] = i__ + 1; +/* L4: */ + } + letree[*mxtree * 9] = 0; +/* les maxima des 2 indices de letree */ + letree[1] = 8; + letree[2] = *mxtree; + +/* la racine */ +/* aucun point interne au triangle equilateral (te) 1 */ + letree[9] = 0; + letree[10] = 0; + letree[11] = 0; + letree[12] = 0; +/* pas de sur-triangle */ + letree[13] = 0; + letree[14] = 0; +/* le numero pxyd des 3 sommets du te 1 */ + letree[15] = *nbsomm + 1; + letree[16] = *nbsomm + 2; + letree[17] = *nbsomm + 3; + +/* calcul de la largeur et hauteur du rectangle englobant */ +/* ====================================================== */ + a[0] = comxmi[7] - comxmi[4]; + a[1] = comxmi[8] - comxmi[5]; +/* la longueur de la diagonale */ +/* Computing 2nd power */ + d__1 = a[0]; +/* Computing 2nd power */ + d__2 = a[1]; + s = sqrt(d__1 * d__1 + d__2 * d__2); + for (k = 1; k <= 2; ++k) { + if (a[k - 1] < s * 1e-4f) { +/* nblgrc(nrerr) = 1 */ + //io___98.ciunit = imprim; + //s_wsle(&io___98); + //do_lio(&c__9, &c__1, "tous les points sont alignes", (ftnlen)28); + //e_wsle(); +/* call lereur */ + *ierr = 7; + return 0; + } +/* L60: */ + } + +/* le maximum des ecarts */ + s += s; + +/* le triangle equilateral englobant */ +/* ================================= */ +/* ecart du rectangle au triangle equilateral */ + rac3 = sqrt(3.); + arete = a[0] + *aretmx * 2 + (a[1] + *aretmx) * 2 / rac3; + +/* le point nbsomm + 1 en bas a gauche */ + ++(*nbsomm); + pxyd[*nbsomm * 3 + 1] = (comxmi[4] + comxmi[7]) * .5 - arete * .5; + pxyd[*nbsomm * 3 + 2] = comxmi[5] - *aretmx; + pxyd[*nbsomm * 3 + 3] = s; + +/* le point nbsomm + 2 en bas a droite */ + ++(*nbsomm); + pxyd[*nbsomm * 3 + 1] = pxyd[(*nbsomm - 1) * 3 + 1] + arete; + pxyd[*nbsomm * 3 + 2] = pxyd[(*nbsomm - 1) * 3 + 2]; + pxyd[*nbsomm * 3 + 3] = s; + +/* le point nbsomm + 3 sommet au dessus */ + ++(*nbsomm); + pxyd[*nbsomm * 3 + 1] = pxyd[(*nbsomm - 2) * 3 + 1] + arete * .5; + pxyd[*nbsomm * 3 + 2] = pxyd[(*nbsomm - 2) * 3 + 2] + arete * .5 * rac3; + pxyd[*nbsomm * 3 + 3] = s; + +/* ajout des sommets des lignes pour former letree */ +/* =============================================== */ + i__1 = nbsofr; + for (i__ = 1; i__ <= i__1; ++i__) { +/* ajout du point i de pxyd a letree */ + teajpt_(&i__, nbsomm, mxsomm, &pxyd[4], letree, &nt, ierr); + if (*ierr != 0) { + return 0; + } +/* L150: */ + } + + return 0; +} /* teajte_ */ + +/* Subroutine */ int tetaid_(integer *nutysu, doublereal *dx, doublereal *dy, + doublereal *longai, integer *ierr) +{ + /* Format strings */ + static char fmt_10000[] = "(\002attention: longueur de areteideale(\002," + "g14.6,\002,\002,g14.6,\002,\002,g14.6,\002)<=0! => rendue >0\002)" + ; + static char fmt_10001[] = "(\002erreur: longueur de areteideale(\002,g14" + ".6,\002,\002,g14.6,\002,\002,g14.6,\002)=0!\002)"; + + /* Builtin functions */ + //integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); + + /* Local variables */ + static doublereal d0; + extern /* Subroutine */ int areteideale_(doublereal *); + static doublereal xyz[3], xyzd[3]; + + /* Fortran I/O blocks */ + static cilist io___105 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___106 = { 0, 0, 0, fmt_10001, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : calculer la longueur de l'arete ideale longai en dx,dy */ +/* ----- */ +/* entrees: */ +/* -------- */ +/* nutysu : numero de traitement de areteideale() selon le type de surface */ +/* 0 pas d'emploi de la fonction areteideale() => aretmx active */ +/* 1 il existe une fonction areteideale(xyz,xyzdir) */ +/* ... autres options a definir ... */ +/* dx, dy : abscisse et ordonnee dans le plan du point (reel2!) */ + +/* sorties: */ +/* -------- */ +/* longai : longueur de l'areteideale(xyz,xyzdir) autour du point xyz */ +/* ierr : 0 si pas d'erreur, <>0 sinon */ +/* 1 calcul incorrect de areteideale(xyz,xyzdir) */ +/* 2 longueur calculee nulle */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* 2345x7..............................................................012 */ + +/* double precision areteideale */ + + *ierr = 0; + if (*nutysu > 0) { + d0 = *longai; +/* le point ou se calcule la longueur */ + xyz[0] = *dx; + xyz[1] = *dy; +/* z pour le calcul de la longueur (inactif ici!) */ + xyz[2] = 0.; +/* la direction pour le calcul de la longueur (inactif ici!) */ + xyzd[0] = 0.; + xyzd[1] = 0.; + xyzd[2] = 0.; + areteideale_(longai); +/* (xyz,xyzd) */ + if (*longai < 0.) { + //io___105.ciunit = unites_1.imprim; + //s_wsfe(&io___105); + //do_fio(&c__3, (char *)&xyz[0], (ftnlen)sizeof(doublereal)); + //e_wsfe(); + *longai = -(*longai); + } + if (*longai == 0.) { + //io___106.ciunit = unites_1.imprim; + //s_wsfe(&io___106); + //do_fio(&c__3, (char *)&xyz[0], (ftnlen)sizeof(doublereal)); + //e_wsfe(); + *ierr = 2; + *longai = d0; + } + } + return 0; +} /* tetaid_ */ + +/* Subroutine */ int tehote_(integer *nutysu, integer *nbarpi, integer * + mxsomm, integer *nbsomm, doublereal *pxyd, doublereal *comxmi, + doublereal *aretmx, integer *letree, integer *mxqueu, integer *laqueu, + integer *ierr) +{ + /* System generated locals */ + integer i__1; + doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8; + static integer equiv_2[3]; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static doublereal a; + static integer i__, j; + static doublereal s, d2; +#define ns1 (equiv_2) +#define ns2 (equiv_2 + 1) +#define ns3 (equiv_2 + 2) + static integer nte, nbs0; + static doublereal dmin__, dmax__, xrmin, yrmin, xrmax, yrmax; +#define nuste (equiv_2) + static doublereal aretm2; + static integer nbsom0; + extern /* Subroutine */ int te4ste_(integer *, integer *, doublereal *, + integer *, integer *, integer *), n1trva_(integer *, integer *, + integer *, integer *, integer *); + extern integer nosui3_(integer *); + extern /* Subroutine */ int tetaid_(integer *, doublereal *, doublereal *, + doublereal *, integer *); + static integer nbiter, niveau, noteva, lequeu, lhqueu; + extern integer notrpt_(doublereal *, doublereal *, integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___126 = { 0, 0, 0, 0, 0 }; + static cilist io___132 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : homogeneisation de l'arbre des te a un saut de taille au plus */ +/* ----- prise en compte des distances souhaitees autour des sommets initiaux */ + +/* entrees: */ +/* -------- */ +/* nutysu : numero de traitement de areteideale() selon le type de surface */ +/* 0 pas d'emploi de la fonction areteideale() => aretmx active */ +/* 1 il existe une fonction areteideale() */ +/* dont seules les 2 premieres composantes de uv sont actives */ +/* autres options a definir... */ +/* nbarpi : nombre de sommets de la frontiere + nombre de points internes */ +/* imposes par l'utilisateur */ +/* mxsomm : nombre maximal de sommets permis pour la triangulation et te */ +/* mxqueu : nombre d'entiers utilisables dans laqueu */ +/* comxmi : minimum et maximum des coordonnees de l'objet */ +/* aretmx : longueur maximale des aretes des triangles equilateraux */ +/* permtr : perimetre de la ligne enveloppe dans le plan */ +/* avant mise a l'echelle a 2**20 */ + +/* modifies: */ +/* --------- */ +/* nbsomm : nombre de sommets apres identification */ +/* pxyd : tableau des coordonnees 2d des points */ +/* par point : x y distance_souhaitee */ +/* letree : arbre-4 des triangles equilateraux (te) fond de la triangulation */ +/* letree(0,0) : no du 1-er te vide dans letree */ +/* letree(1,0) : maximum du 1-er indice de letree (ici 8) */ +/* letree(2,0) : maximum declare du 2-eme indice de letree (ici mxtree) */ +/* letree(0:8,1) : racine de l'arbre (triangle sans sur triangle) */ +/* si letree(0,.)>0 alors */ +/* letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j */ +/* sinon */ +/* letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j */ +/* 0 si pas de point */ +/* ( j est alors une feuille de l'arbre ) */ +/* letree(4,j) : no letree du sur-triangle du triangle j */ +/* letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle */ +/* letree(6:8,j) : no pxyd des 3 sommets du triangle j */ + +/* auxiliaire : */ +/* ------------ */ +/* laqueu : mxqueu entiers servant de queue pour le parcours de letree */ + +/* sorties: */ +/* -------- */ +/* ierr : 0 si pas d'erreur */ +/* 51 si saturation letree dans te4ste */ +/* 52 si saturation pxyd dans te4ste */ +/* >0 si autre erreur */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc avril 1997 */ +/* 2345x7..............................................................012 */ + + +/* lequeu : entree dans la queue */ +/* lhqueu : longueur de la queue */ +/* gestion circulaire */ + + + /* Parameter adjustments */ + pxyd -= 4; + comxmi -= 4; + --laqueu; + + /* Function Body */ + *ierr = 0; + +/* existence ou non de la fonction 'taille_ideale' des aretes */ +/* autour du point. ici la carte est supposee isotrope */ +/* ========================================================== */ +/* attention: si la fonction taille_ideale existe */ +/* alors pxyd(3,*) est la taille_ideale dans l'espace initial */ +/* sinon pxyd(3,*) est la distance calculee dans le plan par */ +/* propagation a partir des tailles des aretes de la frontiere */ + + if (*nutysu > 0) { + +/* la fonction taille_ideale(x,y,z) existe */ +/* --------------------------------------- */ +/* initialisation de la distance souhaitee autour des points 1 a nbsomm */ + i__1 = *nbsomm; + for (i__ = 1; i__ <= i__1; ++i__) { +/* calcul de pxyzd(3,i) */ + tetaid_(nutysu, &pxyd[i__ * 3 + 1], &pxyd[i__ * 3 + 2], &pxyd[i__ + * 3 + 3], ierr); + if (*ierr != 0) { + goto L9999; + } +/* L1: */ + } + + } else { + +/* la fonction taille_ideale(x,y,z) n'existe pas */ +/* --------------------------------------------- */ +/* prise en compte des distances souhaitees dans le plan */ +/* autour des points frontaliers et des points internes imposes */ +/* toutes les autres distances souhaitees ont ete mis a aretmx */ +/* lors de l'execution du sp teqini */ + i__1 = *nbarpi; + for (i__ = 1; i__ <= i__1; ++i__) { +/* le sommet i n'est pas un sommet de letree => sommet frontalier */ +/* recherche du sous-triangle minimal feuille contenant le point i */ + nte = 1; +L2: + nte = notrpt_(&pxyd[i__ * 3 + 1], &pxyd[4], &nte, letree); +/* la distance au sommet le plus eloigne est elle inferieure */ +/* a la distance souhaitee? */ + *ns1 = letree[nte * 9 + 6]; + *ns2 = letree[nte * 9 + 7]; + *ns3 = letree[nte * 9 + 8]; +/* Computing MAX */ +/* Computing 2nd power */ + d__3 = pxyd[i__ * 3 + 1] - pxyd[*ns1 * 3 + 1]; +/* Computing 2nd power */ + d__4 = pxyd[i__ * 3 + 2] - pxyd[*ns1 * 3 + 2]; +/* Computing 2nd power */ + d__5 = pxyd[i__ * 3 + 1] - pxyd[*ns2 * 3 + 1]; +/* Computing 2nd power */ + d__6 = pxyd[i__ * 3 + 2] - pxyd[*ns2 * 3 + 2]; +/* Computing 2nd power */ + d__7 = pxyd[i__ * 3 + 1] - pxyd[*ns3 * 3 + 1]; +/* Computing 2nd power */ + d__8 = pxyd[i__ * 3 + 2] - pxyd[*ns3 * 3 + 2]; + d__1 = d__3 * d__3 + d__4 * d__4, d__2 = d__5 * d__5 + d__6 * + d__6, d__1 = max(d__1,d__2), d__2 = d__7 * d__7 + d__8 * + d__8; + d2 = max(d__1,d__2); +/* Computing 2nd power */ + d__1 = pxyd[i__ * 3 + 3]; + if (d2 > d__1 * d__1) { +/* le triangle nte trop grand doit etre subdivise en 4 sous-triangle */ + te4ste_(nbsomm, mxsomm, &pxyd[4], &nte, letree, ierr); + if (*ierr != 0) { + return 0; + } + goto L2; + } +/* L3: */ + } + } + +/* le sous-triangle central de la racine est decoupe systematiquement */ +/* ================================================================== */ + nte = 2; + if (letree[18] <= 0) { +/* le sous-triangle central de la racine n'est pas subdivise */ +/* il est donc decoupe en 4 soustriangles */ + nbsom0 = *nbsomm; + te4ste_(nbsomm, mxsomm, &pxyd[4], &nte, letree, ierr); + if (*ierr != 0) { + return 0; + } + i__1 = *nbsomm; + for (i__ = nbsom0 + 1; i__ <= i__1; ++i__) { +/* mise a jour de taille_ideale des nouveaux sommets de te */ + tetaid_(nutysu, &pxyd[i__ * 3 + 1], &pxyd[i__ * 3 + 2], &pxyd[i__ + * 3 + 3], ierr); + if (*ierr != 0) { + goto L9999; + } +/* L4: */ + } + } + +/* le carre de la longueur de l'arete de triangles equilateraux */ +/* souhaitee pour le fond de la triangulation */ +/* Computing 2nd power */ + d__1 = *aretmx * 1.34; + aretm2 = d__1 * d__1; + +/* tout te contenu dans le rectangle englobant doit avoir un */ +/* cote < aretmx et etre de meme taille que les te voisins */ +/* s'il contient un point; sinon un seul saut de taille est permis */ +/* =============================================================== */ +/* le rectangle englobant pour selectionner les te "internes" */ +/* le numero des 3 sommets du te englobant racine de l'arbre des te */ + *ns1 = letree[15]; + *ns2 = letree[16]; + *ns3 = letree[17]; + a = *aretmx * .01; +/* abscisse du milieu de l'arete gauche du te 1 */ + s = (pxyd[*ns1 * 3 + 1] + pxyd[*ns3 * 3 + 1]) / 2; +/* Computing MIN */ + d__1 = s, d__2 = comxmi[4] - *aretmx; + xrmin = min(d__1,d__2) - a; +/* abscisse du milieu de l'arete droite du te 1 */ + s = (pxyd[*ns2 * 3 + 1] + pxyd[*ns3 * 3 + 1]) / 2; +/* Computing MAX */ + d__1 = s, d__2 = comxmi[7] + *aretmx; + xrmax = max(d__1,d__2) + a; + yrmin = comxmi[5] - *aretmx; +/* ordonnee de la droite passant par les milieus des 2 aretes */ +/* droite gauche du te 1 */ + s = (pxyd[*ns1 * 3 + 2] + pxyd[*ns3 * 3 + 2]) / 2; +/* Computing MAX */ + d__1 = s, d__2 = comxmi[8] + *aretmx; + yrmax = max(d__1,d__2) + a; + +/* cas particulier de 3 ou 4 ou peu d'aretes frontalieres */ + if (*nbarpi <= 8) { +/* tout le triangle englobant (racine) est a prendre en compte */ + xrmin = pxyd[*ns1 * 3 + 1] - a; + xrmax = pxyd[*ns2 * 3 + 1] + a; + yrmin = pxyd[*ns1 * 3 + 2] - a; + yrmax = pxyd[*ns3 * 3 + 2] + a; + } + + nbs0 = *nbsomm; + nbiter = -1; + +/* initialisation de la queue */ +L5: + ++nbiter; + lequeu = 1; + lhqueu = 0; +/* la racine de letree initialise la queue */ + laqueu[1] = 1; + +/* tant que la longueur de la queue est >=0 traiter le debut de queue */ +L10: + if (lhqueu >= 0) { + +/* le triangle te a traiter */ + i__ = lequeu - lhqueu; + if (i__ <= 0) { + i__ = *mxqueu + i__; + } + nte = laqueu[i__]; +/* la longueur de la queue est reduite */ + --lhqueu; + +/* nte est il un sous-triangle feuille minimal ? */ +L15: + if (letree[nte * 9] > 0) { + +/* non les 4 sous-triangles sont mis dans la queue */ + if (lhqueu + 4 >= *mxqueu) { + //io___126.ciunit = unites_2.imprim; + //s_wsle(&io___126); + //do_lio(&c__9, &c__1, "tehote: saturation de la queue", ( + // ftnlen)30); + //e_wsle(); + *ierr = 7; + return 0; + } + for (i__ = 3; i__ >= 0; --i__) { +/* ajout du sous-triangle i */ + ++lhqueu; + ++lequeu; + if (lequeu > *mxqueu) { + lequeu -= *mxqueu; + } + laqueu[lequeu] = letree[i__ + nte * 9]; +/* L20: */ + } + goto L10; + + } + +/* ici nte est un triangle minimal non subdivise */ +/* --------------------------------------------- */ +/* le te est il dans le cadre englobant de l'objet ? */ + *ns1 = letree[nte * 9 + 6]; + *ns2 = letree[nte * 9 + 7]; + *ns3 = letree[nte * 9 + 8]; + if (pxyd[*ns1 * 3 + 1] > pxyd[*ns2 * 3 + 1]) { + dmin__ = pxyd[*ns2 * 3 + 1]; + dmax__ = pxyd[*ns1 * 3 + 1]; + } else { + dmin__ = pxyd[*ns1 * 3 + 1]; + dmax__ = pxyd[*ns2 * 3 + 1]; + } + if (xrmin <= dmin__ && dmin__ <= xrmax || xrmin <= dmax__ && dmax__ <= + xrmax) { + if (pxyd[*ns1 * 3 + 2] > pxyd[*ns3 * 3 + 2]) { + dmin__ = pxyd[*ns3 * 3 + 2]; + dmax__ = pxyd[*ns1 * 3 + 2]; + } else { + dmin__ = pxyd[*ns1 * 3 + 2]; + dmax__ = pxyd[*ns3 * 3 + 2]; + } + if (yrmin <= dmin__ && dmin__ <= yrmax || yrmin <= dmax__ && + dmax__ <= yrmax) { + +/* nte est un te feuille et interne au rectangle englobant */ +/* ======================================================= */ +/* le carre de la longueur de l'arete du te de numero nte */ +/* Computing 2nd power */ + d__1 = pxyd[*ns1 * 3 + 1] - pxyd[*ns2 * 3 + 1]; +/* Computing 2nd power */ + d__2 = pxyd[*ns1 * 3 + 2] - pxyd[*ns2 * 3 + 2]; + d2 = d__1 * d__1 + d__2 * d__2; + + if (*nutysu == 0) { + +/* il n'existe pas de fonction 'taille_ideale' */ +/* ------------------------------------------- */ +/* si la taille effective de l'arete du te est superieure a aretmx */ +/* alors le te est decoupe */ + if (d2 > aretm2) { +/* le triangle nte trop grand doit etre subdivise */ +/* en 4 sous-triangles */ + te4ste_(nbsomm, mxsomm, &pxyd[4], &nte, letree, ierr); + if (*ierr != 0) { + return 0; + } + goto L15; + } + + } else { + +/* il existe ici une fonction 'taille_ideale' */ +/* ------------------------------------------ */ +/* si la taille effective de l'arete du te est superieure au mini */ +/* des 3 tailles_ideales aux sommets alors le te est decoupe */ + for (i__ = 1; i__ <= 3; ++i__) { +/* Computing 2nd power */ + d__1 = pxyd[nuste[i__ - 1] * 3 + 3] * 1.34; + if (d2 > d__1 * d__1) { +/* le triangle nte trop grand doit etre subdivise */ +/* en 4 sous-triangles */ + nbsom0 = *nbsomm; + te4ste_(nbsomm, mxsomm, &pxyd[4], &nte, letree, + ierr); + if (*ierr != 0) { + return 0; + } + i__1 = *nbsomm; + for (j = nbsom0 + 1; j <= i__1; ++j) { +/* mise a jour de taille_ideale des nouveaux sommets de */ + tetaid_(nutysu, &pxyd[j * 3 + 1], &pxyd[j * 3 + + 2], &pxyd[j * 3 + 3], ierr); + if (*ierr != 0) { + goto L9999; + } +/* L27: */ + } + goto L15; + } +/* L28: */ + } + } + +/* recherche du nombre de niveaux entre nte et les te voisins par se */ +/* si la difference de subdivisions excede 1 alors le plus grand des */ +/* ================================================================= */ +/* L29: */ + for (i__ = 1; i__ <= 3; ++i__) { + +/* noteva triangle voisin de nte par l'arete i */ + n1trva_(&nte, &i__, letree, ¬eva, &niveau); + if (noteva <= 0) { + goto L30; + } +/* il existe un te voisin */ + if (niveau > 0) { + goto L30; + } +/* nte a un te voisin plus petit ou egal */ + if (letree[noteva * 9] <= 0) { + goto L30; + } +/* nte a un te voisin noteva subdivise au moins une fois */ + + if (nbiter > 0) { +/* les 2 sous triangles voisins sont-ils subdivises? */ + *ns2 = letree[i__ + noteva * 9]; + if (letree[*ns2 * 9] <= 0) { +/* ns2 n'est pas subdivise */ + *ns2 = letree[nosui3_(&i__) + noteva * 9]; + if (letree[*ns2 * 9] <= 0) { +/* les 2 sous-triangles ne sont pas subdivises */ + goto L30; + } + } + } + +/* saut>1 => le triangle nte doit etre subdivise en 4 sous-triang */ +/* -------------------------------------------------------------- */ + nbsom0 = *nbsomm; + te4ste_(nbsomm, mxsomm, &pxyd[4], &nte, letree, ierr); + if (*ierr != 0) { + return 0; + } + if (*nutysu > 0) { + i__1 = *nbsomm; + for (j = nbsom0 + 1; j <= i__1; ++j) { +/* mise a jour de taille_ideale des nouveaux sommets de te */ + tetaid_(nutysu, &pxyd[j * 3 + 1], &pxyd[j * 3 + 2] + , &pxyd[j * 3 + 3], ierr); + if (*ierr != 0) { + goto L9999; + } +/* L32: */ + } + } + goto L15; + +L30: + ; + } + } + } + goto L10; + } + if (nbs0 < *nbsomm) { + nbs0 = *nbsomm; + goto L5; + } + return 0; + +/* pb dans le calcul de la fonction taille_ideale */ +L9999: + //io___132.ciunit = unites_2.imprim; + //s_wsle(&io___132); + //do_lio(&c__9, &c__1, "pb dans le calcul de taille_ideale", (ftnlen)34); + //e_wsle(); +/* nblgrc(nrerr) = 1 */ +/* kerr(1) = 'pb dans le calcul de taille_ideale' */ +/* call lereur */ + return 0; +} /* tehote_ */ + +#undef nuste +#undef ns3 +#undef ns2 +#undef ns1 + + +/* Subroutine */ int tetrte_(doublereal *comxmi, doublereal *aretmx, integer * + nbarpi, integer *mxsomm, doublereal *pxyd, integer *mxqueu, integer * + laqueu, integer *letree, integer *mosoar, integer *mxsoar, integer * + n1soar, integer *nosoar, integer *moartr, integer *mxartr, integer * + n1artr, integer *noartr, integer *noarst, integer *ierr) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset, i__1; + doublereal d__1, d__2; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static doublereal a; + static integer i__; + static doublereal s; + static integer ns1, ns2, ns3, nte; + static doublereal dmin__, dmax__; + static integer nbtr, nsot, nutr[13]; + static doublereal xrmin, yrmin, xrmax, yrmax; + extern /* Subroutine */ int f0trte_(integer *, doublereal *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *), f1trte_( + integer *, doublereal *, integer *, integer *, integer *, integer + *, integer *, integer *, integer *, integer *, integer *, integer + *, integer *, integer *, integer *); + extern integer nopre3_(integer *); + extern /* Subroutine */ int f2trte_(integer *, doublereal *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *), + f3trte_(integer *, doublereal *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *), n1trva_(integer *, + integer *, integer *, integer *, integer *); + static integer nbmili, milieu[3], niveau, noteva, lequeu, lhqueu; + + /* Fortran I/O blocks */ + static cilist io___146 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : trianguler les triangles equilateraux feuilles et */ +/* ----- les points de la frontiere et les points internes imposes */ + +/* attention: la triangulation finale n'est pas de type delaunay! */ + +/* entrees: */ +/* -------- */ +/* comxmi : minimum et maximum des coordonnees de l'objet */ +/* aretmx : longueur maximale des aretes des triangles equilateraux */ +/* nbarpi : nombre de sommets de la frontiere + nombre de points internes */ +/* imposes par l'utilisateur */ +/* mxsomm : nombre maximal de sommets declarables dans pxyd */ +/* pxyd : tableau des coordonnees 2d des points */ +/* par point : x y distance_souhaitee */ + +/* mxqueu : nombre d'entiers utilisables dans laqueu */ +/* mosoar : nombre maximal d'entiers par arete du tableau nosoar */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxartr : nombre maximal de triangles stockables dans le tableau noartr */ +/* letree : arbre-4 des triangles equilateraux (te) fond de la triangulation */ +/* letree(0,0) : no du 1-er te vide dans letree */ +/* letree(0,1) : maximum du 1-er indice de letree (ici 8) */ +/* letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree) */ +/* letree(0:8,1) : racine de l'arbre (triangle sans sur triangle) */ +/* si letree(0,.)>0 alors */ +/* letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j */ +/* sinon */ +/* letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j */ +/* 0 si pas de point */ +/* ( j est alors une feuille de l'arbre ) */ +/* letree(4,j) : no letree du sur-triangle du triangle j */ +/* letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle */ +/* letree(6:8,j) : no pxyd des 3 sommets du triangle j */ + +/* modifies: */ +/* --------- */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = nosoar(1)+nosoar(2)*2 */ +/* noarst : noarst(i) numero d'une arete de sommet i */ + +/* auxiliaire : */ +/* ------------ */ +/* laqueu : mxqueu entiers servant de queue pour le parcours de letree */ + +/* sorties: */ +/* -------- */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ +/* ierr : =0 si pas d'erreur */ +/* =1 si le tableau nosoar est sature */ +/* =2 si le tableau noartr est sature */ +/* =3 si aucun des triangles ne contient l'un des points internes d'un t */ +/* =5 si saturation de la queue de parcours de l'arbre des te */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* 2345x7..............................................................012 */ + + + +/* lequeu:entree dans la queue en gestion circulaire */ +/* lhqueu:longueur de la queue en gestion circulaire */ + + +/* le rectangle englobant pour selectionner les te "internes" */ +/* le numero des 3 sommets du te englobant racine de l'arbre des te */ + /* Parameter adjustments */ + comxmi -= 4; + --noarst; + pxyd -= 4; + --laqueu; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + + /* Function Body */ + ns1 = letree[15]; + ns2 = letree[16]; + ns3 = letree[17]; + a = *aretmx * .01; +/* abscisse du milieu de l'arete gauche du te 1 */ + s = (pxyd[ns1 * 3 + 1] + pxyd[ns3 * 3 + 1]) / 2; +/* Computing MIN */ + d__1 = s, d__2 = comxmi[4] - *aretmx; + xrmin = min(d__1,d__2) - a; +/* abscisse du milieu de l'arete droite du te 1 */ + s = (pxyd[ns2 * 3 + 1] + pxyd[ns3 * 3 + 1]) / 2; +/* Computing MAX */ + d__1 = s, d__2 = comxmi[7] + *aretmx; + xrmax = max(d__1,d__2) + a; + yrmin = comxmi[5] - *aretmx; +/* ordonnee de la droite passant par les milieus des 2 aretes */ +/* droite gauche du te 1 */ + s = (pxyd[ns1 * 3 + 2] + pxyd[ns3 * 3 + 2]) / 2; +/* Computing MAX */ + d__1 = s, d__2 = comxmi[8] + *aretmx; + yrmax = max(d__1,d__2) + a; + +/* cas particulier de 3 ou 4 ou peu d'aretes frontalieres */ + if (*nbarpi <= 8) { +/* tout le triangle englobant (racine) est a prendre en compte */ + xrmin = pxyd[ns1 * 3 + 1] - a; + xrmax = pxyd[ns2 * 3 + 1] + a; + yrmin = pxyd[ns1 * 3 + 2] - a; + yrmax = pxyd[ns3 * 3 + 2] + a; + } + +/* initialisation du tableau noartr */ + i__1 = *mxartr; + for (i__ = 1; i__ <= i__1; ++i__) { +/* le numero de l'arete est inconnu */ + noartr[i__ * noartr_dim1 + 1] = 0; +/* le chainage sur le triangle vide suivant */ + noartr[i__ * noartr_dim1 + 2] = i__ + 1; +/* L5: */ + } + noartr[*mxartr * noartr_dim1 + 2] = 0; + *n1artr = 1; + +/* parcours des te jusqu'a trianguler toutes les feuilles (triangles eq) */ +/* ===================================================================== */ +/* initialisation de la queue sur les te */ + *ierr = 0; + lequeu = 1; + lhqueu = 0; +/* la racine de letree initialise la queue */ + laqueu[1] = 1; + +/* tant que la longueur de la queue est >=0 traiter le debut de queue */ +L10: + if (lhqueu >= 0) { + +/* le triangle te a traiter */ + i__ = lequeu - lhqueu; + if (i__ <= 0) { + i__ = *mxqueu + i__; + } + nte = laqueu[i__]; +/* la longueur est reduite */ + --lhqueu; + +/* nte est il un sous-triangle feuille (minimal) ? */ +/* L15: */ + if (letree[nte * 9] > 0) { +/* non les 4 sous-triangles sont mis dans la queue */ + if (lhqueu + 4 >= *mxqueu) { + //io___146.ciunit = unites_2.imprim; + //s_wsle(&io___146); + //do_lio(&c__9, &c__1, "tetrte: saturation de la queue", ( + // ftnlen)30); + //e_wsle(); + *ierr = 5; + return 0; + } + for (i__ = 3; i__ >= 0; --i__) { +/* ajout du sous-triangle i */ + ++lhqueu; + ++lequeu; + if (lequeu > *mxqueu) { + lequeu -= *mxqueu; + } + laqueu[lequeu] = letree[i__ + nte * 9]; +/* L20: */ + } + goto L10; + } + +/* ici nte est un triangle minimal non subdivise */ +/* --------------------------------------------- */ +/* le te est il dans le cadre englobant de l'objet ? */ + ns1 = letree[nte * 9 + 6]; + ns2 = letree[nte * 9 + 7]; + ns3 = letree[nte * 9 + 8]; + if (pxyd[ns1 * 3 + 1] > pxyd[ns2 * 3 + 1]) { + dmin__ = pxyd[ns2 * 3 + 1]; + dmax__ = pxyd[ns1 * 3 + 1]; + } else { + dmin__ = pxyd[ns1 * 3 + 1]; + dmax__ = pxyd[ns2 * 3 + 1]; + } + if (xrmin <= dmin__ && dmin__ <= xrmax || xrmin <= dmax__ && dmax__ <= + xrmax) { + if (pxyd[ns1 * 3 + 2] > pxyd[ns3 * 3 + 2]) { + dmin__ = pxyd[ns3 * 3 + 2]; + dmax__ = pxyd[ns1 * 3 + 2]; + } else { + dmin__ = pxyd[ns1 * 3 + 2]; + dmax__ = pxyd[ns3 * 3 + 2]; + } + if (yrmin <= dmin__ && dmin__ <= yrmax || yrmin <= dmax__ && + dmax__ <= yrmax) { + +/* te minimal et interne au rectangle englobant */ +/* -------------------------------------------- */ +/* recherche du nombre de niveaux entre nte et les te voisins */ +/* par ses aretes */ + nbmili = 0; + for (i__ = 1; i__ <= 3; ++i__) { + +/* a priori pas de milieu de l'arete i du te nte */ + milieu[i__ - 1] = 0; + +/* recherche de noteva te voisin de nte par l'arete i */ + n1trva_(&nte, &i__, letree, ¬eva, &niveau); +/* noteva : >0 numero letree du te voisin par l'arete i */ +/* =0 si pas de te voisin (racine , ... ) */ +/* niveau : =0 si nte et noteva ont meme taille */ +/* >0 nte est 4**niveau fois plus petit que noteva */ + if (noteva > 0) { +/* il existe un te voisin */ + if (letree[noteva * 9] > 0) { +/* noteva est plus petit que nte */ +/* => recherche du numero du milieu du cote=sommet du te no */ +/* le sous-te 0 du te noteva */ + nsot = letree[noteva * 9]; +/* le numero dans pxyd du milieu de l'arete i de nte */ + milieu[i__ - 1] = letree[nopre3_(&i__) + 5 + nsot + * 9]; + ++nbmili; + } + } + +/* L30: */ + } + +/* triangulation du te nte en fonction du nombre de ses milieux */ + switch (nbmili + 1) { + case 1: goto L50; + case 2: goto L100; + case 3: goto L200; + case 4: goto L300; + } + +/* 0 milieu => 1 triangle = le te nte */ +/* ---------------------------------- */ +L50: + f0trte_(&letree[nte * 9], &pxyd[4], mosoar, mxsoar, n1soar, & + nosoar[nosoar_offset], moartr, mxartr, n1artr, & + noartr[noartr_offset], &noarst[1], &nbtr, nutr, ierr); + if (*ierr != 0) { + return 0; + } + goto L10; + +/* 1 milieu => 2 triangles = 2 demi te */ +/* ----------------------------------- */ +L100: + f1trte_(&letree[nte * 9], &pxyd[4], milieu, mosoar, mxsoar, + n1soar, &nosoar[nosoar_offset], moartr, mxartr, + n1artr, &noartr[noartr_offset], &noarst[1], &nbtr, + nutr, ierr); + if (*ierr != 0) { + return 0; + } + goto L10; + +/* 2 milieux => 3 triangles */ +/* ----------------------------------- */ +L200: + f2trte_(&letree[nte * 9], &pxyd[4], milieu, mosoar, mxsoar, + n1soar, &nosoar[nosoar_offset], moartr, mxartr, + n1artr, &noartr[noartr_offset], &noarst[1], &nbtr, + nutr, ierr); + if (*ierr != 0) { + return 0; + } + goto L10; + +/* 3 milieux => 4 triangles = 4 quart te */ +/* ------------------------------------- */ +L300: + f3trte_(&letree[nte * 9], &pxyd[4], milieu, mosoar, mxsoar, + n1soar, &nosoar[nosoar_offset], moartr, mxartr, + n1artr, &noartr[noartr_offset], &noarst[1], &nbtr, + nutr, ierr); + if (*ierr != 0) { + return 0; + } + goto L10; + } + } + goto L10; + } + return 0; +} /* tetrte_ */ + +/* Subroutine */ int aisoar_(integer *mosoar, integer *mxsoar, integer * + nosoar, integer *na1) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, i__1; + + /* Local variables */ + static integer na, na0; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : chainer en colonne lchain les aretes non vides et */ +/* ----- non frontalieres du tableau nosoar */ + +/* entrees: */ +/* -------- */ +/* mosoar : nombre maximal d'entiers par arete dans le tableau nosoar */ +/* mxsoar : nombre maximal d'aretes frontalieres declarables */ + +/* modifies : */ +/* ---------- */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en + */ +/* nosoar(lchain,i)=arete interne suivante */ + +/* sortie : */ +/* -------- */ +/* na1 : numero dans nosoar de la premiere arete interne */ +/* les suivantes sont nosoar(lchain,na1), ... */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* ....................................................................012 */ + +/* formation du chainage des aretes internes a echanger eventuellement */ +/* recherche de la premiere arete non vide et non frontaliere */ + /* Parameter adjustments */ + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + + /* Function Body */ + i__1 = *mxsoar; + for (*na1 = 1; *na1 <= i__1; ++(*na1)) { + if (nosoar[*na1 * nosoar_dim1 + 1] > 0 && nosoar[*na1 * nosoar_dim1 + + 3] <= 0) { + goto L15; + } +/* L10: */ + } + +/* protection de la premiere arete non vide et non frontaliere */ +L15: + na0 = *na1; + i__1 = *mxsoar; + for (na = *na1 + 1; na <= i__1; ++na) { + if (nosoar[na * nosoar_dim1 + 1] > 0 && nosoar[na * nosoar_dim1 + 3] + <= 0) { +/* arete interne => elle est chainee a partir de la precedente */ + nosoar[na0 * nosoar_dim1 + 6] = na; + na0 = na; + } +/* L20: */ + } + +/* la derniere arete interne n'a pas de suivante */ + nosoar[na0 * nosoar_dim1 + 6] = 0; + return 0; +} /* aisoar_ */ + +/* Subroutine */ int tedela_(doublereal *pxyd, integer *noarst, integer * + mosoar, integer *mxsoar, integer *n1soar, integer *nosoar, integer * + n1ardv, integer *moartr, integer *mxartr, integer *n1artr, integer * + noartr, integer *modifs) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset, i__1; + doublereal d__1, d__2; + + /* Local variables */ + static integer i__, j, n; + static doublereal r0, a12; + static integer na; + static doublereal s12, s34; + static integer nt, na0; + static doublereal s123, s142, s143, s234; + static integer ns1, ns2, ns3, ns4, na34, ierr; + extern /* Subroutine */ int te2t2t_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *), mt4sqa_( + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *), cenced_(doublereal *, + doublereal *, doublereal *, doublereal *, integer *); + extern doublereal surtd2_(doublereal *, doublereal *, doublereal *); + static doublereal cetria[3]; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : pour toutes les aretes chainees dans nosoar(lchain,*) */ +/* ----- du tableau nosoar */ +/* echanger la diagonale des 2 triangles si le sommet oppose */ +/* a un triangle ayant en commun une arete appartient au cercle */ +/* circonscrit de l'autre (violation boule vide delaunay) */ + +/* entrees: */ +/* -------- */ +/* pxyd : tableau des x y distance_souhaitee de chaque sommet */ + +/* modifies : */ +/* ---------- */ +/* noarst : noarst(i) numero d'une arete de sommet i */ +/* mosoar : nombre maximal d'entiers par arete dans le tableau nosoar */ +/* mxsoar : nombre maximal d'aretes frontalieres declarables */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en + */ +/* n1ardv : numero dans nosoar de la premiere arete du chainage */ +/* des aretes a rendre delaunay */ + +/* moartr : nombre d'entiers par triangle dans le tableau noartr */ +/* mxartr : nombre maximal de triangles declarables dans noartr */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ +/* modifs : nombre d'echanges de diagonales pour maximiser la qualite */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* ....................................................................012 */ + +/* le nombre d'echanges de diagonales pour minimiser l'aire */ + /* Parameter adjustments */ + pxyd -= 4; + --noarst; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + + /* Function Body */ + *modifs = 0; + r0 = 0.; + +/* la premiere arete du chainage des aretes a rendre delaunay */ + na0 = *n1ardv; + +/* tant que la pile des aretes a echanger eventuellement est non vide */ +/* ================================================================== */ +L20: + if (na0 > 0) { + +/* l'arete a traiter */ + na = na0; +/* la prochaine arete a traiter */ + na0 = nosoar[na0 * nosoar_dim1 + 6]; + +/* l'arete est marquee traitee avec le numero -1 */ + nosoar[na * nosoar_dim1 + 6] = -1; + +/* l'arete est elle active? */ + if (nosoar[na * nosoar_dim1 + 1] == 0) { + goto L20; + } + +/* si arete frontaliere pas d'echange possible */ + if (nosoar[na * nosoar_dim1 + 3] > 0) { + goto L20; + } + +/* existe-t-il 2 triangles ayant cette arete commune? */ + if (nosoar[na * nosoar_dim1 + 4] <= 0 || nosoar[na * nosoar_dim1 + 5] + <= 0) { + goto L20; + } + +/* aucun des 2 triangles est-il desactive? */ + if (noartr[nosoar[na * nosoar_dim1 + 4] * noartr_dim1 + 1] == 0 || + noartr[nosoar[na * nosoar_dim1 + 5] * noartr_dim1 + 1] == 0) { + goto L20; + } + +/* l'arete appartient a deux triangles actifs */ +/* le numero des 4 sommets du quadrangle des 2 triangles */ + mt4sqa_(&na, moartr, &noartr[noartr_offset], mosoar, &nosoar[ + nosoar_offset], &ns1, &ns2, &ns3, &ns4); + if (ns4 == 0) { + goto L20; + } + +/* carre de la longueur de l'arete ns1 ns2 */ +/* Computing 2nd power */ + d__1 = pxyd[ns2 * 3 + 1] - pxyd[ns1 * 3 + 1]; +/* Computing 2nd power */ + d__2 = pxyd[ns2 * 3 + 2] - pxyd[ns1 * 3 + 2]; + a12 = d__1 * d__1 + d__2 * d__2; + +/* comparaison de la somme des aires des 2 triangles */ +/* ------------------------------------------------- */ +/* calcul des surfaces des triangles 123 et 142 de cette arete */ + s123 = surtd2_(&pxyd[ns1 * 3 + 1], &pxyd[ns2 * 3 + 1], &pxyd[ns3 * 3 + + 1]); + s142 = surtd2_(&pxyd[ns1 * 3 + 1], &pxyd[ns4 * 3 + 1], &pxyd[ns2 * 3 + + 1]); + s12 = abs(s123) + abs(s142); + if (s12 <= a12 * .001f) { + goto L20; + } + +/* calcul des surfaces des triangles 143 et 234 de cette arete */ + s143 = surtd2_(&pxyd[ns1 * 3 + 1], &pxyd[ns4 * 3 + 1], &pxyd[ns3 * 3 + + 1]); + s234 = surtd2_(&pxyd[ns2 * 3 + 1], &pxyd[ns3 * 3 + 1], &pxyd[ns4 * 3 + + 1]); + s34 = abs(s234) + abs(s143); + + if ((d__1 = s34 - s12, abs(d__1)) > s34 * 1e-15) { + goto L20; + } + +/* quadrangle convexe : le critere de delaunay intervient */ +/* ------------------ --------------------------------- */ +/* calcul du centre et rayon de la boule circonscrite a ns123 */ +/* pas d'affichage si le triangle est degenere */ + ierr = -1; + cenced_(&pxyd[ns1 * 3 + 1], &pxyd[ns2 * 3 + 1], &pxyd[ns3 * 3 + 1], + cetria, &ierr); + if (ierr > 0) { +/* ierr=1 si triangle degenere => abandon */ + goto L20; + } + +/* Computing 2nd power */ + d__1 = cetria[0] - pxyd[ns4 * 3 + 1]; +/* Computing 2nd power */ + d__2 = cetria[1] - pxyd[ns4 * 3 + 2]; + if (d__1 * d__1 + d__2 * d__2 < cetria[2]) { + +/* protection contre une boucle infinie sur le meme cercle */ + if (r0 == cetria[2]) { + goto L20; + } + +/* oui: ns4 est dans le cercle circonscrit a ns1 ns2 ns3 */ +/* => ns3 est aussi dans le cercle circonscrit de ns1 ns2 ns4 */ +/* echange de la diagonale 12 par 34 des 2 triangles */ + te2t2t_(&na, mosoar, n1soar, &nosoar[nosoar_offset], &noarst[1], + moartr, &noartr[noartr_offset], &na34); + if (na34 == 0) { + goto L20; + } + r0 = cetria[2]; + +/* l'arete na34 est marquee traitee */ + nosoar[na34 * nosoar_dim1 + 6] = -1; + ++(*modifs); + +/* les aretes internes peripheriques des 2 triangles sont enchainees */ + for (j = 4; j <= 5; ++j) { + nt = nosoar[j + na34 * nosoar_dim1]; + for (i__ = 1; i__ <= 3; ++i__) { + n = (i__1 = noartr[i__ + nt * noartr_dim1], abs(i__1)); + if (n != na34) { + if (nosoar[n * nosoar_dim1 + 3] == 0 && nosoar[n * + nosoar_dim1 + 6] == -1) { +/* cette arete marquee est chainee pour etre traitee */ + nosoar[n * nosoar_dim1 + 6] = na0; + na0 = n; + } + } +/* L50: */ + } +/* L60: */ + } + goto L20; + } + +/* retour en haut de la pile des aretes a traiter */ + goto L20; + } + + return 0; +} /* tedela_ */ + +/* Subroutine */ int terefr_(integer *nbarpi, doublereal *pxyd, integer * + mosoar, integer *mxsoar, integer *n1soar, integer *nosoar, integer * + moartr, integer *mxartr, integer *n1artr, integer *noartr, integer * + noarst, integer *mxarcf, integer *n1arcf, integer *noarcf, integer * + larmin, integer *notrcf, integer *nbarpe, integer *ierr) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset, i__1; + + /* Local variables */ + static integer ns1, ns2, narete; + extern /* Subroutine */ int tefoar_(integer *, integer *, doublereal *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *); + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : recherche des aretes de la frontiere non dans la triangulation */ +/* ----- triangulation frontale pour les reobtenir */ + +/* attention: le chainage lchain de nosoar devient celui des cf */ + +/* entrees: */ +/* -------- */ +/* le tableau nosoar */ +/* nbarpi : numero du dernier point interne impose par l'utilisateur */ +/* pxyd : tableau des coordonnees 2d des points */ +/* par point : x y distance_souhaitee */ +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* attention: mxsoar>3*mxsomm obligatoire! */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxartr : nombre maximal de triangles declarables dans noartr */ +/* mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf */ + +/* modifies: */ +/* --------- */ +/* n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar */ +/* chainage des vides suivant en 3 et precedant en 2 de nosoar */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = nosoar(1)+nosoar(2)*2 */ +/* avec mxsoar>=3*mxsomm */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 et */ +/* nosoar(2,arete vide)=l'arete vide qui precede */ +/* nosoar(3,arete vide)=l'arete vide qui suit */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ +/* noarst : noarst(i) numero d'une arete de sommet i */ + + +/* auxiliaires : */ +/* ------------- */ +/* n1arcf : tableau (0:mxarcf) auxiliaire d'entiers */ +/* noarcf : tableau (3,mxarcf) auxiliaire d'entiers */ +/* larmin : tableau (mxarcf) auxiliaire d'entiers */ +/* notrcf : tableau (mxarcf) auxiliaire d'entiers */ + +/* sortie : */ +/* -------- */ +/* nbarpe : nombre d'aretes perdues puis retrouvees */ +/* ierr : =0 si pas d'erreur */ +/* >0 si une erreur est survenue */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* ....................................................................012 */ + + /* Parameter adjustments */ + pxyd -= 4; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --noarst; + --notrcf; + --larmin; + noarcf -= 4; + + /* Function Body */ + *ierr = 0; + +/* le nombre d'aretes de la frontiere non arete de la triangulation */ + *nbarpe = 0; + +/* initialisation du chainage des aretes des cf => 0 arete de cf */ + i__1 = *mxsoar; + for (narete = 1; narete <= i__1; ++narete) { + nosoar[narete * nosoar_dim1 + 6] = -1; +/* L10: */ + } + +/* boucle sur l'ensemble des aretes actuelles */ +/* ========================================== */ + i__1 = *mxsoar; + for (narete = 1; narete <= i__1; ++narete) { + + if (nosoar[narete * nosoar_dim1 + 3] > 0) { +/* arete appartenant a une ligne => frontaliere */ + + if (nosoar[narete * nosoar_dim1 + 4] <= 0 || nosoar[narete * + nosoar_dim1 + 5] <= 0) { +/* l'arete narete frontaliere n'appartient pas a 2 triangles */ +/* => elle est perdue */ + ++(*nbarpe); + +/* le numero des 2 sommets de l'arete frontaliere perdue */ + ns1 = nosoar[narete * nosoar_dim1 + 1]; + ns2 = nosoar[narete * nosoar_dim1 + 2]; +/* write(imprim,10000) ns1,(pxyd(j,ns1),j=1,2), */ +/* % ns2,(pxyd(j,ns2),j=1,2) */ +/* L10000: */ + +/* traitement de cette arete perdue ns1-ns2 */ + tefoar_(&narete, nbarpi, &pxyd[4], mosoar, mxsoar, n1soar, & + nosoar[nosoar_offset], moartr, mxartr, n1artr, & + noartr[noartr_offset], &noarst[1], mxarcf, n1arcf, & + noarcf[4], &larmin[1], ¬rcf[1], ierr); + if (*ierr != 0) { + return 0; + } + +/* fin du traitement de cette arete perdue et retrouvee */ + } + } + +/* L30: */ + } + return 0; +} /* terefr_ */ + +/* Subroutine */ int tesuex_(integer *nblftr, integer *nulftr, integer * + ndtri0, integer *nbsomm, doublereal *pxyd, integer *nslign, integer * + mosoar, integer *mxsoar, integer *nosoar, integer *moartr, integer * + mxartr, integer *n1artr, integer *noartr, integer *noarst, integer * + nbtria, integer *letrsu, integer *ierr) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset, i__1, + i__2; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static integer i__, j, na, nl, nt, na0, na1, ns1, ns2, nt2; + static doublereal dmin__; + static integer noar, noar1, ligne, ntmin, ligne0, lsigne; + + /* Fortran I/O blocks */ + static cilist io___187 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : supprimer du tableau noartr les triangles externes au domaine */ +/* ----- en annulant le numero de leur 1-ere arete dans noartr */ +/* et en les chainant comme triangles vides */ + +/* entrees: */ +/* -------- */ +/* nblftr : nombre de lignes fermees definissant la surface */ +/* nulftr : numero des lignes fermees definissant la surface */ +/* ndtri0 : plus grand numero dans noartr d'un triangle */ +/* pxyd : tableau des coordonnees 2d des points */ +/* par point : x y distance_souhaitee */ +/* nslign : tableau du numero de sommet dans sa ligne pour chaque */ +/* sommet frontalier */ +/* numero du point dans le lexique point si interne impose */ +/* 0 si le point est interne non impose par l'utilisateur */ +/* -1 si le sommet est externe au domaine */ +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* attention: mxsoar>3*mxsomm obligatoire! */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = nosoar(1)+nosoar(2)*2 */ +/* avec mxsoar>=3*mxsomm */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 et */ +/* nosoar(2,arete vide)=l'arete vide qui precede */ +/* nosoar(3,arete vide)=l'arete vide qui suit */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxartr : nombre maximal de triangles declarables */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ +/* noarst : noarst(i) numero nosoar d'une arete de sommet i */ + +/* sorties: */ +/* -------- */ +/* nbtria : nombre de triangles internes au domaine */ +/* letrsu : letrsu(nt)=numero du triangle interne, 0 sinon */ +/* noarst : noarst(i) numero nosoar d'une arete du sommet i (modifi'e) */ +/* ierr : 0 si pas d'erreur, >0 sinon */ +/* c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mai 1999 */ +/* 2345x7..............................................................012 */ + +/* les triangles sont a priori non marques */ + /* Parameter adjustments */ + --nulftr; + --letrsu; + --nslign; + pxyd -= 4; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --noarst; + + /* Function Body */ + i__1 = *ndtri0; + for (nt = 1; nt <= i__1; ++nt) { + letrsu[nt] = 0; +/* L5: */ + } + +/* les aretes sont marquees non chainees */ + i__1 = *mxsoar; + for (noar1 = 1; noar1 <= i__1; ++noar1) { + nosoar[noar1 * nosoar_dim1 + 6] = -2; +/* L10: */ + } + +/* recherche du sommet de la triangulation de plus petite abscisse */ +/* =============================================================== */ + ntmin = 0; + dmin__ = 1e38; + i__1 = *nbsomm; + for (i__ = 1; i__ <= i__1; ++i__) { + if (pxyd[i__ * 3 + 1] < dmin__) { +/* le nouveau minimum */ + noar1 = noarst[i__]; + if (noar1 > 0) { +/* le sommet appartient a une arete de triangle */ + if (nosoar[noar1 * nosoar_dim1 + 4] > 0) { +/* le nouveau minimum */ + dmin__ = pxyd[i__ * 3 + 1]; + ntmin = i__; + } + } + } +/* L20: */ + } + +/* une arete de sommet ntmin */ + noar1 = noarst[ntmin]; +/* un triangle d'arete noar1 */ + ntmin = nosoar[noar1 * nosoar_dim1 + 4]; + if (ntmin <= 0) { +/* nblgrc(nrerr) = 1 */ +/* kerr(1) = 'pas de triangle d''abscisse minimale' */ +/* call lereur */ + //io___187.ciunit = unites_2.imprim; + //s_wsle(&io___187); + //do_lio(&c__9, &c__1, "pas de triangle d'abscisse minimale", (ftnlen) + // 35); + //e_wsle(); + *ierr = 2; + goto L9990; + } + +/* chainage des 3 aretes du triangle ntmin */ +/* ======================================= */ +/* la premiere arete du chainage des aretes traitees */ + noar1 = (i__1 = noartr[ntmin * noartr_dim1 + 1], abs(i__1)); + na0 = (i__1 = noartr[ntmin * noartr_dim1 + 2], abs(i__1)); +/* elle est chainee sur la seconde arete du triangle ntmin */ + nosoar[noar1 * nosoar_dim1 + 6] = na0; +/* les 2 autres aretes du triangle ntmin sont chainees */ + na1 = (i__1 = noartr[ntmin * noartr_dim1 + 3], abs(i__1)); +/* la seconde est chainee sur la troisieme arete */ + nosoar[na0 * nosoar_dim1 + 6] = na1; +/* la troisieme n'a pas de suivante */ + nosoar[na1 * nosoar_dim1 + 6] = 0; + +/* le triangle ntmin est a l'exterieur du domaine */ +/* tous les triangles externes sont marques -123 456 789 */ +/* les triangles de l'autre cote d'une arete sur une ligne */ +/* sont marques: no de la ligne de l'arete * signe oppose */ +/* ======================================================= */ + ligne0 = 0; + ligne = -123456789; + +L40: + if (noar1 != 0) { + +/* l'arete noar1 du tableau nosoar est a traiter */ +/* --------------------------------------------- */ + noar = noar1; +/* l'arete suivante devient la premiere a traiter ensuite */ + noar1 = nosoar[noar1 * nosoar_dim1 + 6]; +/* l'arete noar est traitee */ + nosoar[noar * nosoar_dim1 + 6] = -3; + + for (i__ = 4; i__ <= 5; ++i__) { + +/* l'un des 2 triangles de l'arete */ + nt = nosoar[i__ + noar * nosoar_dim1]; + if (nt > 0) { + +/* triangle deja traite pour une ligne anterieure? */ + if (letrsu[nt] != 0 && (i__1 = letrsu[nt], abs(i__1)) != + ligne) { + goto L60; + } + +/* le triangle est marque avec la valeur de ligne */ + letrsu[nt] = ligne; + +/* chainage eventuel des autres aretes de ce triangle */ +/* si ce n'est pas encore fait */ + for (j = 1; j <= 3; ++j) { + +/* le numero na de l'arete j du triangle nt dans nosoar */ + na = (i__1 = noartr[j + nt * noartr_dim1], abs(i__1)); + if (nosoar[na * nosoar_dim1 + 6] != -2) { + goto L50; + } + +/* le numero de 1 a nblftr dans nulftr de la ligne de l'arete */ + nl = nosoar[na * nosoar_dim1 + 3]; + +/* si l'arete est sur une ligne fermee differente de celle envelo */ +/* et non marquee alors examen du triangle oppose */ + if (nl > 0) { + + if (nl == ligne0) { + goto L50; + } + +/* arete frontaliere de ligne non traitee */ +/* => passage de l'autre cote de la ligne */ +/* le triangle de l'autre cote de la ligne est recherche */ + if (nt == (i__1 = nosoar[na * nosoar_dim1 + 4], abs( + i__1))) { + nt2 = 5; + } else { + nt2 = 4; + } + nt2 = (i__1 = nosoar[nt2 + na * nosoar_dim1], abs( + i__1)); + if (nt2 > 0) { + +/* le triangle nt2 de l'autre cote est marque avec le */ +/* avec le signe oppose de celui de ligne */ + if (ligne >= 0) { + lsigne = -1; + } else { + lsigne = 1; + } + letrsu[nt2] = lsigne * nl; + +/* temoin de ligne a traiter ensuite dans nulftr */ + nulftr[nl] = -(i__1 = nulftr[nl], abs(i__1)); + +/* l'arete est traitee */ + nosoar[na * nosoar_dim1 + 6] = -3; + + } + +/* l'arete est traitee */ + goto L50; + + } + +/* arete non traitee => elle est chainee */ + nosoar[na * nosoar_dim1 + 6] = noar1; + noar1 = na; + +L50: + ; + } + + } +L60: + ; + } + + goto L40; + } +/* les triangles de la ligne fermee ont tous ete marques */ +/* plus d'arete chainee */ + +/* recherche d'une nouvelle ligne fermee a traiter */ +/* =============================================== */ +L65: + i__1 = *nblftr; + for (nl = 1; nl <= i__1; ++nl) { + if (nulftr[nl] < 0) { + goto L80; + } +/* L70: */ + } +/* plus de ligne fermee a traiter */ + goto L110; + +/* tous les triangles de cette composante connexe */ +/* entre ligne et ligne0 vont etre marques */ +/* ============================================== */ +/* remise en etat du numero de ligne */ +/* nl est le numero de la ligne dans nulftr a traiter */ +L80: + nulftr[nl] = -nulftr[nl]; + i__1 = *ndtri0; + for (nt2 = 1; nt2 <= i__1; ++nt2) { + if ((i__2 = letrsu[nt2], abs(i__2)) == nl) { + goto L92; + } +/* L90: */ + } + +/* recherche de l'arete j du triangle nt2 avec ce numero de ligne nl */ +L92: + for (j = 1; j <= 3; ++j) { + +/* le numero de l'arete j du triangle dans nosoar */ + noar1 = 0; + na0 = (i__1 = noartr[j + nt2 * noartr_dim1], abs(i__1)); + if (nl == nosoar[na0 * nosoar_dim1 + 3]) { + +/* na0 est l'arete de ligne nl */ +/* l'arete suivante du triangle nt2 */ + i__ = j % 3 + 1; +/* le numero dans nosoar de l'arete i de nt2 */ + na1 = (i__1 = noartr[i__ + nt2 * noartr_dim1], abs(i__1)); + if (nosoar[na1 * nosoar_dim1 + 6] == -2) { +/* arete non traitee => elle est la premiere du chainage */ + noar1 = na1; +/* pas de suivante dans ce chainage */ + nosoar[na1 * nosoar_dim1 + 6] = 0; + } else { + na1 = 0; + } + +/* l'eventuelle seconde arete suivante */ + i__ = i__ % 3 + 1; + na = (i__1 = noartr[i__ + nt2 * noartr_dim1], abs(i__1)); + if (nosoar[na * nosoar_dim1 + 6] == -2) { + if (na1 == 0) { +/* 1 arete non traitee et seule a chainer */ + noar1 = na; + nosoar[na * nosoar_dim1 + 6] = 0; + } else { +/* 2 aretes a chainer */ + noar1 = na; + nosoar[na * nosoar_dim1 + 6] = na1; + } + } + + if (noar1 > 0) { + +/* il existe au moins une arete a visiter pour ligne */ +/* marquage des triangles internes a la ligne nl */ + ligne = letrsu[nt2]; + ligne0 = nl; + goto L40; + + } else { + +/* nt2 est le seul triangle de la ligne fermee */ + goto L65; + + } + } +/* L95: */ + } + +/* reperage des sommets internes ou externes dans nslign */ +/* nslign(sommet externe au domaine)=-1 */ +/* nslign(sommet interne au domaine)= 0 */ +/* ===================================================== */ +L110: + i__1 = *nbsomm; + for (ns1 = 1; ns1 <= i__1; ++ns1) { +/* tout sommet non sur la frontiere ou interne impose */ +/* est suppose externe */ + if (nslign[ns1] == 0) { + nslign[ns1] = -1; + } +/* L170: */ + } + +/* les triangles externes sont marques vides dans le tableau noartr */ +/* ================================================================ */ + *nbtria = 0; + i__1 = *ndtri0; + for (nt = 1; nt <= i__1; ++nt) { + + if (letrsu[nt] <= 0) { + +/* triangle nt externe */ + if (noartr[nt * noartr_dim1 + 1] != 0) { +/* la premiere arete est annulee */ + noartr[nt * noartr_dim1 + 1] = 0; +/* le triangle nt est considere comme etant vide */ + noartr[nt * noartr_dim1 + 2] = *n1artr; + *n1artr = nt; + } + + } else { + +/* triangle nt interne */ + ++(*nbtria); + letrsu[nt] = *nbtria; + +/* marquage des 3 sommets du triangle nt */ + for (i__ = 1; i__ <= 3; ++i__) { +/* le numero nosoar de l'arete i du triangle nt */ + noar = (i__2 = noartr[i__ + nt * noartr_dim1], abs(i__2)); +/* le numero des 2 sommets */ + ns1 = nosoar[noar * nosoar_dim1 + 1]; + ns2 = nosoar[noar * nosoar_dim1 + 2]; +/* mise a jour du numero d'une arete des 2 sommets de l'arete */ + noarst[ns1] = noar; + noarst[ns2] = noar; +/* ns1 et ns2 sont des sommets de la triangulation du domaine */ + if (nslign[ns1] < 0) { + nslign[ns1] = 0; + } + if (nslign[ns2] < 0) { + nslign[ns2] = 0; + } +/* L190: */ + } + + } + +/* L200: */ + } +/* ici tout sommet externe ns verifie nslign(ns)=-1 */ + +/* les triangles externes sont mis a zero dans nosoar */ +/* ================================================== */ + i__1 = *mxsoar; + for (noar = 1; noar <= i__1; ++noar) { + + if (nosoar[noar * nosoar_dim1 + 1] > 0) { + +/* le second triangle de l'arete noar */ + nt = nosoar[noar * nosoar_dim1 + 5]; + if (nt > 0) { +/* si le triangle nt est externe */ +/* alors il est supprime pour l'arete noar */ + if (letrsu[nt] <= 0) { + nosoar[noar * nosoar_dim1 + 5] = 0; + } + } + +/* le premier triangle de l'arete noar */ + nt = nosoar[noar * nosoar_dim1 + 4]; + if (nt > 0) { + if (letrsu[nt] <= 0) { +/* si le triangle nt est externe */ +/* alors il est supprime pour l'arete noar */ +/* et l'eventuel triangle oppose prend sa place */ +/* en position 4 de nosoar */ + if (nosoar[noar * nosoar_dim1 + 5] > 0) { + nosoar[noar * nosoar_dim1 + 4] = nosoar[noar * + nosoar_dim1 + 5]; + nosoar[noar * nosoar_dim1 + 5] = 0; + } else { + nosoar[noar * nosoar_dim1 + 4] = 0; + } + } + } + } + +/* L300: */ + } + +/* remise en etat pour eviter les modifications de ladefi */ +L9990: + i__1 = *nblftr; + for (nl = 1; nl <= i__1; ++nl) { + if (nulftr[nl] < 0) { + nulftr[nl] = -nulftr[nl]; + } +/* L9991: */ + } + return 0; +} /* tesuex_ */ + +/* Subroutine */ int trp1st_(integer *ns, integer *noarst, integer *mosoar, + integer *nosoar, integer *moartr, integer *mxartr, integer *noartr, + integer *mxpile, integer *lhpile, integer *lapile) +{ + /* Format strings */ + static char fmt_19990[] = "(5(\002 triangle\002,i9))"; + + /* System generated locals */ + integer noartr_dim1, noartr_offset, nosoar_dim1, nosoar_offset, i__1; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), + // e_wsfe(void); + + /* Local variables */ + static integer j, ii, nt0, nt1, nar, nta, noar, nosotr[3]; + extern /* Subroutine */ int nusotr_(integer *, integer *, integer *, + integer *, integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___202 = { 0, 0, 0, 0, 0 }; + static cilist io___207 = { 0, 0, 0, 0, 0 }; + static cilist io___208 = { 0, 0, 0, 0, 0 }; + static cilist io___209 = { 0, 0, 0, 0, 0 }; + static cilist io___210 = { 0, 0, 0, 0, 0 }; + static cilist io___212 = { 0, 0, 0, 0, 0 }; + static cilist io___213 = { 0, 0, 0, 0, 0 }; + static cilist io___214 = { 0, 0, 0, fmt_19990, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : recherche des triangles de noartr partageant le sommet ns */ +/* ----- */ +/* limite: un camembert de centre ns entame 2 fois */ +/* ne donne que l'une des parties */ + +/* entrees: */ +/* -------- */ +/* ns : numero du sommet */ +/* noarst : noarst(i) numero d'une arete de sommet i */ +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxartr : nombre de triangles declares dans noartr */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* mxpile : nombre maximal de triangles empilables */ + +/* sorties : */ +/* --------- */ +/* lhpile : >0 nombre de triangles empiles */ +/* =0 si impossible de tourner autour du point */ +/* ou zero triangle contenant le sommet ns */ +/* =-lhpile si apres butee sur la frontiere il y a a nouveau */ +/* butee sur la frontiere . a ce stade on ne peut dire si tous */ +/* les triangles ayant ce sommet ont ete recenses */ +/* ce cas arrive seulement si le sommet est sur la frontiere */ +/* par un balayage de tous les triangles, lhpile donne le */ +/* nombre de triangles de sommet ns */ +/* remarque: si la pile est saturee recherche de tous les */ +/* triangles de sommet ns par balayage de tous les triangles */ +/* lapile : numero dans noartr des triangles de sommet ns */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur: alain perronnet analyse numerique paris upmc mars 1997 */ +/* modifs: alain perronnet Laboratoire J-L. Lions UPMC Paris octobre 2006 */ +/* ....................................................................012 */ + + /* Parameter adjustments */ + --noarst; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --lapile; + + /* Function Body */ + *lhpile = 0; + +/* la premiere arete de sommet ns */ + nar = noarst[*ns]; + if (nar <= 0) { +/* cc write(imprim,*) 'trp1st: sommet',ns,' sans arete' */ + goto L100; + } + +/* l'arete nar est elle active? */ + if (nosoar[nar * nosoar_dim1 + 1] <= 0) { +/* cc write(imprim,*) 'trp1st: arete vide',nar, */ +/* cc % ' st1:', nosoar(1,nar),' st2:',nosoar(2,nar) */ + goto L100; + } + +/* le premier triangle de sommet ns */ + // nt0 = (i__1 = nosoar[nar * nosoar_dim1 + 4], abs(i__1)); + if (nt0 <= 0) { + //io___202.ciunit = unites_1.imprim; + //s_wsle(&io___202); + //do_lio(&c__9, &c__1, "trp1st: sommet", (ftnlen)14); + //do_lio(&c__3, &c__1, (char *)&(*ns), (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " dans aucun triangle", (ftnlen)20); + //e_wsle(); + goto L100; + } + +/* le triangle est il actif? */ + if (noartr[nt0 * noartr_dim1 + 1] == 0) { + goto L100; + } + +/* le numero des 3 sommets du triangle nt0 dans le sens direct */ + nusotr_(&nt0, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + +/* reperage du sommet ns dans le triangle nt0 */ + for (nar = 1; nar <= 3; ++nar) { + if (nosotr[nar - 1] == *ns) { + goto L10; + } +/* L5: */ + } +/* pas de sommet ns dans le triangle nt0 */ + goto L100; + +/* ns retrouve : le triangle nt0 de sommet ns est empile */ +L10: + *lhpile = 1; + lapile[1] = nt0; + nta = nt0; + +/* recherche dans le sens des aiguilles d'une montre */ +/* (sens indirect) du triangle nt1 de l'autre cote de l'arete */ +/* nar du triangle et en tournant autour du sommet ns */ +/* ========================================================== */ + noar = (i__1 = noartr[nar + nt0 * noartr_dim1], abs(i__1)); +/* le triangle nt1 oppose du triangle nt0 par l'arete noar */ + if (nosoar[noar * nosoar_dim1 + 4] == nt0) { + nt1 = nosoar[noar * nosoar_dim1 + 5]; + } else if (nosoar[noar * nosoar_dim1 + 5] == nt0) { + nt1 = nosoar[noar * nosoar_dim1 + 4]; + } else { + //io___207.ciunit = unites_1.imprim; + //s_wsle(&io___207); + //do_lio(&c__9, &c__1, "trp1st: anomalie arete", (ftnlen)22); + //do_lio(&c__3, &c__1, (char *)&noar, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " sans triangle", (ftnlen)14); + //do_lio(&c__3, &c__1, (char *)&nt0, (ftnlen)sizeof(integer)); + //e_wsle(); + goto L100; + } + +/* la boucle sur les triangles nt1 de sommet ns dans le sens indirect */ +/* ================================================================== */ + if (nt1 > 0) { + + if (noartr[nt1 * noartr_dim1 + 1] == 0) { + goto L30; + } + +/* le triangle nt1 n'a pas ete detruit. il est actif */ +/* le triangle oppose par l'arete noar existe */ +/* le numero des 3 sommets du triangle nt1 dans le sens direct */ +L15: + nusotr_(&nt1, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + +/* reperage du sommet ns dans nt1 */ + for (nar = 1; nar <= 3; ++nar) { + if (nosotr[nar - 1] == *ns) { + goto L25; + } +/* L20: */ + } +/* pas de sommet ns dans le triangle nt1 */ + goto L100; + +/* nt1 est empile */ +L25: + if (*lhpile >= *mxpile) { + goto L100; + } + ++(*lhpile); + lapile[*lhpile] = nt1; + +/* le triangle nt1 de l'autre cote de l'arete de sommet ns */ +/* sauvegarde du precedent triangle dans nta */ + nta = nt1; + noar = (i__1 = noartr[nar + nt1 * noartr_dim1], abs(i__1)); + if (nosoar[noar * nosoar_dim1 + 4] == nt1) { + nt1 = nosoar[noar * nosoar_dim1 + 5]; + } else if (nosoar[noar * nosoar_dim1 + 5] == nt1) { + nt1 = nosoar[noar * nosoar_dim1 + 4]; + } else { + //io___208.ciunit = unites_1.imprim; + //s_wsle(&io___208); + //do_lio(&c__9, &c__1, "trp1st: Anomalie arete", (ftnlen)22); + //do_lio(&c__3, &c__1, (char *)&noar, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " sans triangle", (ftnlen)14); + //do_lio(&c__3, &c__1, (char *)&nt1, (ftnlen)sizeof(integer)); + //e_wsle(); + goto L100; + } + +/* le triangle suivant est il a l'exterieur? */ + if (nt1 <= 0) { + goto L30; + } + +/* non: est il le premier triangle de sommet ns? */ + if (nt1 != nt0) { + goto L15; + } + +/* oui: recherche terminee par arrivee sur nt0 */ +/* les triangles forment un "cercle" de "centre" ns */ +/* lhpile ressort avec le signe + */ + return 0; + + } + +/* pas de triangle voisin a nt1 qui doit etre frontalier */ +/* ===================================================== */ +/* le parcours passe par 1 des triangles exterieurs */ +/* le parcours est inverse par l'arete de gauche */ +/* le triangle nta est le premier triangle empile */ +L30: + *lhpile = 1; + lapile[*lhpile] = nta; + +/* le numero des 3 sommets du triangle nta dans le sens direct */ + nusotr_(&nta, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + for (nar = 1; nar <= 3; ++nar) { + if (nosotr[nar - 1] == *ns) { + goto L33; + } +/* L32: */ + } + goto L100; + +/* l'arete qui precede (rotation / ns dans le sens direct) */ +L33: + if (nar == 1) { + nar = 3; + } else { + --nar; + } + +/* le triangle voisin de nta dans le sens direct */ + noar = (i__1 = noartr[nar + nta * noartr_dim1], abs(i__1)); + if (nosoar[noar * nosoar_dim1 + 4] == nta) { + nt1 = nosoar[noar * nosoar_dim1 + 5]; + } else if (nosoar[noar * nosoar_dim1 + 5] == nta) { + nt1 = nosoar[noar * nosoar_dim1 + 4]; + } else { + //io___209.ciunit = unites_1.imprim; + //s_wsle(&io___209); + //do_lio(&c__9, &c__1, "trp1st: Anomalie arete", (ftnlen)22); + //do_lio(&c__3, &c__1, (char *)&noar, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " SANS triangle", (ftnlen)14); + //do_lio(&c__3, &c__1, (char *)&nta, (ftnlen)sizeof(integer)); + //e_wsle(); + goto L100; + } + if (nt1 <= 0) { +/* un seul triangle contient ns */ +/* parcours de tous les triangles pour lever le doute */ + goto L100; + } + +/* boucle sur les triangles de sommet ns dans le sens direct */ +/* ========================================================== */ +L40: + if (noartr[nt1 * noartr_dim1 + 1] == 0) { + goto L70; + } + +/* le triangle nt1 n'a pas ete detruit. il est actif */ +/* le numero des 3 sommets du triangle nt1 dans le sens direct */ + nusotr_(&nt1, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + +/* reperage du sommet ns dans nt1 */ + for (nar = 1; nar <= 3; ++nar) { + if (nosotr[nar - 1] == *ns) { + goto L60; + } +/* L50: */ + } + goto L100; + +/* nt1 est empile */ +L60: + if (*lhpile >= *mxpile) { + goto L70; + } + ++(*lhpile); + lapile[*lhpile] = nt1; + +/* l'arete qui precede dans le sens direct */ + if (nar == 1) { + nar = 3; + } else { + --nar; + } + +/* l'arete de sommet ns dans nosoar */ + noar = (i__1 = noartr[nar + nt1 * noartr_dim1], abs(i__1)); + +/* le triangle voisin de nta dans le sens direct */ + nta = nt1; + if (nosoar[noar * nosoar_dim1 + 4] == nt1) { + nt1 = nosoar[noar * nosoar_dim1 + 5]; + } else if (nosoar[noar * nosoar_dim1 + 5] == nt1) { + nt1 = nosoar[noar * nosoar_dim1 + 4]; + } else { + //io___210.ciunit = unites_1.imprim; + //s_wsle(&io___210); + //do_lio(&c__9, &c__1, "trp1st: anomalie arete", (ftnlen)22); + //do_lio(&c__3, &c__1, (char *)&noar, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " SANS triangle", (ftnlen)14); + //do_lio(&c__3, &c__1, (char *)&nt1, (ftnlen)sizeof(integer)); + //e_wsle(); + goto L100; + } + if (nt1 > 0) { + goto L40; + } + +/* butee sur le trou => fin des triangles de sommet ns */ +/* ---------------------------------------------------- */ +/* impossible ici de trouver tous les triangles de sommet ns directement */ +/* les triangles de sommet ns ne forment pas une boule de centre ns */ +/* au moins 1, voire 2 triangles frontaliers de sommet ns */ +L70: + *lhpile = -(*lhpile); + return 0; + +/* Balayage de tous les triangles actifs et de sommet ns */ +/* methode lourde et couteuse mais a priori tres fiable */ +/* ----------------------------------------------------- */ +L100: + *lhpile = 0; + i__1 = *mxartr; + for (nt1 = 1; nt1 <= i__1; ++nt1) { + if (noartr[nt1 * noartr_dim1 + 1] != 0) { +/* le numero des 3 sommets du triangle i */ + nusotr_(&nt1, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + for (j = 1; j <= 3; ++j) { + if (nosotr[j - 1] == *ns) { +/* le triangle contient le sommet ns */ + ++(*lhpile); + if (*lhpile > *mxpile) { + goto L9990; + } + lapile[*lhpile] = nt1; + } +/* L110: */ + } + } +/* L120: */ + } +/* il n'est pas sur que ces triangles forment une boule de centre ns */ + *lhpile = -(*lhpile); + return 0; + +/* saturation de la pile des triangles */ +/* ----------------------------------- */ +L9990: + // io___212.ciunit = unites_1.imprim; + // s_wsle(&io___212); + // do_lio(&c__9, &c__1, "trp1st: saturation pile des triangles autour du so" + // "mmet", (ftnlen)54); + // do_lio(&c__3, &c__1, (char *)&(*ns), (ftnlen)sizeof(integer)); + // e_wsle(); + // io___213.ciunit = unites_1.imprim; + // s_wsle(&io___213); + // do_lio(&c__9, &c__1, "Plus de", (ftnlen)7); + // do_lio(&c__3, &c__1, (char *)&(*mxpile), (ftnlen)sizeof(integer)); + // do_lio(&c__9, &c__1, " triangles de sommet", (ftnlen)20); + // do_lio(&c__3, &c__1, (char *)&(*ns), (ftnlen)sizeof(integer)); + // e_wsle(); + // io___214.ciunit = unites_1.imprim; + // s_wsfe(&io___214); + // i__1 = *mxpile; + // for (ii = 1; ii <= i__1; ++ii) { + //do_fio(&c__1, (char *)&ii, (ftnlen)sizeof(integer)); + //do_fio(&c__1, (char *)&lapile[ii], (ftnlen)sizeof(integer)); + // } + // e_wsfe(); + +/* L9999: */ + *lhpile = 0; + return 0; +} /* trp1st_ */ + +/* Subroutine */ int nusotr_(integer *nt, integer *mosoar, integer *nosoar, + integer *moartr, integer *noartr, integer *nosotr) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset, i__1; + + /* Local variables */ + static integer na; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : calcul du numero des 3 sommets du triangle nt de noartr */ +/* ----- dans le sens direct (aire>0 si non degenere) */ + +/* entrees: */ +/* -------- */ +/* nt : numero du triangle dans le tableau noartr */ +/* mosoar : nombre maximal d'entiers par arete */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en + */ +/* sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1=0 si triangle vide => arete2=triangle vide suivant */ + +/* sorties: */ +/* -------- */ +/* nosotr : numero (dans le tableau pxyd) des 3 sommets du triangle */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* 2345x7..............................................................012 */ + +/* les 2 sommets de l'arete 1 du triangle nt dans le sens direct */ + /* Parameter adjustments */ + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --nosotr; + + /* Function Body */ + na = noartr[*nt * noartr_dim1 + 1]; + if (na > 0) { + nosotr[1] = 1; + nosotr[2] = 2; + } else { + nosotr[1] = 2; + nosotr[2] = 1; + na = -na; + } + nosotr[1] = nosoar[nosotr[1] + na * nosoar_dim1]; + nosotr[2] = nosoar[nosotr[2] + na * nosoar_dim1]; + +/* l'arete suivante */ + na = (i__1 = noartr[*nt * noartr_dim1 + 2], abs(i__1)); + +/* le sommet nosotr(3 du triangle 123 */ + nosotr[3] = nosoar[na * nosoar_dim1 + 1]; + if (nosotr[3] == nosotr[1] || nosotr[3] == nosotr[2]) { + nosotr[3] = nosoar[na * nosoar_dim1 + 2]; + } + return 0; +} /* nusotr_ */ + +/* Subroutine */ int tesusp_(doublereal *quamal, integer *nbarpi, doublereal * + pxyd, integer *noarst, integer *mosoar, integer *mxsoar, integer * + n1soar, integer *nosoar, integer *moartr, integer *mxartr, integer * + n1artr, integer *noartr, integer *mxarcf, integer *n1arcf, integer * + noarcf, integer *larmin, integer *notrcf, integer *liarcf, integer * + ierr) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset, i__1, + i__2; + doublereal d__1, d__2; + static integer equiv_2[3]; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static real d__; + static integer i__, j; + static real d0; + static integer ns, nt; +#define ns1 (equiv_2) +#define ns2 (equiv_2 + 1) +#define ns3 (equiv_2 + 2) + static integer nst, nste; + extern /* Subroutine */ int te1stm_(integer *, integer *, doublereal *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *), qutr2d_(doublereal *, + doublereal *, doublereal *, doublereal *), trp1st_(integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *); + static integer narete, nbtrcf; + static doublereal quamin, qualit; + static integer ntqmin, nbsuns; + static doublereal quaopt; + static integer nbstsu; +#define nosotr (equiv_2) + extern /* Subroutine */ int nusotr_(integer *, integer *, integer *, + integer *, integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___226 = { 0, 0, 0, 0, 0 }; + static cilist io___238 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : supprimer de la triangulation les sommets de te trop proches */ +/* ----- soit d'un sommet frontalier ou point interne impose */ +/* soit d'une arete frontaliere si la qualite minimale des triangles */ +/* est inferieure a quamal */ + +/* attention: le chainage lchain de nosoar devient celui des cf */ + +/* entrees: */ +/* -------- */ +/* quamal : qualite des triangles au dessous de laquelle supprimer des sommets */ +/* nbarpi : numero du dernier point interne impose par l'utilisateur */ +/* pxyd : tableau des coordonnees 2d des points */ +/* par point : x y distance_souhaitee */ +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* attention: mxsoar>3*mxsomm obligatoire! */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf */ + +/* modifies: */ +/* --------- */ +/* noarst : noarst(i) numero d'une arete de sommet i */ +/* n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar */ +/* chainage des vides suivant en 3 et precedant en 2 de nosoar */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = nosoar(1)+nosoar(2)*2 */ +/* avec mxsoar>=3*mxsomm */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 et */ +/* nosoar(2,arete vide)=l'arete vide qui precede */ +/* nosoar(3,arete vide)=l'arete vide qui suit */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ + + +/* auxiliaires : */ +/* ------------- */ +/* n1arcf : tableau (0:mxarcf) auxiliaire d'entiers */ +/* noarcf : tableau (3,mxarcf) auxiliaire d'entiers */ +/* larmin : tableau ( mxarcf ) auxiliaire d'entiers */ +/* notrcf : tableau ( mxarcf ) auxiliaire d'entiers */ +/* liarcf : tableau ( mxarcf ) auxiliaire d'entiers */ + +/* sortie : */ +/* -------- */ +/* ierr : =0 si pas d'erreur */ +/* >0 si une erreur est survenue */ +/* 11 algorithme defaillant */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* ....................................................................012 */ + + +/* le nombre de sommets de te supprimes */ + /* Parameter adjustments */ + pxyd -= 4; + --noarst; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --liarcf; + --notrcf; + --larmin; + noarcf -= 4; + + /* Function Body */ + nbstsu = 0; + *ierr = 0; + +/* initialisation du chainage des aretes des cf => 0 arete de cf */ + i__1 = *mxsoar; + for (narete = 1; narete <= i__1; ++narete) { + nosoar[narete * nosoar_dim1 + 6] = -1; +/* L10: */ + } + +/* boucle sur l'ensemble des sommets frontaliers ou points internes */ +/* ================================================================ */ + i__1 = *nbarpi; + for (ns = 1; ns <= i__1; ++ns) { + +/* le nombre de sommets supprimes pour ce sommet ns */ + nbsuns = 0; +/* la qualite minimale au dessous de laquelle le point proche */ +/* interne est supprime */ + quaopt = *quamal; + +/* une arete de sommet ns */ +L15: + narete = noarst[ns]; + if (narete <= 0) { +/* erreur: le point appartient a aucune arete */ + //io___226.ciunit = unites_2.imprim; + //s_wsle(&io___226); + //do_lio(&c__9, &c__1, "sommet ", (ftnlen)7); + //do_lio(&c__3, &c__1, (char *)&ns, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " dans aucune arete", (ftnlen)18); + //e_wsle(); + *ierr = 11; + return 0; + } + +/* recherche des triangles de sommet ns */ + trp1st_(&ns, &noarst[1], mosoar, &nosoar[nosoar_offset], moartr, + mxartr, &noartr[noartr_offset], mxarcf, &nbtrcf, ¬rcf[1]); + if (nbtrcf == 0) { + goto L100; + } + if (nbtrcf < 0) { +/* impossible de trouver tous les triangles de sommet ns */ +/* seule une partie est a priori retrouvee ce qui est normal */ +/* si ns est un sommet frontalier */ + nbtrcf = -nbtrcf; + } + +/* boucle sur les triangles de l'etoile du sommet ns */ +/* recherche du triangle de sommet ns ayant la plus basse qualite */ + quamin = 2.; + i__2 = nbtrcf; + for (i__ = 1; i__ <= i__2; ++i__) { +/* le numero des 3 sommets du triangle nt */ + nt = notrcf[i__]; + nusotr_(&nt, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); +/* nosotr(1:3) est en equivalence avec ns1, ns2, ns3 */ +/* la qualite du triangle ns1 ns2 ns3 */ + qutr2d_(&pxyd[*ns1 * 3 + 1], &pxyd[*ns2 * 3 + 1], &pxyd[*ns3 * 3 + + 1], &qualit); + if (qualit < quamin) { + quamin = qualit; + ntqmin = nt; + } +/* L20: */ + } + +/* bilan sur la qualite des triangles de sommet ns */ + if (quamin < quaopt) { + +/* recherche du sommet de ntqmin le plus proche et non frontalier */ +/* ============================================================== */ +/* le numero des 3 sommets du triangle ntqmin */ + nusotr_(&ntqmin, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + nste = 0; + d0 = 1e28f; + for (j = 1; j <= 3; ++j) { + nst = nosotr[j - 1]; + if (nst != ns && nst > *nbarpi) { +/* Computing 2nd power */ + d__1 = pxyd[nst * 3 + 1] - pxyd[ns * 3 + 1]; +/* Computing 2nd power */ + d__2 = pxyd[nst * 3 + 2] - pxyd[ns * 3 + 2]; + d__ = d__1 * d__1 + d__2 * d__2; + if (d__ < d0) { + d0 = d__; + nste = j; + } + } +/* L30: */ + } + + if (nste > 0) { + +/* nste est le sommet le plus proche de ns de ce */ +/* triangle de mauvaise qualite et sommet non encore traite */ + nste = nosotr[nste - 1]; + +/* nste est un sommet de triangle equilateral */ +/* => le sommet nste va etre supprime */ +/* ========================================== */ + te1stm_(&nste, nbarpi, &pxyd[4], &noarst[1], mosoar, mxsoar, + n1soar, &nosoar[nosoar_offset], moartr, mxartr, + n1artr, &noartr[noartr_offset], mxarcf, n1arcf, & + noarcf[4], &larmin[1], ¬rcf[1], &liarcf[1], ierr); + if (*ierr == 0) { +/* un sommet de te supprime de plus */ + ++nbstsu; + +/* boucle jusqu'a obtenir une qualite suffisante */ +/* si triangulation tres irreguliere => */ +/* destruction de beaucoup de points internes */ +/* les 2 variables suivantes brident ces destructions massives */ + ++nbsuns; + quaopt *= .8f; + if (nbsuns < 5) { + goto L15; + } + } else { + if (*ierr < 0) { +/* le sommet nste est externe donc non supprime */ +/* ou bien le sommet nste est le centre d'un cf dont toutes */ +/* les aretes simples sont frontalieres */ +/* dans les 2 cas le sommet n'est pas supprime */ + *ierr = 0; + goto L100; + } else { +/* erreur motivant un arret de la triangulation */ + return 0; + } + } + } + } + +L100: + ; + } + + //io___238.ciunit = unites_2.imprim; + //s_wsle(&io___238); + //do_lio(&c__9, &c__1, "tesusp: suppression de", (ftnlen)22); + //do_lio(&c__3, &c__1, (char *)&nbstsu, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " sommets de te trop proches de la frontiere", ( + // ftnlen)43); + //e_wsle(); + return 0; +} /* tesusp_ */ + +#undef nosotr +#undef ns3 +#undef ns2 +#undef ns1 + + +/* Subroutine */ int teamqa_(integer *nutysu, doublereal *airemx, integer * + noarst, integer *mosoar, integer *mxsoar, integer *n1soar, integer * + nosoar, integer *moartr, integer *mxartr, integer *n1artr, integer * + noartr, integer *mxtrcf, integer *notrcf, integer *nostbo, integer * + n1arcf, integer *noarcf, integer *larmin, integer *nbarpi, integer * + nbsomm, integer *mxsomm, doublereal *pxyd, integer *nslign, integer * + ierr) +{ + /* System generated locals */ + integer noartr_dim1, noartr_offset, nosoar_dim1, nosoar_offset, i__1, + i__2, i__3, i__4, i__5; + doublereal d__1, d__2; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + double sqrt(doublereal); + + /* Local variables */ + static doublereal d__; + static integer i__, j; + static doublereal x, y, s0, s1; + static integer na, ns, nt, ns1, ns2, ns3, ier; + static doublereal dns; + static integer nst; + static doublereal xns, yns; + static integer nbs1, nbs2, nbs3; + static doublereal dmin__, dmax__, xbar, ybar; + static integer imax, noar, iter; + static doublereal dmoy; + static integer noar0; + static doublereal ponde1, xyzns[3]; + extern doublereal surtd2_(doublereal *, doublereal *, doublereal *); + extern /* Subroutine */ int trp1st_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *), tedela_(doublereal *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *), tr3str_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *), tetaid_(integer *, + doublereal *, doublereal *, doublereal *, integer *); + static integer nbitaq, nbtrcf; + static doublereal airetm; + static integer modifs; + static doublereal ponder; + static integer nbstbo, nosotr[3]; + extern /* Subroutine */ int nusotr_(integer *, integer *, integer *, + integer *, integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___260 = { 0, 0, 0, 0, 0 }; + static cilist io___262 = { 0, 0, 0, 0, 0 }; + static cilist io___274 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but: Boucles sur les aretes actives de la triangulation actuelle */ +/* ---- si la taille de l'arete moyenne est >ampli*taille souhaitee */ +/* alors ajout d'un sommet barycentre du plus grand triangle */ +/* de sommet ns */ +/* si la taille de l'arete moyenne est aretmx active */ +/* 1 il existe une fonction areteideale() */ +/* dont seules les 2 premieres composantes de uv sont actives */ +/* autres options a definir... */ +/* airemx : aire maximale d'un triangle */ +/* noarst : noarst(i) numero d'une arete de sommet i */ +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes frontalieres declarables */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxartr : nombre maximal de triangles declarables dans noartr */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* mxtrcf : nombre maximal de triangles empilables */ +/* nbarpi : numero du dernier sommet frontalier ou interne impose */ +/* nslign : tableau du numero de sommet dans sa ligne pour chaque */ +/* sommet frontalier */ +/* numero du point dans le lexique point si interne impose */ +/* 0 si le point est interne non impose par l'utilisateur */ +/* -1 si le sommet est externe au domaine */ + +/* modifies : */ +/* ---------- */ +/* nbsomm : nombre actuel de sommets de la triangulation */ +/* (certains sommets internes ont ete desactives ou ajoutes) */ +/* pxyd : tableau des coordonnees 2d des points */ + +/* auxiliaires: */ +/* ------------ */ +/* notrcf : tableau ( mxtrcf ) auxiliaire d'entiers */ +/* numero dans noartr des triangles de sommet ns */ +/* nostbo : tableau ( mxtrcf ) auxiliaire d'entiers */ +/* numero dans pxyd des sommets des aretes simples de la boule */ +/* n1arcf : tableau (0:mxtrcf) auxiliaire d'entiers */ +/* noarcf : tableau (3,mxtrcf) auxiliaire d'entiers */ +/* larmin : tableau ( mxtrcf ) auxiliaire d'entiers */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc juin 1997 */ +/* ....................................................................012 */ + +/* initialisation du chainage des aretes des cf => 0 arete de cf */ + /* Parameter adjustments */ + --noarst; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --larmin; + noarcf -= 4; + --notrcf; + --nostbo; + pxyd -= 4; + --nslign; + + /* Function Body */ + i__1 = *mxsoar; + for (noar = 1; noar <= i__1; ++noar) { + nosoar[noar * nosoar_dim1 + 6] = -1; +/* L1: */ + } + noar0 = 0; + +/* le nombre d'iterations pour ameliorer la qualite */ + nbitaq = 5; + ier = 0; + +/* initialisation du parcours */ + nbs1 = *nbsomm; + nbs2 = *nbarpi + 1; + nbs3 = -1; + + i__1 = nbitaq; + for (iter = 1; iter <= i__1; ++iter) { + +/* ccc le nombre de barycentres ajoutes */ +/* cc nbbaaj = 0 */ + +/* coefficient de ponderation croissant avec les iterations */ + ponder = iter * .5 / nbitaq + .1; +/* cc 9 octobre 2006 ponder = min( 1d0, 0.1d0 + iter * 0.9d0 / nbitaq ) */ +/* cc 9 mars 2006 ponder = min( 1d0, ( 50 + (50*iter)/nbitaq ) * 0.01d0 ) */ + ponde1 = 1. - ponder; + +/* l'ordre du parcours dans le sens croissant ou decroissant */ +/* alternance du parcours */ + nt = nbs1; + nbs1 = nbs2; + nbs2 = nt; + nbs3 = -nbs3; + + i__2 = nbs2; + i__3 = nbs3; + for (ns = nbs1; i__3 < 0 ? ns >= i__2 : ns <= i__2; ns += i__3) { + +/* le sommet est il interne au domaine? */ + if (nslign[ns] != 0) { + goto L1000; + } + +/* existe-t-il une arete de sommet ns ? */ + noar = noarst[ns]; + if (noar <= 0) { + goto L1000; + } + if (nosoar[noar * nosoar_dim1 + 1] <= 0) { + goto L1000; + } + +/* le 1-er triangle de l'arete noar */ + nt = nosoar[noar * nosoar_dim1 + 4]; + if (nt <= 0) { + goto L1000; + } + +/* recherche des triangles de sommet ns */ +/* ils doivent former un contour ferme de type etoile */ + trp1st_(&ns, &noarst[1], mosoar, &nosoar[nosoar_offset], moartr, + mxartr, &noartr[noartr_offset], mxtrcf, &nbtrcf, ¬rcf[ + 1]); + if (nbtrcf <= 0) { + goto L1000; + } + +/* mise a jour de la distance souhaitee autour de ns */ + xns = pxyd[ns * 3 + 1]; + yns = pxyd[ns * 3 + 2]; + if (*nutysu > 0) { +/* la fonction taille_ideale(x,y,z) existe */ + tetaid_(nutysu, &xns, &yns, &pxyd[ns * 3 + 3], &ier); + } + +/* boucle sur les triangles qui forment une etoile autour du sommet ns */ +/* chainage des aretes simples de l'etoile formee par ces triangles */ + +/* remise a zero du lien nosoar des aretes a rendre Delaunay */ +L19: + if (noar0 > 0) { + noar = nosoar[noar0 * nosoar_dim1 + 6]; + nosoar[noar0 * nosoar_dim1 + 6] = -1; + noar0 = noar; + goto L19; + } + + noar0 = 0; + nbstbo = 0; + airetm = 0.; + i__4 = nbtrcf; + for (i__ = 1; i__ <= i__4; ++i__) { +/* recherche du triangle de plus grande aire */ + nt = notrcf[i__]; + nusotr_(&nt, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + d__ = surtd2_(&pxyd[nosotr[0] * 3 + 1], &pxyd[nosotr[1] * 3 + + 1], &pxyd[nosotr[2] * 3 + 1]); + if (d__ > airetm) { + airetm = d__; + imax = i__; + } else if (d__ <= 0.) { + //io___260.ciunit = unites_1.imprim; + //s_wsle(&io___260); + //do_lio(&c__9, &c__1, "teamqa: triangle notrcf(", (ftnlen) + // 24); + //do_lio(&c__3, &c__1, (char *)&i__, (ftnlen)sizeof(integer) + // ); + //do_lio(&c__9, &c__1, ")=", (ftnlen)2); + //do_lio(&c__3, &c__1, (char *)¬rcf[i__], (ftnlen)sizeof( + // integer)); + //do_lio(&c__9, &c__1, " st", (ftnlen)3); + //do_lio(&c__3, &c__3, (char *)&nosotr[0], (ftnlen)sizeof( + // integer)); + //do_lio(&c__9, &c__1, " AIRE=", (ftnlen)6); + //do_lio(&c__5, &c__1, (char *)&d__, (ftnlen)sizeof( + // doublereal)); + //do_lio(&c__9, &c__1, "<=0", (ftnlen)3); + //e_wsle(); + goto L1000; + } + +/* le no de l'arete du triangle nt ne contenant pas le sommet ns */ + for (na = 1; na <= 3; ++na) { +/* le numero de l'arete na dans le tableau nosoar */ + noar = (i__5 = noartr[na + nt * noartr_dim1], abs(i__5)); + if (nosoar[noar * nosoar_dim1 + 1] != ns && nosoar[noar * + nosoar_dim1 + 2] != ns) { + goto L25; + } +/* L20: */ + } + //io___262.ciunit = unites_1.imprim; + //s_wsle(&io___262); + //do_lio(&c__9, &c__1, "teamqa: ERREUR triangle", (ftnlen)23); + //do_lio(&c__3, &c__1, (char *)&nt, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " SANS sommet", (ftnlen)12); + //do_lio(&c__3, &c__1, (char *)&ns, (ftnlen)sizeof(integer)); + //e_wsle(); + +/* construction de la liste des sommets des aretes simples */ +/* de la boule des triangles de sommet ns */ +/* ------------------------------------------------------- */ +L25: + for (na = 1; na <= 2; ++na) { + ns1 = nosoar[na + noar * nosoar_dim1]; + for (j = nbstbo; j >= 1; --j) { + if (ns1 == nostbo[j]) { + goto L35; + } +/* L30: */ + } +/* ns1 est un nouveau sommet a ajouter a l'etoile */ + ++nbstbo; + nostbo[nbstbo] = ns1; +L35: + ; + } + +/* noar est une arete potentielle a rendre Delaunay */ + if (nosoar[noar * nosoar_dim1 + 3] == 0) { +/* arete non frontaliere */ + nosoar[noar * nosoar_dim1 + 6] = noar0; + noar0 = noar; + } + +/* L40: */ + } + +/* calcul des 2 coordonnees du barycentre de la boule du sommet ns */ +/* calcul de la longueur moyenne des aretes issues du sommet ns */ +/* --------------------------------------------------------------- */ + xbar = 0.; + ybar = 0.; + dmoy = 0.; + dmax__ = 0.; + dmin__ = 1e124; + dns = 0.; + i__4 = nbstbo; + for (i__ = 1; i__ <= i__4; ++i__) { + nst = nostbo[i__]; + x = pxyd[nst * 3 + 1]; + y = pxyd[nst * 3 + 2]; + xbar += x; + ybar += y; +/* Computing 2nd power */ + d__1 = x - xns; +/* Computing 2nd power */ + d__2 = y - yns; + d__ = sqrt(d__1 * d__1 + d__2 * d__2); + dmoy += d__; + dmax__ = max(dmax__,d__); + dmin__ = min(dmin__,d__); + dns += pxyd[nst * 3 + 3]; +/* L50: */ + } + xbar /= nbstbo; + ybar /= nbstbo; + dmoy /= nbstbo; + dns /= nbstbo; + +/* pas de modification de la topologie lors de la derniere iteration */ +/* ================================================================= */ + if (iter == nbitaq) { + goto L200; + } + +/* si la taille de l'arete maximale est >ampli*taille souhaitee */ +/* alors ajout d'un sommet barycentre du plus grand triangle */ +/* de sommet ns */ +/* ============================================================ */ + if (airetm > *airemx || dmax__ > dns * 1.34) { + +/* ajout du barycentre du triangle notrcf(imax) */ + nt = notrcf[imax]; + nusotr_(&nt, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + if (*nbsomm >= *mxsomm) { + //io___274.ciunit = unites_1.imprim; + //s_wsle(&io___274); + //do_lio(&c__9, &c__1, "saturation du tableau pxyd", ( + // ftnlen)26); + //e_wsle(); +/* abandon de l'amelioration du sommet ns */ + goto L9999; + } + ++(*nbsomm); + for (i__ = 1; i__ <= 3; ++i__) { + pxyd[i__ + *nbsomm * 3] = (pxyd[i__ + nosotr[0] * 3] + + pxyd[i__ + nosotr[1] * 3] + pxyd[i__ + nosotr[2] * + 3]) / 3.; +/* L160: */ + } + if (*nutysu > 0) { +/* la fonction taille_ideale(x,y,z) existe */ + tetaid_(nutysu, &pxyd[*nbsomm * 3 + 1], &pxyd[*nbsomm * 3 + + 2], &pxyd[*nbsomm * 3 + 3], &ier); + } + +/* sommet interne a la triangulation */ + nslign[*nbsomm] = 0; + +/* les 3 aretes du triangle nt sont a rendre delaunay */ + for (i__ = 1; i__ <= 3; ++i__) { + noar = (i__4 = noartr[i__ + nt * noartr_dim1], abs(i__4)); + if (nosoar[noar * nosoar_dim1 + 3] == 0) { +/* arete non frontaliere */ + if (nosoar[noar * nosoar_dim1 + 6] < 0) { +/* arete non encore chainee */ + nosoar[noar * nosoar_dim1 + 6] = noar0; + noar0 = noar; + } + } +/* L170: */ + } + +/* triangulation du triangle de barycentre nbsomm */ +/* protection a ne pas modifier sinon erreur! */ + tr3str_(nbsomm, &nt, mosoar, mxsoar, n1soar, &nosoar[ + nosoar_offset], moartr, mxartr, n1artr, &noartr[ + noartr_offset], &noarst[1], nosotr, ierr); + if (*ierr != 0) { + goto L9999; + } + +/* ccc un barycentre ajoute de plus */ +/* cc nbbaaj = nbbaaj + 1 */ + +/* les aretes chainees de la boule sont rendues delaunay */ + goto L900; + + } + +/* les 2 coordonnees du barycentre des sommets des aretes */ +/* simples de la boule du sommet ns */ +/* ====================================================== */ +/* DEBUT AJOUT 10 octobre 2006 */ +/* PONDERATION POUR EVITER LES DEGENERESCENSES AVEC PROTECTION */ +/* SI UN TRIANGLE DE SOMMET NS A UNE AIRE NEGATIVE APRES BARYCENTRAGE */ +/* ALORS LE SOMMET NS N'EST PAS BOUGE */ + +/* protection des XY du point initial */ +L200: + xyzns[0] = pxyd[ns * 3 + 1]; + xyzns[1] = pxyd[ns * 3 + 2]; + xyzns[2] = pxyd[ns * 3 + 3]; + +/* ponderation pour eviter les degenerescenses */ + pxyd[ns * 3 + 1] = ponde1 * pxyd[ns * 3 + 1] + ponder * xbar; + pxyd[ns * 3 + 2] = ponde1 * pxyd[ns * 3 + 2] + ponder * ybar; + if (*nutysu > 0) { +/* la fonction taille_ideale(x,y,z) existe */ + tetaid_(nutysu, &pxyd[ns * 3 + 1], &pxyd[ns * 3 + 2], &pxyd[ + ns * 3 + 3], &ier); + } + +/* calcul des surfaces avant et apres deplacement de ns */ + s0 = 0.; + s1 = 0.; + i__4 = nbtrcf; + for (i__ = 1; i__ <= i__4; ++i__) { +/* le numero de l'arete du triangle nt ne contenant pas le sommet ns */ + nt = notrcf[i__]; + for (na = 1; na <= 3; ++na) { +/* le numero de l'arete na dans le tableau nosoar */ + noar = (i__5 = noartr[na + nt * noartr_dim1], abs(i__5)); + if (nosoar[noar * nosoar_dim1 + 1] != ns && nosoar[noar * + nosoar_dim1 + 2] != ns) { + ns2 = nosoar[noar * nosoar_dim1 + 1]; + ns3 = nosoar[noar * nosoar_dim1 + 2]; + goto L206; + } +/* L204: */ + } +/* aire signee des 2 triangles */ +L206: + s0 += (d__1 = surtd2_(xyzns, &pxyd[ns2 * 3 + 1], &pxyd[ns3 * + 3 + 1]), abs(d__1)); + s1 += (d__1 = surtd2_(&pxyd[ns * 3 + 1], &pxyd[ns2 * 3 + 1], & + pxyd[ns3 * 3 + 1]), abs(d__1)); +/* L210: */ + } + if ((d__1 = s0 - s1, abs(d__1)) > abs(s0) * 1e-10) { +/* retour a la position initiale */ +/* car le point est passe au dela d'une arete de son etoile */ + pxyd[ns * 3 + 1] = xyzns[0]; + pxyd[ns * 3 + 2] = xyzns[1]; + pxyd[ns * 3 + 3] = xyzns[2]; +/* la ponderation est reduite 10 octobre 2006 */ +/* Computing MAX */ + d__1 = .1, d__2 = ponder * .5; + ponder = max(d__1,d__2); + ponde1 = 1. - ponder; + goto L1000; + } + +/* les aretes chainees de la boule sont rendues delaunay */ +L900: + tedela_(&pxyd[4], &noarst[1], mosoar, mxsoar, n1soar, &nosoar[ + nosoar_offset], &noar0, moartr, mxartr, n1artr, &noartr[ + noartr_offset], &modifs); + +L1000: + ; + } + +/* cc write(imprim,11000) iter, nbbaaj */ +/* cc11000 format('teamqa: iteration',i3,' =>',i6,' barycentres ajoutes') */ + +/* mise a jour pour ne pas oublier les nouveaux sommets */ + if (nbs1 > nbs2) { + nbs1 = *nbsomm; + } else { + nbs2 = *nbsomm; + } + +/* L5000: */ + } + +L9999: + return 0; +} /* teamqa_ */ + +/* Subroutine */ int teamqt_(integer *nutysu, doublereal *aretmx, doublereal * + airemx, integer *noarst, integer *mosoar, integer *mxsoar, integer * + n1soar, integer *nosoar, integer *moartr, integer *mxartr, integer * + n1artr, integer *noartr, integer *mxarcf, integer *notrcf, integer * + nostbo, integer *n1arcf, integer *noarcf, integer *larmin, integer * + nbarpi, integer *nbsomm, integer *mxsomm, doublereal *pxyd, integer * + nslign, integer *ierr) +{ + /* System generated locals */ + integer noartr_dim1, noartr_offset, nosoar_dim1, nosoar_offset; + + /* Local variables */ + extern /* Subroutine */ int qualitetrte_(doublereal *, integer *, integer + *, integer *, integer *, integer *, integer *, integer *, + doublereal *, doublereal *), teamqa_(integer *, doublereal *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + doublereal *, integer *, integer *); + static integer nbtria; + static doublereal quamin, quamoy; + extern /* Subroutine */ int tesuqm_(doublereal *, integer *, doublereal *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, doublereal *), tesusp_( + doublereal *, integer *, doublereal *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *); + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : amelioration de la qualite de la triangulation */ +/* ----- */ + +/* entrees: */ +/* -------- */ +/* nutysu : numero de traitement de areteideale() selon le type de surface */ +/* 0 pas d'emploi de la fonction areteideale() => aretmx active */ +/* 1 il existe une fonction areteideale() */ +/* dont seules les 2 premieres composantes de uv sont actives */ +/* autres options a definir... */ +/* aretmx : longueur maximale des aretes de la future triangulation */ +/* airemx : aire maximale souhaitee des triangles */ +/* noarst : noarst(i) numero d'une arete de sommet i */ +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes frontalieres declarables */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxartr : nombre maximal de triangles declarables dans noartr */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* mxarcf : nombre maximal de triangles empilables */ +/* nbarpi : numero du dernier sommet frontalier ou interne impose */ +/* nslign : tableau du numero de sommet dans sa ligne pour chaque */ +/* sommet frontalier */ +/* numero du point dans le lexique point si interne impose */ +/* 0 si le point est interne non impose par l'utilisateur */ +/* -1 si le sommet est externe au domaine */ + +/* modifies : */ +/* ---------- */ +/* nbsomm : nombre actuel de sommets de la triangulation */ +/* (certains sommets internes ont ete desactives ou ajoutes) */ +/* pxyd : tableau des coordonnees 2d des points */ + +/* auxiliaires: */ +/* ------------ */ +/* notrcf : tableau ( mxarcf ) auxiliaire d'entiers */ +/* numero dans noartr des triangles de sommet ns */ +/* nostbo : tableau ( mxarcf ) auxiliaire d'entiers */ +/* numero dans pxyd des sommets des aretes simples de la boule */ +/* n1arcf : tableau (0:mxarcf) auxiliaire d'entiers */ +/* noarcf : tableau (3,mxarcf) auxiliaire d'entiers */ +/* larmin : tableau ( mxarcf ) auxiliaire d'entiers */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc juin 1997 */ +/* ....................................................................012 */ +/* parameter ( quamal=0.3d0 ) => ok */ +/* parameter ( quamal=0.4d0 ) => pb pour le test ocean */ +/* parameter ( quamal=0.5d0 ) => pb pour le test ocean */ +/* quamal=0.1d0 est choisi pour ne pas trop detruire de sommets */ + + + /* Parameter adjustments */ + --noarst; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --larmin; + noarcf -= 4; + --nostbo; + --notrcf; + pxyd -= 4; + --nslign; + + /* Function Body */ + *ierr = 0; + +/* supprimer de la triangulation les triangles de qualite */ +/* inferieure a quamal */ +/* ====================================================== */ + tesuqm_(&c_b357, nbarpi, &pxyd[4], &noarst[1], mosoar, mxsoar, n1soar, & + nosoar[nosoar_offset], moartr, mxartr, n1artr, &noartr[ + noartr_offset], mxarcf, n1arcf, &noarcf[4], &larmin[1], ¬rcf[1] + , &nostbo[1], &quamin); + qualitetrte_(&pxyd[4], mosoar, mxsoar, &nosoar[nosoar_offset], moartr, + mxartr, &noartr[noartr_offset], &nbtria, &quamoy, &quamin); + +/* suppression des sommets de triangles equilateraux trop proches */ +/* d'un sommet frontalier ou d'un point interne impose par */ +/* triangulation frontale de l'etoile et mise en delaunay */ +/* ============================================================== */ + if (quamin <= .1) { + tesusp_(&c_b357, nbarpi, &pxyd[4], &noarst[1], mosoar, mxsoar, n1soar, + &nosoar[nosoar_offset], moartr, mxartr, n1artr, &noartr[ + noartr_offset], mxarcf, n1arcf, &noarcf[4], &larmin[1], & + notrcf[1], &nostbo[1], ierr); + if (*ierr != 0) { + goto L9999; + } + } + +/* ajustage des tailles moyennes des aretes avec ampli=1.34d0 entre */ +/* ampli/2 x taille_souhaitee et ampli x taille_souhaitee */ +/* + barycentrage des sommets et mise en triangulation delaunay */ +/* ================================================================ */ + teamqa_(nutysu, airemx, &noarst[1], mosoar, mxsoar, n1soar, &nosoar[ + nosoar_offset], moartr, mxartr, n1artr, &noartr[noartr_offset], + mxarcf, ¬rcf[1], &nostbo[1], n1arcf, &noarcf[4], &larmin[1], + nbarpi, nbsomm, mxsomm, &pxyd[4], &nslign[1], ierr); + qualitetrte_(&pxyd[4], mosoar, mxsoar, &nosoar[nosoar_offset], moartr, + mxartr, &noartr[noartr_offset], &nbtria, &quamoy, &quamin); + if (*ierr != 0) { + goto L9999; + } + +L9999: + return 0; +} /* teamqt_ */ + +/* Subroutine */ int trfrcf_(integer *nscent, integer *mosoar, integer * + nosoar, integer *moartr, integer *noartr, integer *nbtrcf, integer * + notrcf, integer *nbarfr) +{ + /* System generated locals */ + integer noartr_dim1, noartr_offset, nosoar_dim1, nosoar_offset, i__1, + i__2; + + /* Local variables */ + static integer i__, j, n, ns, nt, noar; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : calculer le nombre d'aretes simples du contour ferme des */ +/* ----- nbtrcf triangles de numeros stockes dans le tableau notrcf */ +/* ayant tous le sommet nscent */ + +/* entrees: */ +/* -------- */ +/* nscent : numero du sommet appartenant a tous les triangles notrcf */ +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* nbtrcf : >0 nombre de triangles empiles */ +/* =0 si impossible de tourner autour du point */ +/* =-nbtrcf si apres butee sur la frontiere il y a a nouveau */ +/* butee sur la frontiere . a ce stade on ne peut dire si tous */ +/* les triangles ayant ce sommet ont ete recenses */ +/* ce cas arrive seulement si le sommet est sur la frontiere */ +/* notrcf : numero dans noartr des triangles de sommet ns */ + +/* sortie : */ +/* -------- */ +/* nbarfr : nombre d'aretes simples frontalieres */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc juin 1997 */ +/* ....................................................................012 */ + + /* Parameter adjustments */ + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --notrcf; + + /* Function Body */ + *nbarfr = 0; + i__1 = *nbtrcf; + for (n = 1; n <= i__1; ++n) { +/* le numero du triangle n dans le tableau noartr */ + nt = notrcf[n]; +/* parcours des 3 aretes du triangle nt */ + for (i__ = 1; i__ <= 3; ++i__) { +/* le numero de l'arete i dans le tableau nosoar */ + noar = (i__2 = noartr[i__ + nt * noartr_dim1], abs(i__2)); + for (j = 1; j <= 2; ++j) { +/* le numero du sommet j de l'arete noar */ + ns = nosoar[j + noar * nosoar_dim1]; + if (ns == *nscent) { + goto L40; + } +/* L30: */ + } +/* l'arete noar (sans sommet nscent) est elle frontaliere? */ + if (nosoar[noar * nosoar_dim1 + 5] <= 0) { +/* l'arete appartient au plus a un triangle */ +/* une arete simple frontaliere de plus */ + ++(*nbarfr); + } +/* le triangle a au plus une arete sans sommet nscent */ + goto L50; +L40: + ; + } +L50: + ; + } + return 0; +} /* trfrcf_ */ + +/* Subroutine */ int int2ar_(doublereal *p1, doublereal *p2, doublereal *p3, + doublereal *p4, logical *oui) +{ + /* System generated locals */ + doublereal d__1, d__2; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + static doublereal d__, x, y, d21, d43, x21, y21, x43, y43, xx; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : les 2 aretes de r**2 p1-p2 p3-p4 s'intersectent elles */ +/* ----- entre leurs sommets? */ + +/* entrees: */ +/* -------- */ +/* p1,p2,p3,p4 : les 2 coordonnees reelles des sommets des 2 aretes */ + +/* sortie : */ +/* -------- */ +/* oui : .true. si intersection, .false. sinon */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc octobre 1991 */ +/* 2345x7..............................................................012 */ + +/* longueur des aretes */ + /* Parameter adjustments */ + --p4; + --p3; + --p2; + --p1; + + /* Function Body */ + x21 = p2[1] - p1[1]; + y21 = p2[2] - p1[2]; +/* Computing 2nd power */ + d__1 = x21; +/* Computing 2nd power */ + d__2 = y21; + d21 = d__1 * d__1 + d__2 * d__2; + + x43 = p4[1] - p3[1]; + y43 = p4[2] - p3[2]; +/* Computing 2nd power */ + d__1 = x43; +/* Computing 2nd power */ + d__2 = y43; + d43 = d__1 * d__1 + d__2 * d__2; + +/* les 2 aretes sont-elles jugees paralleles ? */ + d__ = x43 * y21 - y43 * x21; + if (abs(d__) <= sqrt(d21 * d43) * .001f) { +/* aretes paralleles . pas d'intersection */ + *oui = FALSE_; + return 0; + } + +/* les 2 coordonnees du point d'intersection */ + x = (p1[1] * x43 * y21 - p3[1] * x21 * y43 - (p1[2] - p3[2]) * x21 * x43) + / d__; + y = -(p1[2] * y43 * x21 - p3[2] * y21 * x43 - (p1[1] - p3[1]) * y21 * y43) + / d__; + +/* coordonnees de x,y dans le repere ns1-ns2 */ + xx = (x - p1[1]) * x21 + (y - p1[2]) * y21; +/* le point est il entre p1 et p2 ? */ + *oui = d21 * -1e-5 <= xx && xx <= d21 * 1.00001; + +/* coordonnees de x,y dans le repere ns3-ns4 */ + xx = (x - p3[1]) * x43 + (y - p3[2]) * y43; +/* le point est il entre p3 et p4 ? */ + *oui = *oui && d43 * -1e-5 <= xx && xx <= d43 * 1.00001; + return 0; +} /* int2ar_ */ + +/* Subroutine */ int trchtd_(doublereal *pxyd, integer *nar00, integer *nar0, + integer *noarcf, integer *namin0, integer *namin, integer *larmin) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal d__1, d__2; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + double sqrt(doublereal); + + /* Local variables */ + static integer i__, j; + static doublereal q, dd; + static integer na0, na1, np1, np2, ns1, ns2, ns3, ns4, na00, ier, nar; + static logical oui; + static integer nar1, nar2, nar3, nbar; + static doublereal dmima; + static integer nbmin; + static real qmima; + static doublereal rayon; + extern /* Subroutine */ int int2ar_(doublereal *, doublereal *, + doublereal *, doublereal *, logical *), qutr2d_(doublereal *, + doublereal *, doublereal *, doublereal *), cenced_(doublereal *, + doublereal *, doublereal *, doublereal *, integer *); + extern doublereal surtd2_(doublereal *, doublereal *, doublereal *); + static doublereal centre[3], unpeps; + + /* Fortran I/O blocks */ + static cilist io___310 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : recherche dans le contour ferme du sommet qui joint a la plus */ +/* ----- courte arete nar00 donne le triangle sans intersection */ +/* avec le contour ferme de meilleure qualite */ + +/* entrees: */ +/* -------- */ +/* pxyd : tableau des coordonnees des sommets et distance_souhaitee */ + +/* entrees et sorties: */ +/* ------------------- */ +/* nar00 : numero dans noarcf de l'arete avant nar0 */ +/* nar0 : numero dans noarcf de la plus petite arete du contour ferme */ +/* a joindre a noarcf(1,namin) pour former le triangle ideal */ +/* noarcf : numero du sommet , numero de l'arete suivante */ +/* numero du triangle exterieur a l'etoile */ + +/* sortie : */ +/* -------- */ +/* namin0 : numero dans noarcf de l'arete avant namin */ +/* namin : numero dans noarcf du sommet choisi */ +/* 0 si contour ferme reduit a moins de 3 aretes */ +/* larmin : tableau auxiliaire pour stocker la liste des numeros des */ +/* aretes de meilleure qualite pour faire le choix final */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc fevrier 1992 */ +/* 2345x7..............................................................012 */ +/* ATTENTION:variables a ajuster selon la machine! */ +/* ATTENTION:dmaxim : le plus grand reel machine */ +/* ATTENTION:sur dec-alpha la precision est de 10**-14 seulement */ + +/* initialisations */ +/* dmaxim : le plus grand reel machine */ + /* Parameter adjustments */ + --larmin; + noarcf -= 4; + pxyd -= 4; + + /* Function Body */ + unpeps = 1.00000000000001; + +/* recherche de la plus courte arete du contour ferme */ + nbmin = 0; + na00 = *nar00; + dmima = 1.7e308; + nbar = 0; + +L2: + na0 = noarcf[na00 * 3 + 2]; + na1 = noarcf[na0 * 3 + 2]; + ++nbar; +/* les 2 sommets de l'arete na0 du cf */ + ns1 = noarcf[na0 * 3 + 1]; + ns2 = noarcf[na1 * 3 + 1]; +/* Computing 2nd power */ + d__1 = pxyd[ns2 * 3 + 1] - pxyd[ns1 * 3 + 1]; +/* Computing 2nd power */ + d__2 = pxyd[ns2 * 3 + 2] - pxyd[ns1 * 3 + 2]; + dd = d__1 * d__1 + d__2 * d__2; + if (dd < dmima) { + dmima = dd; + larmin[1] = na00; + } + na00 = na0; + if (na00 != *nar00) { +/* derniere arete non atteinte */ + goto L2; + } + + if (nbar == 3) { + +/* contour ferme reduit a un triangle */ +/* ---------------------------------- */ + *namin = *nar00; + *nar0 = noarcf[*nar00 * 3 + 2]; + *namin0 = noarcf[*nar0 * 3 + 2]; + return 0; + + } else if (nbar <= 2) { + //io___310.ciunit = unites_1.imprim; + //s_wsle(&io___310); + //do_lio(&c__9, &c__1, "erreur trchtd: cf<3 aretes", (ftnlen)26); + //e_wsle(); + *namin = 0; + *namin0 = 0; + return 0; + } + +/* cf non reduit a un triangle */ +/* la plus petite arete est nar0 dans noarcf */ + *nar00 = larmin[1]; + *nar0 = noarcf[*nar00 * 3 + 2]; + nar = noarcf[*nar0 * 3 + 2]; + + ns1 = noarcf[*nar0 * 3 + 1]; + ns2 = noarcf[nar * 3 + 1]; + +/* recherche dans cette etoile du sommet offrant la meilleure qualite */ +/* du triangle ns1-ns2 ns3 sans intersection avec le contour ferme */ +/* ================================================================== */ + nar3 = nar; + qmima = -1.f; + +/* parcours des sommets possibles ns3 */ +L10: + nar3 = noarcf[nar3 * 3 + 2]; + if (nar3 != *nar0) { + +/* il existe un sommet ns3 different de ns1 et ns2 */ + ns3 = noarcf[nar3 * 3 + 1]; + +/* les aretes ns1-ns3 et ns2-ns3 intersectent-elles une arete */ +/* du contour ferme ? */ +/* ---------------------------------------------------------- */ +/* intersection de l'arete ns2-ns3 et des aretes du cf */ +/* jusqu'au sommet ns3 */ + nar1 = noarcf[nar * 3 + 2]; + +L15: + if (nar1 != nar3 && noarcf[nar1 * 3 + 2] != nar3) { +/* l'arete suivante */ + nar2 = noarcf[nar1 * 3 + 2]; +/* le numero des 2 sommets de l'arete */ + np1 = noarcf[nar1 * 3 + 1]; + np2 = noarcf[nar2 * 3 + 1]; + int2ar_(&pxyd[ns2 * 3 + 1], &pxyd[ns3 * 3 + 1], &pxyd[np1 * 3 + 1] + , &pxyd[np2 * 3 + 1], &oui); + if (oui) { + goto L10; + } +/* les 2 aretes ne s'intersectent pas entre leurs sommets */ + nar1 = nar2; + goto L15; + } + +/* intersection de l'arete ns3-ns1 et des aretes du cf */ +/* jusqu'au sommet de l'arete nar0 */ + nar1 = noarcf[nar3 * 3 + 2]; + +L18: + if (nar1 != *nar0 && noarcf[nar1 * 3 + 2] != *nar0) { +/* l'arete suivante */ + nar2 = noarcf[nar1 * 3 + 2]; +/* le numero des 2 sommets de l'arete */ + np1 = noarcf[nar1 * 3 + 1]; + np2 = noarcf[nar2 * 3 + 1]; + int2ar_(&pxyd[ns1 * 3 + 1], &pxyd[ns3 * 3 + 1], &pxyd[np1 * 3 + 1] + , &pxyd[np2 * 3 + 1], &oui); + if (oui) { + goto L10; + } +/* les 2 aretes ne s'intersectent pas entre leurs sommets */ + nar1 = nar2; + goto L18; + } + +/* le triangle ns1-ns2-ns3 n'intersecte pas une arete du contour ferme */ +/* le calcul de la surface du triangle */ + dd = surtd2_(&pxyd[ns1 * 3 + 1], &pxyd[ns2 * 3 + 1], &pxyd[ns3 * 3 + + 1]); + if (dd <= 0.) { +/* surface negative => triangle a rejeter */ + q = 0.; + } else { +/* calcul de la qualite du triangle ns1-ns2-ns3 */ + qutr2d_(&pxyd[ns1 * 3 + 1], &pxyd[ns2 * 3 + 1], &pxyd[ns3 * 3 + 1] + , &q); + } + + if (q >= qmima * 1.00001f) { +/* q est un vrai maximum de la qualite */ + qmima = q; + nbmin = 1; + larmin[1] = nar3; + } else if (q >= qmima * .999998f) { +/* q est voisin de qmima */ +/* il est empile */ + ++nbmin; + larmin[nbmin] = nar3; + } + goto L10; + } + +/* bilan : existe t il plusieurs sommets de meme qualite? */ +/* ====================================================== */ + if (nbmin > 1) { + +/* oui:recherche de ceux de cercle ne contenant pas d'autres sommets */ + i__1 = nbmin; + for (i__ = 1; i__ <= i__1; ++i__) { +/* le sommet */ + nar = larmin[i__]; + if (nar <= 0) { + goto L80; + } + ns3 = noarcf[nar * 3 + 1]; +/* les coordonnees du centre du cercle circonscrit */ +/* et son rayon */ + ier = -1; + cenced_(&pxyd[ns1 * 3 + 1], &pxyd[ns2 * 3 + 1], &pxyd[ns3 * 3 + 1] + , centre, &ier); + if (ier != 0) { +/* le sommet ns3 ne convient pas */ + larmin[i__] = 0; + goto L80; + } + rayon = centre[2] * unpeps; + i__2 = nbmin; + for (j = 1; j <= i__2; ++j) { + if (j != i__) { +/* l'autre sommet */ + nar1 = larmin[j]; + if (nar1 <= 0) { + goto L70; + } + ns4 = noarcf[nar1 * 3 + 1]; +/* appartient t il au cercle ns1 ns2 ns3 ? */ +/* Computing 2nd power */ + d__1 = centre[0] - pxyd[ns4 * 3 + 1]; +/* Computing 2nd power */ + d__2 = centre[1] - pxyd[ns4 * 3 + 2]; + dd = d__1 * d__1 + d__2 * d__2; + if (dd <= rayon) { +/* ns4 est dans le cercle circonscrit ns1 ns2 ns3 */ +/* le sommet ns3 ne convient pas */ + larmin[i__] = 0; + goto L80; + } + } +L70: + ; + } +L80: + ; + } + +/* existe t il plusieurs sommets ? */ + j = 0; + i__1 = nbmin; + for (i__ = 1; i__ <= i__1; ++i__) { + if (larmin[i__] > 0) { +/* compactage des min */ + ++j; + larmin[j] = larmin[i__]; + } +/* L90: */ + } + + if (j > 1) { +/* oui : choix du plus petit rayon de cercle circonscrit */ + dmima = 1.7e308; + i__1 = nbmin; + for (i__ = 1; i__ <= i__1; ++i__) { + ns3 = noarcf[larmin[i__] * 3 + 1]; + +/* les coordonnees du centre de cercle circonscrit */ +/* au triangle nt et son rayon */ + ier = -1; + cenced_(&pxyd[ns1 * 3 + 1], &pxyd[ns2 * 3 + 1], &pxyd[ns3 * 3 + + 1], centre, &ier); + if (ier != 0) { +/* le sommet ns3 ne convient pas */ + goto L120; + } + rayon = sqrt(centre[2]); + if (rayon < dmima) { + dmima = rayon; + larmin[1] = larmin[i__]; + } +L120: + ; + } + } + } + +/* le choix final */ +/* ============== */ + *namin = larmin[1]; + +/* recherche de l'arete avant namin ( nar0 <> namin ) */ +/* ================================================== */ + nar1 = *nar0; +L200: + if (nar1 != *namin) { + *namin0 = nar1; + nar1 = noarcf[nar1 * 3 + 2]; + goto L200; + } + return 0; +} /* trchtd_ */ + +/* Subroutine */ int trcf0a_(integer *nbcf, integer *na01, integer *na1, + integer *na2, integer *na3, integer *noar1, integer *noar2, integer * + noar3, integer *mosoar, integer *mxsoar, integer *n1soar, integer * + nosoar, integer *moartr, integer *n1artr, integer *noartr, integer * + noarst, integer *mxarcf, integer *n1arcf, integer *noarcf, integer * + nt) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static integer nav, na2s, na3s, nav1, ierr; + extern /* Subroutine */ int trcf3a_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *); + static integer noar2s, noar3s; + extern /* Subroutine */ int fasoar_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___334 = { 0, 0, 0, 0, 0 }; + static cilist io___335 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : modification de la triangulation du contour ferme nbcf */ +/* ----- par ajout d'un triangle ayant 0 arete sur le contour */ +/* creation des 3 aretes dans le tableau nosoar */ +/* modification du contour par ajout de la 3-eme arete */ +/* creation d'un contour ferme a partir de la seconde arete */ + +/* entrees: */ +/* -------- */ +/* nbcf : numero dans n1arcf du cf traite ici */ +/* na01 : numero noarcf de l'arete precedent l'arete na1 de noarcf */ +/* na1 : numero noarcf du 1-er sommet du triangle */ +/* implicitement l'arete na1 n'est pas une arete du triangle */ +/* na2 : numero noarcf du 2-eme sommet du triangle */ +/* implicitement l'arete na1 n'est pas une arete du triangle */ +/* na3 : numero noarcf du 3-eme sommet du triangle */ +/* implicitement l'arete na1 n'est pas une arete du triangle */ + +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* attention: mxsoar>3*mxsomm obligatoire! */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ + +/* entrees et sorties : */ +/* -------------------- */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = nosoar(1)+nosoar(2)*2 */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ + +/* noarst : noarst(i) numero d'une arete de sommet i */ +/* n1arcf : numero d'une arete de chaque contour */ +/* noarcf : numero des aretes de la ligne du contour ferme */ +/* attention : chainage circulaire des aretes */ + +/* sortie : */ +/* -------- */ +/* noar1 : numero dans le tableau nosoar de l'arete 1 du triangle */ +/* noar2 : numero dans le tableau nosoar de l'arete 2 du triangle */ +/* noar3 : numero dans le tableau nosoar de l'arete 3 du triangle */ +/* nt : numero du triangle ajoute dans noartr */ +/* 0 si saturation du tableau noartr ou noarcf ou n1arcf */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* 2345x7..............................................................012 */ + + /* Parameter adjustments */ + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --noarst; + noarcf -= 4; + + /* Function Body */ + ierr = 0; + +/* 2 contours fermes peuvent ils etre ajoutes ? */ + if (*nbcf + 2 > *mxarcf) { + goto L9100; + } + +/* creation des 3 aretes du triangle dans le tableau nosoar */ +/* ======================================================== */ +/* la formation de l'arete sommet1-sommet2 dans le tableau nosoar */ + fasoar_(&noarcf[*na1 * 3 + 1], &noarcf[*na2 * 3 + 1], &c_n1, &c_n1, &c__0, + mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], &noarst[1], + noar1, &ierr); + if (ierr != 0) { + goto L9900; + } + +/* la formation de l'arete sommet2-sommet3 dans le tableau nosoar */ + fasoar_(&noarcf[*na2 * 3 + 1], &noarcf[*na3 * 3 + 1], &c_n1, &c_n1, &c__0, + mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], &noarst[1], + noar2, &ierr); + if (ierr != 0) { + goto L9900; + } + +/* la formation de l'arete sommet3-sommet1 dans le tableau nosoar */ + fasoar_(&noarcf[*na3 * 3 + 1], &noarcf[*na1 * 3 + 1], &c_n1, &c_n1, &c__0, + mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], &noarst[1], + noar3, &ierr); + if (ierr != 0) { + goto L9900; + } + +/* ajout dans noartr de ce triangle nt */ +/* =================================== */ + trcf3a_(&noarcf[*na1 * 3 + 1], &noarcf[*na2 * 3 + 1], &noarcf[*na3 * 3 + + 1], noar1, noar2, noar3, mosoar, &nosoar[nosoar_offset], moartr, + n1artr, &noartr[noartr_offset], nt); + if (*nt <= 0) { + return 0; + } + +/* modification du contour nbcf existant */ +/* chainage de l'arete na2 vers l'arete na1 */ +/* ======================================== */ +/* modification du cf en pointant na2 sur na1 */ + na2s = noarcf[*na2 * 3 + 2]; + noarcf[*na2 * 3 + 2] = *na1; +/* le numero de l'arete dans le tableau nosoar */ + noar2s = noarcf[*na2 * 3 + 3]; +/* le numero de l'arete dans le tableau nosoar */ + noarcf[*na2 * 3 + 3] = *noar1; +/* debut du cf */ + n1arcf[*nbcf] = *na2; + +/* creation d'un nouveau contour ferme na2 - na3 */ +/* ============================================= */ + ++(*nbcf); +/* recherche d'une arete de cf vide */ + nav = n1arcf[0]; + if (nav <= 0) { + goto L9100; + } +/* la 1-ere arete vide est mise a jour */ + n1arcf[0] = noarcf[nav * 3 + 2]; + +/* ajout de l'arete nav pointant sur na2s */ +/* le numero du sommet */ + noarcf[nav * 3 + 1] = noarcf[*na2 * 3 + 1]; +/* l'arete suivante */ + noarcf[nav * 3 + 2] = na2s; +/* le numero nosoar de cette arete */ + noarcf[nav * 3 + 3] = noar2s; + +/* l'arete na3 se referme sur nav */ + na3s = noarcf[*na3 * 3 + 2]; + noarcf[*na3 * 3 + 2] = nav; +/* le numero de l'arete dans le tableau nosoar */ + noar3s = noarcf[*na3 * 3 + 3]; + noarcf[*na3 * 3 + 3] = *noar2; +/* debut du cf+1 */ + n1arcf[*nbcf] = *na3; + +/* creation d'un nouveau contour ferme na3 - na1 */ +/* ============================================= */ + ++(*nbcf); +/* recherche d'une arete de cf vide */ + nav = n1arcf[0]; + if (nav <= 0) { + goto L9100; + } +/* la 1-ere arete vide est mise a jour */ + n1arcf[0] = noarcf[nav * 3 + 2]; + +/* ajout de l'arete nav pointant sur na3s */ +/* le numero du sommet */ + noarcf[nav * 3 + 1] = noarcf[*na3 * 3 + 1]; +/* l'arete suivante */ + noarcf[nav * 3 + 2] = na3s; +/* le numero de l'arete dans le tableau nosoar */ + noarcf[nav * 3 + 3] = noar3s; + +/* recherche d'une arete de cf vide */ + nav1 = n1arcf[0]; + if (nav1 <= 0) { + goto L9100; + } +/* la 1-ere arete vide est mise a jour */ + n1arcf[0] = noarcf[nav1 * 3 + 2]; + +/* l'arete precedente na01 de na1 pointe sur la nouvelle nav1 */ + noarcf[*na01 * 3 + 2] = nav1; + +/* ajout de l'arete nav1 pointant sur nav */ +/* le numero du sommet */ + noarcf[nav1 * 3 + 1] = noarcf[*na1 * 3 + 1]; +/* l'arete suivante */ + noarcf[nav1 * 3 + 2] = nav; +/* le numero de l'arete dans le tableau nosoar */ + noarcf[nav1 * 3 + 3] = *noar3; + +/* debut du cf+2 */ + n1arcf[*nbcf] = nav1; + return 0; + +/* erreur */ +L9100: + //io___334.ciunit = unites_1.imprim; + //s_wsle(&io___334); + //do_lio(&c__9, &c__1, "saturation du tableau mxarcf", (ftnlen)28); + //e_wsle(); + *nt = 0; + return 0; + +/* erreur tableau nosoar sature */ +L9900: + //io___335.ciunit = unites_1.imprim; + //s_wsle(&io___335); + //do_lio(&c__9, &c__1, "saturation du tableau nosoar", (ftnlen)28); + //e_wsle(); + *nt = 0; + return 0; +} /* trcf0a_ */ + +/* Subroutine */ int trcf1a_(integer *nbcf, integer *na01, integer *na1, + integer *na2, integer *noar1, integer *noar3, integer *mosoar, + integer *mxsoar, integer *n1soar, integer *nosoar, integer *moartr, + integer *n1artr, integer *noartr, integer *noarst, integer *mxarcf, + integer *n1arcf, integer *noarcf, integer *nt) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static integer na3, nav, ierr; + extern /* Subroutine */ int trcf3a_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *), fasoar_(integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___336 = { 0, 0, 0, 0, 0 }; + static cilist io___340 = { 0, 0, 0, 0, 0 }; + static cilist io___341 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : modification de la triangulation du contour ferme nbcf */ +/* ----- par ajout d'un triangle ayant 1 arete sur le contour */ +/* modification du contour par ajout de la 3-eme arete */ +/* creation d'un contour ferme a partir de la seconde arete */ + +/* entrees: */ +/* -------- */ +/* nbcf : numero dans n1arcf du cf traite ici */ +/* na01 : numero noarcf de l'arete precedant l'arete na1 de noarcf */ +/* na1 : numero noarcf du 1-er sommet du triangle */ +/* implicitement l'arete na1 n'est pas une arete du triangle */ +/* na2 : numero noarcf du 2-eme sommet du triangle */ +/* cette arete est l'arete 2 du triangle a ajouter */ +/* son arete suivante dans noarcf n'est pas sur le contour */ +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* attention: mxsoar>3*mxsomm obligatoire! */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ + +/* entrees et sorties : */ +/* -------------------- */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = nosoar(1)+nosoar(2)*2 */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ + +/* noarst : noarst(i) numero d'une arete de sommet i */ +/* n1arcf : numero d'une arete de chaque contour */ +/* noarcf : numero des aretes de la ligne du contour ferme */ +/* attention : chainage circulaire des aretes */ + +/* sortie : */ +/* -------- */ +/* noar1 : numero nosoar de l'arete 1 du triangle cree */ +/* noar3 : numero nosoar de l'arete 3 du triangle cree */ +/* nt : numero du triangle ajoute dans notria */ +/* 0 si saturation du tableau notria ou noarcf ou n1arcf */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* 2345x7..............................................................012 */ + +/* un cf supplementaire peut il etre ajoute ? */ + /* Parameter adjustments */ + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --noarst; + noarcf -= 4; + + /* Function Body */ + if (*nbcf >= *mxarcf) { + //io___336.ciunit = unites_1.imprim; + //s_wsle(&io___336); + //do_lio(&c__9, &c__1, "saturation du tableau noarcf", (ftnlen)28); + //e_wsle(); + *nt = 0; + return 0; + } + + ierr = 0; + +/* l' arete suivante du triangle non sur le cf */ + na3 = noarcf[*na2 * 3 + 2]; + +/* creation des 2 nouvelles aretes du triangle dans le tableau nosoar */ +/* ================================================================== */ +/* la formation de l'arete sommet1-sommet2 dans le tableau nosoar */ + fasoar_(&noarcf[*na1 * 3 + 1], &noarcf[*na2 * 3 + 1], &c_n1, &c_n1, &c__0, + mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], &noarst[1], + noar1, &ierr); + if (ierr != 0) { + goto L9900; + } + +/* la formation de l'arete sommet1-sommet3 dans le tableau nosoar */ + fasoar_(&noarcf[na3 * 3 + 1], &noarcf[*na1 * 3 + 1], &c_n1, &c_n1, &c__0, + mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], &noarst[1], noar3, + &ierr); + if (ierr != 0) { + goto L9900; + } + +/* le triangle nt de noartr a l'arete 2 comme arete du contour na2 */ +/* =============================================================== */ + trcf3a_(&noarcf[*na1 * 3 + 1], &noarcf[*na2 * 3 + 1], &noarcf[na3 * 3 + 1] + , noar1, &noarcf[*na2 * 3 + 3], noar3, mosoar, &nosoar[ + nosoar_offset], moartr, n1artr, &noartr[noartr_offset], nt); + if (*nt <= 0) { + return 0; + } + +/* modification du contour ferme existant */ +/* suppression de l'arete na2 du cf */ +/* ====================================== */ +/* modification du cf en pointant na2 sur na1 */ + noarcf[*na2 * 3 + 2] = *na1; + noarcf[*na2 * 3 + 3] = *noar1; +/* debut du cf */ + n1arcf[*nbcf] = *na2; + +/* creation d'un nouveau contour ferme na3 - na1 */ +/* ============================================= */ + ++(*nbcf); + +/* recherche d'une arete de cf vide */ + nav = n1arcf[0]; + if (nav <= 0) { + //io___340.ciunit = unites_1.imprim; + //s_wsle(&io___340); + //do_lio(&c__9, &c__1, "saturation du tableau noarcf", (ftnlen)28); + //e_wsle(); + *nt = 0; + return 0; + } + +/* la 1-ere arete vide est mise a jour */ + n1arcf[0] = noarcf[nav * 3 + 2]; + +/* ajout de l'arete nav pointant sur na3 */ +/* le numero du sommet */ + noarcf[nav * 3 + 1] = noarcf[*na1 * 3 + 1]; +/* l'arete suivante */ + noarcf[nav * 3 + 2] = na3; +/* le numero de l'arete dans le tableau nosoar */ + noarcf[nav * 3 + 3] = *noar3; + +/* l'arete precedente na01 de na1 pointe sur la nouvelle nav */ + noarcf[*na01 * 3 + 2] = nav; + +/* debut du cf */ + n1arcf[*nbcf] = nav; + return 0; + +/* erreur tableau nosoar sature */ +L9900: + //io___341.ciunit = unites_1.imprim; + //s_wsle(&io___341); + //do_lio(&c__9, &c__1, "saturation du tableau nosoar", (ftnlen)28); + //e_wsle(); + *nt = 0; + return 0; +} /* trcf1a_ */ + +/* Subroutine */ int trcf2a_(integer *nbcf, integer *na1, integer *noar3, + integer *mosoar, integer *mxsoar, integer *n1soar, integer *nosoar, + integer *moartr, integer *n1artr, integer *noartr, integer *noarst, + integer *n1arcf, integer *noarcf, integer *nt) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static integer na2, na3, ierr; + extern /* Subroutine */ int trcf3a_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *), fasoar_(integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___345 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : modification de la triangulation du contour ferme nbcf */ +/* ----- par ajout d'un triangle ayant 2 aretes sur le contour */ +/* creation d'une arete dans nosoar (sommet3-sommet1) */ +/* et modification du contour par ajout de la 3-eme arete */ + +/* entrees: */ +/* -------- */ +/* nbcf : numero dans n1arcf du cf traite ici */ +/* na1 : numero noarcf de la premiere arete sur le contour */ +/* implicitement sa suivante est sur le contour */ +/* la suivante de la suivante n'est pas sur le contour */ +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* attention: mxsoar>3*mxsomm obligatoire! */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ + +/* entrees et sorties : */ +/* -------------------- */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = nosoar(1)+nosoar(2)*2 */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ + +/* noarst : noarst(i) numero d'une arete de sommet i */ +/* n1arcf : numero d'une arete de chaque contour */ +/* noarcf : numero des aretes de la ligne du contour ferme */ +/* attention : chainage circulaire des aretes */ + +/* sortie : */ +/* -------- */ +/* noar3 : numero de l'arete 3 dans le tableau nosoar */ +/* nt : numero du triangle ajoute dans noartr */ +/* 0 si saturation du tableau noartr ou nosoar */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* 2345x7..............................................................012 */ + + /* Parameter adjustments */ + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --noarst; + noarcf -= 4; + + /* Function Body */ + ierr = 0; + +/* l'arete suivante de l'arete na1 dans noarcf */ + na2 = noarcf[*na1 * 3 + 2]; +/* l'arete suivante de l'arete na2 dans noarcf */ + na3 = noarcf[na2 * 3 + 2]; + +/* la formation de l'arete sommet3-sommet1 dans le tableau nosoar */ + fasoar_(&noarcf[na3 * 3 + 1], &noarcf[*na1 * 3 + 1], &c_n1, &c_n1, &c__0, + mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], &noarst[1], noar3, + &ierr); + if (ierr != 0) { + if (ierr == 1) { + //io___345.ciunit = unites_1.imprim; + //s_wsle(&io___345); + //do_lio(&c__9, &c__1, "saturation des aretes (tableau nosoar)", ( + // ftnlen)38); + //e_wsle(); + } + *nt = 0; + return 0; + } + +/* le triangle a ses 2 aretes na1 na2 sur le contour ferme */ +/* ajout dans noartr de ce triangle nt */ + trcf3a_(&noarcf[*na1 * 3 + 1], &noarcf[na2 * 3 + 1], &noarcf[na3 * 3 + 1], + &noarcf[*na1 * 3 + 3], &noarcf[na2 * 3 + 3], noar3, mosoar, & + nosoar[nosoar_offset], moartr, n1artr, &noartr[noartr_offset], nt) + ; + if (*nt <= 0) { + return 0; + } + +/* suppression des 2 aretes (na1 na2) du cf */ +/* ces 2 aretes se suivent dans le chainage du cf */ +/* ajout de la 3-eme arete (noar3) dans le cf */ +/* l'arete suivante de na1 devient la suivante de na2 */ + noarcf[*na1 * 3 + 2] = na3; + noarcf[*na1 * 3 + 3] = *noar3; + +/* l'arete na2 devient vide dans noarcf */ + noarcf[na2 * 3 + 2] = n1arcf[0]; + n1arcf[0] = na2; + +/* la premiere pointee dans noarcf est na1 */ +/* chainage circulaire => ce peut etre n'importe laquelle */ + n1arcf[*nbcf] = *na1; + return 0; +} /* trcf2a_ */ + +/* Subroutine */ int trcf3a_(integer *ns1, integer *ns2, integer *ns3, + integer *noar1, integer *noar2, integer *noar3, integer *mosoar, + integer *nosoar, integer *moartr, integer *n1artr, integer *noartr, + integer *nt) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static integer n; + + /* Fortran I/O blocks */ + static cilist io___346 = { 0, 0, 0, 0, 0 }; + + +/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : ajouter dans le tableau noartr le triangle */ +/* ----- de sommets ns1 ns2 ns3 */ +/* d'aretes noar1 noar2 noar3 deja existantes */ +/* dans le tableau nosoar des aretes */ + +/* entrees: */ +/* -------- */ +/* ns1, ns2, ns3 : le numero dans pxyd des 3 sommets du triangle */ +/* noar1,noar2,noar3 : le numero dans nosoar des 3 aretes du triangle */ +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* attention: mxsoar>3*mxsomm obligatoire! */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxartr : nombre maximal de triangles stockables dans le tableau noartr */ + +/* modifies : */ +/* ---------- */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = nosoar(1)+nosoar(2)*2 */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ + +/* sorties: */ +/* -------- */ +/* nt : numero dans noartr du triangle ajoute */ +/* =0 si le tableau noartr est sature */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* ....................................................................012 */ + +/* recherche d'un triangle libre dans le tableau noartr */ + /* Parameter adjustments */ + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + + /* Function Body */ + if (*n1artr <= 0) { + //io___346.ciunit = unites_1.imprim; + //s_wsle(&io___346); + //do_lio(&c__9, &c__1, "saturation du tableau noartr des aretes", ( + // ftnlen)39); + //e_wsle(); + *nt = 0; + return 0; + } + +/* le numero dans noartr du nouveau triangle */ + *nt = *n1artr; + +/* le nouveau premier triangle vide dans le tableau noartr */ + *n1artr = noartr[*n1artr * noartr_dim1 + 2]; + +/* arete 1 du triangle nt */ +/* ====================== */ +/* orientation des 3 aretes du triangle pour qu'il soit direct */ + if (*ns1 == nosoar[*noar1 * nosoar_dim1 + 1]) { + n = 1; + } else { + n = -1; + } +/* le numero de l'arete 1 du triangle nt */ + noartr[*nt * noartr_dim1 + 1] = n * *noar1; + +/* le numero du triangle nt pour l'arete */ + if (nosoar[*noar1 * nosoar_dim1 + 4] <= 0) { + n = 4; + } else { + n = 5; + } + nosoar[n + *noar1 * nosoar_dim1] = *nt; + +/* arete 2 du triangle nt */ +/* ====================== */ +/* orientation des 3 aretes du triangle pour qu'il soit direct */ + if (*ns2 == nosoar[*noar2 * nosoar_dim1 + 1]) { + n = 1; + } else { + n = -1; + } +/* le numero de l'arete 2 du triangle nt */ + noartr[*nt * noartr_dim1 + 2] = n * *noar2; + +/* le numero du triangle nt pour l'arete */ + if (nosoar[*noar2 * nosoar_dim1 + 4] <= 0) { + n = 4; + } else { + n = 5; + } + nosoar[n + *noar2 * nosoar_dim1] = *nt; + +/* arete 3 du triangle nt */ +/* ====================== */ +/* orientation des 3 aretes du triangle pour qu'il soit direct */ + if (*ns3 == nosoar[*noar3 * nosoar_dim1 + 1]) { + n = 1; + } else { + n = -1; + } +/* le numero de l'arete 3 du triangle nt */ + noartr[*nt * noartr_dim1 + 3] = n * *noar3; + +/* le numero du triangle nt pour l'arete */ + if (nosoar[*noar3 * nosoar_dim1 + 4] <= 0) { + n = 4; + } else { + n = 5; + } + nosoar[n + *noar3 * nosoar_dim1] = *nt; + return 0; +} /* trcf3a_ */ + +/* Subroutine */ int trcf3s_(integer *nbcf, integer *na01, integer *na1, + integer *na02, integer *na2, integer *na03, integer *na3, integer * + mosoar, integer *mxsoar, integer *n1soar, integer *nosoar, integer * + moartr, integer *n1artr, integer *noartr, integer *noarst, integer * + mxarcf, integer *n1arcf, integer *noarcf, integer *nt) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset; + + /* Local variables */ + static integer naa1, naa2, naa01, na1cf, na2cf, na3cf, naor1, naor3; + extern /* Subroutine */ int trcf0a_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *), trcf1a_( + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *), + trcf2a_(integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *), trcf3a_(integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *); + static integer nbascf; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : ajout d'un triangle d'aretes na1 2 3 du tableau noarcf */ +/* ----- a la triangulation d'un contour ferme (cf) */ + +/* entrees: */ +/* -------- */ +/* nbcf : numero dans n1arcf du cf traite ici */ +/* mais aussi nombre actuel de cf avant ajout du triangle */ +/* na01 : numero noarcf de l'arete precedent l'arete na1 de noarcf */ +/* na1 : numero noarcf du 1-er sommet du triangle */ +/* na02 : numero noarcf de l'arete precedent l'arete na2 de noarcf */ +/* na2 : numero noarcf du 2-eme sommet du triangle */ +/* na03 : numero noarcf de l'arete precedent l'arete na3 de noarcf */ +/* na3 : numero noarcf du 3-eme sommet du triangle */ + +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* attention: mxsoar>3*mxsomm obligatoire! */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxarcf : nombre maximal d'aretes declarables dans noarcf, n1arcf */ + +/* modifies: */ +/* --------- */ +/* n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar */ +/* chainage des vides suivant en 3 et precedant en 2 de nosoar */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = nosoar(1)+nosoar(2)*2 */ +/* avec mxsoar>=3*mxsomm */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 et */ +/* nosoar(2,arete vide)=l'arete vide qui precede */ +/* nosoar(3,arete vide)=l'arete vide qui suit */ + +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ +/* noarst : noarst(i) numero d'une arete de sommet i */ + +/* n1arcf : numero d'une arete de chaque contour ferme */ +/* noarcf : numero du sommet , numero de l'arete suivante */ +/* numero de l'arete dans le tableau nosoar */ +/* attention : chainage circulaire des aretes */ + +/* sortie : */ +/* -------- */ +/* nbcf : nombre actuel de cf apres ajout du triangle */ +/* nt : numero du triangle ajoute dans noartr */ +/* 0 si saturation du tableau nosoar ou noartr ou noarcf ou n1arcf */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* 2345x7..............................................................012 */ + +/* combien y a t il d'aretes nbascf sur le cf ? */ +/* ============================================ */ +/* la premiere arete est elle sur le cf? */ + /* Parameter adjustments */ + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --noarst; + noarcf -= 4; + + /* Function Body */ + if (noarcf[*na1 * 3 + 2] == *na2) { +/* la 1-ere arete est sur le cf */ + na1cf = 1; + } else { +/* la 1-ere arete n'est pas sur le cf */ + na1cf = 0; + } + +/* la seconde arete est elle sur le cf? */ + if (noarcf[*na2 * 3 + 2] == *na3) { +/* la 2-eme arete est sur le cf */ + na2cf = 1; + } else { + na2cf = 0; + } + +/* la troisieme arete est elle sur le cf? */ + if (noarcf[*na3 * 3 + 2] == *na1) { +/* la 3-eme arete est sur le cf */ + na3cf = 1; + } else { + na3cf = 0; + } + +/* le nombre d'aretes sur le cf */ + nbascf = na1cf + na2cf + na3cf; + +/* traitement selon le nombre d'aretes sur le cf */ +/* ============================================= */ + if (nbascf == 3) { + +/* le contour ferme se reduit a un triangle avec 3 aretes sur le cf */ +/* ---------------------------------------------------------------- */ +/* ajout dans noartr de ce nouveau triangle */ + trcf3a_(&noarcf[*na1 * 3 + 1], &noarcf[*na2 * 3 + 1], &noarcf[*na3 * + 3 + 1], &noarcf[*na1 * 3 + 3], &noarcf[*na2 * 3 + 3], &noarcf[ + *na3 * 3 + 3], mosoar, &nosoar[nosoar_offset], moartr, n1artr, + &noartr[noartr_offset], nt); + if (*nt <= 0) { + return 0; + } + +/* le cf est supprime et chaine vide */ + noarcf[*na3 * 3 + 2] = n1arcf[0]; + n1arcf[0] = *na1; + +/* ce cf a ete traite => un cf de moins a traiter */ + --(*nbcf); + + } else if (nbascf == 2) { + +/* le triangle a 2 aretes sur le contour */ +/* ------------------------------------- */ +/* les 2 aretes sont la 1-ere et 2-eme du triangle */ + if (na1cf == 0) { +/* l'arete 1 n'est pas sur le cf */ + naa1 = *na2; + } else if (na2cf == 0) { +/* l'arete 2 n'est pas sur le cf */ + naa1 = *na3; + } else { +/* l'arete 3 n'est pas sur le cf */ + naa1 = *na1; + } +/* le triangle oppose a l'arete 3 est inconnu */ +/* modification du contour apres integration du */ +/* triangle ayant ses 2-eres aretes sur le cf */ + trcf2a_(nbcf, &naa1, &naor3, mosoar, mxsoar, n1soar, &nosoar[ + nosoar_offset], moartr, n1artr, &noartr[noartr_offset], & + noarst[1], n1arcf, &noarcf[4], nt); + + } else if (nbascf == 1) { + +/* le triangle a 1 arete sur le contour */ +/* ------------------------------------ */ +/* cette arete est la seconde du triangle */ + if (na3cf != 0) { +/* l'arete 3 est sur le cf */ + naa01 = *na02; + naa1 = *na2; + naa2 = *na3; + } else if (na1cf != 0) { +/* l'arete 1 est sur le cf */ + naa01 = *na03; + naa1 = *na3; + naa2 = *na1; + } else { +/* l'arete 2 est sur le cf */ + naa01 = *na01; + naa1 = *na1; + naa2 = *na2; + } +/* le triangle oppose a l'arete 1 et 3 est inconnu */ +/* modification du contour apres integration du */ +/* triangle ayant 1 arete sur le cf avec creation */ +/* d'un nouveau contour ferme */ + trcf1a_(nbcf, &naa01, &naa1, &naa2, &naor1, &naor3, mosoar, mxsoar, + n1soar, &nosoar[nosoar_offset], moartr, n1artr, &noartr[ + noartr_offset], &noarst[1], mxarcf, n1arcf, &noarcf[4], nt); + + } else { + +/* le triangle a 0 arete sur le contour */ +/* ------------------------------------ */ +/* modification du contour apres integration du */ +/* triangle ayant 0 arete sur le cf avec creation */ +/* de 2 nouveaux contours fermes */ + trcf0a_(nbcf, na01, na1, na2, na3, &naa1, &naa2, &naa01, mosoar, + mxsoar, n1soar, &nosoar[nosoar_offset], moartr, n1artr, & + noartr[noartr_offset], &noarst[1], mxarcf, n1arcf, &noarcf[4], + nt); + } + return 0; +} /* trcf3s_ */ + +/* Subroutine */ int tridcf_(integer *nbcf0, integer *nbstpe, integer *nostpe, + doublereal *pxyd, integer *noarst, integer *mosoar, integer *mxsoar, + integer *n1soar, integer *nosoar, integer *moartr, integer *n1artr, + integer *noartr, integer *mxarcf, integer *n1arcf, integer *noarcf, + integer *larmin, integer *nbtrcf, integer *notrcf, integer *ierr) +{ + /* System generated locals */ + integer noartr_dim1, noartr_offset, nosoar_dim1, nosoar_offset, i__1, + i__2; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static doublereal d__; + static integer i__, k; + static doublereal s; + static integer nt, na0, na1, na2, na3, ns1, ns2, ns3, nt0, nt1, nt2, na01, + na02, na12, na03, ncf, ntp0, nbcf; + static doublereal dmin__; + static integer imin, noar, noar1, noar2, noar3, nbstp; + extern /* Subroutine */ int trcf3a_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *), trcf3s_(integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *); + extern doublereal surtd2_(doublereal *, doublereal *, doublereal *); + extern /* Subroutine */ int fasoar_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *); + extern doublereal diptdr_(doublereal *, doublereal *, doublereal *); + extern /* Subroutine */ int trchtd_(doublereal *, integer *, integer *, + integer *, integer *, integer *, integer *); + static integer nosotr[3]; + extern /* Subroutine */ int nusotr_(integer *, integer *, integer *, + integer *, integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___375 = { 0, 0, 0, 0, 0 }; + static cilist io___376 = { 0, 0, 0, 0, 0 }; + static cilist io___377 = { 0, 0, 0, 0, 0 }; + static cilist io___379 = { 0, 0, 0, 0, 0 }; + static cilist io___380 = { 0, 0, 0, 0, 0 }; + static cilist io___381 = { 0, 0, 0, 0, 0 }; + static cilist io___387 = { 0, 0, 0, 0, 0 }; + static cilist io___388 = { 0, 0, 0, 0, 0 }; + static cilist io___389 = { 0, 0, 0, 0, 0 }; + static cilist io___395 = { 0, 0, 0, 0, 0 }; + static cilist io___396 = { 0, 0, 0, 0, 0 }; + static cilist io___398 = { 0, 0, 0, 0, 0 }; + static cilist io___399 = { 0, 0, 0, 0, 0 }; + static cilist io___400 = { 0, 0, 0, 0, 0 }; + static cilist io___401 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : triangulation directe de nbcf0 contours fermes (cf) */ +/* ----- definis par la liste circulaire de leurs aretes peripheriques */ +/* avec integration de nbstpe sommets isoles a l'un des cf initiaux */ + +/* entrees: */ +/* -------- */ +/* nbcf0 : nombre initial de cf a trianguler */ +/* nbstpe : nombre de sommets isoles a l'interieur des cf et */ +/* a devenir sommets de la triangulation */ +/* nostpe : numero dans pxyd des nbstpe sommets isoles */ +/* pxyd : tableau des coordonnees 2d des points */ +/* par point : x y distance_souhaitee */ +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* attention: mxsoar>3*mxsomm obligatoire! */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxarcf : nombre maximal d'aretes declarables dans noarcf, n1arcf, larmin, not */ + +/* modifies: */ +/* --------- */ +/* noarst : noarst(i) numero d'une arete de sommet i */ +/* n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar */ +/* chainage des vides suivant en 3 et precedant en 2 de nosoar */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = nosoar(1)+nosoar(2)*2 */ +/* avec mxsoar>=3*mxsomm */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 et */ +/* nosoar(2,arete vide)=l'arete vide qui precede */ +/* nosoar(3,arete vide)=l'arete vide qui suit */ + +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ + +/* n1arcf : numero de la premiere arete de chacun des nbcf0 cf */ +/* n1arcf(0) no de la premiere arete vide du tableau noarcf */ +/* noarcf(2,i) no de l'arete suivante */ +/* noarcf : numero du sommet , numero de l'arete suivante du cf */ +/* numero de l'arete dans le tableau nosoar */ + +/* auxiliaires : */ +/* ------------- */ +/* larmin : tableau (mxarcf) auxiliaire */ +/* stocker la liste des numeros des meilleures aretes */ +/* lors de la selection du meilleur sommet du cf a trianguler */ +/* cf le sp trchtd */ + +/* sortie : */ +/* -------- */ +/* nbtrcf : nombre de triangles des nbcf0 cf */ +/* notrcf : numero des triangles des nbcf0 cf dans le tableau noartr */ +/* ierr : 0 si pas d'erreur */ +/* 2 saturation de l'un des des tableaux nosoar, noartr, ... */ +/* 3 si contour ferme reduit a moins de 3 aretes */ +/* 4 saturation du tableau notrcf */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* modifs : alain perronnet laboratoire jl lions upmc paris octobre 2006 */ +/* ....................................................................012 */ + + +/* depart avec nbcf0 cf a trianguler */ + /* Parameter adjustments */ + --nostpe; + pxyd -= 4; + --noarst; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --notrcf; + --larmin; + noarcf -= 4; + + /* Function Body */ + nbcf = *nbcf0; + +/* le nombre de triangles formes dans l'ensemble des cf */ + *nbtrcf = 0; + +/* le nombre restant de sommets isoles a integrer au cf */ + nbstp = *nbstpe; + +L1: + if (nbstp <= 0) { + goto L10; + } + +/* il existe au moins un sommet isole */ +/* recherche d'un cf dont la premiere arete forme un triangle */ +/* d'aire>0 avec un sommet isole et recherche du sommet isole */ +/* le plus proche de cette arete */ +/* ========================================================== */ + imin = 0; + dmin__ = 1e123; + i__1 = nbcf; + for (ncf = 1; ncf <= i__1; ++ncf) { +/* le cf en haut de pile a pour arete avant la premiere arete */ + na1 = n1arcf[ncf]; + na2 = na1; +/* recherche de l'arete qui precede la premiere arete */ +L2: + if (noarcf[na2 * 3 + 2] != na1) { + na2 = noarcf[na2 * 3 + 2]; + goto L2; + } +/* l'arete na0 dans noarcf qui precede n1arcf( ncf ) */ + na0 = na2; +/* la premiere arete du cf */ + na1 = noarcf[na0 * 3 + 2]; +/* son numero dans nosoar */ + noar1 = noarcf[na1 * 3 + 3]; +/* l'arete suivante */ + na2 = noarcf[na1 * 3 + 2]; +/* le no pxyd des 2 sommets de l'arete na1 */ + ns1 = noarcf[na1 * 3 + 1]; + ns2 = noarcf[na2 * 3 + 1]; + i__2 = *nbstpe; + for (i__ = 1; i__ <= i__2; ++i__) { +/* le sommet isole ns3 */ + ns3 = nostpe[i__]; + if (ns3 <= 0) { + goto L3; + } +/* aire du triangle arete na1 et sommet ns3 */ + d__ = surtd2_(&pxyd[ns1 * 3 + 1], &pxyd[ns2 * 3 + 1], &pxyd[ns3 * + 3 + 1]); + if (d__ > 0.) { +/* distance de ce sommet ns3 a l'arete na1 */ + d__ = diptdr_(&pxyd[ns3 * 3 + 1], &pxyd[ns1 * 3 + 1], &pxyd[ + ns2 * 3 + 1]); + if (d__ < dmin__) { + dmin__ = d__; + imin = i__; + } + } +L3: + ; + } + if (imin > 0) { +/* le sommet imin de nostpe est a distance minimale de */ +/* la premiere arete du cf de numero ncf */ +/* la formation de l'arete ns2-ns3 dans le tableau nosoar */ + fasoar_(&ns2, &ns3, &c_n1, &c_n1, &c__0, mosoar, mxsoar, n1soar, & + nosoar[nosoar_offset], &noarst[1], &noar2, ierr); + if (*ierr != 0) { + goto L9900; + } +/* la formation de l'arete ns3-ns1 dans le tableau nosoar */ + fasoar_(&ns3, &ns1, &c_n1, &c_n1, &c__0, mosoar, mxsoar, n1soar, & + nosoar[nosoar_offset], &noarst[1], &noar3, ierr); + if (*ierr != 0) { + goto L9900; + } + +/* ajout dans noartr du triangle de sommets ns1 ns2 ns3 */ +/* et d'aretes na1, noar2, noar3 dans nosoar */ + trcf3a_(&ns1, &ns2, &ns3, &noar1, &noar2, &noar3, mosoar, &nosoar[ + nosoar_offset], moartr, n1artr, &noartr[noartr_offset], & + nt); + s = surtd2_(&pxyd[ns1 * 3 + 1], &pxyd[ns2 * 3 + 1], &pxyd[ns3 * 3 + + 1]); + if (s <= 0.) { + //io___375.ciunit = unites_1.imprim; + //s_wsle(&io___375); + //do_lio(&c__9, &c__1, "tridcf: trcf3a produit tr", (ftnlen)25); + //do_lio(&c__3, &c__1, (char *)&nt, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " st", (ftnlen)3); + //do_lio(&c__3, &c__1, (char *)&ns1, (ftnlen)sizeof(integer)); + //do_lio(&c__3, &c__1, (char *)&ns2, (ftnlen)sizeof(integer)); + //do_lio(&c__3, &c__1, (char *)&ns3, (ftnlen)sizeof(integer)); + //e_wsle(); + //io___376.ciunit = unites_1.imprim; + //s_wsle(&io___376); + //do_lio(&c__9, &c__1, "tridcf: triangle AIRE<0", (ftnlen)23); + //e_wsle(); + } + if (nt <= 0) { + *ierr = 7; + return 0; + } + if (*nbtrcf >= *mxarcf) { + //io___377.ciunit = unites_1.imprim; + //s_wsle(&io___377); + //do_lio(&c__9, &c__1, "saturation du tableau notrcf", (ftnlen) + // 28); + //e_wsle(); + *ierr = 8; + return 0; + } + ++(*nbtrcf); + notrcf[*nbtrcf] = nt; + +/* modification du cf. creation d'une arete dans noarcf */ + na12 = n1arcf[0]; + if (na12 <= 0) { + //io___379.ciunit = unites_1.imprim; + //s_wsle(&io___379); + //do_lio(&c__9, &c__1, "saturation du tableau noarcf", (ftnlen) + // 28); + //e_wsle(); + *ierr = 10; + return 0; + } +/* la 1-ere arete vide de noarcf est mise a jour */ + n1arcf[0] = noarcf[na12 * 3 + 2]; + +/* l'arete suivante de na0 */ + noarcf[na1 * 3 + 1] = ns1; + noarcf[na1 * 3 + 2] = na12; + noarcf[na1 * 3 + 3] = noar3; +/* l'arete suivante de na1 */ + noarcf[na12 * 3 + 1] = ns3; + noarcf[na12 * 3 + 2] = na2; + noarcf[na12 * 3 + 3] = noar2; + +/* un sommet isole traite */ + --nbstp; + nostpe[imin] = -nostpe[imin]; + goto L1; + } + +/* L6: */ + } + + if (imin == 0) { + //io___380.ciunit = unites_1.imprim; + //s_wsle(&io___380); + //do_lio(&c__9, &c__1, "tridcf: il reste", (ftnlen)16); + //do_lio(&c__3, &c__1, (char *)&nbstp, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " sommets isoles non triangules", (ftnlen)30); + //e_wsle(); + //io___381.ciunit = unites_1.imprim; + //s_wsle(&io___381); + //do_lio(&c__9, &c__1, "ameliorer l'algorithme", (ftnlen)22); + //e_wsle(); +/* cc pause */ + *ierr = 9; + return 0; + } + +/* tant qu'il existe un cf a trianguler faire */ +/* la triangulation directe du cf */ +/* ========================================== */ +L10: + if (nbcf > 0) { + +/* le cf en haut de pile a pour premiere arete */ + na01 = n1arcf[nbcf]; + na1 = noarcf[na01 * 3 + 2]; + +/* choix du sommet du cf a relier a l'arete na1 */ +/* -------------------------------------------- */ + trchtd_(&pxyd[4], &na01, &na1, &noarcf[4], &na03, &na3, &larmin[1]); + if (na3 == 0) { + *ierr = 3; + return 0; + } + +/* l'arete suivante de na1 */ + na02 = na1; + na2 = noarcf[na1 * 3 + 2]; + +/* formation du triangle arete na1 - sommet noarcf(1,na3) */ +/* ------------------------------------------------------ */ + trcf3s_(&nbcf, &na01, &na1, &na02, &na2, &na03, &na3, mosoar, mxsoar, + n1soar, &nosoar[nosoar_offset], moartr, n1artr, &noartr[ + noartr_offset], &noarst[1], mxarcf, n1arcf, &noarcf[4], &nt); + if (nt <= 0) { +/* saturation du tableau noartr ou noarcf ou n1arcf */ + *ierr = 2; + return 0; + } + nusotr_(&nt, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + s = surtd2_(&pxyd[nosotr[0] * 3 + 1], &pxyd[nosotr[1] * 3 + 1], &pxyd[ + nosotr[2] * 3 + 1]); + if (s <= 0.) { + //io___387.ciunit = unites_1.imprim; + //s_wsle(&io___387); + //do_lio(&c__9, &c__1, "tridcf: trcf3s produit tr", (ftnlen)25); + //do_lio(&c__3, &c__1, (char *)&nt, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " st", (ftnlen)3); + //do_lio(&c__3, &c__3, (char *)&nosotr[0], (ftnlen)sizeof(integer)); + //e_wsle(); + //io___388.ciunit = unites_1.imprim; + //s_wsle(&io___388); + //do_lio(&c__9, &c__1, "tridcf: triangle AIRE<0", (ftnlen)23); + //e_wsle(); + } + +/* ajout du triangle cree a sa pile */ + if (*nbtrcf >= *mxarcf) { + //io___389.ciunit = unites_1.imprim; + //s_wsle(&io___389); + //do_lio(&c__9, &c__1, "saturation du tableau notrcf", (ftnlen)28); + //e_wsle(); + *ierr = 4; + return 0; + } + ++(*nbtrcf); + notrcf[*nbtrcf] = nt; + goto L10; + } + +/* mise a jour du chainage des triangles des aretes */ +/* ================================================ */ + i__1 = *nbtrcf; + for (ntp0 = 1; ntp0 <= i__1; ++ntp0) { + +/* le numero du triangle ajoute dans le tableau noartr */ + nt0 = notrcf[ntp0]; + +/* boucle sur les 3 aretes du triangle nt0 */ + for (i__ = 1; i__ <= 3; ++i__) { + +/* le numero de l'arete i du triangle dans le tableau nosoar */ + noar = (i__2 = noartr[i__ + nt0 * noartr_dim1], abs(i__2)); + +/* ce triangle est il deja chaine dans cette arete? */ + nt1 = nosoar[noar * nosoar_dim1 + 4]; + nt2 = nosoar[noar * nosoar_dim1 + 5]; + if (nt1 == nt0 || nt2 == nt0) { + goto L20; + } + +/* ajout de ce triangle nt0 a l'arete noar */ + if (nt1 <= 0) { +/* le triangle est ajoute a l'arete */ + nosoar[noar * nosoar_dim1 + 4] = nt0; + } else if (nt2 <= 0) { +/* le triangle est ajoute a l'arete */ + nosoar[noar * nosoar_dim1 + 5] = nt0; + } else { +/* l'arete appartient a 2 triangles differents de nt0 */ +/* anomalie. chainage des triangles des aretes defectueux */ +/* a corriger */ + //io___395.ciunit = unites_1.imprim; + //s_wsle(&io___395); + //do_lio(&c__9, &c__1, "tridcf: erreur 1 arete dans 3 triangles" + // , (ftnlen)39); + //e_wsle(); + //io___396.ciunit = unites_1.imprim; + //s_wsle(&io___396); + //do_lio(&c__9, &c__1, "tridcf: arete nosoar(", (ftnlen)21); + //do_lio(&c__3, &c__1, (char *)&noar, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, ")=", (ftnlen)2); + //i__2 = *mosoar; + //for (k = 1; k <= i__2; ++k) { + // do_lio(&c__3, &c__1, (char *)&nosoar[k + noar * + // nosoar_dim1], (ftnlen)sizeof(integer)); + //} + //e_wsle(); + nusotr_(&nt0, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + //io___398.ciunit = unites_1.imprim; + //s_wsle(&io___398); + //do_lio(&c__9, &c__1, "tridcf: triangle nt0=", (ftnlen)21); + //do_lio(&c__3, &c__1, (char *)&nt0, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " st:", (ftnlen)4); + //for (k = 1; k <= 3; ++k) { + // do_lio(&c__3, &c__1, (char *)&nosotr[k - 1], (ftnlen) + // sizeof(integer)); + //} + //e_wsle(); + nusotr_(&nt1, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + //io___399.ciunit = unites_1.imprim; + //s_wsle(&io___399); + //do_lio(&c__9, &c__1, "tridcf: triangle nt1=", (ftnlen)21); + //do_lio(&c__3, &c__1, (char *)&nt1, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " st:", (ftnlen)4); + //for (k = 1; k <= 3; ++k) { + // do_lio(&c__3, &c__1, (char *)&nosotr[k - 1], (ftnlen) + // sizeof(integer)); + //} + //e_wsle(); + nusotr_(&nt2, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + //io___400.ciunit = unites_1.imprim; + //s_wsle(&io___400); + //do_lio(&c__9, &c__1, "tridcf: triangle nt2=", (ftnlen)21); + //do_lio(&c__3, &c__1, (char *)&nt2, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " st:", (ftnlen)4); + //for (k = 1; k <= 3; ++k) { + // do_lio(&c__3, &c__1, (char *)&nosotr[k - 1], (ftnlen) + // sizeof(integer)); + //} + //e_wsle(); +/* cc pause */ + *ierr = 5; + return 0; + } + +L20: + ; + } + +/* L30: */ + } + return 0; + +/* erreur tableau nosoar sature */ +L9900: + //io___401.ciunit = unites_1.imprim; + //s_wsle(&io___401); + //do_lio(&c__9, &c__1, "saturation du tableau nosoar", (ftnlen)28); + //e_wsle(); + *ierr = 6; + return 0; +} /* tridcf_ */ + +/* Subroutine */ int te1stm_(integer *nsasup, integer *nbarpi, doublereal * + pxyd, integer *noarst, integer *mosoar, integer *mxsoar, integer * + n1soar, integer *nosoar, integer *moartr, integer *mxartr, integer * + n1artr, integer *noartr, integer *mxarcf, integer *n1arcf, integer * + noarcf, integer *larmin, integer *notrcf, integer *liarcf, integer * + ierr) +{ + /* Format strings */ + static char fmt_10055[] = "(\002aire0=\002,d25.16,\002 aire1=\002,d25.16)" + ; + + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset, i__1; + doublereal d__1; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), + // e_wsfe(void); + + /* Local variables */ + static integer i__; + static doublereal s, s0, s1; + static integer nt, nbcf, noar, noar0; + extern doublereal surtd2_(doublereal *, doublereal *, doublereal *); + static integer nbarcf; + extern /* Subroutine */ int trp1st_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *), tedela_(doublereal *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *); + static integer mmarcf, nbarfr; + extern /* Subroutine */ int tridcf_(integer *, integer *, integer *, + doublereal *, integer *, integer *, integer *, integer *, integer + *, integer *, integer *, integer *, integer *, integer *, integer + *, integer *, integer *, integer *, integer *); + static integer nbtrcf; + extern /* Subroutine */ int focftr_(integer *, integer *, integer *, + doublereal *, integer *, integer *, integer *, integer *, integer + *, integer *, integer *, integer *, integer *, integer *, integer + *, integer *, integer *, integer *); + static integer modifs; + extern /* Subroutine */ int trfrcf_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *); + static integer nbstpe, nostpe[512], nosotr[3]; + extern /* Subroutine */ int nusotr_(integer *, integer *, integer *, + integer *, integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___403 = { 0, 0, 0, 0, 0 }; + static cilist io___416 = { 0, 0, 0, 0, 0 }; + static cilist io___417 = { 0, 0, 0, 0, 0 }; + static cilist io___418 = { 0, 0, 0, 0, 0 }; + static cilist io___419 = { 0, 0, 0, fmt_10055, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : supprimer de la triangulation le sommet nsasup qui doit */ +/* ----- etre un sommet interne ("centre" d'une boule de triangles) */ + +/* attention: le chainage lchain de nosoar devient celui des cf */ + +/* entrees: */ +/* -------- */ +/* nsasup : numero dans le tableau pxyd du sommet a supprimer */ +/* nbarpi : numero du dernier sommet frontalier ou interne impose */ +/* pxyd : tableau des coordonnees 2d des points */ +/* par point : x y distance_souhaitee */ +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* attention: mxsoar>3*mxsomm obligatoire! */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf */ + +/* modifies: */ +/* --------- */ +/* noarst : noarst(i) numero d'une arete de sommet i */ +/* n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar */ +/* chainage des vides suivant en 3 et precedant en 2 de nosoar */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = nosoar(1)+nosoar(2)*2 */ +/* avec mxsoar>=3*mxsomm */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 et */ +/* nosoar(2,arete vide)=l'arete vide qui precede */ +/* nosoar(3,arete vide)=l'arete vide qui suit */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ + + +/* auxiliaires : */ +/* ------------- */ +/* n1arcf : tableau (0:mxarcf) auxiliaire d'entiers */ +/* noarcf : tableau (3,mxarcf) auxiliaire d'entiers */ +/* larmin : tableau ( mxarcf ) auxiliaire d'entiers */ +/* notrcf : tableau ( mxarcf ) auxiliaire d'entiers */ +/* liarcf : tableau ( mxarcf ) auxiliaire d'entiers */ + +/* sortie : */ +/* -------- */ +/* ierr : =0 si pas d'erreur */ +/* -1 le sommet a supprimer n'est pas le centre d'une boule */ +/* de triangles. il est suppose externe */ +/* ou bien le sommet est centre d'un cf dont toutes les */ +/* aretes sont frontalieres */ +/* dans les 2 cas => retour sans modifs */ +/* >0 si une erreur est survenue */ +/* =11 algorithme defaillant */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* ....................................................................012 */ + + /* Parameter adjustments */ + pxyd -= 4; + --noarst; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --liarcf; + --notrcf; + --larmin; + noarcf -= 4; + + /* Function Body */ + if (*nsasup <= *nbarpi) { +/* sommet frontalier non destructible */ + *ierr = -1; + return 0; + } + *ierr = 0; + +/* nsasup est il un sommet interne, "centre" d'une boule de triangles? */ +/* => le sommet nsasup peut etre supprime */ +/* =================================================================== */ +/* formation du cf de ''centre'' le sommet nsasup */ + trp1st_(nsasup, &noarst[1], mosoar, &nosoar[nosoar_offset], moartr, + mxartr, &noartr[noartr_offset], mxarcf, &nbtrcf, ¬rcf[1]); + + if (nbtrcf <= 2) { +/* erreur: impossible de trouver tous les triangles de sommet nsasup */ +/* ou pas assez de triangles de sommet nsasup */ +/* le sommet nsasup n'est pas supprime de la triangulation */ + *ierr = -1; + return 0; + } + + if (nbtrcf * 3 > *mxarcf) { + //io___403.ciunit = unites_2.imprim; + //s_wsle(&io___403); + //do_lio(&c__9, &c__1, "saturation du tableau noarcf", (ftnlen)28); + //e_wsle(); + *ierr = 10; + return 0; + } + +/* si toutes les aretes du cf sont frontalieres, alors il est */ +/* interdit de detruire le sommet "centre" du cf */ +/* calcul du nombre nbarfr des aretes simples des nbtrcf triangles */ + trfrcf_(nsasup, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], &nbtrcf, ¬rcf[1], &nbarfr); + if (nbarfr >= nbtrcf) { +/* toutes les aretes simples sont frontalieres */ +/* le sommet nsasup ("centre" de la cavite) n'est pas supprime */ + *ierr = -1; + return 0; + } + +/* calcul des surfaces avant suppression du point */ + s0 = 0.; + i__1 = nbtrcf; + for (i__ = 1; i__ <= i__1; ++i__) { + nt = notrcf[i__]; +/* les numeros des 3 sommets du triangle nt */ + nusotr_(&nt, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + s = surtd2_(&pxyd[nosotr[0] * 3 + 1], &pxyd[nosotr[1] * 3 + 1], &pxyd[ + nosotr[2] * 3 + 1]); + s0 += abs(s); +/* L10: */ + } + +/* formation du contour ferme (liste chainee des aretes simples) */ +/* forme a partir des aretes des triangles de l'etoile du sommet nsasup */ +/* les aretes doubles sont detruites */ +/* les triangles du cf sont detruits */ + focftr_(&nbtrcf, ¬rcf[1], nbarpi, &pxyd[4], &noarst[1], mosoar, mxsoar, + n1soar, &nosoar[nosoar_offset], moartr, n1artr, &noartr[ + noartr_offset], &nbarcf, n1arcf, &noarcf[4], &nbstpe, nostpe, + ierr); + if (*ierr != 0) { +/* modification de ierr pour continuer le calcul */ + *ierr = -543; + return 0; + } + +/* ici le sommet nsasup n'appartient plus a aucune arete */ + noarst[*nsasup] = 0; + +/* chainage des aretes vides dans le tableau noarcf */ + n1arcf[0] = nbarcf + 1; +/* Computing MIN */ + i__1 = nbarcf << 3; + mmarcf = min(i__1,*mxarcf); + i__1 = mmarcf; + for (i__ = nbarcf + 1; i__ <= i__1; ++i__) { + noarcf[i__ * 3 + 2] = i__ + 1; +/* L40: */ + } + noarcf[mmarcf * 3 + 2] = 0; + +/* sauvegarde du chainage des aretes peripheriques */ +/* pour la mise en delaunay du maillage */ + nbcf = n1arcf[1]; + i__1 = nbarcf; + for (i__ = 1; i__ <= i__1; ++i__) { +/* le numero de l'arete dans le tableau nosoar */ + liarcf[i__] = noarcf[nbcf * 3 + 3]; +/* l'arete suivante dans le cf */ + nbcf = noarcf[nbcf * 3 + 2]; +/* L50: */ + } + +/* triangulation directe du contour ferme sans le sommet nsasup */ +/* ============================================================ */ + nbcf = 1; + tridcf_(&nbcf, &nbstpe, nostpe, &pxyd[4], &noarst[1], mosoar, mxsoar, + n1soar, &nosoar[nosoar_offset], moartr, n1artr, &noartr[ + noartr_offset], mxarcf, n1arcf, &noarcf[4], &larmin[1], &nbtrcf, & + notrcf[1], ierr); + if (*ierr != 0) { + return 0; + } +/* calcul des surfaces apres suppression du point */ + s1 = 0.; + i__1 = nbtrcf; + for (i__ = 1; i__ <= i__1; ++i__) { + nt = notrcf[i__]; +/* les numeros des 3 sommets du triangle nt */ + nusotr_(&nt, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + s = surtd2_(&pxyd[nosotr[0] * 3 + 1], &pxyd[nosotr[1] * 3 + 1], &pxyd[ + nosotr[2] * 3 + 1]); + if (s <= 0.) { + //io___416.ciunit = unites_2.imprim; + //s_wsle(&io___416); + //do_lio(&c__9, &c__1, "te1stm: apres tridcf le triangle", (ftnlen) + // 32); + //do_lio(&c__3, &c__1, (char *)&nt, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " st", (ftnlen)3); + //do_lio(&c__3, &c__3, (char *)&nosotr[0], (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " AIRE<0", (ftnlen)7); + //e_wsle(); + } + s1 += abs(s); +/* L55: */ + } + + if ((d__1 = s0 - s1, abs(d__1)) > s0 * 1e-10) { + //io___417.ciunit = unites_2.imprim; + //s_wsle(&io___417); + //e_wsle(); + //io___418.ciunit = unites_2.imprim; + //s_wsle(&io___418); + //do_lio(&c__9, &c__1, "te1stm: difference des aires lors suppression " + // "st", (ftnlen)48); + //do_lio(&c__3, &c__1, (char *)&(*nsasup), (ftnlen)sizeof(integer)); + //e_wsle(); + //io___419.ciunit = unites_2.imprim; + //s_wsfe(&io___419); + //do_fio(&c__1, (char *)&s0, (ftnlen)sizeof(doublereal)); + //do_fio(&c__1, (char *)&s1, (ftnlen)sizeof(doublereal)); + //e_wsfe(); + } + +/* transformation des triangles du cf en triangles delaunay */ +/* ======================================================== */ +/* construction du chainage lchain dans nosoar */ +/* des aretes peripheriques du cf a partir de la sauvegarde liarcf */ + noar0 = liarcf[1]; + i__1 = nbarcf; + for (i__ = 2; i__ <= i__1; ++i__) { +/* le numero de l'arete peripherique du cf dans nosoar */ + noar = liarcf[i__]; + if (nosoar[noar * nosoar_dim1 + 3] <= 0) { +/* arete interne => elle est chainee a partir de la precedente */ + nosoar[noar0 * nosoar_dim1 + 6] = noar; + noar0 = noar; + } +/* L60: */ + } +/* la derniere arete peripherique n'a pas de suivante */ + nosoar[noar0 * nosoar_dim1 + 6] = 0; + +/* mise en delaunay des aretes chainees */ + tedela_(&pxyd[4], &noarst[1], mosoar, mxsoar, n1soar, &nosoar[ + nosoar_offset], &liarcf[1], moartr, mxartr, n1artr, &noartr[ + noartr_offset], &modifs); + return 0; +} /* te1stm_ */ + +/* Subroutine */ int tr3str_(integer *np, integer *nt, integer *mosoar, + integer *mxsoar, integer *n1soar, integer *nosoar, integer *moartr, + integer *mxartr, integer *n1artr, integer *noartr, integer *noarst, + integer *nutr, integer *ierr) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset; + + /* Local variables */ + static integer i__, i1, nt0, nti, noar, nu2sar[2]; + extern /* Subroutine */ int hasoar_(integer *, integer *, integer *, + integer *, integer *, integer *); + static integer nuarco[3], nosotr[3]; + extern /* Subroutine */ int nusotr_(integer *, integer *, integer *, + integer *, integer *, integer *); + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : former les 3 sous-triangles du triangle nt a partir */ +/* ----- du point interne np */ + +/* entrees: */ +/* -------- */ +/* np : numero dans le tableau pxyd du point */ +/* nt : numero dans le tableau noartr du triangle a trianguler */ +/* mosoar : nombre maximal d'entiers par arete du tableau nosoar */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxartr : nombre maximal de triangles stockables dans le tableau noartr */ + +/* modifies: */ +/* --------- */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages */ +/* sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante */ +/* hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ +/* noarst : noarst(i) numero d'une arete de sommet i */ + +/* sorties: */ +/* -------- */ +/* nutr : le numero des 3 sous-triangles du triangle nt */ +/* nt : en sortie le triangle initial n'est plus actif dans noartr */ +/* c'est en fait le premier triangle vide de noartr */ +/* ierr : =0 si pas d'erreur */ +/* =1 si le tableau nosoar est sature */ +/* =2 si le tableau noartr est sature */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* ....................................................................012 */ + + +/* reservation des 3 nouveaux triangles dans le tableau noartr */ +/* =========================================================== */ + /* Parameter adjustments */ + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --noarst; + --nutr; + + /* Function Body */ + for (i__ = 1; i__ <= 3; ++i__) { +/* le numero du sous-triangle i dans le tableau noartr */ + if (*n1artr <= 0) { +/* tableau noartr sature */ + *ierr = 2; + return 0; + } + nutr[i__] = *n1artr; +/* le nouveau premier triangle libre dans noartr */ + *n1artr = noartr[*n1artr * noartr_dim1 + 2]; +/* L10: */ + } + +/* les numeros des 3 sommets du triangle nt */ + nusotr_(nt, mosoar, &nosoar[nosoar_offset], moartr, &noartr[noartr_offset] + , nosotr); + +/* formation des 3 aretes nosotr(i)-np dans le tableau nosoar */ +/* ========================================================== */ + nt0 = nutr[3]; + for (i__ = 1; i__ <= 3; ++i__) { + +/* le triangle a creer */ + nti = nutr[i__]; + +/* les 2 sommets du cote i du triangle nosotr */ + nu2sar[0] = nosotr[i__ - 1]; + nu2sar[1] = *np; + hasoar_(mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], nu2sar, &noar) + ; +/* en sortie: noar>0 => no arete retrouvee */ +/* <0 => no arete ajoutee */ +/* =0 => saturation du tableau nosoar */ + + if (noar == 0) { +/* saturation du tableau nosoar */ + *ierr = 1; + return 0; + } else if (noar < 0) { +/* l'arete a ete ajoutee. initialisation des autres informations */ + noar = -noar; +/* le numero des 2 sommets a ete initialise par hasoar */ +/* et (nosoar(1,noar) le triangle nt0 */ + nosoar[noar * nosoar_dim1 + 4] = nt0; +/* le triangle 2 de l'arete noar => le triangle nti */ + nosoar[noar * nosoar_dim1 + 5] = nti; + +/* le sommet nosotr(i) appartient a l'arete noar */ + noarst[nosotr[i__ - 1]] = noar; + +/* le numero d'arete nosotr(i)-np */ + nuarco[i__ - 1] = noar; + +/* le triangle qui precede le suivant */ + nt0 = nti; +/* L20: */ + } + +/* le numero d'une arete du point np */ + noarst[*np] = noar; + +/* les 3 sous-triangles du triangle nt sont formes dans le tableau noartr */ +/* ====================================================================== */ + for (i__ = 1; i__ <= 3; ++i__) { + +/* le numero suivant i => i mod 3 + 1 */ + if (i__ != 3) { + i1 = i__ + 1; + } else { + i1 = 1; + } + +/* le numero dans noartr du sous-triangle a ajouter */ + nti = nutr[i__]; + +/* le numero de l'arete i du triangle initial nt */ +/* est l'arete 1 du sous-triangle i */ + noar = noartr[i__ + *nt * noartr_dim1]; + noartr[nti * noartr_dim1 + 1] = noar; + +/* mise a jour du numero de triangle de cette arete */ + noar = abs(noar); + if (nosoar[noar * nosoar_dim1 + 4] == *nt) { +/* le sous-triangle nti remplace le triangle nt */ + nosoar[noar * nosoar_dim1 + 4] = nti; + } else { +/* le sous-triangle nti remplace le triangle nt */ + nosoar[noar * nosoar_dim1 + 5] = nti; + } + +/* l'arete 2 du sous-triangle i est l'arete i1 ajoutee */ + if (nosotr[i1 - 1] == nosoar[nuarco[i1 - 1] * nosoar_dim1 + 1]) { +/* l'arete ns i1-np dans nosoar est dans le sens direct */ + noartr[nti * noartr_dim1 + 2] = nuarco[i1 - 1]; + } else { +/* l'arete ns i1-np dans nosoar est dans le sens indirect */ + noartr[nti * noartr_dim1 + 2] = -nuarco[i1 - 1]; + } + +/* l'arete 3 du sous-triangle i est l'arete i ajoutee */ + if (nosotr[i__ - 1] == nosoar[nuarco[i__ - 1] * nosoar_dim1 + 1]) { +/* l'arete ns i1-np dans nosoar est dans le sens indirect */ + noartr[nti * noartr_dim1 + 3] = -nuarco[i__ - 1]; + } else { +/* l'arete ns i1-np dans nosoar est dans le sens direct */ + noartr[nti * noartr_dim1 + 3] = nuarco[i__ - 1]; + } +/* L30: */ + } + +/* le triangle nt est rendu libre */ +/* ============================== */ +/* il devient n1artr le premier triangle libre */ + noartr[*nt * noartr_dim1 + 1] = 0; + noartr[*nt * noartr_dim1 + 2] = *n1artr; + *n1artr = *nt; + return 0; +} /* tr3str_ */ + +/* Subroutine */ int mt4sqa_(integer *na, integer *moartr, integer *noartr, + integer *mosoar, integer *nosoar, integer *ns1, integer *ns2, integer + *ns3, integer *ns4) +{ + /* System generated locals */ + integer noartr_dim1, noartr_offset, nosoar_dim1, nosoar_offset, i__1; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static integer i__, nt, naa; + + /* Fortran I/O blocks */ + static cilist io___431 = { 0, 0, 0, 0, 0 }; + static cilist io___432 = { 0, 0, 0, 0, 0 }; + static cilist io___434 = { 0, 0, 0, 0, 0 }; + static cilist io___436 = { 0, 0, 0, 0, 0 }; + static cilist io___438 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : calcul du numero des 4 sommets de l'arete na de nosoar */ +/* ----- formant un quadrangle */ + +/* entrees: */ +/* -------- */ +/* na : numero de l'arete dans nosoar a traiter */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1=0 si triangle vide => arete2=triangle vide suivant */ +/* mosoar : nombre maximal d'entiers par arete */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en + */ +/* sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante */ + +/* sorties: */ +/* -------- */ +/* ns1,ns2,ns3 : les 3 numeros des sommets du triangle t1 en sens direct */ +/* ns1,ns4,ns2 : les 3 numeros des sommets du triangle t2 en sens direct */ + +/* si erreur rencontree => ns4 = 0 */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* 2345x7..............................................................012 */ + +/* le numero de triangle est il correct ? */ +/* a supprimer apres mise au point */ + /* Parameter adjustments */ + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + + /* Function Body */ + if (*na <= 0) { +/* nblgrc(nrerr) = 1 */ +/* write(kerr(mxlger)(1:6),'(i6)') na */ +/* kerr(1) = kerr(mxlger)(1:6) // */ +/* % ' no incorrect arete dans nosoar' */ +/* call lereur */ + //io___431.ciunit = unites_1.imprim; + //s_wsle(&io___431); + //do_lio(&c__3, &c__1, (char *)&(*na), (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " no incorrect arete dans nosoar", (ftnlen)31); + //e_wsle(); + *ns4 = 0; + return 0; + } + + if (nosoar[*na * nosoar_dim1 + 1] <= 0) { +/* nblgrc(nrerr) = 1 */ +/* write(kerr(mxlger)(1:6),'(i6)') na */ +/* kerr(1) = kerr(mxlger)(1:6) // */ +/* % ' arete non active dans nosoar' */ +/* call lereur */ + //io___432.ciunit = unites_1.imprim; + //s_wsle(&io___432); + //do_lio(&c__3, &c__1, (char *)&(*na), (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " arete non active dans nosoar", (ftnlen)29); + //e_wsle(); + *ns4 = 0; + return 0; + } + +/* recherche de l'arete na dans le premier triangle */ + nt = nosoar[*na * nosoar_dim1 + 4]; + if (nt <= 0) { +/* nblgrc(nrerr) = 1 */ +/* write(kerr(mxlger)(1:6),'(i6)') na */ +/* kerr(1) = 'triangle 1 incorrect pour l''arete ' // */ +/* % kerr(mxlger)(1:6) */ +/* call lereur */ + //io___434.ciunit = unites_1.imprim; + //s_wsle(&io___434); + //do_lio(&c__9, &c__1, "triangle 1 incorrect pour l'arete ", (ftnlen)34) + // ; + //do_lio(&c__3, &c__1, (char *)&(*na), (ftnlen)sizeof(integer)); + //e_wsle(); + *ns4 = 0; + return 0; + } + + for (i__ = 1; i__ <= 3; ++i__) { + if ((i__1 = noartr[i__ + nt * noartr_dim1], abs(i__1)) == *na) { + goto L8; + } +/* L5: */ + } +/* si arrivee ici => bogue avant */ + /* io___436.ciunit = unites_1.imprim; + s_wsle(&io___436); + do_lio(&c__9, &c__1, "mt4sqa: arete", (ftnlen)13); + do_lio(&c__3, &c__1, (char *)&(*na), (ftnlen)sizeof(integer)); + do_lio(&c__9, &c__1, " non dans le triangle", (ftnlen)21); + do_lio(&c__3, &c__1, (char *)&nt, (ftnlen)sizeof(integer)); + e_wsle();*/ + *ns4 = 0; + return 0; + +/* les 2 sommets de l'arete na */ +L8: + if (noartr[i__ + nt * noartr_dim1] > 0) { + *ns1 = 1; + *ns2 = 2; + } else { + *ns1 = 2; + *ns2 = 1; + } + *ns1 = nosoar[*ns1 + *na * nosoar_dim1]; + *ns2 = nosoar[*ns2 + *na * nosoar_dim1]; + +/* l'arete suivante */ + if (i__ < 3) { + ++i__; + } else { + i__ = 1; + } + naa = (i__1 = noartr[i__ + nt * noartr_dim1], abs(i__1)); + +/* le sommet ns3 du triangle 123 */ + *ns3 = nosoar[naa * nosoar_dim1 + 1]; + if (*ns3 == *ns1 || *ns3 == *ns2) { + *ns3 = nosoar[naa * nosoar_dim1 + 2]; + } + +/* le triangle de l'autre cote de l'arete na */ +/* ========================================= */ + nt = nosoar[*na * nosoar_dim1 + 5]; + if (nt <= 0) { +/* nblgrc(nrerr) = 1 */ +/* write(kerr(mxlger)(1:6),'(i6)') na */ +/* kerr(1) = 'triangle 2 incorrect pour l''arete ' // */ +/* % kerr(mxlger)(1:6) */ +/* call lereur */ + //io___438.ciunit = unites_1.imprim; + //s_wsle(&io___438); + //do_lio(&c__9, &c__1, "triangle 2 incorrect pour l'arete ", (ftnlen)34) + // ; + //do_lio(&c__3, &c__1, (char *)&(*na), (ftnlen)sizeof(integer)); + //e_wsle(); + *ns4 = 0; + return 0; + } + +/* le numero de l'arete naa du triangle nt */ + naa = (i__1 = noartr[nt * noartr_dim1 + 1], abs(i__1)); + if (naa == *na) { + naa = (i__1 = noartr[nt * noartr_dim1 + 2], abs(i__1)); + } + *ns4 = nosoar[naa * nosoar_dim1 + 1]; + if (*ns4 == *ns1 || *ns4 == *ns2) { + *ns4 = nosoar[naa * nosoar_dim1 + 2]; + } + return 0; +} /* mt4sqa_ */ + +/* Subroutine */ int te2t2t_(integer *noaret, integer *mosoar, integer * + n1soar, integer *nosoar, integer *noarst, integer *moartr, integer * + noartr, integer *noar34) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset, i__1; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static integer n1, n2, n3, ns1, ns2, ns3, ns4, nt1, nt2, na31, na23, na14, + na42, ierr; + extern /* Subroutine */ int mt4sqa_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *), + fasoar_(integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *), sasoar_(integer *, integer *, integer *, integer *, + integer *, integer *); + static integer mxsoar; + + /* Fortran I/O blocks */ + static cilist io___445 = { 0, 0, 0, 0, 0 }; + static cilist io___451 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : echanger la diagonale des 2 triangles ayant en commun */ +/* ----- l'arete noaret du tableau nosoar si c'est possible */ + +/* entrees: */ +/* -------- */ +/* noaret : numero de l'arete a echanger entre les 2 triangles */ +/* mosoar : nombre maximal d'entiers par arete */ +/* moartr : nombre maximal d'entiers par triangle */ + +/* modifies : */ +/* ---------- */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en + */ +/* sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante */ +/* noarst : noarst(i) numero d'une arete de sommet i */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ + +/* sortie : */ +/* -------- */ +/* noar34 : numero nosoar de la nouvelle arete diagonale */ +/* 0 si pas d'echange des aretes diagonales */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc avril 1997 */ +/* ....................................................................012 */ + +/* une arete frontaliere ne peut etre echangee */ + /* Parameter adjustments */ + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + --noarst; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + + /* Function Body */ + *noar34 = 0; + if (nosoar[*noaret * nosoar_dim1 + 3] > 0) { + return 0; + } + +/* les 4 sommets des 2 triangles ayant l'arete noaret en commun */ + mt4sqa_(noaret, moartr, &noartr[noartr_offset], mosoar, &nosoar[ + nosoar_offset], &ns1, &ns2, &ns3, &ns4); +/* ns1,ns2,ns3 : les 3 numeros des sommets du triangle nt1 en sens direct */ +/* ns1,ns4,ns2 : les 3 numeros des sommets du triangle nt2 en sens direct */ + +/* recherche du numero de l'arete noaret dans le triangle nt1 */ + nt1 = nosoar[*noaret * nosoar_dim1 + 4]; + for (n1 = 1; n1 <= 3; ++n1) { + if ((i__1 = noartr[n1 + nt1 * noartr_dim1], abs(i__1)) == *noaret) { + goto L15; + } +/* L10: */ + } +/* impossible d'arriver ici sans bogue! */ + //io___445.ciunit = unites_2.imprim; + //s_wsle(&io___445); + //do_lio(&c__9, &c__1, "anomalie dans te2t2t 1", (ftnlen)22); + //e_wsle(); + +/* l'arete de sommets 2 et 3 */ +L15: + if (n1 < 3) { + n2 = n1 + 1; + } else { + n2 = 1; + } + na23 = noartr[n2 + nt1 * noartr_dim1]; + +/* l'arete de sommets 3 et 1 */ + if (n2 < 3) { + n3 = n2 + 1; + } else { + n3 = 1; + } + na31 = noartr[n3 + nt1 * noartr_dim1]; + +/* recherche du numero de l'arete noaret dans le triangle nt2 */ + nt2 = nosoar[*noaret * nosoar_dim1 + 5]; + for (n1 = 1; n1 <= 3; ++n1) { + if ((i__1 = noartr[n1 + nt2 * noartr_dim1], abs(i__1)) == *noaret) { + goto L25; + } +/* L20: */ + } +/* impossible d'arriver ici sans bogue! */ + //io___451.ciunit = unites_2.imprim; + //s_wsle(&io___451); + //do_lio(&c__9, &c__1, "Anomalie dans te2t2t 2", (ftnlen)22); + //e_wsle(); + +/* l'arete de sommets 1 et 4 */ +L25: + if (n1 < 3) { + n2 = n1 + 1; + } else { + n2 = 1; + } + na14 = noartr[n2 + nt2 * noartr_dim1]; + +/* l'arete de sommets 4 et 2 */ + if (n2 < 3) { + n3 = n2 + 1; + } else { + n3 = 1; + } + na42 = noartr[n3 + nt2 * noartr_dim1]; + +/* les triangles 123 142 deviennent 143 234 */ +/* ======================================== */ +/* ajout de l'arete ns3-ns4 */ +/* on evite l'affichage de l'erreur */ + ierr = -1; + fasoar_(&ns3, &ns4, &nt1, &nt2, &c__0, mosoar, &mxsoar, n1soar, &nosoar[ + nosoar_offset], &noarst[1], noar34, &ierr); + if (ierr > 0) { +/* ierr=1 si le tableau nosoar est sature */ +/* =2 si arete a creer et appartenant a 2 triangles distincts */ +/* des triangles nt1 et nt2 */ +/* =3 si arete appartenant a 2 triangles distincts */ +/* differents des triangles nt1 et nt2 */ +/* =4 si arete appartenant a 2 triangles distincts */ +/* dont le second n'est pas le triangle nt2 */ +/* => pas d'echange */ + *noar34 = 0; + return 0; + } + +/* suppression de l'arete noaret */ + sasoar_(noaret, mosoar, &mxsoar, n1soar, &nosoar[nosoar_offset], &noarst[ + 1]); + +/* nt1 = triangle 143 */ + noartr[nt1 * noartr_dim1 + 1] = na14; +/* sens de stockage de l'arete ns3-ns4 dans nosoar? */ + if (nosoar[*noar34 * nosoar_dim1 + 1] == ns3) { + n1 = -1; + } else { + n1 = 1; + } + noartr[nt1 * noartr_dim1 + 2] = *noar34 * n1; + noartr[nt1 * noartr_dim1 + 3] = na31; + +/* nt2 = triangle 234 */ + noartr[nt2 * noartr_dim1 + 1] = na23; + noartr[nt2 * noartr_dim1 + 2] = -(*noar34) * n1; + noartr[nt2 * noartr_dim1 + 3] = na42; + +/* echange nt1 -> nt2 pour l'arete na23 */ + na23 = abs(na23); + if (nosoar[na23 * nosoar_dim1 + 4] == nt1) { + n1 = 4; + } else { + n1 = 5; + } + nosoar[n1 + na23 * nosoar_dim1] = nt2; + +/* echange nt2 -> nt1 pour l'arete na14 */ + na14 = abs(na14); + if (nosoar[na14 * nosoar_dim1 + 4] == nt2) { + n1 = 4; + } else { + n1 = 5; + } + nosoar[n1 + na14 * nosoar_dim1] = nt1; + +/* numero d'une arete de chacun des 4 sommets */ + noarst[ns1] = na14; + noarst[ns2] = na23; + noarst[ns3] = *noar34; + noarst[ns4] = *noar34; + return 0; +} /* te2t2t_ */ + +/* Subroutine */ int f0trte_(integer *letree, doublereal *pxyd, integer * + mosoar, integer *mxsoar, integer *n1soar, integer *nosoar, integer * + moartr, integer *mxartr, integer *n1artr, integer *noartr, integer * + noarst, integer *nbtr, integer *nutr, integer *ierr) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static integer i__, i1, nt; + extern /* Subroutine */ int fasoar_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *); + static integer lesign, nuarco[3]; + extern /* Subroutine */ int trpite_(integer *, doublereal *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___456 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : former le ou les triangles du triangle equilateral letree */ +/* ----- les points internes au te deviennent des sommets des */ +/* sous-triangles du te */ + +/* entrees: */ +/* -------- */ +/* letree : arbre-4 des triangles equilateraux (te) fond de la triangulation */ +/* si letree(0)>0 alors */ +/* letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j */ +/* sinon */ +/* letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j */ +/* 0 si pas de point */ +/* ( le te est une feuille de l'arbre ) */ +/* letree(4) : no letree du sur-triangle du triangle j */ +/* letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle */ +/* letree(6:8) : no pxyd des 3 sommets du triangle j */ +/* pxyd : tableau des x y distance_souhaitee de chaque sommet */ +/* mosoar : nombre maximal d'entiers par arete du tableau nosoar */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxartr : nombre maximal de triangles stockables dans le tableau noartr */ + +/* modifies: */ +/* --------- */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar */ +/* sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ +/* noarst : noarst(i) numero d'une arete de sommet i */ + +/* sorties: */ +/* -------- */ +/* nbtr : nombre de sous-triangles du te, triangulation du te */ +/* nutr : numero des nbtr sous-triangles du te dans le tableau noartr */ +/* ierr : =0 si pas d'erreur */ +/* =1 si le tableau nosoar est sature */ +/* =2 si le tableau noartr est sature */ +/* =3 si aucun des triangles ne contient l'un des points internes au te */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* ....................................................................012 */ + +/* le numero nt du triangle dans le tableau noartr */ + /* Parameter adjustments */ + pxyd -= 4; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --noarst; + --nutr; + + /* Function Body */ + if (*n1artr <= 0) { +/* tableau noartr sature */ + //io___456.ciunit = unites_1.imprim; + //s_wsle(&io___456); + //do_lio(&c__9, &c__1, "f0trte: tableau noartr sature", (ftnlen)29); + //e_wsle(); + *ierr = 2; + return 0; + } + nt = *n1artr; +/* le numero du nouveau premier triangle libre dans noartr */ + *n1artr = noartr[*n1artr * noartr_dim1 + 2]; + +/* formation du triangle = le triangle equilateral letree */ + for (i__ = 1; i__ <= 3; ++i__) { + if (i__ != 3) { + i1 = i__ + 1; + } else { + i1 = 1; + } +/* ajout eventuel de l'arete si si+1 dans le tableau nosoar */ + fasoar_(&letree[i__ + 5], &letree[i1 + 5], &nt, &c_n1, &c__0, mosoar, + mxsoar, n1soar, &nosoar[nosoar_offset], &noarst[1], &nuarco[ + i__ - 1], ierr); + if (*ierr != 0) { + return 0; + } +/* L10: */ + } + +/* le triangle nt est forme dans le tableau noartr */ + for (i__ = 1; i__ <= 3; ++i__) { +/* letree(5+i) est le numero du sommet 1 de l'arete i du te */ + if (letree[i__ + 5] == nosoar[nuarco[i__ - 1] * nosoar_dim1 + 1]) { + lesign = 1; + } else { + lesign = -1; + } +/* l'arete ns1-ns2 dans nosoar est celle du cote du te */ + noartr[i__ + nt * noartr_dim1] = lesign * nuarco[i__ - 1]; +/* L20: */ + } + +/* triangulation du te=triangle nt par ajout des points internes du te */ + *nbtr = 1; + nutr[1] = nt; + trpite_(letree, &pxyd[4], mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], + moartr, mxartr, n1artr, &noartr[noartr_offset], &noarst[1], nbtr, + &nutr[1], ierr); + return 0; +} /* f0trte_ */ + +/* Subroutine */ int f1trte_(integer *letree, doublereal *pxyd, integer * + milieu, integer *mosoar, integer *mxsoar, integer *n1soar, integer * + nosoar, integer *moartr, integer *mxartr, integer *n1artr, integer * + noartr, integer *noarst, integer *nbtr, integer *nutr, integer *ierr) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset; + + /* Local variables */ + static integer i__, i1, nm; + extern /* Subroutine */ int fasoar_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *); + static integer lesign, nuarco[5]; + extern /* Subroutine */ int trpite_(integer *, doublereal *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *); + static integer nosotr[3]; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : former les triangles du triangle equilateral letree */ +/* ----- a partir de l'un des 3 milieux des cotes du te */ +/* et des points internes au te */ +/* ils deviennent tous des sommets des sous-triangles du te */ + +/* entrees: */ +/* -------- */ +/* letree : arbre-4 des triangles equilateraux (te) fond de la triangulation */ +/* si letree(0)>0 alors */ +/* letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j */ +/* sinon */ +/* letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j */ +/* 0 si pas de point */ +/* ( le te est une feuille de l'arbre ) */ +/* letree(4) : no letree du sur-triangle du triangle j */ +/* letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle */ +/* letree(6:8) : no pxyd des 3 sommets du triangle j */ +/* pxyd : tableau des x y distance_souhaitee de chaque sommet */ +/* milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te */ +/* 0 si pas de milieu du cote i a ajouter */ +/* mosoar : nombre maximal d'entiers par arete du tableau nosoar */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxartr : nombre maximal de triangles stockables dans le tableau noartr */ + +/* modifies: */ +/* --------- */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar */ +/* sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ +/* noarst : noarst(np) numero d'une arete du sommet np */ + +/* sorties: */ +/* -------- */ +/* nbtr : nombre de sous-triangles du te, triangulation du te */ +/* nutr : numero des nbtr sous-triangles du te dans le tableau noartr */ +/* ierr : =0 si pas d'erreur */ +/* =1 si le tableau nosoar est sature */ +/* =2 si le tableau noartr est sature */ +/* =3 si aucun des triangles ne contient l'un des points internes au te */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* ....................................................................012 */ + + +/* le numero des 2 triangles (=2 demi te) a creer dans le tableau noartr */ + /* Parameter adjustments */ + pxyd -= 4; + --milieu; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --noarst; + --nutr; + + /* Function Body */ + for (*nbtr = 1; *nbtr <= 2; ++(*nbtr)) { + if (*n1artr <= 0) { +/* tableau noartr sature */ + *ierr = 2; + return 0; + } + nutr[*nbtr] = *n1artr; +/* le nouveau premier triangle libre dans noartr */ + *n1artr = noartr[*n1artr * noartr_dim1 + 2]; +/* L5: */ + } + *nbtr = 2; + +/* recherche du milieu a creer */ + for (i__ = 1; i__ <= 3; ++i__) { + if (milieu[i__] != 0) { + goto L9; + } +/* L7: */ + } +/* le numero pxyd du point milieu du cote i */ +L9: + nm = milieu[i__]; + +/* on se ramene au seul cas i=3 c-a-d le milieu est sur le cote 3 */ + if (i__ == 1) { +/* milieu sur le cote 1 */ + nosotr[0] = letree[7]; + nosotr[1] = letree[8]; + nosotr[2] = letree[6]; + } else if (i__ == 2) { +/* milieu sur le cote 2 */ + nosotr[0] = letree[8]; + nosotr[1] = letree[6]; + nosotr[2] = letree[7]; + } else { +/* milieu sur le cote 3 */ + nosotr[0] = letree[6]; + nosotr[1] = letree[7]; + nosotr[2] = letree[8]; + } + +/* formation des 2 aretes s1 s2 et s2 s3 */ + for (i__ = 1; i__ <= 2; ++i__) { + if (i__ != 3) { + i1 = i__ + 1; + } else { + i1 = 1; + } +/* ajout eventuel de l'arete dans nosoar */ + fasoar_(&nosotr[i__ - 1], &nosotr[i1 - 1], &nutr[i__], &c_n1, &c__0, + mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], &noarst[1], & + nuarco[i__ - 1], ierr); + if (*ierr != 0) { + return 0; + } +/* L10: */ + } + +/* ajout eventuel de l'arete s3 milieu dans nosoar */ + fasoar_(&nosotr[2], &nm, &nutr[2], &c_n1, &c__0, mosoar, mxsoar, n1soar, & + nosoar[nosoar_offset], &noarst[1], &nuarco[2], ierr); + if (*ierr != 0) { + return 0; + } + +/* ajout eventuel de l'arete milieu s1 dans nosoar */ + fasoar_(nosotr, &nm, &nutr[1], &c_n1, &c__0, mosoar, mxsoar, n1soar, & + nosoar[nosoar_offset], &noarst[1], &nuarco[3], ierr); + if (*ierr != 0) { + return 0; + } + +/* ajout eventuel de l'arete milieu s2 dans nosoar */ + fasoar_(&nosotr[1], &nm, &nutr[1], &nutr[2], &c__0, mosoar, mxsoar, + n1soar, &nosoar[nosoar_offset], &noarst[1], &nuarco[4], ierr); + if (*ierr != 0) { + return 0; + } + +/* les aretes s1 s2 et s2 s3 dans le tableau noartr */ + for (i__ = 1; i__ <= 2; ++i__) { +/* nosotr(i) est le numero du sommet 1 de l'arete i du te */ + if (nosotr[i__ - 1] == nosoar[nuarco[i__ - 1] * nosoar_dim1 + 1]) { + lesign = 1; + } else { + lesign = -1; + } +/* l'arete ns1-ns2 dans nosoar est celle du cote du te */ + noartr[nutr[i__] * noartr_dim1 + 1] = lesign * nuarco[i__ - 1]; +/* L20: */ + } + +/* l'arete mediane s2 milieu */ + if (nm == nosoar[nuarco[4] * nosoar_dim1 + 1]) { + lesign = -1; + } else { + lesign = 1; + } + noartr[nutr[1] * noartr_dim1 + 2] = lesign * nuarco[4]; + noartr[nutr[2] * noartr_dim1 + 3] = -lesign * nuarco[4]; + +/* l'arete s1 milieu */ + if (nm == nosoar[nuarco[3] * nosoar_dim1 + 1]) { + lesign = 1; + } else { + lesign = -1; + } + noartr[nutr[1] * noartr_dim1 + 3] = lesign * nuarco[3]; + +/* l'arete s3 milieu */ + if (nm == nosoar[nuarco[2] * nosoar_dim1 + 1]) { + lesign = -1; + } else { + lesign = 1; + } + noartr[nutr[2] * noartr_dim1 + 2] = lesign * nuarco[2]; + +/* triangulation des 2 demi te par ajout des points internes du te */ + trpite_(letree, &pxyd[4], mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], + moartr, mxartr, n1artr, &noartr[noartr_offset], &noarst[1], nbtr, + &nutr[1], ierr); + return 0; +} /* f1trte_ */ + +/* Subroutine */ int f2trte_(integer *letree, doublereal *pxyd, integer * + milieu, integer *mosoar, integer *mxsoar, integer *n1soar, integer * + nosoar, integer *moartr, integer *mxartr, integer *n1artr, integer * + noartr, integer *noarst, integer *nbtr, integer *nutr, integer *ierr) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset; + + /* Local variables */ + static integer i__, nm2, nm3; + extern /* Subroutine */ int fasoar_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *); + static integer lesign, nuarco[7]; + extern /* Subroutine */ int trpite_(integer *, doublereal *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *); + static integer nosotr[3]; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : former les triangles du triangle equilateral letree */ +/* ----- a partir de 2 milieux des cotes du te */ +/* et des points internes au te */ +/* ils deviennent tous des sommets des sous-triangles du te */ + +/* entrees: */ +/* -------- */ +/* letree : arbre-4 des triangles equilateraux (te) fond de la triangulation */ +/* si letree(0)>0 alors */ +/* letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j */ +/* sinon */ +/* letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j */ +/* 0 si pas de point */ +/* ( le te est une feuille de l'arbre ) */ +/* letree(4) : no letree du sur-triangle du triangle j */ +/* letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle */ +/* letree(6:8) : no pxyd des 3 sommets du triangle j */ +/* pxyd : tableau des x y distance_souhaitee de chaque sommet */ +/* milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te */ +/* 0 si pas de milieu du cote i a ajouter */ +/* mosoar : nombre maximal d'entiers par arete du tableau nosoar */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxartr : nombre maximal de triangles stockables dans le tableau noartr */ + +/* modifies: */ +/* --------- */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar */ +/* sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ +/* noarst : noarst(np) numero d'une arete du sommet np */ + +/* sorties: */ +/* -------- */ +/* nbtr : nombre de sous-triangles du te, triangulation du te */ +/* nutr : numero des nbtr sous-triangles du te dans le tableau noartr */ +/* ierr : =0 si pas d'erreur */ +/* =1 si le tableau nosoar est sature */ +/* =2 si le tableau noartr est sature */ +/* =3 si aucun des triangles ne contient l'un des points internes au te */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* ....................................................................012 */ + + +/* le numero des 3 triangles a creer dans le tableau noartr */ + /* Parameter adjustments */ + pxyd -= 4; + --milieu; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --noarst; + --nutr; + + /* Function Body */ + for (*nbtr = 1; *nbtr <= 3; ++(*nbtr)) { + if (*n1artr <= 0) { +/* tableau noartr sature */ + *ierr = 2; + return 0; + } + nutr[*nbtr] = *n1artr; +/* le nouveau premier triangle libre dans noartr */ + *n1artr = noartr[*n1artr * noartr_dim1 + 2]; +/* L5: */ + } + *nbtr = 3; + +/* recherche du premier milieu a creer */ + for (i__ = 1; i__ <= 3; ++i__) { + if (milieu[i__] != 0) { + goto L9; + } +/* L7: */ + } + +/* on se ramene au seul cas i=2 c-a-d le cote 1 n'a pas de milieu */ +L9: + if (i__ == 2) { +/* pas de milieu sur le cote 1 */ + nosotr[0] = letree[6]; + nosotr[1] = letree[7]; + nosotr[2] = letree[8]; +/* le numero pxyd du milieu du cote 2 */ + nm2 = milieu[2]; +/* le numero pxyd du milieu du cote 3 */ + nm3 = milieu[3]; + } else if (milieu[2] != 0) { +/* pas de milieu sur le cote 3 */ + nosotr[0] = letree[8]; + nosotr[1] = letree[6]; + nosotr[2] = letree[7]; +/* le numero pxyd du milieu du cote 2 */ + nm2 = milieu[1]; +/* le numero pxyd du milieu du cote 3 */ + nm3 = milieu[2]; + } else { +/* pas de milieu sur le cote 2 */ + nosotr[0] = letree[7]; + nosotr[1] = letree[8]; + nosotr[2] = letree[6]; +/* le numero pxyd du milieu du cote 2 */ + nm2 = milieu[3]; +/* le numero pxyd du milieu du cote 3 */ + nm3 = milieu[1]; + } + +/* ici seul le cote 1 n'a pas de milieu */ +/* nm2 est le milieu du cote 2 */ +/* nm3 est le milieu du cote 3 */ + +/* ajout eventuel de l'arete s1 s2 dans nosoar */ + fasoar_(nosotr, &nosotr[1], &nutr[1], &c_n1, &c__0, mosoar, mxsoar, + n1soar, &nosoar[nosoar_offset], &noarst[1], nuarco, ierr); + if (*ierr != 0) { + return 0; + } + +/* ajout eventuel de l'arete s1 s2 dans nosoar */ + fasoar_(&nosotr[1], &nm2, &nutr[1], &c_n1, &c__0, mosoar, mxsoar, n1soar, + &nosoar[nosoar_offset], &noarst[1], &nuarco[1], ierr); + if (*ierr != 0) { + return 0; + } + +/* ajout eventuel de l'arete s1 nm2 dans nosoar */ + fasoar_(nosotr, &nm2, &nutr[1], &nutr[2], &c__0, mosoar, mxsoar, n1soar, & + nosoar[nosoar_offset], &noarst[1], &nuarco[2], ierr); + if (*ierr != 0) { + return 0; + } + +/* ajout eventuel de l'arete nm2 nm3 dans nosoar */ + fasoar_(&nm3, &nm2, &nutr[2], &nutr[3], &c__0, mosoar, mxsoar, n1soar, & + nosoar[nosoar_offset], &noarst[1], &nuarco[3], ierr); + if (*ierr != 0) { + return 0; + } + +/* ajout eventuel de l'arete s1 nm3 dans nosoar */ + fasoar_(nosotr, &nm3, &nutr[2], &c_n1, &c__0, mosoar, mxsoar, n1soar, & + nosoar[nosoar_offset], &noarst[1], &nuarco[4], ierr); + if (*ierr != 0) { + return 0; + } + +/* ajout eventuel de l'arete nm2 s3 dans nosoar */ + fasoar_(&nm2, &nosotr[2], &nutr[3], &c_n1, &c__0, mosoar, mxsoar, n1soar, + &nosoar[nosoar_offset], &noarst[1], &nuarco[5], ierr); + +/* ajout eventuel de l'arete nm3 s3 dans nosoar */ + fasoar_(&nosotr[2], &nm3, &nutr[3], &c_n1, &c__0, mosoar, mxsoar, n1soar, + &nosoar[nosoar_offset], &noarst[1], &nuarco[6], ierr); + if (*ierr != 0) { + return 0; + } + +/* le triangle s1 s2 nm2 ou arete1 arete2 arete3 */ + for (i__ = 1; i__ <= 2; ++i__) { +/* nosotr(i) est le numero du sommet 1 de l'arete i du te */ + if (nosotr[i__ - 1] == nosoar[nuarco[i__ - 1] * nosoar_dim1 + 1]) { + lesign = 1; + } else { + lesign = -1; + } +/* l'arete ns1-ns2 dans nosoar est celle du cote du te */ + noartr[i__ + nutr[1] * noartr_dim1] = lesign * nuarco[i__ - 1]; +/* L20: */ + } + if (nm2 == nosoar[nuarco[2] * nosoar_dim1 + 1]) { + lesign = 1; + } else { + lesign = -1; + } + noartr[nutr[1] * noartr_dim1 + 3] = lesign * nuarco[2]; + +/* le triangle s1 nm2 nm3 */ + noartr[nutr[2] * noartr_dim1 + 1] = -lesign * nuarco[2]; + if (nm2 == nosoar[nuarco[3] * nosoar_dim1 + 1]) { + lesign = 1; + } else { + lesign = -1; + } + noartr[nutr[2] * noartr_dim1 + 2] = lesign * nuarco[3]; + noartr[nutr[3] * noartr_dim1 + 1] = -lesign * nuarco[3]; + if (nm3 == nosoar[nuarco[4] * nosoar_dim1 + 1]) { + lesign = 1; + } else { + lesign = -1; + } + noartr[nutr[2] * noartr_dim1 + 3] = lesign * nuarco[4]; + +/* le triangle nm2 nm3 s3 */ + if (nm2 == nosoar[nuarco[5] * nosoar_dim1 + 1]) { + lesign = 1; + } else { + lesign = -1; + } + noartr[nutr[3] * noartr_dim1 + 2] = lesign * nuarco[5]; + if (nm3 == nosoar[nuarco[6] * nosoar_dim1 + 1]) { + lesign = -1; + } else { + lesign = 1; + } + noartr[nutr[3] * noartr_dim1 + 3] = lesign * nuarco[6]; + +/* triangulation des 3 sous-te par ajout des points internes du te */ + trpite_(letree, &pxyd[4], mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], + moartr, mxartr, n1artr, &noartr[noartr_offset], &noarst[1], nbtr, + &nutr[1], ierr); + return 0; +} /* f2trte_ */ + +/* Subroutine */ int f3trte_(integer *letree, doublereal *pxyd, integer * + milieu, integer *mosoar, integer *mxsoar, integer *n1soar, integer * + nosoar, integer *moartr, integer *mxartr, integer *n1artr, integer * + noartr, integer *noarst, integer *nbtr, integer *nutr, integer *ierr) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset; + + /* Local variables */ + static integer i__, i0, i1, i3; + extern /* Subroutine */ int fasoar_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *); + static integer lesign, nuarco[9]; + extern /* Subroutine */ int trpite_(integer *, doublereal *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *); + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : former les triangles du triangle equilateral letree */ +/* ----- a partir de 3 milieux des cotes du te */ +/* et des points internes au te */ +/* ils deviennent tous des sommets des sous-triangles du te */ + +/* entrees: */ +/* -------- */ +/* letree : arbre-4 des triangles equilateraux (te) fond de la triangulation */ +/* si letree(0)>0 alors */ +/* letree(0:3) : no (>0) letree des 4 sous-triangles du triangle j */ +/* sinon */ +/* letree(0:3) :-no pxyd des 1 a 4 points internes au triangle j */ +/* 0 si pas de point */ +/* ( le te est une feuille de l'arbre ) */ +/* letree(4) : no letree du sur-triangle du triangle j */ +/* letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle */ +/* letree(6:8) : no pxyd des 3 sommets du triangle j */ +/* pxyd : tableau des x y distance_souhaitee de chaque sommet */ +/* milieu : milieu(i) numero dans pxyd du milieu de l'arete i du te */ +/* 0 si pas de milieu du cote i a ajouter */ +/* mosoar : nombre maximal d'entiers par arete du tableau nosoar */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxartr : nombre maximal de triangles stockables dans le tableau noartr */ + +/* modifies: */ +/* --------- */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar */ +/* sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ +/* noarst : noarst(np) numero d'une arete du sommet np */ + +/* sorties: */ +/* -------- */ +/* nbtr : nombre de sous-triangles du te, triangulation du te */ +/* nutr : numero des nbtr sous-triangles du te dans le tableau noartr */ +/* ierr : =0 si pas d'erreur */ +/* =1 si le tableau nosoar est sature */ +/* =2 si le tableau noartr est sature */ +/* =3 si aucun des triangles ne contient l'un des points internes au te */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* ....................................................................012 */ + + +/* le numero des 4 triangles a creer dans le tableau noartr */ + /* Parameter adjustments */ + pxyd -= 4; + --milieu; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --noarst; + --nutr; + + /* Function Body */ + for (*nbtr = 1; *nbtr <= 4; ++(*nbtr)) { + if (*n1artr <= 0) { +/* tableau noartr sature */ + *ierr = 2; + return 0; + } + nutr[*nbtr] = *n1artr; +/* le nouveau premier triangle libre dans noartr */ + *n1artr = noartr[*n1artr * noartr_dim1 + 2]; +/* L5: */ + } + *nbtr = 4; + + for (i__ = 1; i__ <= 3; ++i__) { +/* le sommet suivant */ + if (i__ != 3) { + i1 = i__ + 1; + } else { + i1 = 1; + } +/* le sommet precedant */ + if (i__ != 1) { + i0 = i__ - 1; + } else { + i0 = 3; + } + i3 = i__ * 3; + +/* ajout eventuel de l'arete si mi dans nosoar */ + fasoar_(&letree[i__ + 5], &milieu[i__], &nutr[i__], &c_n1, &c__0, + mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], &noarst[1], & + nuarco[i3 - 3], ierr); + if (*ierr != 0) { + return 0; + } + +/* ajout eventuel de l'arete mi mi-1 dans nosoar */ + fasoar_(&milieu[i__], &milieu[i0], &nutr[i__], &nutr[4], &c__0, + mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], &noarst[1], & + nuarco[i3 - 2], ierr); + if (*ierr != 0) { + return 0; + } + +/* ajout eventuel de l'arete m i-1 si dans nosoar */ + fasoar_(&milieu[i0], &letree[i__ + 5], &nutr[i__], &c_n1, &c__0, + mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], &noarst[1], & + nuarco[i3 - 1], ierr); + if (*ierr != 0) { + return 0; + } + +/* L10: */ + } + +/* les 3 sous-triangles pres des sommets */ + for (i__ = 1; i__ <= 3; ++i__) { +/* le sommet suivant */ + if (i__ != 3) { + i1 = i__ + 1; + } else { + i1 = 1; + } +/* le sommet precedant */ + if (i__ != 1) { + i0 = i__ - 1; + } else { + i0 = 3; + } + i3 = i__ * 3; + +/* ajout du triangle arete3i-2 arete3i-1 arete3i */ + if (letree[i__ + 5] == nosoar[nuarco[i3 - 3] * nosoar_dim1 + 1]) { + lesign = 1; + } else { + lesign = -1; + } + noartr[nutr[i__] * noartr_dim1 + 1] = lesign * nuarco[i3 - 3]; + + if (milieu[i__] == nosoar[nuarco[i3 - 2] * nosoar_dim1 + 1]) { + lesign = 1; + } else { + lesign = -1; + } + noartr[nutr[i__] * noartr_dim1 + 2] = lesign * nuarco[i3 - 2]; + + if (milieu[i0] == nosoar[nuarco[i3 - 1] * nosoar_dim1 + 1]) { + lesign = 1; + } else { + lesign = -1; + } + noartr[nutr[i__] * noartr_dim1 + 3] = lesign * nuarco[i3 - 1]; + +/* L20: */ + } + +/* le sous triangle central */ + i3 = -1; + for (i__ = 1; i__ <= 3; ++i__) { + i3 += 3; + if (milieu[i__] == nosoar[nuarco[i3 - 1] * nosoar_dim1 + 1]) { + lesign = -1; + } else { + lesign = 1; + } + noartr[i__ + nutr[4] * noartr_dim1] = lesign * nuarco[i3 - 1]; +/* L30: */ + } + +/* triangulation des 3 sous-te par ajout des points internes du te */ + trpite_(letree, &pxyd[4], mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], + moartr, mxartr, n1artr, &noartr[noartr_offset], &noarst[1], nbtr, + &nutr[1], ierr); + return 0; +} /* f3trte_ */ + +/* Subroutine */ int hasoar_(integer *mosoar, integer *mxsoar, integer * + n1soar, integer *nosoar, integer *nu2sar, integer *noar) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset; + + /* Local variables */ + static integer i__; + +/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : rechercher le numero des 2 sommets d'une arete parmi */ +/* ----- les numeros des 2 sommets des aretes du tableau nosoar */ +/* s ils n y sont pas stockes les y ajouter */ +/* dans tous les cas retourner le numero de l'arete dans nosoar */ + +/* la methode employee ici est celle du hachage */ +/* avec pour fonction d'adressage h(ns1,ns2)=min(ns1,ns2) */ + +/* remarque: h(ns1,ns2)=ns1 + 2*ns2 */ +/* ne marche pas si des aretes sont detruites */ +/* et ajoutees aux aretes vides */ +/* le chainage est commun a plusieurs hachages! */ +/* d'ou ce choix du minimum pour le hachage */ + +/* entrees: */ +/* -------- */ +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* attention: mxsoar>3*mxsomm obligatoire! */ + +/* modifies: */ +/* --------- */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 */ +/* chainage des aretes vides amont et aval */ +/* l'arete vide qui precede=nosoar(4,i) */ +/* l'arete vide qui suit =nosoar(5,i) */ +/* nosoar : numero des 2 sommets, no ligne, 2 triangles de l'arete, */ +/* chainage momentan'e d'aretes, chainage du hachage des aretes */ +/* hachage des aretes = min( nosoar(1), nosoar(2) ) */ +/* nu2sar : en entree les 2 numeros des sommets de l'arete */ +/* en sortie nu2sar(1)0 si le tableau nu2sar est l'arete noar retrouvee */ +/* dans le tableau nosoar */ +/* <0 si le tableau nu2sar a ete ajoute et forme l'arete */ +/* -noar du tableau nosoar avec nosoar(1,noar) nu2sar[2]) { + +/* permutation des numeros des 2 sommets pour */ +/* amener le plus petit dans nu2sar(1) */ + i__ = nu2sar[1]; + nu2sar[1] = nu2sar[2]; + nu2sar[2] = i__; + } + +/* la fonction d'adressage du hachage des aretes : h(ns1,ns2)=min(ns1,ns2) */ +/* =============================================== */ + *noar = nu2sar[1]; + +/* la recherche de l'arete dans le chainage du hachage */ +/* --------------------------------------------------- */ +L10: + if (nu2sar[1] == nosoar[*noar * nosoar_dim1 + 1]) { + if (nu2sar[2] == nosoar[*noar * nosoar_dim1 + 2]) { + +/* l'arete est retrouvee */ +/* ..................... */ + return 0; + } + } + +/* l'arete suivante parmi celles ayant meme fonction d'adressage */ + i__ = nosoar[*mosoar + *noar * nosoar_dim1]; + if (i__ > 0) { + *noar = i__; + goto L10; + } + +/* noar est ici la derniere arete (sans suivante) du chainage */ +/* a partir de l'adressage du hachage */ + +/* l'arete non retrouvee doit etre ajoutee */ +/* ....................................... */ + if (nosoar[nu2sar[1] * nosoar_dim1 + 1] == 0) { + +/* l'adresse de hachage est libre => elle devient la nouvelle arete */ +/* retouche des chainages de cette arete noar qui ne sera plus vide */ + *noar = nu2sar[1]; +/* l'eventuel chainage du hachage n'est pas modifie */ + + } else { + +/* la premiere arete dans l'adressage du hachage n'est pas libre */ +/* => choix quelconque d'une arete vide pour ajouter cette arete */ + if (*n1soar <= 0) { + +/* le tableau nosoar est sature avec pour temoin d'erreur */ + *noar = 0; + return 0; + + } else { + +/* l'arete n1soar est vide => c'est la nouvelle arete */ +/* mise a jour du chainage de la derniere arete noar du chainage */ +/* sa suivante est la nouvelle arete n1soar */ + nosoar[*mosoar + *noar * nosoar_dim1] = *n1soar; + +/* l'arete ajoutee est n1soar */ + *noar = *n1soar; + +/* la nouvelle premiere arete vide */ + *n1soar = nosoar[*n1soar * nosoar_dim1 + 5]; + +/* la premiere arete vide n1soar n'a pas d'arete vide precedente */ + nosoar[*n1soar * nosoar_dim1 + 4] = 0; + +/* noar la nouvelle arete est la derniere du chainage du hachage */ + nosoar[*mosoar + *noar * nosoar_dim1] = 0; + + } + + } + +/* les 2 sommets de la nouvelle arete noar */ + nosoar[*noar * nosoar_dim1 + 1] = nu2sar[1]; + nosoar[*noar * nosoar_dim1 + 2] = nu2sar[2]; + +/* le tableau nu2sar a ete ajoute avec l'indice -noar */ + *noar = -(*noar); + return 0; +} /* hasoar_ */ + +/* Subroutine */ int mt3str_(integer *nt, integer *moartr, integer *noartr, + integer *mosoar, integer *nosoar, integer *ns1, integer *ns2, integer + *ns3) +{ + /* System generated locals */ + integer noartr_dim1, noartr_offset, nosoar_dim1, nosoar_offset; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static integer na; + + /* Fortran I/O blocks */ + static cilist io___481 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : calcul du numero des 3 sommets du triangle nt du tableau noartr */ +/* ----- */ + +/* entrees: */ +/* -------- */ +/* nt : numero du triangle de noartr a traiter */ +/* moartr : nombre maximal d'entiers par triangle */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1=0 si triangle vide => arete2=triangle vide suivant */ +/* mosoar : nombre maximal d'entiers par arete */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles, chainages en + */ +/* sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante */ + +/* sorties: */ +/* -------- */ +/* ns1,ns2,ns3 : les 3 numeros des sommets du triangle en sens direct */ + +/* si erreur rencontree => ns1 = 0 */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc juillet 1995 */ +/* 2345x7..............................................................012 */ + +/* le numero de triangle est il correct ? */ +/* a supprimer apres mise au point */ + /* Parameter adjustments */ + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + + /* Function Body */ + if (*nt <= 0) { +/* nblgrc(nrerr) = 1 */ +/* write(kerr(mxlger)(1:6),'(i6)') nt */ +/* kerr(1) = kerr(mxlger)(1:6) // */ +/* % ' no triangle dans noartr incorrect' */ +/* call lereur */ + //io___481.ciunit = unites_1.imprim; + //s_wsle(&io___481); + //do_lio(&c__3, &c__1, (char *)&(*nt), (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " no triangle dans noartr incorrect", (ftnlen)34) + // ; + //e_wsle(); + *ns1 = 0; + return 0; + } + + na = noartr[*nt * noartr_dim1 + 1]; + if (na > 0) { +/* arete dans le sens direct */ + *ns1 = nosoar[na * nosoar_dim1 + 1]; + *ns2 = nosoar[na * nosoar_dim1 + 2]; + } else { +/* arete dans le sens indirect */ + *ns1 = nosoar[-na * nosoar_dim1 + 2]; + *ns2 = nosoar[-na * nosoar_dim1 + 1]; + } + + na = noartr[*nt * noartr_dim1 + 2]; + if (na > 0) { +/* arete dans le sens direct => ns3 est le second sommet de l'arete */ + *ns3 = nosoar[na * nosoar_dim1 + 2]; + } else { +/* arete dans le sens indirect => ns3 est le premier sommet de l'arete */ + *ns3 = nosoar[-na * nosoar_dim1 + 1]; + } + return 0; +} /* mt3str_ */ + +/* Subroutine */ int trpite_(integer *letree, doublereal *pxyd, integer * + mosoar, integer *mxsoar, integer *n1soar, integer *nosoar, integer * + moartr, integer *mxartr, integer *n1artr, integer *noartr, integer * + noarst, integer *nbtr, integer *nutr, integer *ierr) +{ + /* Format strings */ + static char fmt_10010[] = "(\002 erreur trpite: pas de triangle contenan" + "t le point\002,i7)"; + + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset, i__1; + + /* Builtin functions */ + integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); + + /* Local variables */ + static integer k, n, np, nt; + extern /* Subroutine */ int tr3str_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *); + static integer nsigne; + extern /* Subroutine */ int ptdatr_(doublereal *, doublereal *, integer *, + integer *); + static integer nosotr[3]; + extern /* Subroutine */ int nusotr_(integer *, integer *, integer *, + integer *, integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___489 = { 0, 0, 0, fmt_10010, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : former le ou les sous-triangles des nbtr triangles nutr */ +/* ----- qui forment le triangle equilateral letree par ajout */ +/* des points internes au te qui deviennent des sommets des */ +/* sous-triangles des nbtr triangles */ + +/* entrees: */ +/* -------- */ +/* letree : arbre-4 des triangles equilateraux (te) fond de la triangulation */ +/* letree(0:3):-no pxyd des 1 a 4 points internes au triangle j */ +/* 0 si pas de point */ +/* ( le te est ici une feuille de l'arbre ) */ +/* letree(4) : no letree du sur-triangle du triangle j */ +/* letree(5) : 0 1 2 3 no du sous-triangle j pour son sur-triangle */ +/* letree(6:8) : no pxyd des 3 sommets du triangle j */ +/* pxyd : tableau des x y distance_souhaitee de chaque sommet */ +/* mosoar : nombre maximal d'entiers par arete du tableau nosoar */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxartr : nombre maximal de triangles stockables dans le tableau noartr */ + +/* modifies: */ +/* --------- */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = (nosoar(1)+nosoar(2)) modulo mxsoar */ +/* sommet 1 = 0 si arete vide => sommet 2 = arete vide suivante */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ +/* noarst : noarst(i) numero d'une arete de sommet i */ + +/* sorties: */ +/* -------- */ +/* nbtr : nombre de sous-triangles du te */ +/* nutr : numero des nbtr sous-triangles du te dans le tableau noartr */ +/* ierr : =0 si pas d'erreur */ +/* =1 si le tableau nosoar est sature */ +/* =2 si le tableau noartr est sature */ +/* =3 si aucun des triangles ne contient l'un des points internes au te */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* ....................................................................012 */ + + + /* Parameter adjustments */ + pxyd -= 4; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --noarst; + --nutr; + + /* Function Body */ + *ierr = 0; + +/* si pas de point interne alors retour */ + if (letree[0] == 0) { + goto L150; + } + +/* il existe au moins un point interne a trianguler */ +/* dans les nbtr triangles */ + for (k = 0; k <= 3; ++k) { + +/* le numero du point */ + np = -letree[k]; + if (np == 0) { + goto L150; + } + +/* le point np dans pxyd est a traiter */ + i__1 = *nbtr; + for (n = 1; n <= i__1; ++n) { + +/* les numeros des 3 sommets du triangle nt=nutr(n) */ + nt = nutr[n]; + nusotr_(&nt, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + +/* le triangle nt contient il le point np? */ + ptdatr_(&pxyd[np * 3 + 1], &pxyd[4], nosotr, &nsigne); +/* nsigne>0 si le point est dans le triangle ou sur une des 3 aretes */ +/* =0 si triangle degenere ou indirect ou ne contient pas le poin */ + + if (nsigne > 0) { + +/* le triangle nt est triangule en 3 sous-triangles */ + tr3str_(&np, &nt, mosoar, mxsoar, n1soar, &nosoar[ + nosoar_offset], moartr, mxartr, n1artr, &noartr[ + noartr_offset], &noarst[1], &nutr[*nbtr + 1], ierr); + if (*ierr != 0) { + return 0; + } + +/* reamenagement des 3 triangles crees dans nutr */ +/* en supprimant le triangle nt */ + nutr[n] = nutr[*nbtr + 3]; + *nbtr += 2; +/* le point np est triangule */ + goto L100; + + } +/* L10: */ + } + +/* erreur: le point np n'est pas dans l'un des nbtr triangles */ + //io___489.ciunit = unites_1.imprim; + //s_wsfe(&io___489); + //do_fio(&c__1, (char *)&np, (ftnlen)sizeof(integer)); + //e_wsfe(); + *ierr = 3; + return 0; + +L100: + ; + } + +L150: + return 0; +} /* trpite_ */ + +/* Subroutine */ int sasoar_(integer *noar, integer *mosoar, integer *mxsoar, + integer *n1soar, integer *nosoar, integer *noarst) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, i__1; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static integer i__, k, ns[2], noar0, noar1; + + /* Fortran I/O blocks */ + static cilist io___495 = { 0, 0, 0, 0, 0 }; + static cilist io___496 = { 0, 0, 0, 0, 0 }; + static cilist io___497 = { 0, 0, 0, 0, 0 }; + + +/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : supprimer l'arete noar du tableau nosoar */ +/* ----- si celle ci n'est pas une arete des lignes de la fontiere */ + +/* la methode employee ici est celle du hachage */ +/* avec pour fonction d'adressage h = min( nu2sar(1), nu2sar(2) ) */ + +/* attention: il faut mettre a jour le no d'arete des 2 sommets */ +/* de l'arete supprimee dans le tableau noarst! */ + +/* entrees: */ +/* -------- */ +/* noar : numero de l'arete de nosoar a supprimer */ +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage h */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* attention: mxsoar>3*mxsomm obligatoire! */ + +/* modifies: */ +/* --------- */ +/* n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar */ +/* chainage des vides suivant en 3 et precedant en 2 de nosoar */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 et */ +/* nosoar(4,arete vide)=l'arete vide qui precede */ +/* nosoar(5,arete vide)=l'arete vide qui suit */ +/* noarst : numero d'une arete de nosoar pour chaque sommet */ +/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique upmc paris mars 1997 */ +/* modifs : alain perronnet laboratoire jl lions upmc paris octobre 2006 */ +/* ...................................................................012 */ + +/* 13/10/2006 */ +/* mise a jour de noarst pour les 2 sommets de l'arete a supprimer */ +/* necessaire uniquement pour les sommets frontaliers et internes imposes */ +/* le numero des 2 sommets de l'arete noar a supprimer */ + /* Parameter adjustments */ + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + --noarst; + + /* Function Body */ + ns[0] = nosoar[*noar * nosoar_dim1 + 1]; + ns[1] = nosoar[*noar * nosoar_dim1 + 2]; + for (k = 1; k <= 2; ++k) { + if (noarst[ns[k - 1]] == *noar) { +/* il faut remettre a jour le pointeur sur une arete */ + if (nosoar[ns[k - 1] * nosoar_dim1 + 1] == ns[k - 1] && nosoar[ns[ + k - 1] * nosoar_dim1 + 2] > 0 && nosoar[ns[k - 1] * + nosoar_dim1 + 4] > 0) { +/* arete active de sommet ns(k) */ + noarst[ns[k - 1]] = ns[k - 1]; + } else { + i__1 = *mxsoar; + for (i__ = 1; i__ <= i__1; ++i__) { + if (nosoar[i__ * nosoar_dim1 + 1] > 0 && nosoar[i__ * + nosoar_dim1 + 4] > 0) { +/* arete non vide */ + if (nosoar[i__ * nosoar_dim1 + 2] == ns[k - 1] || + nosoar[i__ * nosoar_dim1 + 1] == ns[k - 1] && + nosoar[i__ * nosoar_dim1 + 2] > 0) { +/* arete active de sommet ns(k) */ + noarst[ns[k - 1]] = i__; + goto L8; + } + } +/* L5: */ + } + } + } +L8: + ; + } +/* 13/10/2006 */ + + if (nosoar[*noar * nosoar_dim1 + 3] <= 0) { + +/* l'arete n'est pas frontaliere => elle devient une arete vide */ + +/* recherche de l'arete qui precede dans le chainage du hachage */ + noar1 = nosoar[*noar * nosoar_dim1 + 1]; + +/* parcours du chainage du hachage jusqu'a retrouver l'arete noar */ +L10: + if (noar1 != *noar) { + +/* l'arete suivante parmi celles ayant meme fonction d'adressage */ + noar0 = noar1; + noar1 = nosoar[*mosoar + noar1 * nosoar_dim1]; + if (noar1 > 0) { + goto L10; + } + +/* l'arete noar n'a pas ete retrouvee dans le chainage => erreur */ + // io___495.ciunit = unites_1.imprim; + // s_wsle(&io___495); + // do_lio(&c__9, &c__1, "erreur sasoar:arete non dans le chainage ", + // (ftnlen)41); + // do_lio(&c__3, &c__1, (char *)&(*noar), (ftnlen)sizeof(integer)); + // e_wsle(); + // io___496.ciunit = unites_1.imprim; + // s_wsle(&io___496); + // do_lio(&c__9, &c__1, "arete de st1=", (ftnlen)13); + // do_lio(&c__3, &c__1, (char *)&nosoar[*noar * nosoar_dim1 + 1], ( + // ftnlen)sizeof(integer)); + // do_lio(&c__9, &c__1, " st2=", (ftnlen)5); + // do_lio(&c__3, &c__1, (char *)&nosoar[*noar * nosoar_dim1 + 2], ( + // ftnlen)sizeof(integer)); + // do_lio(&c__9, &c__1, " ligne=", (ftnlen)7); + // do_lio(&c__3, &c__1, (char *)&nosoar[*noar * nosoar_dim1 + 3], ( + // ftnlen)sizeof(integer)); + // do_lio(&c__9, &c__1, " tr1=", (ftnlen)5); + // do_lio(&c__3, &c__1, (char *)&nosoar[*noar * nosoar_dim1 + 4], ( + // ftnlen)sizeof(integer)); + // do_lio(&c__9, &c__1, " tr2=", (ftnlen)5); + // do_lio(&c__3, &c__1, (char *)&nosoar[*noar * nosoar_dim1 + 5], ( + // ftnlen)sizeof(integer)); + // e_wsle(); + // io___497.ciunit = unites_1.imprim; + // s_wsle(&io___497); + // do_lio(&c__9, &c__1, "chainages=", (ftnlen)10); + // i__1 = *mosoar; + // for (i__ = 6; i__ <= i__1; ++i__) { + //do_lio(&c__3, &c__1, (char *)&nosoar[i__ + *noar * + // nosoar_dim1], (ftnlen)sizeof(integer)); + // } + // e_wsle(); +/* cc pause */ +/* l'arete n'est pas detruite */ + return 0; + + } + + if (*noar != nosoar[*noar * nosoar_dim1 + 1]) { + +/* saut de l'arete noar dans le chainage du hachage */ +/* noar0 initialisee est ici l'arete qui precede noar dans ce chainage */ + nosoar[*mosoar + noar0 * nosoar_dim1] = nosoar[*mosoar + *noar * + nosoar_dim1]; + +/* le chainage du hachage n'existe plus pour noar */ +/* pas utile car mise a zero faite dans le sp hasoar */ +/* cc nosoar( mosoar, noar ) = 0 */ + +/* noar devient la nouvelle premiere arete du chainage des vides */ + nosoar[*noar * nosoar_dim1 + 4] = 0; + nosoar[*noar * nosoar_dim1 + 5] = *n1soar; +/* la nouvelle precede l'ancienne premiere */ + nosoar[*n1soar * nosoar_dim1 + 4] = *noar; + *n1soar = *noar; + +/* cc else */ + +/* noar est la premiere arete du chainage du hachage h */ +/* cette arete ne peut etre consideree dans le chainage des vides */ +/* car le chainage du hachage doit etre conserve (sinon perte...) */ + + } + +/* le temoin d'arete vide */ + nosoar[*noar * nosoar_dim1 + 1] = 0; + } + return 0; +} /* sasoar_ */ + +/* Subroutine */ int caetoi_(integer *noar, integer *mosoar, integer *mxsoar, + integer *n1soar, integer *nosoar, integer *noarst, integer *n1aeoc, + integer *nbtrar) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static integer na, na0, nbpass; + extern /* Subroutine */ int sasoar_(integer *, integer *, integer *, + integer *, integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___501 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : ajouter (ou retirer) l'arete noar de nosoar de l'etoile */ +/* ----- des aretes simples chainees en position lchain de nosoar */ +/* detruire du tableau nosoar les aretes doubles */ + +/* attention: le chainage lchain de nosoar devient celui des cf */ + +/* entree : */ +/* -------- */ +/* noar : numero dans le tableau nosoar de l'arete a traiter */ +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* attention: mxsoar>3*mxsomm obligatoire! */ + +/* entrees et sorties: */ +/* ------------------- */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* n1aeoc : numero dans nosoar de la premiere arete simple de l'etoile */ + +/* sortie : */ +/* -------- */ +/* nbtrar : 1 si arete ajoutee, 2 si arete double supprimee, 0 si erreur */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* 2345x7..............................................................012 */ + +/* si l'arete n'appartient pas aux aretes de l'etoile naetoi */ +/* alors elle est ajoutee a l'etoile dans naetoi */ +/* sinon elle est empilee dans npile pour etre detruite ensuite */ +/* elle est supprimee de l'etoile naetoi */ + + /* Parameter adjustments */ + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + --noarst; + + /* Function Body */ + if (nosoar[*noar * nosoar_dim1 + 6] < 0) { + +/* arete de l'etoile vue pour la premiere fois */ +/* elle est ajoutee au chainage */ + nosoar[*noar * nosoar_dim1 + 6] = *n1aeoc; +/* elle devient la premiere du chainage */ + *n1aeoc = *noar; +/* arete simple */ + *nbtrar = 1; + + } else { + +/* arete double de l'etoile. elle est supprimee du chainage */ + na0 = 0; + na = *n1aeoc; + nbpass = 0; +/* parcours des aretes chainees jusqu'a trouver l'arete noar */ +L10: + if (na != *noar) { +/* passage a la suivante */ + na0 = na; + na = nosoar[na * nosoar_dim1 + 6]; + if (na <= 0) { + *nbtrar = 0; + return 0; + } + ++nbpass; + if (nbpass > 512) { + //io___501.ciunit = unites_1.imprim; + //s_wsle(&io___501); + //do_lio(&c__9, &c__1, "Pb dans caetoi: boucle infinie evitee", + // (ftnlen)37); + //e_wsle(); + *nbtrar = 0; + return 0; + } + goto L10; + } + +/* suppression de noar du chainage des aretes simples de l'etoile */ + if (na0 > 0) { +/* il existe une arete qui precede */ + nosoar[na0 * nosoar_dim1 + 6] = nosoar[*noar * nosoar_dim1 + 6]; + } else { +/* noar est en fait n1aeoc la premiere du chainage */ + *n1aeoc = nosoar[*noar * nosoar_dim1 + 6]; + } +/* noar n'est plus une arete simple de l'etoile */ + nosoar[*noar * nosoar_dim1 + 6] = -1; + +/* destruction du tableau nosoar de l'arete double noar */ + sasoar_(noar, mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], &noarst[ + 1]); + +/* arete double */ + *nbtrar = 2; + } + return 0; +} /* caetoi_ */ + +/* Subroutine */ int focftr_(integer *nbtrcf, integer *notrcf, integer * + nbarpi, doublereal *pxyd, integer *noarst, integer *mosoar, integer * + mxsoar, integer *n1soar, integer *nosoar, integer *moartr, integer * + n1artr, integer *noartr, integer *nbarcf, integer *n1arcf, integer * + noarcf, integer *nbstpe, integer *nostpe, integer *ierr) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset, i__1, + i__2; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static integer i__, j, k, n, kk, nt, na0, na1, ns0, ns1, ns2, nt0, noar, + nbst, n1ae00, n1aeoc; + extern /* Subroutine */ int caetoi_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *); + static integer nbtrar, nosotr[3]; + extern /* Subroutine */ int nusotr_(integer *, integer *, integer *, + integer *, integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___511 = { 0, 0, 0, 0, 0 }; + static cilist io___512 = { 0, 0, 0, 0, 0 }; + static cilist io___513 = { 0, 0, 0, 0, 0 }; + static cilist io___519 = { 0, 0, 0, 0, 0 }; + static cilist io___521 = { 0, 0, 0, 0, 0 }; + static cilist io___523 = { 0, 0, 0, 0, 0 }; + static cilist io___524 = { 0, 0, 0, 0, 0 }; + static cilist io___525 = { 0, 0, 0, 0, 0 }; + static cilist io___526 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : former un contour ferme (cf) avec les aretes simples des */ +/* ----- nbtrcf triangles du tableau notrcf */ +/* destruction des nbtrcf triangles du tableau noartr */ +/* destruction des aretes doubles du tableau nosoar */ + +/* attention: le chainage lchain de nosoar devient celui des cf */ + +/* entrees: */ +/* -------- */ +/* nbtrcf : nombre de triangles du cf a former */ +/* notrcf : numero des triangles dans le tableau noartr */ +/* nbarpi : numero du dernier sommet frontalier ou interne impose */ +/* pxyd : tableau des coordonnees 2d des points */ +/* par point : x y distance_souhaitee */ + +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* attention: mxsoar>3*mxsomm obligatoire! */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ + +/* entrees et sorties : */ +/* -------------------- */ +/* noarst : noarst(i) numero d'une arete de sommet i */ +/* n1soar : numero de la premiere arete vide dans le tableau nosoar */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = nosoar(1)+nosoar(2)*2 */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ + +/* sorties: */ +/* -------- */ +/* nbarcf : nombre d'aretes du cf */ +/* n1arcf : numero d'une arete de chaque contour */ +/* noarcf : numero des aretes de la ligne du contour ferme */ +/* attention: chainage circulaire des aretes */ +/* les aretes vides pointes par n1arcf(0) ne sont pas chainees */ +/* nbstpe : nombre de sommets perdus dans la suppression des triangles */ +/* nostpe : numero des sommets perdus dans la suppression des triangles */ +/* ierr : 0 si pas d'erreur */ +/* 14 si les lignes fermees se coupent => donnees a revoir */ +/* 15 si une seule arete simple frontaliere */ +/* 16 si boucle infinie car toutes les aretes simples */ +/* de la boule sont frontalieres! */ +/* 17 si boucle infinie dans caetoi */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique upmc paris mars 1997 */ +/* modifs : alain perronnet laboratoire jl lions upmc paris octobre 2006 */ +/* ....................................................................012 */ + +/* formation des aretes simples du cf autour de l'arete ns1-ns2 */ +/* attention: le chainage lchain du tableau nosoar devient actif */ +/* ============================================================ */ +/* ici toutes les aretes du tableau nosoar verifient nosoar(lchain,i) = -1 */ +/* ce qui equivaut a dire que l'etoile des aretes simples est vide */ +/* (initialisation dans le sp insoar puis remise a -1 dans la suite!) */ + /* Parameter adjustments */ + --notrcf; + pxyd -= 4; + --noarst; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + noarcf -= 4; + --nostpe; + + /* Function Body */ + n1aeoc = 0; + *ierr = 0; + +/* 13/10/2006 */ +/* nombre de sommets des triangles a supprimer sans repetition */ + nbst = 0; +/* 13/10/2006 */ + +/* ajout a l'etoile des aretes simples des 3 aretes des triangles a supprimer */ +/* suppression des triangles de l'etoile pour les aretes simples de l'etoile */ + i__1 = *nbtrcf; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* ajout ou retrait des 3 aretes du triangle notrcf(i) de l'etoile */ + nt = notrcf[i__]; + +/* 13/10/2006 ............................................... */ + nusotr_(&nt, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + +/* ajout des numeros de sommets non encore vus dans l'etoile */ + for (k = 1; k <= 3; ++k) { + i__2 = nbst; + for (j = 1; j <= i__2; ++j) { + if (nosotr[k - 1] == nostpe[j]) { + goto L3; + } +/* L2: */ + } +/* ajout du sommet */ + ++nbst; + nostpe[nbst] = nosotr[k - 1]; +L3: + ; + } +/* 13/10/2006 ................................................ */ + + for (j = 1; j <= 3; ++j) { +/* l'arete de nosoar a traiter */ + noar = (i__2 = noartr[j + nt * noartr_dim1], abs(i__2)); + caetoi_(&noar, mosoar, mxsoar, n1soar, &nosoar[nosoar_offset], & + noarst[1], &n1aeoc, &nbtrar); + if (nbtrar <= 0) { + //io___511.ciunit = unites_1.imprim; + //s_wsle(&io___511); + //do_lio(&c__9, &c__1, "focftr: erreur dans caetoi noar=", ( + // ftnlen)32); + //do_lio(&c__3, &c__1, (char *)&noar, (ftnlen)sizeof(integer)); + //e_wsle(); + *ierr = 17; + return 0; + } +/* si arete simple alors suppression du numero de triangle */ +/* pour cette arete */ + if (nbtrar == 1) { + if (nosoar[noar * nosoar_dim1 + 4] == nt) { + nosoar[noar * nosoar_dim1 + 4] = nosoar[noar * + nosoar_dim1 + 5]; + } else if (nosoar[noar * nosoar_dim1 + 5] == nt) { + nosoar[noar * nosoar_dim1 + 5] = -1; + } else { + // io___512.ciunit = unites_1.imprim; + // s_wsle(&io___512); + // do_lio(&c__9, &c__1, "focftr: anomalie arete", (ftnlen)22) + // ; + // do_lio(&c__3, &c__1, (char *)&noar, (ftnlen)sizeof( + // integer)); + // do_lio(&c__9, &c__1, " sans triangle", (ftnlen)14); + // do_lio(&c__3, &c__1, (char *)&nt, (ftnlen)sizeof(integer)) + // ; + // e_wsle(); + // io___513.ciunit = unites_1.imprim; + // s_wsle(&io___513); + // do_lio(&c__9, &c__1, "focftr: nosoar(", (ftnlen)15); + // do_lio(&c__3, &c__1, (char *)&noar, (ftnlen)sizeof( + // integer)); + // do_lio(&c__9, &c__1, ")=", (ftnlen)2); + // i__2 = *mosoar; + // for (kk = 1; kk <= i__2; ++kk) { + //do_lio(&c__3, &c__1, (char *)&nosoar[kk + noar * + // nosoar_dim1], (ftnlen)sizeof(integer)); + // } + // e_wsle(); + nosoar[noar * nosoar_dim1 + 5] = -1; + } +/* else */ +/* l'arete appartient a aucun triangle => elle est vide */ +/* les positions 4 et 5 servent maintenant aux chainages des vides */ + } +/* L5: */ + } +/* L10: */ + } + +/* les aretes simples de l'etoile sont reordonnees pour former une */ +/* ligne fermee = un contour ferme peripherique de l'etoile encore dit 1 cf */ +/* ======================================================================== */ + n1ae00 = n1aeoc; +L12: + na1 = n1aeoc; +/* la premiere arete du contour ferme */ + ns0 = nosoar[na1 * nosoar_dim1 + 1]; + ns1 = nosoar[na1 * nosoar_dim1 + 2]; + +/* l'arete est-elle dans le sens direct? */ +/* recherche de l'arete du triangle exterieur nt d'arete na1 */ + nt = nosoar[na1 * nosoar_dim1 + 4]; + if (nt <= 0) { + nt = nosoar[na1 * nosoar_dim1 + 5]; + } + +/* attention au cas de l'arete initiale frontaliere de no de triangles 0 et - */ + if (nt <= 0) { +/* permutation circulaire des aretes simples chainees */ +/* la premiere arete doit devenir la derniere du chainage, */ +/* la 2=>1, la 3=>2, ... , la derniere=>l'avant derniere, 1=>derniere */ + n1aeoc = nosoar[n1aeoc * nosoar_dim1 + 6]; + if (n1aeoc == n1ae00) { +/* attention: boucle infinie si toutes les aretes simples */ +/* de la boule sont frontalieres!... arretee par ce test */ + *ierr = 16; + //io___519.ciunit = unites_1.imprim; + //s_wsle(&io___519); + //do_lio(&c__9, &c__1, "focftr: boucle dans les aretes de l etoile", + // (ftnlen)42); + //e_wsle(); + return 0; + } + noar = n1aeoc; + na0 = 0; +L14: + if (noar > 0) { +/* la sauvegarde de l'arete et l'arete suivante */ + na0 = noar; + noar = nosoar[noar * nosoar_dim1 + 6]; + goto L14; + } + if (na0 <= 0) { +/* une seule arete simple frontaliere */ + *ierr = 15; + //io___521.ciunit = unites_1.imprim; + //s_wsle(&io___521); + //do_lio(&c__9, &c__1, "focftr: 1 arete seule pour l etoile", ( + // ftnlen)35); + //e_wsle(); + return 0; + } +/* le suivant de l'ancien dernier est l'ancien premier */ + nosoar[na0 * nosoar_dim1 + 6] = na1; +/* le nouveau dernier est l'ancien premier */ + nosoar[na1 * nosoar_dim1 + 6] = 0; + goto L12; + } + +/* ici l'arete na1 est l'une des aretes du triangle nt */ + for (i__ = 1; i__ <= 3; ++i__) { + if ((i__1 = noartr[i__ + nt * noartr_dim1], abs(i__1)) == na1) { +/* c'est l'arete */ + if (noartr[i__ + nt * noartr_dim1] > 0) { +/* elle est parcourue dans le sens indirect de l'etoile */ +/* (car c'est en fait le triangle exterieur a la boule) */ + ns0 = nosoar[na1 * nosoar_dim1 + 2]; + ns1 = nosoar[na1 * nosoar_dim1 + 1]; + } + goto L17; + } +/* L15: */ + } + +/* le 1-er sommet ou arete du contour ferme */ +L17: + n1arcf[1] = 1; +/* le nombre de sommets du contour ferme de l'etoile */ + *nbarcf = 1; +/* le premier sommet de l'etoile */ + noarcf[*nbarcf * 3 + 1] = ns0; +/* l'arete suivante du cf */ + noarcf[*nbarcf * 3 + 2] = *nbarcf + 1; +/* le numero de cette arete dans le tableau nosoar */ + noarcf[*nbarcf * 3 + 3] = na1; +/* mise a jour du numero d'arete du sommet ns0 */ + noarst[ns0] = na1; + +/* l'arete suivante a chainer */ + n1aeoc = nosoar[na1 * nosoar_dim1 + 6]; +/* l'arete na1 n'est plus dans l'etoile */ + nosoar[na1 * nosoar_dim1 + 6] = -1; + +/* boucle sur les aretes simples de l'etoile */ +L20: + if (n1aeoc > 0) { + +/* recherche de l'arete de 1-er sommet ns1 */ + na0 = -1; + na1 = n1aeoc; +L25: + if (na1 > 0) { + +/* le numero du dernier sommet de l'arete precedente */ +/* est il l'un des 2 sommets de l'arete na1? */ + if (ns1 == nosoar[na1 * nosoar_dim1 + 1]) { +/* l'autre sommet de l'arete na1 */ + ns2 = nosoar[na1 * nosoar_dim1 + 2]; + } else if (ns1 == nosoar[na1 * nosoar_dim1 + 2]) { +/* l'autre sommet de l'arete na1 */ + ns2 = nosoar[na1 * nosoar_dim1 + 1]; + } else { +/* non: passage a l'arete suivante */ + na0 = na1; + na1 = nosoar[na1 * nosoar_dim1 + 6]; + goto L25; + } + +/* oui: na1 est l'arete peripherique suivante */ +/* na0 est sa precedente dans le chainage */ +/* une arete de plus dans le contour ferme (cf) */ + ++(*nbarcf); +/* le premier sommet de l'arete nbarcf peripherique */ + noarcf[*nbarcf * 3 + 1] = ns1; +/* l'arete suivante du cf */ + noarcf[*nbarcf * 3 + 2] = *nbarcf + 1; +/* le numero de cette arete dans le tableau nosoar */ + noarcf[*nbarcf * 3 + 3] = na1; +/* mise a jour du numero d'arete du sommet ns1 */ + noarst[ns1] = na1; + +/* suppression de l'arete des aretes simples de l'etoile */ + if (n1aeoc == na1) { + n1aeoc = nosoar[na1 * nosoar_dim1 + 6]; + } else { + nosoar[na0 * nosoar_dim1 + 6] = nosoar[na1 * nosoar_dim1 + 6]; + } +/* l'arete n'est plus une arete simple de l'etoile */ + nosoar[na1 * nosoar_dim1 + 6] = -1; + +/* le sommet final de l'arete a rechercher ensuite */ + ns1 = ns2; + goto L20; + } + } + +/* verification */ + if (ns1 != ns0) { +/* arete non retrouvee : l'etoile ne se referme pas */ + //io___523.ciunit = unites_1.imprim; + //s_wsle(&io___523); + //do_lio(&c__9, &c__1, "focftr: revoyez vos donnees du bord", (ftnlen) + // 35); + //e_wsle(); + //io___524.ciunit = unites_1.imprim; + //s_wsle(&io___524); + //do_lio(&c__9, &c__1, "les lignes fermees doivent etre disjointes", ( + // ftnlen)42); + //e_wsle(); + //io___525.ciunit = unites_1.imprim; + //s_wsle(&io___525); + //do_lio(&c__9, &c__1, "verifiez si elles ne se coupent pas", (ftnlen) + // 35); + //e_wsle(); + *ierr = 14; + return 0; + } + +/* l'arete suivant la derniere arete du cf est la premiere du cf */ +/* => realisation d'un chainage circulaire des aretes du cf */ + noarcf[*nbarcf * 3 + 2] = 1; + +/* 13/10/2006 */ +/* existe t il des sommets perdus? */ +/* ------------------------------- */ + if (nbst > 512) { + //io___526.ciunit = unites_1.imprim; + //s_wsle(&io___526); + //do_lio(&c__9, &c__1, "focftr: tableau nostfe(", (ftnlen)23); + //do_lio(&c__3, &c__1, (char *)&c__512, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, ") a augmenter", (ftnlen)13); + //e_wsle(); + //*ierr = 15; + return 0; + } +/* le nombre de sommets perdus */ + *nbstpe = nbst - *nbarcf; + if (*nbstpe > 0) { +/* oui: stockage dans nostpe des sommets perdus */ +/* tout sommet des aretes de l'etoile est supprime */ +/* de la liste des sommets */ + i__1 = *nbarcf; + for (i__ = 1; i__ <= i__1; ++i__) { +/* le numero du sommet de l'arete du cf */ + ns1 = noarcf[i__ * 3 + 1]; + i__2 = nbst; + for (j = 1; j <= i__2; ++j) { + if (ns1 == nostpe[j]) { +/* le sommet peripherique est supprime */ +/* de la liste des sommets perdus */ + nostpe[j] = 0; + goto L40; + } +/* L30: */ + } +L40: + ; + } + +/* compression */ + n = 0; + i__1 = nbst; + for (i__ = 1; i__ <= i__1; ++i__) { + if (nostpe[i__] == 0 || nostpe[i__] > *nbarpi) { +/* un sommet de l'etoile ou perdu mais supprimable */ +/* ce qui apporte plus de qualites aux triangles a former */ + ++n; + } else { +/* un sommet perdu */ + nostpe[i__ - n] = nostpe[i__]; + } +/* L45: */ + } + *nbstpe = nbst - n; +/* cc write(imprim,*)'focftr:',nbstpe,' sommets isoles:',(nostpe(k),k=1,nbstpe) */ + } +/* 13/10/2006 */ + +/* destruction des triangles de l'etoile du tableau noartr */ +/* ------------------------------------------------------- */ + i__1 = *nbtrcf; + for (n = 1; n <= i__1; ++n) { +/* le numero du triangle dans noartr */ + nt0 = notrcf[n]; +/* l'arete 1 de nt0 devient nulle */ + noartr[nt0 * noartr_dim1 + 1] = 0; +/* chainage de nt0 en tete du chainage des triangles vides de noartr */ + noartr[nt0 * noartr_dim1 + 2] = *n1artr; + *n1artr = nt0; +/* L60: */ + } + return 0; +} /* focftr_ */ + +/* Subroutine */ int int1sd_(integer *ns1, integer *ns2, integer *ns3, + integer *ns4, doublereal *pxyd, integer *linter, doublereal *x0, + doublereal *y0) +{ + /* System generated locals */ + doublereal d__1, d__2; + + /* Local variables */ + static doublereal d__, x, y, x1, y1, d21, d43, p21, p43, x21, y21, x43, + y43; + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : existence ou non d'une intersection a l'interieur */ +/* ----- des 2 aretes ns1-ns2 et ns3-ns4 */ +/* attention les intersections au sommet sont comptees */ + +/* entrees: */ +/* -------- */ +/* ns1,...ns4 : numero pxyd des 4 sommets */ +/* pxyd : les coordonnees des sommets */ + +/* sortie : */ +/* -------- */ +/* linter : -1 si ns3-ns4 parallele a ns1 ns2 */ +/* 0 si ns3-ns4 n'intersecte pas ns1-ns2 entre les aretes */ +/* 1 si ns3-ns4 intersecte ns1-ns2 entre les aretes */ +/* 2 si le point d'intersection est ns1 entre ns3-ns4 */ +/* 3 si le point d'intersection est ns3 entre ns1-ns2 */ +/* 4 si le point d'intersection est ns4 entre ns1-ns2 */ +/* x0,y0 : 2 coordonnees du point d'intersection s'il existe(linter>=1) */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc fevrier 1992 */ +/* 2345x7..............................................................012 */ + + /* Parameter adjustments */ + pxyd -= 4; + + /* Function Body */ + x1 = pxyd[*ns1 * 3 + 1]; + y1 = pxyd[*ns1 * 3 + 2]; + x21 = pxyd[*ns2 * 3 + 1] - x1; + y21 = pxyd[*ns2 * 3 + 2] - y1; +/* Computing 2nd power */ + d__1 = x21; +/* Computing 2nd power */ + d__2 = y21; + d21 = d__1 * d__1 + d__2 * d__2; + + x43 = pxyd[*ns4 * 3 + 1] - pxyd[*ns3 * 3 + 1]; + y43 = pxyd[*ns4 * 3 + 2] - pxyd[*ns3 * 3 + 2]; +/* Computing 2nd power */ + d__1 = x43; +/* Computing 2nd power */ + d__2 = y43; + d43 = d__1 * d__1 + d__2 * d__2; + +/* les 2 aretes sont-elles jugees paralleles ? */ + d__ = x43 * y21 - y43 * x21; + if (d__ * d__ <= d21 * 1e-6 * d43) { +/* cote i parallele a ns1-ns2 */ + *linter = -1; + return 0; + } + +/* les 2 coordonnees du point d'intersection */ + x = (x1 * x43 * y21 - pxyd[*ns3 * 3 + 1] * x21 * y43 - (y1 - pxyd[*ns3 * + 3 + 2]) * x21 * x43) / d__; + y = (-y1 * y43 * x21 + pxyd[*ns3 * 3 + 2] * y21 * x43 + (x1 - pxyd[*ns3 * + 3 + 1]) * y21 * y43) / d__; + +/* coordonnee barycentrique de x,y dans le repere ns1-ns2 */ + p21 = ((x - x1) * x21 + (y - y1) * y21) / d21; +/* coordonnee barycentrique de x,y dans le repere ns3-ns4 */ + p43 = ((x - pxyd[*ns3 * 3 + 1]) * x43 + (y - pxyd[*ns3 * 3 + 2]) * y43) / + d43; + + + if (-1e-6f <= p21 && p21 <= 1.000001f) { +/* x,y est entre ns1-ns2 */ + if (p21 <= .001f && (-1e-6f <= p43 && p43 <= 1.000001f)) { +/* le point x,y est proche de ns1 et interne a ns3-ns4 */ + *linter = 2; + *x0 = pxyd[*ns1 * 3 + 1]; + *y0 = pxyd[*ns1 * 3 + 2]; + return 0; + } else if (-1e-6f <= p43 && p43 <= .001f) { +/* le point x,y est proche de ns3 et entre ns1-ns2 */ + *linter = 3; + *x0 = pxyd[*ns3 * 3 + 1]; + *y0 = pxyd[*ns3 * 3 + 2]; + return 0; + } else if (.999f <= p43 && p43 <= 1.000001f) { +/* le point x,y est proche de ns4 et entre ns1-ns2 */ + *linter = 4; + *x0 = pxyd[*ns4 * 3 + 1]; + *y0 = pxyd[*ns4 * 3 + 2]; + return 0; + } else if (.001f <= p43 && p43 <= .999f) { +/* le point x,y est entre ns3-ns4 */ + *linter = 1; + *x0 = x; + *y0 = y; + return 0; + } + } + +/* pas d'intersection a l'interieur des aretes */ + *linter = 0; + return 0; +} /* int1sd_ */ + +/* Subroutine */ int tefoar_(integer *narete, integer *nbarpi, doublereal * + pxyd, integer *mosoar, integer *mxsoar, integer *n1soar, integer * + nosoar, integer *moartr, integer *mxartr, integer *n1artr, integer * + noartr, integer *noarst, integer *mxarcf, integer *n1arcf, integer * + noarcf, integer *larmin, integer *notrcf, integer *ierr) +{ + /* System generated locals */ + integer noartr_dim1, noartr_offset, nosoar_dim1, nosoar_offset, i__1; + doublereal d__1, d__2; + static integer equiv_1[2]; + + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void), s_rsle(cilist *), e_rsle(void); + double sqrt(doublereal); + + /* Local variables */ + static doublereal d__; + static integer i__, j, k; + static doublereal x, y, d3, d4; + static integer i1, n1, n2; + static doublereal x1, y1, x2, y2, d12; + static integer na, ns[2], nt, na0, na1, na2, ns1, ns2, nt0, ns3, ns4, nt1, + na00, na01, nbt, nsp; +#define nacf (equiv_1) + static integer nbcf; + static doublereal dmin__; + static integer ipas, noar; +#define nacf1 (equiv_1) +#define nacf2 (equiv_1 + 1) + static integer nsens, nbtrc0; + extern /* Subroutine */ int int1sd_(integer *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *); + extern integer nopre3_(integer *), nosui3_(integer *); + static integer nbarcf; + extern /* Subroutine */ int trp1st_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *); + static integer mmarcf; + extern /* Subroutine */ int tridcf_(integer *, integer *, integer *, + doublereal *, integer *, integer *, integer *, integer *, integer + *, integer *, integer *, integer *, integer *, integer *, integer + *, integer *, integer *, integer *, integer *); + static integer nbtrcf; + extern /* Subroutine */ int focftr_(integer *, integer *, integer *, + doublereal *, integer *, integer *, integer *, integer *, integer + *, integer *, integer *, integer *, integer *, integer *, integer + *, integer *, integer *, integer *); + static integer lapitr[32], linter, nbstpe, nostpe[512], nosotr[3]; + extern /* Subroutine */ int nusotr_(integer *, integer *, integer *, + integer *, integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___548 = { 0, 0, 0, 0, 0 }; + static cilist io___549 = { 0, 0, 0, 0, 0 }; + static cilist io___558 = { 0, 0, 0, 0, 0 }; + static cilist io___560 = { 0, 0, 0, 0, 0 }; + static cilist io___563 = { 0, 0, 0, 0, 0 }; + static cilist io___564 = { 0, 0, 0, 0, 0 }; + static cilist io___571 = { 0, 0, 0, 0, 0 }; + static cilist io___572 = { 0, 0, 0, 0, 0 }; + static cilist io___576 = { 0, 0, 0, 0, 0 }; + static cilist io___577 = { 0, 0, 0, 0, 0 }; + static cilist io___587 = { 0, 0, 0, 0, 0 }; + static cilist io___588 = { 0, 0, 0, 0, 0 }; + static cilist io___589 = { 0, 0, 0, 0, 0 }; + static cilist io___590 = { 0, 0, 0, 0, 0 }; + static cilist io___591 = { 0, 0, 0, 0, 0 }; + static cilist io___592 = { 0, 0, 0, 0, 0 }; + static cilist io___593 = { 0, 0, 0, 0, 0 }; + static cilist io___594 = { 0, 0, 0, 0, 0 }; + static cilist io___595 = { 0, 0, 0, 0, 0 }; + static cilist io___596 = { 0, 0, 0, 0, 0 }; + static cilist io___599 = { 0, 0, 0, 0, 0 }; + static cilist io___604 = { 0, 0, 0, 0, 0 }; + static cilist io___605 = { 0, 0, 0, 0, 0 }; + static cilist io___606 = { 0, 0, 0, 0, 0 }; + static cilist io___607 = { 0, 0, 0, 0, 0 }; + static cilist io___608 = { 0, 0, 0, 0, 0 }; + static cilist io___609 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : forcer l'arete narete de nosoar dans la triangulation actuelle */ +/* ----- triangulation frontale pour la reobtenir */ + +/* attention: le chainage lchain(=6) de nosoar devient actif */ +/* durant la formation des contours fermes (cf) */ + +/* entrees: */ +/* -------- */ +/* narete : numero nosoar de l'arete frontaliere a forcer */ +/* nbarpi : numero du dernier point interne impose par l'utilisateur */ +/* pxyd : tableau des coordonnees 2d des points */ +/* par point : x y distance_souhaitee */ + +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* attention: mxsoar>3*mxsomm obligatoire! */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ +/* mxartr : nombre maximal de triangles stockables dans le tableau noartr */ + +/* modifies: */ +/* --------- */ +/* n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar */ +/* chainage des vides suivant en 3 et precedant en 2 de nosoar */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = nosoar(1)+nosoar(2)*2 */ +/* avec mxsoar>=3*mxsomm */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 et */ +/* nosoar(2,arete vide)=l'arete vide qui precede */ +/* nosoar(3,arete vide)=l'arete vide qui suit */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ +/* noarst : noarst(i) numero d'une arete de sommet i */ + +/* mxarcf : nombre de variables des tableaux n1arcf, noarcf, larmin, notrcf */ + +/* tableaux auxiliaires : */ +/* ---------------------- */ +/* n1arcf : tableau (0:mxarcf) auxiliaire */ +/* noarcf : tableau (3,mxarcf) auxiliaire */ +/* larmin : tableau (mxarcf) auxiliaire */ +/* notrcf : tableau (1:mxarcf) auxiliaire */ + +/* sortie : */ +/* -------- */ +/* ierr : 0 si pas d'erreur */ +/* 1 saturation des sommets */ +/* 2 ns1 dans aucun triangle */ +/* 9 tableau nosoar de taille insuffisante car trop d'aretes */ +/* a probleme */ +/* 10 un des tableaux n1arcf, noarcf notrcf est sature */ +/* augmenter a l'appel mxarcf */ +/* >11 algorithme defaillant */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc mars 1997 */ +/* modifs : alain perronnet laboratoire jl lions upmc paris octobre 2006 */ +/* ....................................................................012 */ + + + /* Parameter adjustments */ + pxyd -= 4; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --noarst; + --notrcf; + --larmin; + noarcf -= 4; + + /* Function Body */ + *ierr = 0; + +/* traitement de cette arete perdue */ + ns1 = nosoar[*narete * nosoar_dim1 + 1]; + ns2 = nosoar[*narete * nosoar_dim1 + 2]; + +/* cc write(imprim,*) */ +/* cc write(imprim,*) 'tefoar reconstruction de l''arete ',ns1,' ', ns2 */ +/* cc write(imprim,*) 'sommet',ns1,' x=',pxyd(1,ns1),' y=',pxyd(2,ns1) */ +/* cc write(imprim,*) 'sommet',ns2,' x=',pxyd(1,ns2),' y=',pxyd(2,ns2) */ + +/* le sommet ns2 est il correct? */ + na = noarst[ns2]; + if (na <= 0) { + //io___548.ciunit = unites_2.imprim; + //s_wsle(&io___548); + //do_lio(&c__9, &c__1, "tefoar: erreur sommet ", (ftnlen)22); + //do_lio(&c__3, &c__1, (char *)&ns2, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " sans arete", (ftnlen)11); + //e_wsle(); + *ierr = 8; +/* cc pause */ + return 0; + } + if (nosoar[na * nosoar_dim1 + 4] <= 0) { + //io___549.ciunit = unites_2.imprim; + //s_wsle(&io___549); + //do_lio(&c__9, &c__1, "tefoar: erreur sommet ", (ftnlen)22); + //do_lio(&c__3, &c__1, (char *)&ns2, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " dans aucun triangle", (ftnlen)20); + //e_wsle(); + *ierr = 8; +/* cc pause */ + return 0; + } + +/* le premier passage: recherche dans le sens ns1->ns2 */ + ipas = 0; + +/* recherche des triangles intersectes par le segment ns1-ns2 */ +/* ========================================================== */ +L3: + x1 = pxyd[ns1 * 3 + 1]; + y1 = pxyd[ns1 * 3 + 2]; + x2 = pxyd[ns2 * 3 + 1]; + y2 = pxyd[ns2 * 3 + 2]; +/* Computing 2nd power */ + d__1 = x2 - x1; +/* Computing 2nd power */ + d__2 = y2 - y1; + d12 = d__1 * d__1 + d__2 * d__2; + +/* recherche du triangle voisin dans le sens indirect de rotation */ + nsens = -1; + +/* recherche du no local du sommet ns1 dans l'un de ses triangles */ +L10: + na01 = noarst[ns1]; + if (na01 <= 0) { + //io___558.ciunit = unites_2.imprim; + //s_wsle(&io___558); + //do_lio(&c__9, &c__1, "tefoar: sommet ", (ftnlen)15); + //do_lio(&c__3, &c__1, (char *)&ns1, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " sans arete", (ftnlen)11); + //e_wsle(); + *ierr = 8; +/* cc pause */ + return 0; + } + nt0 = nosoar[na01 * nosoar_dim1 + 4]; + if (nt0 <= 0) { + //io___560.ciunit = unites_2.imprim; + //s_wsle(&io___560); + //do_lio(&c__9, &c__1, "tefoar: sommet ", (ftnlen)15); + //do_lio(&c__3, &c__1, (char *)&ns1, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " dans aucun triangle", (ftnlen)20); + //e_wsle(); + *ierr = 8; +/* cc pause */ + return 0; + } + +/* le numero des 3 sommets du triangle nt0 dans le sens direct */ +L20: + nusotr_(&nt0, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + for (na00 = 1; na00 <= 3; ++na00) { + if (nosotr[na00 - 1] == ns1) { + goto L26; + } +/* L22: */ + } + +L25: + if (ipas == 0) { +/* le second passage: recherche dans le sens ns2->ns1 */ +/* tentative d'inversion des 2 sommets extremites de l'arete a forcer */ + na00 = ns1; + ns1 = ns2; + ns2 = na00; + ipas = 1; + goto L3; + } else { +/* les sens ns1->ns2 et ns2->ns1 ne donne pas de solution! */ + //io___563.ciunit = unites_2.imprim; + //s_wsle(&io___563); + //do_lio(&c__9, &c__1, "tefoar:arete ", (ftnlen)13); + //do_lio(&c__3, &c__1, (char *)&ns1, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " - ", (ftnlen)3); + //do_lio(&c__3, &c__1, (char *)&ns2, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " a imposer", (ftnlen)10); + //e_wsle(); + //io___564.ciunit = unites_2.imprim; + //s_wsle(&io___564); + //do_lio(&c__9, &c__1, "tefoar:anomalie sommet ", (ftnlen)23); + //do_lio(&c__3, &c__1, (char *)&ns1, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, "non dans le triangle de sommets ", (ftnlen)32); + //for (i__ = 1; i__ <= 3; ++i__) { + // do_lio(&c__3, &c__1, (char *)&nosotr[i__ - 1], (ftnlen)sizeof( + // integer)); + //} + //e_wsle(); + *ierr = 11; +/* cc pause */ + return 0; + } + +/* le numero des aretes suivante et precedente */ +L26: + na0 = nosui3_(&na00); + na1 = nopre3_(&na00); + ns3 = nosotr[na0 - 1]; + ns4 = nosotr[na1 - 1]; + +/* point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4 */ +/* ------------------------------------------------------------ */ + int1sd_(&ns1, &ns2, &ns3, &ns4, &pxyd[4], &linter, &x1, &y1); + if (linter <= 0) { + +/* pas d'intersection: rotation autour du point ns1 */ +/* pour trouver le triangle de l'autre cote de l'arete na01 */ + if (nsens < 0) { +/* sens indirect de rotation: l'arete de sommet ns1 */ + na01 = (i__1 = noartr[na00 + nt0 * noartr_dim1], abs(i__1)); + } else { +/* sens direct de rotation: l'arete de sommet ns1 qui precede */ + na01 = (i__1 = noartr[na1 + nt0 * noartr_dim1], abs(i__1)); + } +/* le triangle de l'autre cote de l'arete na01 */ + if (nosoar[na01 * nosoar_dim1 + 4] == nt0) { + nt0 = nosoar[na01 * nosoar_dim1 + 5]; + } else { + nt0 = nosoar[na01 * nosoar_dim1 + 4]; + } + if (nt0 > 0) { + goto L20; + } + +/* le parcours sort du domaine */ +/* il faut tourner dans l'autre sens autour de ns1 */ + if (nsens < 0) { + nsens = 1; + goto L10; + } + +/* dans les 2 sens, pas d'intersection => impossible */ +/* essai avec l'arete inversee ns1 <-> ns2 */ + if (ipas == 0) { + goto L25; + } + //io___571.ciunit = unites_2.imprim; + //s_wsle(&io___571); + //do_lio(&c__9, &c__1, "tefoar: arete ", (ftnlen)14); + //do_lio(&c__3, &c__1, (char *)&ns1, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " ", (ftnlen)1); + //do_lio(&c__3, &c__1, (char *)&ns2, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " sans intersection avec les triangles actuels", + // (ftnlen)45); + //e_wsle(); + //io___572.ciunit = unites_2.imprim; + //s_wsle(&io___572); + //do_lio(&c__9, &c__1, "revoyez les lignes du contour", (ftnlen)29); + //e_wsle(); + *ierr = 12; +/* cc pause */ + return 0; + } + +/* il existe une intersection avec l'arete opposee au sommet ns1 */ +/* ============================================================= */ +/* nbtrcf : nombre de triangles du cf */ + nbtrcf = 1; + notrcf[1] = nt0; + +/* le triangle oppose a l'arete na0 de nt0 */ +L30: + noar = (i__1 = noartr[na0 + nt0 * noartr_dim1], abs(i__1)); + if (nosoar[noar * nosoar_dim1 + 4] == nt0) { + nt1 = nosoar[noar * nosoar_dim1 + 5]; + } else { + nt1 = nosoar[noar * nosoar_dim1 + 4]; + } + if (nt1 <= 0) { + //io___576.ciunit = unites_2.imprim; + //s_wsle(&io___576); + //do_lio(&c__9, &c__1, "erreur dans tefoar nt1=", (ftnlen)23); + //do_lio(&c__3, &c__1, (char *)&nt1, (ftnlen)sizeof(integer)); + //e_wsle(); + //io___577.ciunit = unites_2.lecteu; + //s_rsle(&io___577); + //do_lio(&c__3, &c__1, (char *)&j, (ftnlen)sizeof(integer)); + //e_rsle(); + } + +/* le numero des 3 sommets du triangle nt1 dans le sens direct */ + nusotr_(&nt1, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + +/* le triangle nt1 contient il ns2 ? */ + for (j = 1; j <= 3; ++j) { + if (nosotr[j - 1] == ns2) { + goto L70; + } +/* L32: */ + } + +/* recherche de l'arete noar, na1 dans nt1 qui est l'arete na0 de nt0 */ + for (na1 = 1; na1 <= 3; ++na1) { + if ((i__1 = noartr[na1 + nt1 * noartr_dim1], abs(i__1)) == noar) { + goto L35; + } +/* L34: */ + } + +/* recherche de l'intersection de ns1-ns2 avec les 2 autres aretes de nt1 */ +/* ====================================================================== */ +L35: + na2 = na1; + for (i1 = 1; i1 <= 2; ++i1) { +/* l'arete suivante */ + na2 = nosui3_(&na2); + +/* les 2 sommets de l'arete na2 de nt1 */ + noar = (i__1 = noartr[na2 + nt1 * noartr_dim1], abs(i__1)); + ns3 = nosoar[noar * nosoar_dim1 + 1]; + ns4 = nosoar[noar * nosoar_dim1 + 2]; + +/* point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4 */ +/* ------------------------------------------------------------ */ + int1sd_(&ns1, &ns2, &ns3, &ns4, &pxyd[4], &linter, &x, &y); + if (linter > 0) { + +/* les 2 aretes s'intersectent en (x,y) */ +/* distance de (x,y) a ns3 et ns4 */ +/* Computing 2nd power */ + d__1 = pxyd[ns3 * 3 + 1] - x; +/* Computing 2nd power */ + d__2 = pxyd[ns3 * 3 + 2] - y; + d3 = d__1 * d__1 + d__2 * d__2; +/* Computing 2nd power */ + d__1 = pxyd[ns4 * 3 + 1] - x; +/* Computing 2nd power */ + d__2 = pxyd[ns4 * 3 + 2] - y; + d4 = d__1 * d__1 + d__2 * d__2; +/* nsp est le point le plus proche de (x,y) */ + if (d3 < d4) { + nsp = ns3; + d__ = d3; + } else { + nsp = ns4; + d__ = d4; + } + if (d__ > d12 * 1e-5) { + goto L60; + } + +/* ici le sommet nsp est trop proche de l'arete perdue ns1-ns2 */ + if (nsp <= *nbarpi) { +/* point utilisateur ou frontalier donc non supprimable */ + //io___587.ciunit = unites_2.imprim; + //s_wsle(&io___587); + //do_lio(&c__9, &c__1, "tefoar: sommet nsp=", (ftnlen)19); + //do_lio(&c__3, &c__1, (char *)&nsp, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " frontalier trop proche de l'arete per" + // "due ns1=", (ftnlen)46); + //do_lio(&c__3, &c__1, (char *)&ns1, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, "-ns2=", (ftnlen)5); + //do_lio(&c__3, &c__1, (char *)&ns2, (ftnlen)sizeof(integer)); + //e_wsle(); + //io___588.ciunit = unites_2.imprim; + //s_wsle(&io___588); + //do_lio(&c__9, &c__1, "s", (ftnlen)1); + //do_lio(&c__3, &c__1, (char *)&nsp, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, ": x=", (ftnlen)4); + //do_lio(&c__5, &c__1, (char *)&pxyd[nsp * 3 + 1], (ftnlen) + // sizeof(doublereal)); + //do_lio(&c__9, &c__1, " y=", (ftnlen)3); + //do_lio(&c__5, &c__1, (char *)&pxyd[nsp * 3 + 2], (ftnlen) + // sizeof(doublereal)); + //e_wsle(); + //io___589.ciunit = unites_2.imprim; + //s_wsle(&io___589); + //do_lio(&c__9, &c__1, "s", (ftnlen)1); + //do_lio(&c__3, &c__1, (char *)&ns1, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, ": x=", (ftnlen)4); + //do_lio(&c__5, &c__1, (char *)&pxyd[ns1 * 3 + 1], (ftnlen) + // sizeof(doublereal)); + //do_lio(&c__9, &c__1, " y=", (ftnlen)3); + //do_lio(&c__5, &c__1, (char *)&pxyd[ns1 * 3 + 2], (ftnlen) + // sizeof(doublereal)); + //e_wsle(); + //io___590.ciunit = unites_2.imprim; + //s_wsle(&io___590); + //do_lio(&c__9, &c__1, "s", (ftnlen)1); + //do_lio(&c__3, &c__1, (char *)&ns2, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, ": x=", (ftnlen)4); + //do_lio(&c__5, &c__1, (char *)&pxyd[ns2 * 3 + 1], (ftnlen) + // sizeof(doublereal)); + //do_lio(&c__9, &c__1, " y=", (ftnlen)3); + //do_lio(&c__5, &c__1, (char *)&pxyd[ns2 * 3 + 2], (ftnlen) + // sizeof(doublereal)); + //e_wsle(); + //io___591.ciunit = unites_2.imprim; + //s_wsle(&io___591); + //do_lio(&c__9, &c__1, "arete s", (ftnlen)7); + //do_lio(&c__3, &c__1, (char *)&ns1, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, "-s", (ftnlen)2); + //do_lio(&c__3, &c__1, (char *)&ns2, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " coupe arete s", (ftnlen)14); + //do_lio(&c__3, &c__1, (char *)&ns3, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, "-s", (ftnlen)2); + //do_lio(&c__3, &c__1, (char *)&ns4, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " en (x,y)", (ftnlen)9); + //e_wsle(); + //io___592.ciunit = unites_2.imprim; + //s_wsle(&io___592); + //do_lio(&c__9, &c__1, "s", (ftnlen)1); + //do_lio(&c__3, &c__1, (char *)&ns3, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, ": x=", (ftnlen)4); + //do_lio(&c__5, &c__1, (char *)&pxyd[ns3 * 3 + 1], (ftnlen) + // sizeof(doublereal)); + //do_lio(&c__9, &c__1, " y=", (ftnlen)3); + //do_lio(&c__5, &c__1, (char *)&pxyd[ns3 * 3 + 2], (ftnlen) + // sizeof(doublereal)); + //e_wsle(); + //io___593.ciunit = unites_2.imprim; + //s_wsle(&io___593); + //do_lio(&c__9, &c__1, "s", (ftnlen)1); + //do_lio(&c__3, &c__1, (char *)&ns4, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, ": x=", (ftnlen)4); + //do_lio(&c__5, &c__1, (char *)&pxyd[ns4 * 3 + 1], (ftnlen) + // sizeof(doublereal)); + //do_lio(&c__9, &c__1, " y=", (ftnlen)3); + //do_lio(&c__5, &c__1, (char *)&pxyd[ns4 * 3 + 2], (ftnlen) + // sizeof(doublereal)); + //e_wsle(); + //io___594.ciunit = unites_2.imprim; + //s_wsle(&io___594); + //do_lio(&c__9, &c__1, "intersection en: x=", (ftnlen)19); + //do_lio(&c__5, &c__1, (char *)&x, (ftnlen)sizeof(doublereal)); + //do_lio(&c__9, &c__1, " y=", (ftnlen)3); + //do_lio(&c__5, &c__1, (char *)&y, (ftnlen)sizeof(doublereal)); + //e_wsle(); + //io___595.ciunit = unites_2.imprim; + //s_wsle(&io___595); + //do_lio(&c__9, &c__1, "distance ns1-ns2=", (ftnlen)17); + //d__1 = sqrt(d12); + //do_lio(&c__5, &c__1, (char *)&d__1, (ftnlen)sizeof(doublereal) + // ); + //e_wsle(); + //io___596.ciunit = unites_2.imprim; + //s_wsle(&io___596); + //do_lio(&c__9, &c__1, "distance (x,y) au plus proche", (ftnlen) + // 29); + //do_lio(&c__3, &c__1, (char *)&ns3, (ftnlen)sizeof(integer)); + //do_lio(&c__3, &c__1, (char *)&ns4, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, "=", (ftnlen)1); + //d__1 = sqrt(d__); + //do_lio(&c__5, &c__1, (char *)&d__1, (ftnlen)sizeof(doublereal) + // ); + //e_wsle(); + *ierr = 13; +/* cc pause */ + return 0; + } + +/* le sommet interne nsp est supprime en mettant tous les triangles */ +/* l'ayant comme sommet dans la pile notrcf des triangles a supprimer */ +/* ------------------------------------------------------------------ */ +/* cc write(imprim,*) 'tefoar: le sommet ',nsp,' est supprime' */ +/* construction de la liste des triangles de sommet nsp */ + trp1st_(&nsp, &noarst[1], mosoar, &nosoar[nosoar_offset], moartr, + mxartr, &noartr[noartr_offset], &c__32, &nbt, lapitr); + if (nbt <= 0) { +/* les triangles de sommet nsp ne forme pas une "boule" */ +/* avec ce sommet nsp pour "centre" */ + //io___599.ciunit = unites_2.imprim; + //s_wsle(&io___599); + //do_lio(&c__9, &c__1, "tefoar: les triangles autour du sommet " + // , (ftnlen)39); + //do_lio(&c__3, &c__1, (char *)&nsp, (ftnlen)sizeof(integer)); + //do_lio(&c__9, &c__1, " ne forme pas une etoile", (ftnlen)24); + //e_wsle(); + nbt = -nbt; + } + +/* ajout des triangles de sommet nsp a notrcf */ + nbtrc0 = nbtrcf; + i__1 = nbt; + for (j = 1; j <= i__1; ++j) { + nt = lapitr[j - 1]; + for (k = nbtrcf; k >= 1; --k) { + if (nt == notrcf[k]) { + goto L38; + } +/* L37: */ + } +/* triangle ajoute */ + ++nbtrcf; + notrcf[nbtrcf] = nt; +L38: + ; + } + +/* ce sommet supprime n'appartient plus a aucun triangle */ + noarst[nsp] = 0; + +/* ns2 est-il un sommet des triangles empiles? */ +/* ------------------------------------------- */ + i__1 = nbtrcf; + for (nt = nbtrc0 + 1; nt <= i__1; ++nt) { +/* le triangle a supprimer nt */ + nt1 = notrcf[nt]; +/* le numero des 3 sommets du triangle nt1 dans le sens direct */ + nusotr_(&nt1, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + for (k = 1; k <= 3; ++k) { +/* le sommet k de nt1 */ + if (nosotr[k - 1] == ns2) { +/* but atteint */ + goto L80; + } +/* L39: */ + } +/* L40: */ + } + +/* recherche du plus proche point d'intersection de ns1-ns2 */ +/* par rapport a ns2 avec les aretes des triangles ajoutes */ + nt0 = 0; + dmin__ = d12 * 10000; + i__1 = nbtrcf; + for (nt = nbtrc0 + 1; nt <= i__1; ++nt) { + nt1 = notrcf[nt]; +/* le numero des 3 sommets du triangle nt1 dans le sens direct */ + nusotr_(&nt1, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + for (k = 1; k <= 3; ++k) { +/* les 2 sommets de l'arete k de nt */ + ns3 = nosotr[k - 1]; + ns4 = nosotr[nosui3_(&k) - 1]; + +/* point d'intersection du segment ns1-ns2 avec l'arete ns3-ns4 */ +/* ------------------------------------------------------------ */ + int1sd_(&ns1, &ns2, &ns3, &ns4, &pxyd[4], &linter, &x, &y) + ; + if (linter > 0) { +/* les 2 aretes s'intersectent en (x,y) */ +/* Computing 2nd power */ + d__1 = x - x2; +/* Computing 2nd power */ + d__2 = y - y2; + d__ = d__1 * d__1 + d__2 * d__2; + if (d__ < dmin__) { + nt0 = nt1; + na0 = k; + dmin__ = d__; + } + } +/* L45: */ + } +/* L48: */ + } + +/* redemarrage avec le triangle nt0 et l'arete na0 */ + if (nt0 > 0) { + goto L30; + } + + //io___604.ciunit = unites_2.imprim; + //s_wsle(&io___604); + //do_lio(&c__9, &c__1, "tefoar: algorithme defaillant", (ftnlen)29); + //e_wsle(); + *ierr = 14; +/* cc pause */ + return 0; + } +/* L50: */ + } + +/* pas d'intersection differente de l'initiale => sommet sur ns1-ns2 */ +/* tentative d'inversion des sommets de l'arete ns1-ns2 */ + if (ipas == 0) { + goto L25; + } + //io___605.ciunit = unites_2.imprim; + //s_wsle(&io___605); + //e_wsle(); + //io___606.ciunit = unites_2.imprim; + //s_wsle(&io___606); + //do_lio(&c__9, &c__1, "tefoar 50: revoyez vos donnees", (ftnlen)30); + //e_wsle(); + //io___607.ciunit = unites_2.imprim; + //s_wsle(&io___607); + //do_lio(&c__9, &c__1, "les lignes fermees doivent etre disjointes", ( + // ftnlen)42); + //e_wsle(); + //io___608.ciunit = unites_2.imprim; + //s_wsle(&io___608); + //do_lio(&c__9, &c__1, "verifiez si elles ne se coupent pas", (ftnlen)35); + //e_wsle(); + *ierr = 15; +/* cc pause */ + return 0; + +/* cas sans probleme : intersection differente de celle initiale */ +/* ================= ========================================= */ +L60: + ++nbtrcf; + notrcf[nbtrcf] = nt1; +/* passage au triangle suivant */ + na0 = na2; + nt0 = nt1; + goto L30; + +/* ---------------------------------------------------------- */ +/* ici toutes les intersections de ns1-ns2 ont ete parcourues */ +/* tous les triangles intersectes ou etendus forment les */ +/* nbtrcf triangles du tableau notrcf */ +/* ---------------------------------------------------------- */ +L70: + ++nbtrcf; + notrcf[nbtrcf] = nt1; + +/* formation du cf des aretes simples des triangles de notrcf */ +/* et destruction des nbtrcf triangles du tableau noartr */ +/* attention: le chainage lchain du tableau nosoar devient actif */ +/* ============================================================= */ +L80: + if (nbtrcf * 3 > *mxarcf) { + //io___609.ciunit = unites_2.imprim; + //s_wsle(&io___609); + //do_lio(&c__9, &c__1, "saturation du tableau noarcf", (ftnlen)28); + //e_wsle(); + *ierr = 10; +/* cc pause */ + return 0; + } + + focftr_(&nbtrcf, ¬rcf[1], nbarpi, &pxyd[4], &noarst[1], mosoar, mxsoar, + n1soar, &nosoar[nosoar_offset], moartr, n1artr, &noartr[ + noartr_offset], &nbarcf, n1arcf, &noarcf[4], &nbstpe, nostpe, + ierr); + if (*ierr != 0) { + return 0; + } + +/* chainage des aretes vides dans le tableau noarcf */ +/* ------------------------------------------------ */ +/* decalage de 2 aretes car 2 aretes sont necessaires ensuite pour */ +/* integrer 2 fois l'arete perdue et former ainsi 2 cf */ +/* comme nbtrcf*3 minore mxarcf il existe au moins 2 places vides */ +/* derriere => pas de test de debordement */ + n1arcf[0] = nbarcf + 3; +/* Computing MIN */ + i__1 = nbarcf << 3; + mmarcf = min(i__1,*mxarcf); + i__1 = mmarcf; + for (i__ = nbarcf + 3; i__ <= i__1; ++i__) { + noarcf[i__ * 3 + 2] = i__ + 1; +/* L90: */ + } + noarcf[mmarcf * 3 + 2] = 0; + +/* reperage des sommets ns1 ns2 de l'arete perdue dans le cf */ +/* --------------------------------------------------------- */ + ns1 = nosoar[*narete * nosoar_dim1 + 1]; + ns2 = nosoar[*narete * nosoar_dim1 + 2]; + ns[0] = ns1; + ns[1] = ns2; + for (i__ = 1; i__ <= 2; ++i__) { +/* la premiere arete dans noarcf du cf */ + na0 = n1arcf[1]; +L110: + if (noarcf[na0 * 3 + 1] != ns[i__ - 1]) { +/* passage a l'arete suivante */ + na0 = noarcf[na0 * 3 + 2]; + goto L110; + } +/* position dans noarcf du sommet i de l'arete perdue */ + nacf[i__ - 1] = na0; +/* L120: */ + } + +/* formation des 2 cf chacun contenant l'arete ns1-ns2 */ +/* --------------------------------------------------- */ +/* sauvegarde de l'arete suivante de celle de sommet ns1 */ + na0 = noarcf[*nacf1 * 3 + 2]; + nt1 = noarcf[*nacf1 * 3 + 3]; + +/* le premier cf */ + n1arcf[1] = *nacf1; +/* l'arete suivante dans le premier cf */ + noarcf[*nacf1 * 3 + 2] = *nacf2; +/* cette arete est celle perdue */ + noarcf[*nacf1 * 3 + 3] = *narete; + +/* le second cf */ +/* l'arete doublee */ + n1 = nbarcf + 1; + n2 = nbarcf + 2; +/* le premier sommet de la premiere arete du second cf */ + noarcf[n1 * 3 + 1] = ns2; +/* l'arete suivante dans le second cf */ + noarcf[n1 * 3 + 2] = n2; +/* cette arete est celle perdue */ + noarcf[n1 * 3 + 3] = *narete; +/* la seconde arete du second cf */ + noarcf[n2 * 3 + 1] = ns1; + noarcf[n2 * 3 + 2] = na0; + noarcf[n2 * 3 + 3] = nt1; + n1arcf[2] = n1; + +/* recherche du precedent de nacf2 */ +L130: + na1 = noarcf[na0 * 3 + 2]; + if (na1 != *nacf2) { +/* passage a l'arete suivante */ + na0 = na1; + goto L130; + } +/* na0 precede nacf2 => il precede n1 */ + noarcf[na0 * 3 + 2] = n1; + +/* depart avec 2 cf */ + nbcf = 2; + +/* triangulation directe des 2 contours fermes */ +/* l'arete ns1-ns2 devient une arete de la triangulation des 2 cf */ +/* ============================================================== */ + tridcf_(&nbcf, &nbstpe, nostpe, &pxyd[4], &noarst[1], mosoar, mxsoar, + n1soar, &nosoar[nosoar_offset], moartr, n1artr, &noartr[ + noartr_offset], mxarcf, n1arcf, &noarcf[4], &larmin[1], &nbtrcf, & + notrcf[1], ierr); + + return 0; +} /* tefoar_ */ + +#undef nacf2 +#undef nacf1 +#undef nacf + + +/* Subroutine */ int te4ste_(integer *nbsomm, integer *mxsomm, doublereal * + pxyd, integer *ntrp, integer *letree, integer *ierr) +{ + /* Builtin functions */ + //integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + // e_wsle(void); + + /* Local variables */ + static integer i__, i1, i2, np[4], ns1, ns2, nsot; + extern integer nopre3_(integer *); + extern /* Subroutine */ int n1trva_(integer *, integer *, integer *, + integer *, integer *); + extern integer nosui3_(integer *); + static integer milieu[3], niveau, noteva; + extern integer notrpt_(doublereal *, doublereal *, integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___625 = { 0, 0, 0, 0, 0 }; + static cilist io___626 = { 0, 0, 0, 0, 0 }; + static cilist io___629 = { 0, 0, 0, 0, 0 }; + static cilist io___630 = { 0, 0, 0, 0, 0 }; + + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : decouper un te ntrp de letree en 4 sous-triangles */ +/* ----- eliminer les sommets de te trop proches des points */ + +/* entrees: */ +/* -------- */ +/* mxsomm : nombre maximal de points declarables dans pxyd */ +/* ntrp : numero letree du triangle a decouper en 4 sous-triangles */ + +/* modifies : */ +/* ---------- */ +/* nbsomm : nombre actuel de points dans pxyd */ +/* pxyd : tableau des coordonnees des points */ +/* par point : x y distance_souhaitee */ +/* letree : arbre-4 des triangles equilateraux (te) fond de la triangulation */ +/* letree(0,0) : no du 1-er te vide dans letree */ +/* letree(0,1) : maximum du 1-er indice de letree (ici 8) */ +/* letree(0,2) : maximum declare du 2-eme indice de letree (ici mxtree) */ +/* letree(0:8,1) : racine de l'arbre (triangle sans sur triangle) */ +/* si letree(0,.)>0 alors */ +/* letree(0:3,j) : no (>0) letree des 4 sous-triangles du triangle j */ +/* sinon */ +/* letree(0:3,j) :-no pxyd des 1 a 4 points internes au triangle j */ +/* 0 si pas de point */ +/* ( j est alors une feuille de l'arbre ) */ +/* letree(4,j) : no letree du sur-triangle du triangle j */ +/* letree(5,j) : 0 1 2 3 no du sous-triangle j pour son sur-triangle */ +/* letree(6:8,j) : no pxyd des 3 sommets du triangle j */ + +/* sorties : */ +/* --------- */ +/* ierr : 0 si pas d'erreur, 51 saturation letree, 52 saturation pxyd */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet analyse numerique paris upmc juillet 1994 */ +/* 2345x7..............................................................012 */ + +/* debut par l'arete 2 du triangle ntrp */ + /* Parameter adjustments */ + pxyd -= 4; + + /* Function Body */ + *ierr = 0; + i1 = 2; + i2 = 3; + for (i__ = 1; i__ <= 3; ++i__) { + +/* le milieu de l'arete i1 existe t il deja ? */ + n1trva_(ntrp, &i1, letree, ¬eva, &niveau); + if (noteva > 0) { +/* il existe un te voisin */ +/* s'il existe 4 sous-triangles le milieu existe deja */ + if (letree[noteva * 9] > 0) { +/* le milieu existe */ + nsot = letree[noteva * 9]; + milieu[i__ - 1] = letree[nopre3_(&i1) + 5 + nsot * 9]; + goto L25; + } + } + +/* le milieu n'existe pas. il est cree */ + ++(*nbsomm); + if (*nbsomm > *mxsomm) { +/* plus assez de place dans pxyd */ + //io___625.ciunit = unites_1.imprim; + //s_wsle(&io___625); + //do_lio(&c__9, &c__1, "te4ste: saturation pxyd", (ftnlen)23); + //e_wsle(); + //io___626.ciunit = unites_1.imprim; + //s_wsle(&io___626); + //e_wsle(); + *ierr = 52; + return 0; + } +/* le milieu de l'arete i */ + milieu[i__ - 1] = *nbsomm; + +/* ntrp est le triangle de milieux d'arete ces 3 sommets */ + ns1 = letree[i1 + 5 + *ntrp * 9]; + ns2 = letree[i2 + 5 + *ntrp * 9]; + pxyd[*nbsomm * 3 + 1] = (pxyd[ns1 * 3 + 1] + pxyd[ns2 * 3 + 1]) * .5f; + pxyd[*nbsomm * 3 + 2] = (pxyd[ns1 * 3 + 2] + pxyd[ns2 * 3 + 2]) * .5f; + +/* l'arete et milieu suivant */ +L25: + i1 = i2; + i2 = nosui3_(&i2); +/* L30: */ + } + + for (i__ = 0; i__ <= 3; ++i__) { + +/* le premier triangle vide */ + nsot = letree[0]; + if (nsot <= 0) { +/* manque de place. saturation letree */ + *ierr = 51; + //io___629.ciunit = unites_1.imprim; + //s_wsle(&io___629); + //do_lio(&c__9, &c__1, "te4ste: saturation letree", (ftnlen)25); + //e_wsle(); + //io___630.ciunit = unites_1.imprim; + //s_wsle(&io___630); + //e_wsle(); + return 0; + } + +/* mise a jour du premier te libre */ + letree[0] = letree[nsot * 9]; + +/* nsot est le i-eme sous triangle */ + letree[nsot * 9] = 0; + letree[nsot * 9 + 1] = 0; + letree[nsot * 9 + 2] = 0; + letree[nsot * 9 + 3] = 0; + +/* le numero des points et sous triangles dans ntrp */ + np[i__] = -letree[i__ + *ntrp * 9]; + letree[i__ + *ntrp * 9] = nsot; + +/* le sommet commun avec le triangle ntrp */ + letree[i__ + 5 + nsot * 9] = letree[i__ + 5 + *ntrp * 9]; + +/* le sur-triangle et numero de sous-triangle de nsot */ +/* a laisser ici car incorrect sinon pour i=0 */ + letree[nsot * 9 + 4] = *ntrp; + letree[nsot * 9 + 5] = i__; + +/* le sous-triangle du triangle */ + letree[i__ + *ntrp * 9] = nsot; +/* L50: */ + } + +/* le numero des nouveaux sommets milieux */ + nsot = letree[*ntrp * 9]; + letree[nsot * 9 + 6] = milieu[0]; + letree[nsot * 9 + 7] = milieu[1]; + letree[nsot * 9 + 8] = milieu[2]; + + nsot = letree[*ntrp * 9 + 1]; + letree[nsot * 9 + 7] = milieu[2]; + letree[nsot * 9 + 8] = milieu[1]; + + nsot = letree[*ntrp * 9 + 2]; + letree[nsot * 9 + 6] = milieu[2]; + letree[nsot * 9 + 8] = milieu[0]; + + nsot = letree[*ntrp * 9 + 3]; + letree[nsot * 9 + 6] = milieu[1]; + letree[nsot * 9 + 7] = milieu[0]; + +/* repartition des eventuels 4 points np dans ces 4 sous-triangles */ +/* il y a obligatoirement suffisamment de place */ + for (i__ = 0; i__ <= 3; ++i__) { + if (np[i__] > 0) { + nsot = notrpt_(&pxyd[np[i__] * 3 + 1], &pxyd[4], ntrp, letree); +/* ajout du point */ + for (i1 = 0; i1 <= 3; ++i1) { + if (letree[i1 + nsot * 9] == 0) { +/* place libre a occuper */ + letree[i1 + nsot * 9] = -np[i__]; + goto L110; + } +/* L100: */ + } + } +L110: + ; + } + return 0; +} /* te4ste_ */ + +/* Subroutine */ int tesuqm_(doublereal *quamal, integer *nbarpi, doublereal * + pxyd, integer *noarst, integer *mosoar, integer *mxsoar, integer * + n1soar, integer *nosoar, integer *moartr, integer *mxartr, integer * + n1artr, integer *noartr, integer *mxarcf, integer *n1arcf, integer * + noarcf, integer *larmin, integer *notrcf, integer *liarcf, doublereal + *quamin) +{ + /* System generated locals */ + integer nosoar_dim1, nosoar_offset, noartr_dim1, noartr_offset, i__1, + i__2; + doublereal d__1, d__2; + + /* Local variables */ + static integer j, n; + static doublereal a12, s12, s34; + static integer nt; + static doublereal s123, s142, s143, s234; + static integer ns1, ns2, ns3, ns4, nbt, naop, noar, ierr, noar34; + extern /* Subroutine */ int te2t2t_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *), mt4sqa_( + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *), te1stm_(integer *, integer *, + doublereal *, integer *, integer *, integer *, integer *, integer + *, integer *, integer *, integer *, integer *, integer *, integer + *, integer *, integer *, integer *, integer *, integer *), + qutr2d_(doublereal *, doublereal *, doublereal *, doublereal *); + extern doublereal surtd2_(doublereal *, doublereal *, doublereal *); + static integer narete, notraj[3]; + static doublereal qualit; + static integer nbtrqm; + extern /* Subroutine */ int tritas_(integer *, doublereal *, integer *); + static integer ntqmin, notrqm[1024], nosotr[3]; + static doublereal qutrqm[1024]; + extern /* Subroutine */ int nusotr_(integer *, integer *, integer *, + integer *, integer *, integer *); + +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : supprimer de la triangulation les triangles de qualite */ +/* ----- inferieure a quamal */ + +/* entrees: */ +/* -------- */ +/* quamal : qualite des triangles au dessous de laquelle supprimer des sommets */ +/* nbarpi : numero du dernier point interne impose par l'utilisateur */ +/* pxyd : tableau des coordonnees 2d des points */ +/* par point : x y distance_souhaitee */ +/* mosoar : nombre maximal d'entiers par arete et */ +/* indice dans nosoar de l'arete suivante dans le hachage */ +/* mxsoar : nombre maximal d'aretes stockables dans le tableau nosoar */ +/* attention: mxsoar>3*mxsomm obligatoire! */ +/* moartr : nombre maximal d'entiers par arete du tableau noartr */ + +/* modifies: */ +/* --------- */ +/* noarst : noarst(i) numero d'une arete de sommet i */ +/* n1soar : no de l'eventuelle premiere arete libre dans le tableau nosoar */ +/* chainage des vides suivant en 3 et precedant en 2 de nosoar */ +/* nosoar : numero des 2 sommets , no ligne, 2 triangles de l'arete, */ +/* chainage des aretes frontalieres, chainage du hachage des aretes */ +/* hachage des aretes = nosoar(1)+nosoar(2)*2 */ +/* avec mxsoar>=3*mxsomm */ +/* une arete i de nosoar est vide <=> nosoar(1,i)=0 et */ +/* nosoar(2,arete vide)=l'arete vide qui precede */ +/* nosoar(3,arete vide)=l'arete vide qui suit */ +/* n1artr : numero du premier triangle vide dans le tableau noartr */ +/* le chainage des triangles vides se fait sur noartr(2,.) */ +/* noartr : les 3 aretes des triangles +-arete1, +-arete2, +-arete3 */ +/* arete1 = 0 si triangle vide => arete2 = triangle vide suivant */ + +/* auxiliaires : */ +/* ------------- */ +/* n1arcf : tableau (0:mxarcf) auxiliaire d'entiers */ +/* noarcf : tableau (3,mxarcf) auxiliaire d'entiers */ +/* larmin : tableau (mxarcf) auxiliaire d'entiers */ +/* notrcf : tableau (mxarcf) auxiliaire d'entiers */ +/* liarcf : tableau (mxarcf) auxiliaire d'entiers */ + +/* sortie : */ +/* -------- */ +/* quamin : qualite minimale des triangles */ +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : alain perronnet Laboratoire JL Lions UPMC Paris Octobre 2006 */ +/* ....................................................................012 */ + + /* Parameter adjustments */ + pxyd -= 4; + --noarst; + nosoar_dim1 = *mosoar; + nosoar_offset = 1 + nosoar_dim1; + nosoar -= nosoar_offset; + noartr_dim1 = *moartr; + noartr_offset = 1 + noartr_dim1; + noartr -= noartr_offset; + --liarcf; + --notrcf; + --larmin; + noarcf -= 4; + + /* Function Body */ + ierr = 0; + +/* initialisation du chainage des aretes des cf => 0 arete de cf */ + i__1 = *mxsoar; + for (narete = 1; narete <= i__1; ++narete) { + nosoar[narete * nosoar_dim1 + 6] = -1; +/* L5: */ + } + +/* recherche des triangles de plus basse qualite */ + *quamin = 2.f; + nbtrqm = 0; + i__1 = *mxartr; + for (nt = 1; nt <= i__1; ++nt) { + if (noartr[nt * noartr_dim1 + 1] == 0) { + goto L10; + } +/* le numero des 3 sommets du triangle nt */ + nusotr_(&nt, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); +/* la qualite du triangle ns1 ns2 ns3 */ + qutr2d_(&pxyd[nosotr[0] * 3 + 1], &pxyd[nosotr[1] * 3 + 1], &pxyd[ + nosotr[2] * 3 + 1], &qualit); + if (qualit < *quamal) { + if (nbtrqm >= 1024) { + goto L10; + } + ++nbtrqm; + notrqm[nbtrqm - 1] = nt; + qutrqm[nbtrqm - 1] = qualit; + } +L10: + ; + } + +/* tri croissant des qualites minimales des triangles */ + tritas_(&nbtrqm, qutrqm, notrqm); + +/* le plus mauvais triangle */ + ntqmin = notrqm[0]; + *quamin = qutrqm[0]; + + i__1 = nbtrqm; + for (n = 1; n <= i__1; ++n) { + +/* no du triangle de mauvaise qualite */ + ntqmin = notrqm[n - 1]; + +/* le triangle a t il ete traite? */ + if (noartr[ntqmin * noartr_dim1 + 1] == 0) { + goto L100; + } + +/* cc print * */ +/* cc print *,'tesuqm: triangle',ntqmin,' qualite=',qutrqm(n) */ +/* cc print *,'tesuqm: noartr(',ntqmin,')=', */ +/* cc % (noartr(j,ntqmin),j=1,moartr) */ +/* ccc */ +/* cc do 12 j=1,3 */ +/* cc noar = noartr(j,ntqmin) */ +/* cc print*,'arete',noar,' nosoar=',(nosoar(i,abs(noar)),i=1,mosoar) */ +/* cc 12 continue */ + +/* le numero des 3 sommets du triangle ntqmin */ + nusotr_(&ntqmin, mosoar, &nosoar[nosoar_offset], moartr, &noartr[ + noartr_offset], nosotr); + +/* cc do 15 j=1,3 */ +/* cc nbt = nosotr(j) */ +/* cc print *,'sommet',nbt,': x=',pxyd(1,nbt),' y=',pxyd(2,nbt) */ +/* cc 15 continue */ + +/* recherche des triangles adjacents par les aretes de ntqmin */ + nbt = 0; + for (j = 1; j <= 3; ++j) { +/* le no de l'arete j dans nosoar */ + noar = (i__2 = noartr[j + ntqmin * noartr_dim1], abs(i__2)); +/* le triangle adjacent a l'arete j de ntqmin */ + if (nosoar[noar * nosoar_dim1 + 4] == ntqmin) { + notraj[j - 1] = nosoar[noar * nosoar_dim1 + 5]; + } else { + notraj[j - 1] = nosoar[noar * nosoar_dim1 + 4]; + } + if (notraj[j - 1] > 0) { +/* 1 triangle adjacent de plus */ + naop = j; + ++nbt; + } else { +/* pas de triangle adjacent */ + notraj[j - 1] = 0; + } +/* L20: */ + } + + if (nbt == 1) { + +/* ntqmin a un seul triangle oppose par l'arete naop */ +/* le triangle a 2 aretes frontalieres est plat */ +/* l'arete commune aux 2 triangles est rendue Delaunay */ +/* --------------------------------------------------- */ + noar = (i__2 = noartr[naop + ntqmin * noartr_dim1], abs(i__2)); + if (nosoar[noar * nosoar_dim1 + 3] != 0) { +/* arete frontaliere */ + goto L100; + } + +/* l'arete appartient a deux triangles actifs */ +/* le numero des 4 sommets du quadrangle des 2 triangles */ + mt4sqa_(&noar, moartr, &noartr[noartr_offset], mosoar, &nosoar[ + nosoar_offset], &ns1, &ns2, &ns3, &ns4); + if (ns4 == 0) { + goto L100; + } + +/* carre de la longueur de l'arete ns1 ns2 */ +/* Computing 2nd power */ + d__1 = pxyd[ns2 * 3 + 1] - pxyd[ns1 * 3 + 1]; +/* Computing 2nd power */ + d__2 = pxyd[ns2 * 3 + 2] - pxyd[ns1 * 3 + 2]; + a12 = d__1 * d__1 + d__2 * d__2; + +/* comparaison de la somme des aires des 2 triangles */ +/* ------------------------------------------------- */ +/* calcul des surfaces des triangles 123 et 142 de cette arete */ + s123 = surtd2_(&pxyd[ns1 * 3 + 1], &pxyd[ns2 * 3 + 1], &pxyd[ns3 * + 3 + 1]); + s142 = surtd2_(&pxyd[ns1 * 3 + 1], &pxyd[ns4 * 3 + 1], &pxyd[ns2 * + 3 + 1]); +/* cc print *,'tesuqm: ns4=',ns4,' x=',pxyd(1,ns4), */ +/* cc % ' y=',pxyd(2,ns4) */ +/* cc print *,'tesuqm: s123=',s123,' s142=',s142 */ + s12 = abs(s123) + abs(s142); + if (s12 <= a12 * .001f) { + goto L100; + } + +/* calcul des surfaces des triangles 143 et 234 de cette arete */ + s143 = surtd2_(&pxyd[ns1 * 3 + 1], &pxyd[ns4 * 3 + 1], &pxyd[ns3 * + 3 + 1]); + s234 = surtd2_(&pxyd[ns2 * 3 + 1], &pxyd[ns3 * 3 + 1], &pxyd[ns4 * + 3 + 1]); +/* cc print *,'tesuqm: s143=',s143,' s234=',s234 */ + s34 = abs(s234) + abs(s143); +/* cc print *,'tesuqm: s12=',s12,' s34=',s34 */ + + if ((d__1 = s34 - s12, abs(d__1)) > s34 * 1e-14) { + goto L100; + } + +/* quadrangle convexe */ +/* echange de la diagonale 12 par 34 des 2 triangles */ +/* ------------------------------------------------- */ + te2t2t_(&noar, mosoar, n1soar, &nosoar[nosoar_offset], &noarst[1], + moartr, &noartr[noartr_offset], &noar34); +/* cc print *,'tesuqm: sortie te2t2t avec noar34=',noar34 */ + + + } else if (nbt == 2) { + +/* ntqmin a 2 triangles opposes par l'arete naop */ +/* essai de supprimer le sommet non frontalier */ +/* --------------------------------------------- */ + for (j = 1; j <= 3; ++j) { + if (notraj[j - 1] == 0) { + goto L33; + } +/* L30: */ + } + +/* arete sans triangle adjacent */ +L33: + noar = (i__2 = noartr[j + ntqmin * noartr_dim1], abs(i__2)); +/* cc print *,'tesuqm: nosoar(',noar,')=', */ +/* cc % (nosoar(j,noar),j=1,mosoar) */ + if (noar <= 0) { + goto L100; + } + +/* ses 2 sommets */ + ns1 = nosoar[noar * nosoar_dim1 + 1]; + ns2 = nosoar[noar * nosoar_dim1 + 2]; + +/* ns3 l'autre sommet non frontalier */ + for (j = 1; j <= 3; ++j) { + ns3 = nosotr[j - 1]; + if (ns3 != ns1 && ns3 != ns2) { + goto L40; + } +/* L36: */ + } + +L40: + if (ns3 > *nbarpi) { + +/* le sommet ns3 non frontalier va etre supprime */ +/* cc print*,'tesuqm: ntqmin=',ntqmin, */ +/* cc % ' demande la suppression ns3=',ns3 */ + te1stm_(&ns3, nbarpi, &pxyd[4], &noarst[1], mosoar, mxsoar, + n1soar, &nosoar[nosoar_offset], moartr, mxartr, + n1artr, &noartr[noartr_offset], mxarcf, n1arcf, & + noarcf[4], &larmin[1], ¬rcf[1], &liarcf[1], &ierr); +/* cc if( ierr .eq. 0 ) then */ +/* cc print *,'tesuqm: st supprime ns3=',ns3 */ +/* cc else */ +/* cc print *,'tesuqm: ST NON SUPPRIME ns3=',ns3,' ierr=',ierr */ +/* cc endif */ + } + + } + +L100: + ; + } + + return 0; +} /* tesuqm_ */ + +/* Subroutine */ int tritas_(integer *nb, doublereal *a, integer *noanc) +{ + static integer fil, fin, per; + static doublereal aux; + static integer pere, naux, fils1, fils2; + +/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* but : tri croissant du tableau a de nb reels par la methode du tas */ +/* ----- methode due a williams et floyd o(n log n ) */ +/* version avec un pointeur sur un tableau dont est extrait a */ +/* entrees: */ +/* -------- */ +/* nb : nombre de termes du tableau a */ +/* a : les nb reels double precision a trier dans a */ +/* noanc : numero ancien position de l'information (souvent noanc(i)=i) */ + +/* sorties: */ +/* -------- */ +/* a : les nb reels croissants dans a */ +/* noanc : numero ancien position de l'information */ +/* noanc(1)=no position pointeur sur a(1), ... */ +/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ +/* auteur : perronnet alain analyse numerique upmc paris fevrier 1991 */ +/* ...................................................................012 */ + +/* formation du tas sous forme d'un arbre binaire */ + /* Parameter adjustments */ + --noanc; + --a; + + /* Function Body */ + fin = *nb + 1; + + for (pere = *nb / 2; pere >= 1; --pere) { + +/* descendre pere jusqu'a n dans a de facon a respecter */ +/* a(pere)>a(j) pour j fils ou petit fils de pere */ +/* c-a-d pour tout j tel que pere <= e(j/2)= a(j) */ +/* >= a(j+1) */ + +/* protection du pere */ + per = pere; + +/* le fils 1 du pere */ +L10: + fils1 = per << 1; + if (fils1 < fin) { +/* il existe un fils1 */ + fil = fils1; + fils2 = fils1 + 1; + if (fils2 < fin) { +/* il existe 2 fils . selection du plus grand */ + if (a[fils2] > a[fils1]) { + fil = fils2; + } + } + +/* ici fil est le plus grand des fils */ + if (a[per] < a[fil]) { +/* permutation de per et fil */ + aux = a[per]; + a[per] = a[fil]; + a[fil] = aux; +/* le pointeur est aussi permute */ + naux = noanc[per]; + noanc[per] = noanc[fil]; + noanc[fil] = naux; +/* le nouveau pere est le fils permute */ + per = fil; + goto L10; + } + } +/* L20: */ + } + +/* a chaque iteration la racine (plus grande valeur actuelle de a) */ +/* est mise a sa place (fin actuelle du tableau) et permutee avec */ +/* la valeur qui occupe cette place, puis descente de cette nouvelle */ +/* racine pour respecter le fait que tout pere est plus grand que tous */ +/* ses fils */ +/* c-a-d pour tout j tel que pere <= e(j/2)= a(j) */ +/* >= a(j+1) */ + for (fin = *nb; fin >= 2; --fin) { +/* la permutation premier dernier */ + aux = a[fin]; + a[fin] = a[1]; + a[1] = aux; +/* le pointeur est aussi permute */ + naux = noanc[fin]; + noanc[fin] = noanc[1]; + noanc[1] = naux; + +/* descendre a(1) entre 1 et fin */ + per = 1; + +/* le fils 1 du pere */ +L30: + fils1 = per << 1; + if (fils1 < fin) { +/* il existe un fils1 */ + fil = fils1; + fils2 = fils1 + 1; + if (fils2 < fin) { +/* il existe 2 fils . selection du plus grand */ + if (a[fils2] > a[fils1]) { + fil = fils2; + } + } + +/* ici fil est le plus grand des fils */ + if (a[per] < a[fil]) { +/* permutation de per et fil */ + aux = a[per]; + a[per] = a[fil]; + a[fil] = aux; +/* le pointeur est aussi permute */ + naux = noanc[per]; + noanc[per] = noanc[fil]; + noanc[fil] = naux; +/* le nouveau pere est le fils permute */ + per = fil; + goto L30; + } + } +/* L50: */ + } + return 0; +} /* tritas_ */ +