src/tool/Information/infve2.F

   1       subroutine infve2 ( coonoe,
   2      >                    somare, np2are, hetare, merare,
   3      >                    posifa, facare,
   4      >                    aretri, hettri, nivtri, nintri,
   5      >                    voltri, pypetr,
   6      >                    famtri,
   7      >                    arequa, hetqua, nivqua, ninqua,
   8      >                    volqua, pypequ,
   9      >                    famqua,
  10      >                    infsup, typbor, tbaux1,
  11      >                    zoom, xyzmiz, xyzmaz,
  12      >                    tbaux2,
  13      >                    numniv, numblo, nublfa, nubnvo,
  14      >                    nnquvi, nbquvi,
  15      >                    nntrvi, nbtrvi,
  16      >                    nnarvi, nbarvi,
  17      >                    ulsort, langue, codret )
  18 c ______________________________________________________________________
  19 c
  20 c                             H O M A R D
  21 c
  22 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  23 c
  24 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  25 c aupres des huissiers de justice Simart et Lavoir a Clamart
  26 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  27 c aupres des huissiers de justice
  28 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  29 c
  30 c    HOMARD est une marque deposee d'Electricite de France
  31 c
  32 c Copyright EDF 1996
  33 c Copyright EDF 1998
  34 c Copyright EDF 2002
  35 c Copyright EDF 2020
  36 c ______________________________________________________________________
  37 c
  38 c   INformation : Fichier VEctoriel - 2eme partie
  39 c   --            -       --          -
  40 c ______________________________________________________________________
  41 c
  42 c determination de la liste des noeuds des faces et aretes a visualiser
  43 c
  44 c       remarque : en sortie, on dispose de la liste des noeuds
  45 c       decrivant une face a visualiser par ses noeuds.
  46 c       la numerotation precedente des faces correspondantes est
  47 c       oubliee, et une nouvelle numerotation est disponible
  48 c       par defaut grace a l'ordre de sortie des triplets/quadruplets.
  49 c       idem pour les aretes isolees
  50 c ______________________________________________________________________
  51 c .        .     .        .                                            .
  52 c .  nom   . e/s . taille .           description                      .
  53 c .____________________________________________________________________.
  54 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  55 c .        .     . * sdim .                                            .
  56 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  57 c . merare . e   . nbarto . mere de chaque arete                       .
  58 c . np2are . e   . nbarto . numero du noeud p2 milieu de l'arete       .
  59 c . posifa . e   . nbarto . pointeur sur tableau facare                .
  60 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  61 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  62 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  63 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  64 c . nivtri . e   . nbtrto . niveau des triangles                       .
  65 c . nintri . e   . nbtrto . noeud interne au triangle                  .
  66 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  67 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  68 c .        .     .        .   0 : pas de voisin                        .
  69 c .        .     .        . j>0 : tetraedre j                          .
  70 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  71 c . pypetr . e   .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
  72 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  73 c .        .     .        . pypetr(2,j) = numero du pentaedre voisin   .
  74 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  75 c . famtri . e   . nbtrto . famille des triangles                      .
  76 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  77 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  78 c . nivqua . e   . nbquto . niveau des quadrangles                     .
  79 c . ninqua . e   . nbquto . noeud interne au quadrangle                .
  80 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
  81 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  82 c .        .     .        .   0 : pas de voisin                        .
  83 c .        .     .        . j>0 : hexaedre j                           .
  84 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  85 c . pypequ . e   .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
  86 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
  87 c .        .     .        . pypequ(2,j) = numero du pentaedre voisin   .
  88 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
  89 c . famqua . e   . nbquto . famille des quadrangles                    .
  90 c . infsup . e   .   1    . information supplementaire a afficher      .
  91 c .        .     .        . 0 : aucune                                 .
  92 c .        .     .        . 1 : numero homard des noeuds               .
  93 c .        .     .        . 2 : numero du calcul des noeuds            .
  94 c .        .     .        . 3 : numero homard des faces                .
  95 c .        .     .        . 4 : numero du calcul des faces             .
  96 c .        .     .        . 5 : numero homard des aretes               .
  97 c .        .     .        . 6 : numero du calcul des aretes            .
  98 c .        .     .        . np : choix n et choix p simultanement      .
  99 c . typbor . e   .   1    . type d'affichage du bord                   .
 100 c .        .     .        .   0 : pas de trace                         .
 101 c .        .     .        .   1 : trace en rouge                       .
 102 c .        .     .        .   2 : trace en noir                        .
 103 c . tbaux1 . e   . nbftri/. donne un numero equivalent a une famille   .
 104 c .        .     . nbfqua . selon que l'orientation est gardee ou non  .
 105 c . zoom   . e   .   1    . vrai ou faux selon zoom ou non             .
 106 c . xyzmiz . e   .   1    . abscisse (i=1), ordonnee (i=2) et          .
 107 c .        .     .        . cote (i=3) minimales de la fenetre de zoom .
 108 c . xyzmaz . e   .   1    . abscisse (i=1), ordonnee (i=2) et          .
 109 c .        .     .        . cote (i=3) maximales de la fenetre de zoom .
 110 c . tbaux2 . es  .-nbquto:. tableau de travail                         .
 111 c .        .     .nbt/arto.                                            .
 112 c . numniv . e   .   1    . numero du niveau a tracer                  .
 113 c .        .     .        . -1 : tous les niveaux                      .
 114 c . numblo . e   .   1    . numero du bloc a tracer                    .
 115 c .        .     .        . 0 : trace du domaine global                .
 116 c . nublfa . e   .-nbquto:. numero de blocs des faces                  .
 117 c .        .     . nbtrto .                                            .
 118 c . nubnvo . e   .   *    . . si numblo>0 : numero de blocs des volumes.
 119 c .        .     .        . . si numniv >=0 : niveau des volumes       .
 120 c .        .     .        . Rangement :                                .
 121 c .        .     .        . les tetraedres                             .
 122 c .        .     .        . les hexaedres                              .
 123 c .        .     .        . les pyramides                              .
 124 c .        .     .        . les pentaedres                             .
 125 c . nnquvi .   s .12nbquac. 1 : niveau du quadrangle a afficher        .
 126 c .        .     .        . 2 : numero HOMARD du quadrangle            .
 127 c .        .     .        . 3, 4, 5, 6 : numeros des noeuds p1         .
 128 c .        .     .        . 7 : famille du quadrangle                  .
 129 c .        .     .        . 8, 9, 10, 11 : numeros des noeuds p2       .
 130 c .        .     .        . 12 : numero du noeud interne               .
 131 c . nbquvi .   s .   1    . nombre de quadrangles a visualiser         .
 132 c . nntrvi .   s .10nbtrac. 1 : niveau du triangle a afficher          .
 133 c .        .     .        . 2 : numero HOMARD du triangle              .
 134 c .        .     .        . 3, 4, 5 : numeros des noeuds p1            .
 135 c .        .     .        . 6 : famille du triangle                    .
 136 c .        .     .        . 7, 8, 9 : numeros des noeuds p2            .
 137 c .        .     .        . 10 : numero du noeud interne               .
 138 c . nbtrvi .   s .   1    . nombre de triangles a visualiser           .
 139 c . nnarvi .   s .6*nbarto. niveau et numero des aretes a visualiser   .
 140 c .        .     .        . liste des noeuds des aretes a visualiser   .
 141 c . nbarvi .   s .   1    . nombre d'aretes visualisables              .
 142 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 143 c . langue . e   .    1   . langue des messages                        .
 144 c .        .     .        . 1 : francais, 2 : anglais                  .
 145 c . codret . es  .    1   . code de retour des modules                 .
 146 c .        .     .        . 0 : pas de probleme                        .
 147 c ______________________________________________________________________
 148 c
 149 c====
 150 c 0. declarations et dimensionnement
 151 c====
 152 c
 153 c 0.1. ==> generalites
 154 c
 155       implicit none
 156       save
 157 c
 158       character*6 nompro
 159       parameter ( nompro = 'INFVE2' )
 160 c
 161 #include "nblang.h"
 162 c
 163 c 0.2. ==> communs
 164 c
 165 #include "envex1.h"
 166 #include "envca1.h"
 167 #include "envada.h"
 168 #include "impr02.h"
 169 #include "nombno.h"
 170 #include "nombar.h"
 171 #include "nombqu.h"
 172 #include "nombtr.h"
 173 #include "nombte.h"
 174 #include "nombhe.h"
 175 #include "nombpy.h"
 176 #include "nombpe.h"
 177 #include "nbfami.h"
 178 c
 179 c 0.3. ==> arguments
 180 c
 181       double precision coonoe(nbnoto,sdim)
 182 c
 183       integer somare(2,nbarto)
 184       integer np2are(nbarto), merare(nbarto), hetare(nbarto)
 185       integer posifa(0:nbarto), facare(nbfaar)
 186       integer aretri(nbtrto,3), hettri(nbtrto), nivtri(nbtrto)
 187       integer nintri(nbtrto)
 188       integer voltri(2,nbtrto), pypetr(2,*)
 189       integer famtri(nbtrto)
 190       integer arequa(nbquto,4), hetqua(nbquto), nivqua(nbquto)
 191       integer ninqua(nbquto)
 192       integer volqua(2,nbquto), pypequ(2,*)
 193       integer famqua(nbquto)
 194       integer tbaux2(-nbquto:*)
 195       integer nnquvi(12,nbquac), nbquvi
 196       integer nntrvi(10,nbtrac), nbtrvi
 197       integer numniv
 198       integer numblo, nublfa(-nbquto:nbtrto), nubnvo(*)
 199       integer nnarvi(6,nbarto), nbarvi
 200       integer infsup, typbor, tbaux1(*)
 201 c
 202       double precision xyzmiz(sdim), xyzmaz(sdim)
 203 c
 204       logical zoom
 205 c
 206       integer ulsort, langue, codret
 207 c
 208 c 0.4. ==> variables locales
 209 c
 210       integer a1, a2, a3, a4
 211       integer sa1a2, sa2a3, sa3a4, sa4a1, sa3a1
 212       integer larete, letria, lequad, noeudf(4)
 213       integer iaux, jaux, kaux, laux
 214       integer infsu1, infsu2, infsu3
 215       logical avoir
 216 c
 217 #ifdef _DEBUG_HOMARD_
 218       double precision daux(sdim)
 219 #endif
 220 c
 221       integer nbmess
 222       parameter ( nbmess = 10 )
 223       character*80 texte(nblang,nbmess)
 224 c_______________________________________________________________________
 225 c
 226 c====
 227 c 1. prealables
 228 c====
 229 c
 230 #include "impr01.h"
 231 c
 232 #ifdef _DEBUG_HOMARD_
 233       write (ulsort,texte(langue,1)) 'Entree', nompro
 234       call dmflsh (iaux)
 235 #endif
 236 c
 237       texte(1,4) = '(''Nombre de '',a,'' a tracer :'',i10)'
 238 c
 239       texte(2,4) = '(''Number of '',a,'' for plotting:'',i10)'
 240 c
 241 #include "impr03.h"
 242 c
 243 c     a priori, on ne trace rien
 244 c
 245       nbarvi = 0
 246       nbtrvi = 0
 247       nbquvi = 0
 248 c
 249 c====
 250 c 2. Recherche des faces a tracer :
 251 c    On trace une face seulement si elle est active et
 252 c    . si elle appartient a une region bidimensionnelle du maillage, et
 253 c      si elle appartient au bloc ou au niveau retenu
 254 c    . si elle est une face ayant un et un seul element volumique
 255 c      voisin, et si ce volume appartient au bloc ou au niveau retenu
 256 c    . si elle est une face ayant deux elements volumiques voisins,
 257 c      et si un et un seul des volumes appartient au bloc ou au niveau
 258 c      retenu
 259 c
 260 c    La convention est la suivante :
 261 c    * tbaux2(iaux) vaut 0 si la face est d'une region 2D, du bloc ou
 262 c      du niveau retenu
 263 c    * tbaux2(iaux) vaut 1 si la face borde un domaine volumique, du
 264 c      bloc ou du niveau retenu
 265 c    * tbaux2(iaux) vaut 2 si la face est interne a un domaine
 266 c      volumique, un et un seul des voisins appartenant au bloc ou au
 267 c      niveau retenu
 268 c    * tbaux2(iaux) vaut -1 sinon
 269 c    On tracera donc pour tbaux2(iaux) >= 0
 270 c====
 271 c
 272 #ifdef _DEBUG_HOMARD_
 273       write (ulsort,*) '2. recherche des faces a tracer'
 274 #endif
 275 c
 276 c 2.1. ==> A priori, on ne retient rien
 277 c
 278       do 21 , iaux = -nbquto, nbtrto
 279         tbaux2(iaux) = -1
 280    21 continue
 281 c
 282 c 2.2. ==> En l'absence de mailles 3D
 283 c
 284       if ( nbteto.eq.0 .and. nbheto.eq.0 .and.
 285      >     nbpyto.eq.0 .and. nbpeto.eq.0 ) then
 286 c
 287 c 2.2.1. ==> Pour tout le domaine et sans tenir compte des niveaux, on
 288 c            se contente de filtrer sur les actives / inactives
 289 c
 290         if ( numblo.eq.0 .and. numniv.eq.-1 ) then
 291 c
 292           do 221 , iaux = -nbquto, -1
 293             if ( mod(hetqua(-iaux),100).eq.0 ) then
 294               tbaux2(iaux) = 0
 295             endif
 296   221     continue
 297 c
 298           do 212 , iaux = 1, nbtrto
 299             if ( mod(hettri(iaux),10).eq.0 ) then
 300               tbaux2(iaux) = 0
 301             endif
 302   212     continue
 303 c
 304 c 2.1.2. ==> Avec un bloc, on filtre aussi sur ce bloc
 305 c
 306         elseif ( numblo.gt.0 ) then
 307 c
 308           do 213 , iaux = -nbquto, -1
 309             if ( mod(hetqua(-iaux),100).eq.0 ) then
 310               if ( nublfa(iaux).eq.numblo ) then
 311                 tbaux2(iaux) = 0
 312               endif
 313             endif
 314   213     continue
 315 c
 316           do 214 , iaux = 1, nbtrto
 317             if ( mod(hettri(iaux),10).eq.0 ) then
 318               if ( nublfa(iaux).eq.numblo ) then
 319                 tbaux2(iaux) = 0
 320               endif
 321             endif
 322   214     continue
 323 c
 324 c 2.1.2. ==> Avec un niveau, on filtre aussi sur ce niveau
 325 c
 326         else
 327 c
 328           do 215 , iaux = -nbquto, -1
 329             if ( mod(hetqua(-iaux),100).eq.0 ) then
 330               if ( nivqua(iaux).eq.numniv ) then
 331                 tbaux2(iaux) = 0
 332               endif
 333             endif
 334   215     continue
 335 c
 336           do 216 , iaux = 1, nbtrto
 337             if ( mod(hettri(iaux),10).eq.0 ) then
 338               if ( nivtri(iaux).eq.numniv ) then
 339                 tbaux2(iaux) = 0
 340               endif
 341             endif
 342   216     continue
 343 c
 344         endif
 345 c
 346       endif
 347 c
 348 c 2.2 ==> En presence d'elements volumiques
 349 c 2.2.1. ==> Les triangles
 350 c
 351       if ( codret.eq.0 ) then
 352 c
 353       if ( nbteto.gt.0 .or. nbpyto.gt.0 .or. nbpeto.gt.0 ) then
 354 c
 355 #ifdef _DEBUG_HOMARD_
 356       write (ulsort,texte(langue,3)) 'INFVE5_tr', nompro
 357 #endif
 358         iaux = 2
 359         call infve5 ( iaux, nbtrto, voltri, pypetr,
 360      >                hettri,
 361      >                numniv, numblo, nubnvo,
 362      >                tbaux2,
 363      >                ulsort, langue, codret )
 364 c
 365       endif
 366 c
 367       endif
 368 c
 369 c 2.2.2. ==> Les quadrangles
 370 c
 371       if ( codret.eq.0 ) then
 372 c
 373       if ( nbheto.gt.0 .or. nbpyto.gt.0 .or. nbpeto.gt.0 ) then
 374 c
 375 #ifdef _DEBUG_HOMARD_
 376       write (ulsort,texte(langue,3)) 'INFVE5_qu', nompro
 377 #endif
 378         iaux = 4
 379         call infve5 ( iaux, nbquto, volqua, pypequ,
 380      >                hetqua,
 381      >                numniv, numblo, nubnvo,
 382      >                tbaux2,
 383      >                ulsort, langue, codret )
 384 c
 385       endif
 386 c
 387       endif
 388 c
 389 c====
 390 c 3. caracteristiques associees aux triangles a tracer
 391 c====
 392 c
 393 #ifdef _DEBUG_HOMARD_
 394       write (ulsort,*) '3. caracteristiques des tria a tracer'
 395 #endif
 396 c
 397 c 3.1. ==> prealable : on etablit le tableau de correspondance des
 398 c          familles.
 399 c          on indique simplement le numero de la famille.
 400 c
 401 c          iaux : numero de la famille en cours d'examen
 402 c          jaux : nombre de familles equivalentes etablies
 403 c          kaux : numero des familles a comparer
 404 c          laux : numero des codes a comparer
 405 c          famille courante iaux
 406 c
 407       if ( codret.eq.0 ) then
 408 c
 409       do 31 , iaux = 1 , nbftri
 410         tbaux1(iaux) = iaux
 411    31 continue
 412 c
 413       do 30 , letria = 1 , nbtrto
 414 c
 415         if ( tbaux2(letria).ge.0 ) then
 416 c
 417           avoir = .true.
 418 c
 419 c 3.2. ==> on cherche les sommets
 420 c
 421           a1 = aretri(letria,1)
 422           a2 = aretri(letria,2)
 423           a3 = aretri(letria,3)
 424 c
 425           call utsotr ( somare, a1, a2, a3,
 426      >                  sa1a2, sa2a3, sa3a1 )
 427 c
 428           noeudf(1) = sa1a2
 429           noeudf(2) = sa2a3
 430           noeudf(3) = sa3a1
 431 c
 432 c 3.3. ==> on cherche si au moins un des noeuds est a l'interieur
 433 c          de la fenetre de zoom
 434 c
 435           if ( zoom ) then
 436 c
 437             avoir = .false.
 438 c
 439             do 33 , iaux = 1 , 3
 440               kaux = 0
 441               do 331 , jaux = 1 , sdim
 442                 if ( coonoe(noeudf(iaux),jaux).ge.xyzmiz(jaux) .and.
 443      >               coonoe(noeudf(iaux),jaux).le.xyzmaz(jaux) ) then
 444                   kaux = kaux + 1
 445                 endif
 446   331         continue
 447               if ( kaux.eq.sdim ) then
 448                 avoir = .true.
 449                 goto 332
 450               endif
 451    33       continue
 452 c
 453   332       continue
 454 c
 455           endif
 456 c
 457 c 3.4. ==> Si le triangle est retenu, filtrage eventuel pour deboggage
 458 c
 459 #ifdef _DEBUG_HOMARD_
 460           if ( avoir ) then
 461 c
 462             do 34 , jaux = 1 , sdim
 463               daux(jaux) = 0.d0
 464               do 341 , iaux = 1 , 3
 465                 daux(jaux) = daux(jaux) + coonoe(noeudf(iaux),jaux)
 466   341         continue
 467               daux(jaux) = daux(jaux)/3.d0
 468    34       continue
 469 cgn            print *,daux
 470 c
 471             if ( abs(daux(1)-6.d-2).lt.1.d-5 ) then
 472               avoir = .false.
 473             elseif ( abs(daux(1)-4.d-2).lt.1.d-5 ) then
 474               avoir = .false.
 475             elseif ( abs(daux(2)-1.5d-2).lt.1.d-5 ) then
 476               avoir = .false.
 477             elseif ( abs(daux(3)-0.0d-2).lt.1.d-5 ) then
 478               avoir = .false.
 479             elseif ( abs(daux(3)-1.5d-2).lt.1.d-5 ) then
 480               avoir = .false.
 481             endif
 482 c
 483           endif
 484 #endif
 485 c
 486 c 3.5. ==> Si le triangle est retenu, on le memorise ainsi que
 487 c          son niveau, sa famille, et on stocke ses trois sommets.
 488 c          En degre 2, on stocke les 3 noeuds milieux. Attention a
 489 c          les placer en coherence avec l'ordre des sommets ...
 490 c
 491           if ( avoir ) then
 492 c
 493             nbtrvi = nbtrvi + 1
 494 c
 495             nntrvi(1,nbtrvi) = nivtri(letria)
 496             nntrvi(2,nbtrvi) = letria
 497             nntrvi(3,nbtrvi) = noeudf(1)
 498             nntrvi(4,nbtrvi) = noeudf(2)
 499             nntrvi(5,nbtrvi) = noeudf(3)
 500             nntrvi(6,nbtrvi) = tbaux1(famtri(letria))
 501             if ( degre.eq.2 ) then
 502               nntrvi(7,nbtrvi) = np2are(aretri(letria,2))
 503               nntrvi(8,nbtrvi) = np2are(aretri(letria,3))
 504               nntrvi(9,nbtrvi) = np2are(aretri(letria,1))
 505             endif
 506             if ( mod(mailet,2).eq.0 ) then
 507               nntrvi(10,nbtrvi) = nintri(letria)
 508             endif
 509 c
 510           endif
 511 c
 512         endif
 513 c
 514   30  continue
 515 c
 516 #ifdef _DEBUG_HOMARD_
 517       write (ulsort,texte(langue,4)) mess14(langue,3,2), nbtrvi
 518 #endif
 519 c
 520       endif
 521 c
 522 c====
 523 c 4. caracteristiques associees aux quadrangles a tracer
 524 c====
 525 c
 526 #ifdef _DEBUG_HOMARD_
 527       write (ulsort,*) '4. caracteristiques des quad a tracer'
 528 #endif
 529 c
 530       if ( codret.eq.0 ) then
 531 c
 532 c 4.1. ==> prealable : on etablit le tableau de correspondance des
 533 c          familles.
 534 c          on indique simplement le numero de la famille.
 535 c
 536 c          iaux : numero de la famille en cours d'examen
 537 c          jaux : nombre de familles equivalentes etablies
 538 c          kaux : numero des familles a comparer
 539 c          laux : numero des codes a comparer
 540 c          famille courante iaux
 541 c
 542       do 41 , iaux = 1 , nbfqua
 543         tbaux1(iaux) = iaux
 544    41 continue
 545 c
 546       do 40 , lequad = 1 , nbquto
 547 c
 548         if ( tbaux2(-lequad).ge.0 ) then
 549 c
 550           avoir = .true.
 551 c
 552 c 4.2. ==> on cherche les sommets
 553 c
 554           a1 = arequa(lequad,1)
 555           a2 = arequa(lequad,2)
 556           a3 = arequa(lequad,3)
 557           a4 = arequa(lequad,4)
 558 c
 559           call utsoqu ( somare, a1, a2, a3, a4,
 560      >                  sa1a2, sa2a3, sa3a4, sa4a1 )
 561 c
 562           noeudf(1) = sa1a2
 563           noeudf(2) = sa2a3
 564           noeudf(3) = sa3a4
 565           noeudf(4) = sa4a1
 566 c
 567 c 4.3. ==> on cherche si au moins un des noeuds est a l'interieur
 568 c          de la fenetre de zoom
 569 c
 570           if ( zoom ) then
 571 c
 572             avoir = .false.
 573 c
 574             do 43 , iaux = 1 , 4
 575               kaux = 0
 576               do 431 , jaux = 1 , sdim
 577                 if ( coonoe(noeudf(iaux),jaux).ge.xyzmiz(jaux) .and.
 578      >               coonoe(noeudf(iaux),jaux).le.xyzmaz(jaux) ) then
 579                   kaux = kaux + 1
 580                 endif
 581   431         continue
 582               if ( kaux.eq.sdim ) then
 583                 avoir = .true.
 584                 goto 432
 585               endif
 586    43       continue
 587 c
 588   432       continue
 589 c
 590           endif
 591 c
 592 c 4.4. ==> Si le quadrangle est retenu, filtrage eventuel pour deboggage
 593 c
 594 #ifdef _DEBUG_HOMARD_
 595           if ( avoir ) then
 596 c
 597             do 44 , jaux = 1 , sdim
 598               daux(jaux) = 0.d0
 599               do 441 , iaux = 1 , 4
 600                 daux(jaux) = daux(jaux) + coonoe(noeudf(iaux),jaux)
 601   441         continue
 602               daux(jaux) = daux(jaux)/4.d0
 603    44       continue
 604 c
 605             if ( abs(daux(1)-6.d-2).lt.1.d-5 ) then
 606               avoir = .false.
 607             elseif ( abs(daux(1)-4.d-2).lt.1.d-5 ) then
 608               avoir = .false.
 609             elseif ( abs(daux(2)-1.5d-2).lt.1.d-5 ) then
 610               avoir = .false.
 611             elseif ( abs(daux(3)-0.0d-2).lt.1.d-5 ) then
 612               avoir = .false.
 613             elseif ( abs(daux(3)-1.5d-2).lt.1.d-5 ) then
 614               avoir = .false.
 615             endif
 616 c
 617           endif
 618 #endif
 619 c
 620 c 4.5. ==> Si le quadrangle est retenu, on le memorise ainsi que
 621 c          son niveau, sa famille, et on stocke ses quatre sommets.
 622 c          En degre 2, on stocke les 4 noeuds milieux. Attention a
 623 c          les placer en coherence avec l'ordre des sommets ...
 624 c
 625           if ( avoir ) then
 626 c
 627             nbquvi = nbquvi + 1
 628 cgn      write (ulsort,*) 'quadrangle ',lequad,' de niveau ',nivqua(lequad)
 629 c
 630             nnquvi(1,nbquvi) = nivqua(lequad)
 631             nnquvi(2,nbquvi) = lequad
 632             nnquvi(3,nbquvi) = noeudf(1)
 633             nnquvi(4,nbquvi) = noeudf(2)
 634             nnquvi(5,nbquvi) = noeudf(3)
 635             nnquvi(6,nbquvi) = noeudf(4)
 636             nnquvi(7,nbquvi) = tbaux1(famqua(lequad))
 637             if ( degre.eq.2 ) then
 638               nnquvi( 8,nbquvi) = np2are(arequa(lequad,2))
 639               nnquvi( 9,nbquvi) = np2are(arequa(lequad,3))
 640               nnquvi(10,nbquvi) = np2are(arequa(lequad,4))
 641               nnquvi(11,nbquvi) = np2are(arequa(lequad,1))
 642             endif
 643             if ( mod(mailet,3).eq.0 ) then
 644               nnquvi(12,nbquvi) = ninqua(lequad)
 645             endif
 646 c
 647           endif
 648 c
 649         endif
 650 c
 651   40  continue
 652
 653 #ifdef _DEBUG_HOMARD_
 654       write (ulsort,texte(langue,4)) mess14(langue,3,4), nbquvi
 655 #endif
 656 c
 657       endif
 658 c
 659 c====
 660 c 5. recherche des aretes a tracer si on a demande le trace des bords
 661 c
 662 c    Une arete a tracer a au plus une face voisine
 663 c
 664 c    la convention est la suivante :
 665 c    * tbaux2(iaux) vaut 0 si l'arete est isolee et est active ;
 666 c    * tbaux2(iaux) vaut 1 si l'arete est un bord de face active ;
 667 c    * tbaux2(iaux) vaut 2 sinon.
 668 c====
 669 c
 670 #ifdef _DEBUG_HOMARD_
 671       write (ulsort,*) '5. recherche des aretes a tracer'
 672 #endif
 673 c
 674       if ( numblo.eq.0 .and. numniv.eq.-1 ) then
 675 c
 676       if ( codret.eq.0 ) then
 677 c
 678 c 5.1. ==> on repere les aretes isolees actives ; pour les autres, on
 679 c          les oublie
 680 c
 681       do 51 , larete = 1 , nbarto
 682 cgn            print *,hetare(larete),posifa(larete-1),posifa(larete)
 683         if ( mod(hetare(larete),10).eq.0 .and.
 684      >       posifa(larete).eq.posifa(larete-1) ) then
 685           tbaux2(larete) = 0
 686         else
 687           tbaux2(larete) = 2
 688         endif
 689 cgn              print *,'===> tbaux2(,',larete,') = ',tbaux2(larete)
 690    51 continue
 691 c
 692 c 5.2. ==> recherche des bords eventuels de faces actives
 693 c          attention aux voisinages multiples dus aux conformites
 694 c
 695       if ( typbor.gt.0 ) then
 696 c
 697         do 521 , larete = 1 , nbarto
 698           jaux = 0
 699           do 522 , iaux = posifa(larete-1)+1, posifa(larete)
 700             kaux = facare(iaux)
 701             if ( kaux.gt.0 ) then
 702               if ( mod(hettri(kaux),10).eq.0 ) then
 703                 jaux = jaux + 1
 704               endif
 705             else
 706               if ( mod(hetqua(-kaux),100).eq.0 ) then
 707                 jaux = jaux + 1
 708               endif
 709             endif
 710   522     continue
 711           if ( jaux.eq.1 ) then
 712             tbaux2(larete) = 1
 713           endif
 714   521   continue
 715 c
 716       endif
 717 c
 718       endif
 719 c
 720       endif
 721 c
 722 c====
 723 c 6. recherche des noeuds associes aux aretes retenues
 724 c    methode : on boucle sur toutes les aretes retenues en ne
 725 c              considerant que les actives.
 726 c              pour celles-la, on recupere les 2 sommets
 727 c====
 728 c
 729 #ifdef _DEBUG_HOMARD_
 730       write (ulsort,*) '6. recherche des noeuds associes aux aretes'
 731 #endif
 732 c
 733       if ( ( numblo.eq.0 .and. numniv.eq.-1 ) .or.
 734      >     ( typbor.gt.0 ) ) then
 735 c
 736       if ( codret.eq.0 ) then
 737 c
 738       infsu1 = mod(infsup,10)
 739       if ( infsup.ge.10 ) then
 740         iaux = ( infsup-infsu1 ) / 10
 741         infsu2 = mod(iaux,10)
 742         if ( iaux.ge.10 ) then
 743           infsu3 = ( iaux-infsu2 ) / 10
 744         else
 745           infsu3 = 0
 746         endif
 747       else
 748         infsu2 = 0
 749         infsu3 = 0
 750       endif
 751 c
 752       if ( ( infsu1.ge.5 .and. infsu1.le.6 ) .or.
 753      >     ( infsu2.ge.5 .and. infsu2.le.6 ) .or.
 754      >     ( infsu3.ge.5 .and. infsu3.le.6 ) ) then
 755         laux = 1
 756       else
 757         laux = 0
 758       endif
 759 c
 760       avoir = .true.
 761       do 60 , larete = 1 , nbarto
 762 c
 763 c       dans le cas ou l'arete "est active" et "est a tracer"
 764 c
 765         if ( tbaux2(larete).le.1 .or.
 766      >       ( laux.eq.1 .and. mod(hetare(larete),10).eq.0 ) ) then
 767 c
 768 c 6.1. ==> on memorise les deux noeuds
 769 c
 770           noeudf(1) = somare ( 1, larete )
 771           noeudf(2) = somare ( 2, larete )
 772 c
 773 c 6.3. ==> on cherche si au moins un des noeuds est a l'interieur
 774 c          de la fenetre de zoom
 775 c
 776           if ( zoom ) then
 777 c
 778             avoir = .false.
 779 c
 780             do 62 , iaux = 1 , 2
 781               kaux = 0
 782               do 621 , jaux = 1 , sdim
 783                 if ( coonoe(noeudf(iaux),jaux).ge.xyzmiz(jaux) .and.
 784      >               coonoe(noeudf(iaux),jaux).le.xyzmaz(jaux) ) then
 785                   kaux = kaux + 1
 786                 endif
 787   621         continue
 788               if ( kaux.eq.sdim ) then
 789                 avoir = .true.
 790                 goto 622
 791               endif
 792    62       continue
 793 c
 794   622       continue
 795 c
 796           endif
 797 c
 798 c 6.4. ==> Si l'arete est retenue, on la memorise, ainsi que son niveau
 799 c          et ses noeuds extremes.
 800 c          En degre 2, on stocke le noeud milieu
 801 c
 802           if ( avoir ) then
 803 c
 804             nbarvi = nbarvi + 1
 805 c
 806             jaux = larete
 807             do 64 , iaux = 0 , nivsup
 808               if ( merare(jaux).eq.0 ) then
 809                 nnarvi(1,nbarvi) = iaux
 810                 goto 641
 811               endif
 812               jaux = merare(jaux)
 813    64       continue
 814   641       continue
 815             nnarvi(2,nbarvi) = larete
 816             nnarvi(3,nbarvi) = noeudf(1)
 817             nnarvi(4,nbarvi) = noeudf(2)
 818             nnarvi(5,nbarvi) = tbaux2(larete)
 819 c            if ( tbaux2(larete).eq.1 ) then
 820 c              nnarvi(5,nbarvi) = 1
 821 c            else
 822 c              nnarvi(5,nbarvi) = 0
 823 c            endif
 824             if ( degre.eq.2 ) then
 825               nnarvi(6,nbarvi) = np2are(larete)
 826             endif
 827 c
 828           endif
 829 c
 830         endif
 831 c
 832   60  continue
 833 c
 834 #ifdef _DEBUG_HOMARD_
 835       if ( codret.eq.0 ) then
 836       write (ulsort,texte(langue,4)) mess14(langue,3,1), nbarvi
 837       endif
 838 #endif
 839 c
 840       endif
 841 c
 842       endif
 843 c
 844 c====
 845 c 7. la fin
 846 c====
 847 c
 848       if ( codret.ne.0 ) then
 849 c
 850 #include "envex2.h"
 851 c
 852       write (ulsort,texte(langue,1)) 'Sortie', nompro
 853       write (ulsort,texte(langue,2)) codret
 854 c
 855       endif
 856 c
 857 #ifdef _DEBUG_HOMARD_
 858       write (ulsort,texte(langue,1)) 'Sortie', nompro
 859       call dmflsh (iaux)
 860 #endif
 861 c
 862       end