src/tool/Utilitaire/utb11b.F

   1       subroutine utb11b ( nbbloc,
   2      >                    hetare, somare,
   3      >                    hettri, aretri,
   4      >                    hetqua, arequa,
   5      >                    hettet, tritet,
   6      >                    hethex, quahex,
   7      >                    hetpyr, facpyr,
   8      >                    hetpen, facpen,
   9      >                    povoso, voisom,
  10      >                    posifa, facare,
  11      >                    voltri, pypetr,
  12      >                    volqua, pypequ,
  13      >                    famare, cfaare,
  14      >                    famtri, cfatri,
  15      >                    famqua, cfaqua,
  16      >                    famtet, cfatet,
  17      >                    famhex, cfahex,
  18      >                    fampyr, cfapyr,
  19      >                    fampen, cfapen,
  20      >                    lapile, tabau2, tabau3, tabau4,
  21      >                    taba11, taba12, taba13, taba14,
  22      >                    taba15, taba16,
  23      >                    nublvo,
  24      >                    ulbila,
  25      >                    ulsort, langue, codret )
  26 c ______________________________________________________________________
  27 c
  28 c                             H O M A R D
  29 c
  30 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  31 c
  32 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  33 c aupres des huissiers de justice Simart et Lavoir a Clamart
  34 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  35 c aupres des huissiers de justice
  36 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  37 c
  38 c    HOMARD est une marque deposee d'Electricite de France
  39 c
  40 c Copyright EDF 1996
  41 c Copyright EDF 1998
  42 c Copyright EDF 2002
  43 c Copyright EDF 2020
  44 c ______________________________________________________________________
  45 c
  46 c    UTilitaire - Bilan sur le maillage - option 11 - phase b
  47 c    --           -                              --         -
  48 c ______________________________________________________________________
  49 c
  50 c    analyse de la connexite des volumes
  51 c remarque : on s'est arrange pour que les mailles externes soient
  52 c            numerotes dans cet ordre :
  53 c            . les tetraedres
  54 c            . les triangles
  55 c            . les aretes
  56 c            . les mailles-points
  57 c            . les quadrangles
  58 c            . les hexaedres
  59 c            . les pyramides
  60 c            . les pentaedres
  61 c ______________________________________________________________________
  62 c .        .     .        .                                            .
  63 c .  nom   . e/s . taille .           description                      .
  64 c .____________________________________________________________________.
  65 c . nbbloc .  s  .   1    . nombre de blocs                            .
  66 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  67 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  68 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  69 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  70 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  71 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  72 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  73 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  74 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  75 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  76 c . hetpyr . e   . nbpyto . historique de l'etat des pyramides         .
  77 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  78 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  79 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  80 c . povoso . e   .0:nbnoto. pointeur des voisins par noeud             .
  81 c . voisom . e   . nvosom . aretes voisines de chaque noeud            .
  82 c . posifa . e   .0:nbarto. pointeur sur tableau facare                .
  83 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  84 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  85 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  86 c .        .     .        .   0 : pas de voisin                        .
  87 c .        .     .        . j>0 : tetraedre j                          .
  88 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  89 c . pypetr . e   .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
  90 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  91 c .        .     .        . pypetr(2,j) = numero du pentaedre voisin   .
  92 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  93 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
  94 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  95 c .        .     .        .   0 : pas de voisin                        .
  96 c .        .     .        . j>0 : hexaedre j                           .
  97 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  98 c . pypequ . e   .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
  99 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
 100 c .        .     .        . pypequ(2,j) = numero du pentaedre voisin   .
 101 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
 102 c . famare . e   . nbarto . famille des aretes                         .
 103 c . cfaare . e   . nctfar*. codes des familles des aretes              .
 104 c . famtri . e   . nbtrto . famille des triangles                      .
 105 c . cfatri . e   . nctftr*. codes des familles des triangles           .
 106 c .        .     . nbftri .   1 : famille MED                          .
 107 c .        .     .        .   2 : type de triangle                     .
 108 c .        .     .        .   3 : numero de surface de frontiere       .
 109 c .        .     .        .   4 : famille des aretes internes apres raf.
 110 c .        .     .        . + l : appartenance a l'equivalence l       .
 111 c . famqua . e   . nbquto . famille des quadrangles                    .
 112 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
 113 c .        .     . nbfqua .   1 : famille MED                          .
 114 c .        .     .        .   2 : type de quadrangle                   .
 115 c .        .     .        .   3 : numero de surface de frontiere       .
 116 c .        .     .        .   4 : famille des aretes internes apres raf.
 117 c .        .     .        .   5 : famille des triangles de conformite  .
 118 c .        .     .        .   6 : famille de sf active/inactive        .
 119 c .        .     .        . + l : appartenance a l'equivalence l       .
 120 c . famtet . e   . nbteto . famille des tetraedres                     .
 121 c . cfatet .     . nctfte*. codes des familles des tetraedres          .
 122 c .        .     . nbftet .   1 : famille MED                          .
 123 c .        .     .        .   2 : type de tetraedres                   .
 124 c . famhex . e   . nbheto . famille des hexaedres                      .
 125 c . cfahex .     . nctfhe*. codes des familles des hexaedres           .
 126 c .        .     . nbfhex .   1 : famille MED                          .
 127 c .        .     .        .   2 : type d'hexaedres                     .
 128 c .        .     .        .   3 : famille des tetraedres de conformite .
 129 c .        .     .        .   4 : famille des pyramides de conformite  .
 130 c . fampyr . e   . nbpyto . famille des pyramides                      .
 131 c . cfapyr .     . nctfpy*. codes des familles des pyramides           .
 132 c .        .     . nbfpyr .   1 : famille MED                          .
 133 c .        .     .        .   2 : type de pyramides                    .
 134 c . fampen . e   . nbpeto . famille des pentaedres                     .
 135 c . cfapen .     . nctfpe*. codes des familles des pentaedres          .
 136 c .        .     . nbfpen .   1 : famille MED                          .
 137 c .        .     .        .   2 : type de pentaedres                   .
 138 c .        .     .        .   3 : famille des tetraedres de conformite .
 139 c .        .     .        .   4 : famille des pyramides de conformite  .
 140 c . lapile .  a  .   *    . tableau de travail                         .
 141 c . tabau2 .  a  . nbnoto . tableau de travail                         .
 142 c . tabau3 .  a  . nbarto . tableau de travail                         .
 143 c . tabau4 .  a  .-nbquto . tableau de travail                         .
 144 c .        .     . :nbtrto.                                            .
 145 c . taba11 .  a  .    *   . tableau de travail                         .
 146 c . taba12 .  a  . nbnoto . tableau de travail                         .
 147 c . taba13 .  a  . nbarto . tableau de travail                         .
 148 c . taba14 .  a  .    *   . tableau de travail                         .
 149 c . taba15 .  a  . nbarto . tableau de travail                         .
 150 c . taba16 .  a  .   *    . tableau de travail                         .
 151 c . nublvo .  s  .   *    . numero de blocs des volumes, ranges ainsi :.
 152 c .        .     .        . les tetraedres                             .
 153 c .        .     .        . les hexaedres                              .
 154 c .        .     .        . les pyramides                              .
 155 c .        .     .        . les pentaedres                             .
 156 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
 157 c .        .     .        . si 0 : on n'ecrit rien                     .
 158 c . ulsort . e   .   1    . unite logique de la sortie generale        .
 159 c . langue . e   .    1   . langue des messages                        .
 160 c .        .     .        . 1 : francais, 2 : anglais                  .
 161 c . codret .  s  .    1   . code de retour des modules                 .
 162 c .        .     .        . 0 : pas de probleme                        .
 163 c .        .     .        . 1 : probleme                               .
 164 c .____________________________________________________________________.
 165 c
 166 c====
 167 c 0. declarations et dimensionnement
 168 c====
 169 c
 170 c 0.1. ==> generalites
 171 c
 172       implicit none
 173       save
 174 c
 175       character*6 nompro
 176       parameter ( nompro = 'UTB11B' )
 177 c
 178 #include "nblang.h"
 179 #include "coftex.h"
 180 c
 181 c 0.2. ==> communs
 182 c
 183 #include "envex1.h"
 184 #include "nbfami.h"
 185 #include "nombno.h"
 186 #include "nombar.h"
 187 #include "nombtr.h"
 188 #include "nombqu.h"
 189 #include "nombte.h"
 190 #include "nombpy.h"
 191 #include "nombhe.h"
 192 #include "nombpe.h"
 193 c
 194 #include "dicfen.h"
 195 #include "impr02.h"
 196 c
 197 c 0.3. ==> arguments
 198 c
 199       integer nbbloc
 200       integer hetare(nbarto), somare(2,nbarto)
 201       integer hettri(nbtrto), aretri(nbtrto,3)
 202       integer hetqua(nbquto), arequa(nbquto,4)
 203       integer hettet(nbteto), tritet(nbtecf,4)
 204       integer hethex(nbheto), quahex(nbhecf,6)
 205       integer hetpyr(nbpyto), facpyr(nbpycf,5)
 206       integer hetpen(nbpeto), facpen(nbpecf,5)
 207       integer posifa(0:nbarto), facare(nbfaar)
 208       integer povoso(0:nbnoto), voisom(*)
 209       integer voltri(2,nbtrto), pypetr(2,*)
 210       integer volqua(2,nbquto), pypequ(2,*)
 211 c
 212       integer famare(nbarto), cfaare(nctfar,nbfare)
 213       integer famtri(nbtrto), cfatri(nctftr,nbftri)
 214       integer famqua(nbquto), cfaqua(nctfqu,nbfqua)
 215       integer famtet(nbteto), cfatet(nctfte,nbftet)
 216       integer famhex(nbheto), cfahex(nctfhe,nbfhex)
 217       integer fampyr(nbpyto), cfapyr(nctfpy,nbfpyr)
 218       integer fampen(nbpeto), cfapen(nctfpe,nbfpen)
 219 c
 220       integer lapile(*)
 221       integer tabau2(nbnoto)
 222       integer tabau3(nbarto)
 223       integer tabau4(-nbquto:*)
 224       integer taba11(*)
 225       integer taba12(nbnoto)
 226       integer taba13(nbarto)
 227       integer taba14(*)
 228       integer taba15(nbarto)
 229       integer taba16(*)
 230       integer nublvo(*)
 231 c
 232       integer ulbila
 233       integer ulsort, langue, codret
 234 c
 235 c 0.4. ==> variables locales
 236 c
 237       integer iaux, jaux, kaux, laux, maux
 238       integer tbiaux(1)
 239       integer levolu, nument, typvo0, typvol
 240       integer etat
 241       integer lamail, lgpile
 242       integer maxtet, maxhex, maxpyr, maxpen
 243       integer dectet, dechex, decpyr, decpen
 244       integer lapyra, lepent
 245       integer nbblfa
 246 #ifdef _DEBUG_HOMARD_
 247       integer glop
 248       integer typenh
 249 #endif
 250 c
 251       integer nbmess
 252       parameter (nbmess = 10 )
 253       character*80 texte(nblang,nbmess)
 254 c
 255 c====
 256 c 1. initialisations
 257 c====
 258 c
 259 #include "impr01.h"
 260 c
 261 #ifdef _DEBUG_HOMARD_
 262       write (ulsort,texte(langue,1)) 'Entree', nompro
 263       call dmflsh (iaux)
 264 #endif
 265 c
 266 c 1.1. ==> Les messages
 267 c
 268       texte(1,4) = '(/,3x,''. Connexite des '',a)'
 269       texte(1,5) =
 270      >'(5x,''* Les '',a,'' sont en un seul bloc.'',15x,''*'')'
 271       texte(1,6) =
 272      >'(5x,''*'',19x,''Blocs de '',a,14x,''*'')'
 273       texte(1,7) =
 274      >'(5x,''* Bloc numero '',i8,5x,'' * '',i11,1x,a,'' *'')'
 275       texte(1,8) =
 276      >'(5x,''*    Nombre d''''Euler (2+V-F+A-S) :'',i5,19x,''*'')'
 277       texte(1,9) = '(''.. Nombre de blocs de '',a,'':'',i5)'
 278       texte(1,10) = '(''.. Impression du bloc'',i8)'
 279 c
 280       texte(2,4) = '(/,3x,''. Connexity of '',a)'
 281       texte(2,5) =
 282      >'(5x,''* All the '',a,'' are connected.'',18x,''*'')'
 283       texte(2,6) =
 284      >'(5x,''*'',19x,''Blocks of '',a,13x,''*'')'
 285       texte(2,7) =
 286      >'(5x,''* Block # '',i8,9x,'' * '',i11,1x,a,'' *'')'
 287       texte(2,8) =
 288      >'(5x,''*    Euler characteristic (2+V-F+A-S):'',i5,14x,''*'')'
 289       texte(2,9) = '(''.. Number of blocks of '',a,'':'',i5)'
 290       texte(2,10) = '(''.. Printing of block #'',i8)'
 291 c
 292 #include "impr03.h"
 293 cgn      print 91020,(voltri(1,iaux),iaux=1,nbtrto)
 294 cgn      print 91020,(voltri(2,iaux),iaux=1,nbtrto)
 295 cgn      print 91020,(pypetr(1,iaux),iaux=1,16)
 296 cgn      print 91020,(pypetr(2,iaux),iaux=1,56)
 297 cgn      print 91020,(pypequ(1,iaux),iaux=1,4)
 298 cgn      print 91020,(pypequ(2,iaux),iaux=1,14)
 299 c
 300 10100 format(/,5x,58('*'))
 301 10200 format(  5x,58('*'))
 302 c
 303 c 1.2. ==> constantes
 304 c
 305       if ( nbpyac.eq.0 .and. nbheac.eq.0 .and. nbpeac.eq.0 ) then
 306         typvo0 = 3
 307       elseif ( nbheac.eq.0 .and. nbpeac.eq.0 .and. nbteac.eq.0 ) then
 308         typvo0 = 5
 309       elseif ( nbpeac.eq.0 .and. nbteac.eq.0 .and. nbpyac.eq.0 ) then
 310         typvo0 = 6
 311       elseif ( nbteac.eq.0 .and. nbpyac.eq.0 .and. nbheac.eq.0 ) then
 312         typvo0 = 7
 313       else
 314         typvo0 = 9
 315       endif
 316 c
 317 #ifdef _DEBUG_HOMARD_
 318       if ( ulbila.gt.0 ) then
 319         write (ulsort,texte(langue,4)) mess14(langue,3,typvo0)
 320       endif
 321 #endif
 322 c
 323 #ifdef _DEBUG_HOMARD_
 324       write (ulsort,90002) 'nbteto, nbtecf, nbteca',
 325      >                      nbteto, nbtecf, nbteca
 326       write (ulsort,90002) 'nbheto, nbhecf, nbheca',
 327      >                      nbheto, nbhecf, nbheca
 328       write (ulsort,90002) 'nbpyto, nbpycf, nbpyca',
 329      >                      nbpyto, nbpycf, nbpyca
 330       write (ulsort,90002) 'nbpeto, nbpecf, nbpeca',
 331      >                      nbpeto, nbpecf, nbpeca
 332 #endif
 333 c
 334       dectet = 0
 335       maxtet = dectet + nbteto
 336       dechex = maxtet
 337       maxhex = dechex + nbheto
 338       decpyr = maxhex
 339       maxpyr = decpyr + nbpyto
 340       decpen = maxpyr
 341       maxpen = decpen + nbpeto
 342 c
 343 #ifdef _DEBUG_HOMARD_
 344       write (ulsort,90015) 'dectet', dectet, ', maxtet', maxtet
 345       write (ulsort,90015) 'dechex', dechex, ', maxhex', maxhex
 346       write (ulsort,90015) 'decpyr', decpyr, ', maxpyr', maxpyr
 347       write (ulsort,90015) 'decpen', decpen, ', maxpen', maxpen
 348 #endif
 349 c
 350 c 1.3. ==> Aucun bloc au depart
 351 c
 352       do 13 , iaux = 1 , maxpen
 353         nublvo(iaux) = 0
 354    13 continue
 355 c
 356       codret = 0
 357 c
 358 c====
 359 c 2. blocs de volumes
 360 c====
 361 #ifdef _DEBUG_HOMARD_
 362       write (ulsort,90002) '2. blocs de volumes ; codret =', codret
 363 #endif
 364 c
 365       iaux = 2
 366       iaux = iaux + ( nbteac + nbheac + nbpyac + nbpeac )
 367       iaux = iaux - ( nbtrac + nbquac )
 368       iaux = iaux + nbarac
 369       iaux = iaux - nbnop1
 370       write (ulbila,10100)
 371       write (ulbila,texte(langue,8)) iaux
 372       write (ulbila,10200)
 373 c
 374       nbbloc = 0
 375       lgpile = 0
 376 c
 377       do 20 , levolu = 1, maxpen
 378 c
 379         etat = -1
 380 #ifdef _DEBUG_HOMARD_
 381         if ( levolu.eq.0 ) then
 382           glop = 1
 383         else
 384           glop = 01
 385         endif
 386 #endif
 387 #ifdef _DEBUG_HOMARD_
 388         if ( glop.ne.0 ) then
 389         write (ulsort,90002) 'Volume', levolu
 390         endif
 391 #endif
 392         if ( levolu.le.maxtet ) then
 393           nument = levolu - dectet
 394           if ( cfatet(cotyel,famtet(nument)).ne.0 ) then
 395             etat = mod(hettet(nument),100)
 396           endif
 397         elseif ( levolu.le.maxhex ) then
 398           nument = levolu - dechex
 399           if ( cfahex(cotyel,famhex(nument)).ne.0 ) then
 400             etat = mod(hethex(nument),1000)
 401           endif
 402         elseif ( levolu.le.maxpyr ) then
 403           nument = levolu - decpyr
 404           if ( cfapyr(cotyel,fampyr(nument)).ne.0 ) then
 405             etat = mod(hetpyr(nument),100)
 406           endif
 407         else
 408           nument = levolu - decpen
 409           if ( cfapen(cotyel,fampen(nument)).ne.0 ) then
 410             etat = mod(hetpen(nument),100)
 411           endif
 412         endif
 413 #ifdef _DEBUG_HOMARD_
 414         if ( glop.ne.0 ) then
 415         write (ulsort,90002) '============== etat', etat
 416         endif
 417 #endif
 418 c
 419         if ( etat.eq.0 ) then
 420 c
 421           if ( nublvo(levolu).eq.0 ) then
 422 c
 423 c 2.1. ==> on commence un nouveau bloc
 424 c 2.1.1. ==> impression des caracteristiques du bloc precedent
 425 c
 426           if ( ulbila.gt.0 .and. nbbloc.ge.1 ) then
 427 #ifdef _DEBUG_HOMARD_
 428       write (ulsort,90002) 'nbbloc', nbbloc
 429 #endif
 430 c
 431 c 2.1.1.1. ==> recherche des faces actives de ce bloc
 432 c
 433             if ( codret.eq.0 ) then
 434 c
 435             iaux = 3
 436 c
 437 #ifdef _DEBUG_HOMARD_
 438       write (ulsort,texte(langue,3)) 'UTB11E', nompro
 439 #endif
 440             call utb11e ( iaux, nbbloc, nublvo,
 441      >                    tbiaux,
 442      >                    tbiaux, tbiaux,
 443      >                    tritet, quahex, facpyr, facpen,
 444      >                    maxtet, maxhex, maxpyr, maxpen,
 445      >                    tabau3, tabau4,
 446      >                    ulsort, langue, codret )
 447 c
 448             endif
 449 c
 450 c 2.1.1.2. ==> recherche des blocs de faces actives de ce bloc
 451 c
 452             if ( codret.eq.0 ) then
 453 c
 454             iaux = 1
 455             jaux = 0
 456 #ifdef _DEBUG_HOMARD_
 457       write (ulsort,texte(langue,3)) 'UTB11C', nompro
 458 #endif
 459             call utb11c ( nbblfa, iaux, tabau4,
 460      >                    hetare, somare,
 461      >                    hettri, aretri,
 462      >                    hetqua, arequa,
 463      >                    povoso, voisom,
 464      >                    posifa, facare,
 465      >                    famare, cfaare,
 466      >                    famtri, cfatri,
 467      >                    famqua, cfaqua,
 468      >                    taba11, taba12, taba13,
 469      >                    taba15, taba16,
 470      >                    taba14,
 471      >                    jaux,
 472      >                    ulsort, langue, codret )
 473 c
 474             endif
 475 c
 476 c 2.1.1.3. ==> impression veritable
 477 c
 478             if ( codret.eq.0 ) then
 479 c
 480 #ifdef _DEBUG_HOMARD_
 481       write (ulsort,texte(langue,10)) nbbloc
 482 #endif
 483 c
 484 #ifdef _DEBUG_HOMARD_
 485       write (ulsort,texte(langue,3)) 'UTB11F', nompro
 486 #endif
 487             call utb11f ( nbbloc, nbblfa, typvo0, typvol,
 488      >                    nublvo, tabau2, tabau3, tabau4,
 489      >                    ulbila,
 490      >                    ulsort, langue, codret )
 491 c
 492             endif
 493 c
 494           endif
 495 c
 496 c 2.1.2. ==> initialisations pour un nouveau bloc
 497 c
 498             nbbloc = nbbloc + 1
 499             lamail = levolu
 500 #ifdef _DEBUG_HOMARD_
 501       write (ulsort,90015) 'debut du bloc ',nbbloc,
 502      >                     ' avec lamail = ', lamail
 503 #endif
 504 c
 505           do 2121 , iaux = 1 , nbnoto
 506             tabau2(iaux) = 0
 507  2121     continue
 508           do 2122 , iaux = 1 , nbarto
 509             tabau3(iaux) = 0
 510  2122     continue
 511 c
 512           typvol = 0
 513 c
 514    21     continue
 515 c
 516 #ifdef _DEBUG_HOMARD_
 517         if ( glop.ne.0 ) then
 518           if ( lamail.le.maxtet ) then
 519             typenh = 3
 520           elseif ( lamail.le.maxhex ) then
 521             typenh = 6
 522           elseif ( lamail.le.maxpyr ) then
 523             typenh = 5
 524           else
 525             typenh = 7
 526           endif
 527           write (ulsort,*) '... Maille', lamail,
 528      >                         ' (',mess14(langue,1,typenh),')'
 529         endif
 530 #endif
 531 c
 532 c 2.2. ==> memorisation du bloc pour la maille courante
 533 c
 534             nublvo(lamail) = nbbloc
 535 c
 536             if ( lamail.le.maxtet ) then
 537               if ( typvol.eq.0 ) then
 538                 typvol = 3
 539               elseif ( typvol.ne.3 ) then
 540                 typvol = 9
 541               endif
 542             elseif ( lamail.le.maxhex ) then
 543               if ( typvol.eq.0 ) then
 544                 typvol = 6
 545               elseif ( typvol.ne.6 ) then
 546                 typvol = 9
 547               endif
 548             elseif ( lamail.le.maxpyr ) then
 549               if ( typvol.eq.0 ) then
 550                 typvol = 5
 551               elseif ( typvol.ne.5 ) then
 552                 typvol = 9
 553               endif
 554             else
 555               if ( typvol.eq.0 ) then
 556                 typvol = 7
 557               elseif ( typvol.ne.7 ) then
 558                 typvol = 9
 559               endif
 560             endif
 561 c
 562 c 2.3. ==> mise des voisins dans la pile s'ils n'ont pas ete vus.
 563 c          Il faut faire attention  a la numerotation. Pour la pile et
 564 c          nublvo, c'est la numerotation globale des mailles ; pour les
 565 c          caracteristiques des entites, c'est leur numero local.
 566 c
 567 c 2.3.1. ==> Cas d'un tetraedre
 568 c
 569             if ( lamail.le.maxtet ) then
 570 c
 571               nument = lamail - dectet
 572 #ifdef _DEBUG_HOMARD_
 573         if ( glop.eq.1 ) then
 574         write (ulsort,90002) 'C''est le tetraedre ', nument
 575         endif
 576 #endif
 577 c
 578               if ( nument.le.nbtecf ) then
 579 c
 580               do 231 , iaux = 1 , 4
 581 c
 582                 jaux = tritet(nument,iaux)
 583 #ifdef _DEBUG_HOMARD_
 584         if ( glop.ne.0 ) then
 585         write (ulsort,90002) '..... triangle jaux = ', jaux
 586         endif
 587 #endif
 588                 do 2311 , laux = 1 , 3
 589                   kaux = aretri(jaux,laux)
 590                   tabau3(kaux) = tabau3(kaux) + 1
 591                   maux = somare(1,kaux)
 592                   tabau2(maux) = tabau2(maux) + 1
 593                   maux = somare(2,kaux)
 594                   tabau2(maux) = tabau2(maux) + 1
 595  2311           continue
 596 c
 597                 do 2312 , laux = 1 , 2
 598 c
 599                   kaux = voltri(laux,jaux)
 600 c
 601 c 2.3.1.1. ==> Le voisin est un autre tetraedre
 602 c
 603                   if ( kaux.gt.0 .and. kaux.ne.nument ) then
 604 #ifdef _DEBUG_HOMARD_
 605         if ( glop.ne.0 ) then
 606        write (ulsort,90015) '....... Le ',laux,
 607      >                      '-ieme voisin est le tetraedre ',kaux
 608        write (ulsort,90002) '....... du bloc ',nublvo(kaux)
 609         endif
 610 #endif
 611 c
 612                     if ( nublvo(kaux).eq.0 ) then
 613                       if ( cfatet(cotyel,famtet(kaux)).ne.0 ) then
 614                         etat = mod( hettet(kaux),100)
 615                         if ( etat.eq.0 ) then
 616                           lgpile = lgpile + 1
 617                           lapile(lgpile) = kaux
 618                         endif
 619                       endif
 620                     endif
 621 c
 622                   elseif ( kaux.lt.0 ) then
 623 c
 624                     kaux = -kaux
 625 c
 626 c 2.3.1.2. ==> Le voisin est une pyramide
 627 c
 628                     if ( pypetr(1,kaux).ne.0 ) then
 629                       lapyra = pypetr(1,kaux)
 630 #ifdef _DEBUG_HOMARD_
 631         if ( glop.ne.0 ) then
 632       write (ulsort,90015) '....... Le ',laux,
 633      >                     '-ieme voisin est la pyramide ',lapyra
 634       write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra)
 635         endif
 636 #endif
 637                       if ( nublvo(decpyr+lapyra).eq.0 ) then
 638                         if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then
 639                           etat = mod( hetpyr(lapyra),100)
 640                           if ( etat.eq.0 ) then
 641                             lgpile = lgpile + 1
 642                             lapile(lgpile) = decpyr+lapyra
 643                           endif
 644                         endif
 645                       endif
 646                     endif
 647 c
 648 c 2.3.1.3. ==> Le voisin est un pentaedre
 649 c
 650                     if ( pypetr(2,kaux).ne.0 ) then
 651                       lepent = pypetr(2,kaux)
 652 #ifdef _DEBUG_HOMARD_
 653         if ( glop.ne.0 ) then
 654       write (ulsort,90015) '....... Le ',laux,
 655      >                     '-ieme voisin est le pentaedre ',lepent
 656       write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent)
 657         endif
 658 #endif
 659                       if ( nublvo(decpen+lepent).eq.0 ) then
 660                         if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then
 661                           etat = mod( hetpen(lepent),100)
 662                           if ( etat.eq.0 ) then
 663                             lgpile = lgpile + 1
 664                             lapile(lgpile) = decpen+lepent
 665                           endif
 666                         endif
 667                       endif
 668                     endif
 669 c
 670                   endif
 671 c
 672  2312           continue
 673 c
 674   231         continue
 675 #ifdef _DEBUG_HOMARD_
 676         if ( glop.ne.0 ) then
 677         write (ulsort,*) 'OK'
 678         endif
 679 #endif
 680 c
 681               endif
 682 c
 683 c 2.3.2. ==> Cas d'un hexaedre
 684 c
 685             elseif ( lamail.le.maxhex ) then
 686 c
 687               nument = lamail-dechex
 688 #ifdef _DEBUG_HOMARD_
 689         if ( glop.eq.1 ) then
 690         write (ulsort,90002) 'C''est l''hexaedre   ', nument
 691         endif
 692 #endif
 693 c
 694               if ( nument.le.nbhecf ) then
 695 c
 696               do 232 , iaux = 1 , 6
 697 c
 698                 jaux = quahex(nument,iaux)
 699 #ifdef _DEBUG_HOMARD_
 700         if ( glop.eq.1 ) then
 701         write (ulsort,90002) '..... quadrangle jaux = ', jaux
 702         endif
 703 #endif
 704                 do 2321 , laux = 1 , 4
 705                   kaux = arequa(jaux,laux)
 706                   tabau3(kaux) = tabau3(kaux) + 1
 707                   maux = somare(1,kaux)
 708                   tabau2(maux) = tabau2(maux) + 1
 709                   maux = somare(2,kaux)
 710                   tabau2(maux) = tabau2(maux) + 1
 711  2321           continue
 712 c
 713                 do 2322 , laux = 1 , 2
 714 c
 715                   kaux = volqua(laux,jaux)
 716 c
 717 #ifdef _DEBUG_HOMARD_
 718         if ( glop.eq.1 ) then
 719         write (ulsort,90002) '....... kaux = ', kaux
 720         endif
 721 #endif
 722 c
 723 c 2.3.2.1. ==> Le voisin est un autre hexaedre
 724 c
 725                   if ( kaux.gt.0 .and. kaux.ne.nument ) then
 726 c
 727 #ifdef _DEBUG_HOMARD_
 728       if ( glop.eq.1 ) then
 729       write (ulsort,90015) '....... Le ',laux,
 730      >                     '-ieme voisin est l''hexaedre ',kaux
 731       write (ulsort,90002) '....... du bloc ', nublvo(dechex+kaux)
 732       endif
 733 #endif
 734                     if ( nublvo(dechex+kaux).eq.0 ) then
 735                       if ( cfahex(cotyel,famhex(kaux)).ne.0 ) then
 736                         etat = mod( hethex(kaux),1000)
 737                         if ( etat.eq.0 ) then
 738                           lgpile = lgpile + 1
 739                           lapile(lgpile) = dechex+kaux
 740                         endif
 741                       endif
 742                     endif
 743 c
 744                   elseif ( kaux.lt.0 ) then
 745 c
 746                     kaux = -kaux
 747 cgn        if ( glop.eq.1 ) then
 748 cgn        write (ulsort,90002) 'pypequ(1,kaux)', pypequ(1,kaux)
 749 cgn        write (ulsort,90002) 'pypequ(2,kaux)', pypequ(2,kaux)
 750 cgn        endif
 751 c
 752 c 2.3.2.2. ==> Le voisin est une pyramide
 753 c
 754                     if ( pypequ(1,kaux).ne.0 ) then
 755                       lapyra = pypequ(1,kaux)
 756 #ifdef _DEBUG_HOMARD_
 757       if ( glop.eq.1 ) then
 758       write (ulsort,90015) '....... Le ',laux,
 759      >                     '-ieme voisin est la pyramide ', lapyra
 760       write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra)
 761       endif
 762 #endif
 763                       if ( nublvo(decpyr+lapyra).eq.0 ) then
 764                         if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then
 765                           etat = mod( hetpyr(lapyra),100)
 766                           if ( etat.eq.0 ) then
 767                             lgpile = lgpile + 1
 768                             lapile(lgpile) = decpyr+lapyra
 769                           endif
 770                         endif
 771                       endif
 772                     endif
 773 c
 774 c 2.3.2.3. ==> Le voisin est un pentaedre
 775 c
 776                     if ( pypequ(2,kaux).ne.0 ) then
 777                       lepent = pypequ(2,kaux)
 778 #ifdef _DEBUG_HOMARD_
 779       if ( glop.eq.1 ) then
 780       write (ulsort,90015) '....... Le ',laux,
 781      >                     '-ieme voisin est le pentaedre ',lepent
 782       write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent)
 783       endif
 784 #endif
 785                       if ( nublvo(decpen+lepent).eq.0 ) then
 786                         if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then
 787                           etat = mod( hetpen(lepent),100)
 788                           if ( etat.eq.0 ) then
 789                             lgpile = lgpile + 1
 790                             lapile(lgpile) = decpen+lepent
 791                           endif
 792                         endif
 793                       endif
 794                     endif
 795 c
 796                   endif
 797 c
 798  2322           continue
 799 c
 800   232         continue
 801 c
 802               endif
 803 c
 804 c 2.3.3. ==> Cas de la pyramide
 805 c
 806             elseif ( lamail.le.maxpyr ) then
 807 c
 808               nument = lamail-decpyr
 809 #ifdef _DEBUG_HOMARD_
 810         if ( glop.eq.1 ) then
 811         write (ulsort,90002) 'C''est la pyramide  ',nument
 812         endif
 813 #endif
 814 c
 815               if ( nument.le.nbpycf ) then
 816 c
 817 c 2.3.3.1. ==> Le voisinage par les triangles
 818 c
 819               do 233 , iaux = 1 , 4
 820 c
 821                 jaux = facpyr(nument,iaux)
 822 #ifdef _DEBUG_HOMARD_
 823         if ( glop.eq.1 ) then
 824         write (ulsort,90015) '..... ', iaux,'-ieme triangle = ', jaux
 825         endif
 826 #endif
 827                 do 2331 , laux = 1 , 3
 828                   kaux = aretri(jaux,laux)
 829                   tabau3(kaux) = tabau3(kaux) + 1
 830                   maux = somare(1,kaux)
 831                   tabau2(maux) = tabau2(maux) + 1
 832                   maux = somare(2,kaux)
 833                   tabau2(maux) = tabau2(maux) + 1
 834  2331           continue
 835 c
 836                 do 2332 , laux = 1 , 2
 837 c
 838                   kaux = voltri(laux,jaux)
 839 c
 840 c 2.3.3.1.1. ==> Le voisin est un tetraedre
 841 c
 842                   if ( kaux.gt.0 ) then
 843 c
 844 #ifdef _DEBUG_HOMARD_
 845       if ( glop.eq.1 ) then
 846       write (ulsort,90015) '....... Le ',laux,
 847      >                     '-ieme voisin est le tetraedre ',kaux
 848       write (ulsort,90002) '....... du bloc ', nublvo(kaux)
 849       endif
 850 #endif
 851                     if ( nublvo(kaux).eq.0 ) then
 852                       if ( cfatet(cotyel,famtet(kaux)).ne.0 ) then
 853                         etat = mod( hettet(kaux),100)
 854                         if ( etat.eq.0 ) then
 855                           lgpile = lgpile + 1
 856                           lapile(lgpile) = kaux
 857                         endif
 858                       endif
 859                     endif
 860 c
 861                   elseif ( kaux.lt.0 ) then
 862 c
 863                     kaux = -kaux
 864 c
 865 c 2.3.3.1.2. ==> Le voisin est une autre pyramide
 866 c
 867                     lapyra = pypetr(1,kaux)
 868                     if ( lapyra.ne.0 .and. lapyra.ne.nument ) then
 869 #ifdef _DEBUG_HOMARD_
 870       if ( glop.eq.1 ) then
 871       write (ulsort,90015) '....... Le ',laux,
 872      >                     '-ieme voisin est la pyramide ',lapyra
 873       write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra)
 874       endif
 875 #endif
 876                       if ( nublvo(decpyr+lapyra).eq.0 ) then
 877                         if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then
 878                           etat = mod( hetpyr(lapyra),100)
 879                           if ( etat.eq.0 ) then
 880                             lgpile = lgpile + 1
 881                             lapile(lgpile) = decpyr+lapyra
 882                           endif
 883                         endif
 884                       endif
 885                     endif
 886 c
 887 c 2.3.3.1.3. ==> Le voisin est un pentaedre
 888 c
 889                     if ( pypetr(2,kaux).ne.0 ) then
 890                       lepent = pypetr(2,kaux)
 891 #ifdef _DEBUG_HOMARD_
 892       if ( glop.eq.1 ) then
 893       write (ulsort,90015) '....... Le ',laux,
 894      >                     '-ieme voisin est le pentaedre ',lepent
 895       write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent)
 896       endif
 897 #endif
 898                       if ( nublvo(decpen+lepent).eq.0 ) then
 899                         if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then
 900                           etat = mod( hetpen(lepent),100)
 901                           if ( etat.eq.0 ) then
 902                             lgpile = lgpile + 1
 903                             lapile(lgpile) = decpen+lepent
 904                           endif
 905                         endif
 906                       endif
 907                     endif
 908 c
 909                   endif
 910 c
 911  2332           continue
 912 c
 913   233         continue
 914 c
 915 c 2.3.3.2. ==> Le voisinage par le quadrangle
 916 c
 917               jaux = facpyr(nument,5)
 918 #ifdef _DEBUG_HOMARD_
 919         if ( glop.eq.1 ) then
 920         write (ulsort,90002) '..... le quadrangle numero', jaux
 921         endif
 922 #endif
 923               do 2333 , laux = 1 , 4
 924                 kaux = arequa(jaux,laux)
 925                 tabau3(kaux) = tabau3(kaux) + 1
 926                 maux = somare(1,kaux)
 927                 tabau2(maux) = tabau2(maux) + 1
 928                 maux = somare(2,kaux)
 929                 tabau2(maux) = tabau2(maux) + 1
 930  2333         continue
 931 c
 932               do 2334 , laux = 1 , 2
 933 c
 934                 kaux = volqua(laux,jaux)
 935 c
 936 c 2.3.3.2.1. ==> Le voisin est un hexaedre
 937 c
 938                 if ( kaux.gt.0 ) then
 939 #ifdef _DEBUG_HOMARD_
 940       if ( glop.eq.1 ) then
 941       write (ulsort,90015) '....... Le ',laux,
 942      >                     '-ieme voisin est l''hexaedre ',kaux
 943       write (ulsort,90002) '....... du bloc ', nublvo(dechex+kaux)
 944       endif
 945 #endif
 946 c
 947                   if ( nublvo(dechex+kaux).eq.0 ) then
 948                     if ( cfahex(cotyel,famhex(kaux)).ne.0 ) then
 949                       etat = mod( hethex(kaux),1000)
 950                       if ( etat.eq.0 ) then
 951                         lgpile = lgpile + 1
 952                         lapile(lgpile) = dechex+kaux
 953                       endif
 954                     endif
 955                   endif
 956 c
 957                 elseif ( kaux.lt.0 ) then
 958 c
 959                   kaux = -kaux
 960 c
 961 c 2.3.3.2.2. ==> Le voisin est une autre pyramide
 962 c
 963                   lapyra = pypequ(1,kaux)
 964                   if ( lapyra.ne.0 .and. lapyra.ne.nument ) then
 965 #ifdef _DEBUG_HOMARD_
 966       if ( glop.eq.1 ) then
 967       write (ulsort,90015) '....... Le ',laux,
 968      >                     '-ieme voisin est la pyramide ',lapyra
 969       write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra)
 970       endif
 971 #endif
 972                     if ( nublvo(decpyr+lapyra).eq.0 ) then
 973                       if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then
 974                         etat = mod( hetpyr(lapyra),100)
 975                         if ( etat.eq.0 ) then
 976                           lgpile = lgpile + 1
 977                           lapile(lgpile) = decpyr+lapyra
 978                         endif
 979                       endif
 980                     endif
 981                   endif
 982 c
 983 c 2.3.3.2.3. ==> Le voisin est un pentaedre
 984 c
 985                   if ( pypequ(2,kaux).ne.0 ) then
 986                     lepent = pypequ(2,kaux)
 987 #ifdef _DEBUG_HOMARD_
 988       if ( glop.eq.1 ) then
 989       write (ulsort,90015) '....... Le ',laux,
 990      >                     '-ieme voisin est le pentaedre ',lepent
 991       write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent)
 992       endif
 993 #endif
 994                     if ( nublvo(decpen+lepent).eq.0 ) then
 995                       if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then
 996                         etat = mod( hetpen(lepent),100)
 997                         if ( etat.eq.0 ) then
 998                           lgpile = lgpile + 1
 999                           lapile(lgpile) = decpen+lepent
1000                         endif
1001                       endif
1002                     endif
1003                   endif
1004 c
1005                 endif
1006 c
1007  2334         continue
1008 c
1009               endif
1010 c
1011 c 2.3.4. ==> Cas du pentaedre
1012 c
1013             else
1014 c
1015               nument = lamail-decpen
1016 #ifdef _DEBUG_HOMARD_
1017         if ( glop.eq.1 ) then
1018         write (ulsort,90002) 'C''est le pentaedre ',nument
1019         endif
1020 #endif
1021 c
1022               if ( nument.le.nbpecf ) then
1023 c
1024 c 2.3.4.1. ==> Le voisinage par les triangles
1025 c
1026               do 2341 , iaux = 1 , 2
1027 c
1028                 jaux = facpen(nument,iaux)
1029 #ifdef _DEBUG_HOMARD_
1030         if ( glop.eq.1 ) then
1031         write (ulsort,90015) '..... ', iaux,'-ieme triangle = ', jaux
1032         endif
1033 #endif
1034                 do 23411 , laux = 1 , 3
1035                   kaux = aretri(jaux,laux)
1036                   tabau3(kaux) = tabau3(kaux) + 1
1037                   maux = somare(1,kaux)
1038                   tabau2(maux) = tabau2(maux) + 1
1039                   maux = somare(2,kaux)
1040                   tabau2(maux) = tabau2(maux) + 1
1041 23411           continue
1042 c
1043                 do 23412 , laux = 1 , 2
1044 c
1045                   kaux = voltri(laux,jaux)
1046 c
1047 c 2.3.4.1.1. ==> Le voisin est un tetraedre
1048 c
1049                   if ( kaux.gt.0 ) then
1050 c
1051 #ifdef _DEBUG_HOMARD_
1052       if ( glop.eq.1 ) then
1053       write (ulsort,90015) '....... Le ',laux,
1054      >                     '-ieme voisin est le tetraedre ',kaux
1055       write (ulsort,90002) '....... du bloc ', nublvo(kaux)
1056       endif
1057 #endif
1058                     if ( nublvo(kaux).eq.0 ) then
1059                       if ( cfatet(cotyel,famtet(kaux)).ne.0 ) then
1060                         etat = mod( hettet(kaux),100)
1061                         if ( etat.eq.0 ) then
1062                           lgpile = lgpile + 1
1063                           lapile(lgpile) = kaux
1064                         endif
1065                       endif
1066                     endif
1067 c
1068                   elseif ( kaux.lt.0 ) then
1069 c
1070                     kaux = -kaux
1071 c
1072 c 2.3.4.1.2. ==> Le voisin est une pyramide
1073 c
1074                     if ( pypetr(1,kaux).ne.0 ) then
1075                       lapyra = pypetr(1,kaux)
1076 #ifdef _DEBUG_HOMARD_
1077       if ( glop.eq.1 ) then
1078       write (ulsort,90015) '....... Le ',laux,
1079      >                     '-ieme voisin est la pyramide ',lapyra
1080       write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra)
1081       endif
1082 #endif
1083                       if ( nublvo(decpyr+lapyra).eq.0 ) then
1084                         if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then
1085                           etat = mod( hetpyr(lapyra),100)
1086                           if ( etat.eq.0 ) then
1087                             lgpile = lgpile + 1
1088                             lapile(lgpile) = decpyr+lapyra
1089                           endif
1090                         endif
1091                       endif
1092                     endif
1093 c
1094 c 2.3.4.1.3. ==> Le voisin est un autre pentaedre
1095 c
1096                     lepent = pypetr(2,kaux)
1097                     if ( lepent.ne.0 .and. lepent.ne.nument ) then
1098 #ifdef _DEBUG_HOMARD_
1099       if ( glop.eq.1 ) then
1100       write (ulsort,90002) 'nument', nument
1101       write (ulsort,90015) '....... Le ',laux,
1102      >                     '-ieme voisin est le pentaedre ',lepent
1103       write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent)
1104       endif
1105 #endif
1106                       if ( nublvo(decpen+lepent).eq.0 ) then
1107                         if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then
1108                           etat = mod( hetpen(lepent),100)
1109                           if ( etat.eq.0 ) then
1110                             lgpile = lgpile + 1
1111                             lapile(lgpile) = decpen+lepent
1112                           endif
1113                         endif
1114                       endif
1115                     endif
1116 c
1117                   endif
1118 c
1119 23412           continue
1120 c
1121  2341         continue
1122 c
1123 c 2.3.4.2. ==> Le voisinage par les quadrangles
1124 c
1125               do 2342 , iaux = 3 , 5
1126 c
1127                 jaux = facpen(nument,iaux)
1128 #ifdef _DEBUG_HOMARD_
1129         if ( glop.eq.1 ) then
1130         write (ulsort,90015) '..... ', iaux,'-ieme quadrangle =', jaux
1131         endif
1132 #endif
1133                 do 23421 , laux = 1 , 4
1134                   kaux = arequa(jaux,laux)
1135                   tabau3(kaux) = tabau3(kaux) + 1
1136                   maux = somare(1,kaux)
1137                   tabau2(maux) = tabau2(maux) + 1
1138                   maux = somare(2,kaux)
1139                   tabau2(maux) = tabau2(maux) + 1
1140 23421           continue
1141 c
1142                 do 23422 , laux = 1 , 2
1143 c
1144                   kaux = volqua(laux,jaux)
1145 c
1146 #ifdef _DEBUG_HOMARD_
1147           if ( glop.eq.1 ) then
1148           write (ulsort,90002) '....... kaux = ', kaux
1149           endif
1150 #endif
1151 c
1152 c 2.3.4.2.1. ==> Le voisin est un hexaedre
1153 c
1154                   if ( kaux.gt.0 ) then
1155 #ifdef _DEBUG_HOMARD_
1156       if ( glop.eq.1 ) then
1157       write (ulsort,90015) '....... Le ',laux,
1158      >                     '-ieme voisin est l''hexaedre ',kaux
1159       write (ulsort,90002) '....... du bloc ', nublvo(dechex+kaux)
1160       endif
1161 #endif
1162 c
1163                     if ( nublvo(dechex+kaux).eq.0 ) then
1164                       if ( cfahex(cotyel,famhex(kaux)).ne.0 ) then
1165                         etat = mod( hethex(kaux),1000)
1166                         if ( etat.eq.0 ) then
1167                           lgpile = lgpile + 1
1168                           lapile(lgpile) = dechex+kaux
1169                         endif
1170                       endif
1171                     endif
1172 c
1173                   elseif ( kaux.lt.0 ) then
1174 c
1175                     kaux = -kaux
1176 c
1177 c 2.3.4.2.2. ==> Le voisin est une pyramide
1178 c
1179                     if ( pypequ(1,kaux).ne.0 ) then
1180                       lapyra = pypequ(1,kaux)
1181 #ifdef _DEBUG_HOMARD_
1182       if ( glop.eq.1 ) then
1183       write (ulsort,90015) '....... Le ',laux,
1184      >                     '-ieme voisin est la pyramide ',lapyra
1185       write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra)
1186       endif
1187 #endif
1188                       if ( nublvo(decpyr+lapyra).eq.0 ) then
1189                         if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then
1190                           etat = mod( hetpyr(lapyra),100)
1191                           if ( etat.eq.0 ) then
1192                             lgpile = lgpile + 1
1193                             lapile(lgpile) = decpyr+lapyra
1194                           endif
1195                         endif
1196                       endif
1197                     endif
1198 c
1199 c 2.3.4.2.3. ==> Le voisin est un autre pentaedre
1200 c
1201                     lepent = pypequ(2,kaux)
1202                     if ( lepent.ne.0 .and. lepent.ne.nument ) then
1203 #ifdef _DEBUG_HOMARD_
1204       if ( glop.eq.1 ) then
1205       write (ulsort,90015) '....... Le ',laux,
1206      >                     '-ieme voisin est le pentaedre ',lepent
1207       write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent)
1208       endif
1209 #endif
1210                       if ( nublvo(decpen+lepent).eq.0 ) then
1211                         if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then
1212                           etat = mod( hetpen(lepent),100)
1213                           if ( etat.eq.0 ) then
1214                             lgpile = lgpile + 1
1215                             lapile(lgpile) = decpen+lepent
1216                           endif
1217                         endif
1218                       endif
1219                      endif
1220 c
1221                   endif
1222 c
1223 23422           continue
1224 c
1225  2342         continue
1226 c
1227               endif
1228 c
1229             endif
1230 c
1231 c 2.4. ==> on passe a la maille suivante de la pile
1232 c
1233             if ( lgpile.gt.0 ) then
1234 c
1235               lamail = lapile(lgpile)
1236               lgpile = lgpile - 1
1237               goto 21
1238 c
1239             endif
1240 #ifdef _DEBUG_HOMARD_
1241       write (ulsort,90002) 'fin du bloc', nbbloc
1242 #endif
1243 c
1244           endif
1245 c
1246         endif
1247 c
1248    20 continue
1249 c
1250 c====
1251 c 3. impression du dernier bloc
1252 c====
1253 #ifdef _DEBUG_HOMARD_
1254       write(ulsort,90002) '3. impression dernier bloc ; codret', codret
1255 #endif
1256 c
1257       if ( codret.eq.0 ) then
1258 c
1259       if ( ulbila.gt.0 ) then
1260 c
1261 c 3.1. ==> recherche des faces actives de ce bloc
1262 c
1263         if ( codret.eq.0 ) then
1264 c
1265         iaux = 3
1266 c
1267 #ifdef _DEBUG_HOMARD_
1268       write (ulsort,texte(langue,3)) 'UTB11E', nompro
1269 #endif
1270         call utb11e ( iaux, nbbloc, nublvo,
1271      >                tbiaux,
1272      >                tbiaux, tbiaux,
1273      >                tritet, quahex, facpyr, facpen,
1274      >                maxtet, maxhex, maxpyr, maxpen,
1275      >                tabau3, tabau4,
1276      >                ulsort, langue, codret )
1277 c
1278         endif
1279 c
1280 c 3.2. ==> recherche des blocs de faces actives de ce bloc
1281 c
1282         if ( codret.eq.0 ) then
1283 c
1284         iaux = 1
1285         jaux = 0
1286 #ifdef _DEBUG_HOMARD_
1287       write (ulsort,texte(langue,3)) 'UTB11C', nompro
1288 #endif
1289         call utb11c ( nbblfa, iaux, tabau4,
1290      >                hetare, somare,
1291      >                hettri, aretri,
1292      >                hetqua, arequa,
1293      >                povoso, voisom,
1294      >                posifa, facare,
1295      >                famare, cfaare,
1296      >                famtri, cfatri,
1297      >                famqua, cfaqua,
1298      >                taba11, taba12, taba13,
1299      >                taba15, taba16,
1300      >                taba14,
1301      >                jaux,
1302      >                ulsort, langue, codret )
1303 c
1304         endif
1305 c
1306 c 3.3. ==> impression veritable
1307 c
1308         if ( codret.eq.0 ) then
1309 c
1310 #ifdef _DEBUG_HOMARD_
1311       write (ulsort,texte(langue,9)) mess14(langue,3,8), nbblfa
1312       write (ulsort,texte(langue,10)) nbbloc
1313 #endif
1314 c
1315         if ( nbbloc.eq.1 ) then
1316           iaux = -nbbloc
1317         else
1318           iaux =  nbbloc
1319         endif
1320 #ifdef _DEBUG_HOMARD_
1321       write (ulsort,texte(langue,3)) 'UTB11F', nompro
1322 #endif
1323         call utb11f ( iaux, nbblfa, typvo0, typvol,
1324      >                nublvo, tabau2, tabau3, tabau4,
1325      >                ulbila,
1326      >                ulsort, langue, codret )
1327 c
1328         write (ulbila,3000)
1329  3000   format(5x,58('*'))
1330 c
1331         endif
1332 c
1333       endif
1334 c
1335       endif
1336 c
1337 c====
1338 c 4. la fin
1339 c====
1340 c
1341       if ( codret.ne.0 ) then
1342 c
1343 #include "envex2.h"
1344 c
1345       write (ulsort,texte(langue,1)) 'Sortie', nompro
1346       write (ulsort,texte(langue,2)) codret
1347 c
1348       endif
1349 c
1350 #ifdef _DEBUG_HOMARD_
1351       write (ulsort,texte(langue,1)) 'Sortie', nompro
1352       call dmflsh (iaux)
1353 #endif
1354 c
1355       end