src/tool/Utilitaire/utb17b.F

   1       subroutine utb17b ( somare, np2are,
   2      >                    aretri, voltri,
   3      >                    famtri, cfatri,
   4      >                    arequa, volqua,
   5      >                    famqua, cfaqua,
   6      >                    hettet, tritet, cotrte, aretet,
   7      >                    hethex, quahex, coquhe, arehex,
   8      >                    hetpyr, facpyr, cofapy, arepyr,
   9      >                    hetpen, facpen, cofape, arepen,
  10      >                    tabaux,
  11      >                    ulbila,
  12      >                    ulsort, langue, codret )
  13 c ______________________________________________________________________
  14 c
  15 c                             H O M A R D
  16 c
  17 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  18 c
  19 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  20 c aupres des huissiers de justice Simart et Lavoir a Clamart
  21 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  22 c aupres des huissiers de justice
  23 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  24 c
  25 c    HOMARD est une marque deposee d'Electricite de France
  26 c
  27 c Copyright EDF 1996
  28 c Copyright EDF 1998
  29 c Copyright EDF 2002
  30 c Copyright EDF 2020
  31 c ______________________________________________________________________
  32 c
  33 c    UTilitaire - Bilan sur le maillage - option 17 - phase b
  34 c    --           -                              --         -
  35 c ______________________________________________________________________
  36 c
  37 c diagnostic des elements volumiques du calcul
  38 c un element est surcontraint si tous ses noeuds sont au bord du domaine
  39 c ______________________________________________________________________
  40 c .        .     .        .                                            .
  41 c .  nom   . e/s . taille .           description                      .
  42 c .____________________________________________________________________.
  43 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  44 c . np2are . e   . nbarto . numero des noeuds p2 milieux d'aretes      .
  45 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  46 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  47 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  48 c .        .     .        .   0 : pas de voisin                        .
  49 c .        .     .        . j>0 : tetraedre j                          .
  50 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  51 c . famtri . e   . nbtrto . famille des triangles                      .
  52 c . cfatri . e   . nctftr*. codes des familles des triangles           .
  53 c .        .     . nbftri .   1 : famille MED                          .
  54 c .        .     .        .   2 : type de triangle                     .
  55 c .        .     .        .   3 : numero de surface de frontiere       .
  56 c .        .     .        .   4 : famille des aretes internes apres raf.
  57 c .        .     .        . + l : appartenance a l'equivalence l       .
  58 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  59 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
  60 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  61 c .        .     .        .   0 : pas de voisin                        .
  62 c .        .     .        . j>0 : hexaedre j                           .
  63 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  64 c . famqua . e   . nbquto . famille des quadrangles                    .
  65 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  66 c .        .     . nbfqua .   1 : famille MED                          .
  67 c .        .     .        .   2 : type de quadrangle                   .
  68 c .        .     .        .   3 : numero de surface de frontiere       .
  69 c .        .     .        .   4 : famille des aretes internes apres raf.
  70 c .        .     .        .   5 : famille des triangles de conformite  .
  71 c .        .     .        .   6 : famille de sf active/inactive        .
  72 c .        .     .        . + l : appartenance a l'equivalence l       .
  73 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  74 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  75 c . cotrte . e   .nbtecf*4. codes des triangles des tetraedres         .
  76 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  77 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  78 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  79 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  80 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  81 c . hetpyr . e   . nbpyto . historique de l'etat des pyramides         .
  82 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  83 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  84 c . arepyr . e   .nbpyca*8. numeros des 8 aretes des pyramides         .
  85 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  86 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  87 c . cofape . e   .nbpecf*5. codes des faces des pentaedres             .
  88 c . arepen . e   .nbpeca*9. numeros des 9 aretes des pentaedres        .
  89 c . tabaux . e   . nbnoto . 0 : le noeud est interne                   .
  90 c .        .     .        . 1 : le noeud est au bord d'un volume       .
  91 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
  92 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  93 c . langue . e   .    1   . langue des messages                        .
  94 c .        .     .        . 1 : francais, 2 : anglais                  .
  95 c . codret .  s  .    1   . code de retour des modules                 .
  96 c .        .     .        . 0 : pas de probleme                        .
  97 c .        .     .        . 1 : probleme                               .
  98 c .____________________________________________________________________.
  99 c
 100 c====
 101 c 0. declarations et dimensionnement
 102 c====
 103 c
 104 c 0.1. ==> generalites
 105 c
 106       implicit none
 107       save
 108 c
 109       character*6 nompro
 110       parameter ( nompro = 'UTB17B' )
 111 c
 112 #include "nblang.h"
 113 #include "coftex.h"
 114 c
 115 c 0.2. ==> communs
 116 c
 117 #include "envca1.h"
 118 #include "nbfami.h"
 119 #include "nombno.h"
 120 #include "nombar.h"
 121 #include "nombtr.h"
 122 #include "nombqu.h"
 123 #include "nombte.h"
 124 #include "nombhe.h"
 125 #include "nombpy.h"
 126 #include "nombpe.h"
 127 c
 128 #include "dicfen.h"
 129 #include "impr02.h"
 130 c
 131 c 0.3. ==> arguments
 132 c
 133       integer somare(2,nbarto), np2are(nbarto)
 134 c
 135       integer aretri(nbtrto,3), voltri(2,nbtrto)
 136       integer famtri(nbtrto), cfatri(nctftr,nbftri)
 137 c
 138       integer arequa(nbquto,4), volqua(2,nbquto)
 139       integer famqua(nbquto), cfaqua(nctfqu,nbfqua)
 140 c
 141       integer hettet(nbteto)
 142       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 143       integer hethex(nbheto)
 144       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
 145       integer hetpyr(nbpyto)
 146       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
 147       integer hetpen(nbpeto)
 148       integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
 149 c
 150       integer tabaux(nbnoto)
 151 c
 152       integer ulbila
 153       integer ulsort, langue, codret
 154 c
 155 c 0.4. ==> variables locales
 156 c
 157       integer iaux
 158       integer letet0, lehex0, lepen0, lapyr0
 159       integer letetr, lehexa, lepent, lapyra
 160       integer letria, lequad
 161       integer nbensc, nbensb
 162       integer listar(12), listso(8)
 163       integer etat
 164 c
 165       logical aubord
 166       logical afaire
 167 c
 168       integer nbmess
 169       parameter (nbmess = 10 )
 170       character*80 texte(nblang,nbmess)
 171 c
 172 c 0.5. ==> initialisations
 173 c ______________________________________________________________________
 174 c
 175 c====
 176 c 1. initialisation
 177 c====
 178 c
 179 #include "impr01.h"
 180 c
 181 #ifdef _DEBUG_HOMARD_
 182       write (ulsort,texte(langue,1)) 'Entree', nompro
 183       call dmflsh (iaux)
 184 #endif
 185 c
 186       texte(1,4) = '(''Nombre de '',a,'' actifs : '',i8)'
 187       texte(1,5) = '(''. Examen du '',a,i8)'
 188       texte(1,6) = '(''... '',a,i10,'' au bord'')'
 189       texte(1,7) =
 190      >'(''. Le bord du '',a,i10,'' n''''est pas une maille de calcul.''
 191      >)'
 192       texte(1,8) = '(''. Le '',a,i8,'' est surcontraint.'')'
 193 c
 194       texte(2,4) = '(''Number of active '',a,'': '',i8)'
 195       texte(2,5) = '(''. Examination of '',a,''#'',i8)'
 196       texte(2,6) = '(''... '',a,''#'',i8,'' on the boundary'')'
 197       texte(2,7) =
 198      >'(''. The boundary of the '',a,i10,'' is not a calculation mesh.''
 199      >)'
 200       texte(2,8) = '(''. The '',a,''#'',i8,'' is overstressed.'')'
 201 c
 202 #include "impr03.h"
 203 c
 204 #ifdef _DEBUG_HOMARD_
 205       write (ulsort,texte(langue,4)) mess14(langue,3,3), nbteac
 206       write (ulsort,texte(langue,4)) mess14(langue,3,5), nbpyac
 207       write (ulsort,texte(langue,4)) mess14(langue,3,6), nbheac
 208       write (ulsort,texte(langue,4)) mess14(langue,3,7), nbpeac
 209 #endif
 210 c
 211       codret = 0
 212 c
 213 c====
 214 c 2. Diagnostic sur les tetraedres
 215 c====
 216 #ifdef _DEBUG_HOMARD_
 217       write (ulsort,90002) '2. tetraedres, codret', codret
 218 #endif
 219 c
 220       if ( nbteac.gt.0 ) then
 221 c
 222 #ifdef _DEBUG_HOMARD_
 223       write (ulsort,90002) 'nbteto', nbteto
 224       write (ulsort,90002) 'nbtecf', nbtecf
 225       write (ulsort,90002) 'nbteca', nbteca
 226 #endif
 227 c
 228         if ( nbteca.eq.0 ) then
 229           afaire =.true.
 230         else
 231           afaire =.false.
 232         endif
 233 c
 234         nbensc = 0
 235         nbensb = 0
 236         aubord = .false.
 237 c
 238         do 2 , letet0 = 1, nbteto
 239 c
 240           letetr = letet0
 241 c
 242 #ifdef _DEBUG_HOMARD_
 243       write (ulsort,texte(langue,5)) mess14(langue,1,3), letetr
 244 #endif
 245 c
 246           etat = mod( hettet(letetr),100 )
 247 c
 248           if ( etat.eq.0 ) then
 249 c
 250 c 2.1. ==> On regarde si tous les noeuds sont sur le bord
 251 c
 252             call utaste ( letetr,
 253      >                    nbtrto, nbtecf, nbteca,
 254      >                    somare, aretri,
 255      >                    tritet, cotrte, aretet,
 256      >                    listar, listso )
 257 c
 258             do 211 , iaux = 1 , 4
 259               if ( tabaux(listso(iaux)).eq.0 ) then
 260                 goto 219
 261               endif
 262   211       continue
 263             if ( degre.eq.2 ) then
 264               do 212 , iaux = 1 , 6
 265                 if ( tabaux(np2are(listar(iaux))).eq.0 ) then
 266                   goto 219
 267                 endif
 268   212         continue
 269             endif
 270 c
 271             nbensc = nbensc + 1
 272 #ifdef _DEBUG_HOMARD_
 273             write (ulsort,texte(langue,8)) mess14(langue,1,3), letetr
 274 #endif
 275 c
 276   219       continue
 277 c
 278 c 2.2. ==> On verifie que chaque face au bord est un element de calcul
 279 c
 280             if ( afaire ) then
 281 c
 282               do 22 , iaux = 1 , 4
 283 c
 284                 letria = tritet(letetr,iaux)
 285                 if ( voltri(2,letria).eq.0 ) then
 286 #ifdef _DEBUG_HOMARD_
 287               write (ulsort,texte(langue,6)) mess14(langue,1,2), letria
 288 #endif
 289 c
 290                   aubord = .true.
 291                   if ( cfatri(cotyel,famtri(letria)).eq.0 ) then
 292                     nbensb = nbensb + 1
 293 #ifdef _DEBUG_HOMARD_
 294               write (ulsort,texte(langue,7)) mess14(langue,1,3), letetr
 295 #endif
 296                     goto 229
 297                   endif
 298 c
 299                 endif
 300 c
 301    22         continue
 302 c
 303             endif
 304 c
 305   229       continue
 306 c
 307           endif
 308 c
 309     2   continue
 310 c
 311 c 2.3. ==> Impression
 312 c
 313 #ifdef _DEBUG_HOMARD_
 314       write (ulsort,texte(langue,3)) 'UTB17E', nompro
 315 #endif
 316         iaux = 3
 317         call utb17e ( iaux, nbensc, aubord, nbensb,
 318      >                ulbila,
 319      >                ulsort, langue, codret )
 320 c
 321       endif
 322 c
 323 c====
 324 c 3. Diagnostic sur les hexaedres
 325 c====
 326 #ifdef _DEBUG_HOMARD_
 327       write (ulsort,90002) '3. hexaedres, codret', codret
 328 #endif
 329 c
 330       if ( nbheac.gt.0 ) then
 331 c
 332 #ifdef _DEBUG_HOMARD_
 333       write (ulsort,90002) 'nbheto', nbheto
 334       write (ulsort,90002) 'nbhecf', nbhecf
 335       write (ulsort,90002) 'nbheca', nbheca
 336 #endif
 337 c
 338         if ( nbheca.eq.0 ) then
 339           afaire =.true.
 340         else
 341           afaire =.false.
 342         endif
 343 c
 344         nbensc = 0
 345         nbensb = 0
 346         aubord = .false.
 347 c
 348         do 3 , lehex0 = 1, nbheto
 349 c
 350           lehexa = lehex0
 351 c
 352 #ifdef _DEBUG_HOMARD_
 353       write (ulsort,texte(langue,5)) mess14(langue,1,6), lehexa
 354 #endif
 355 c
 356           etat = mod(hethex(lehexa),1000)
 357 c
 358           if ( etat.eq.0 ) then
 359 c
 360 c 3.1. ==> On regarde si tous les noeuds sont sur le bord
 361 c
 362             call utashe ( lehexa,
 363      >                    nbquto, nbhecf, nbheca,
 364      >                    somare, arequa,
 365      >                    quahex, coquhe, arehex,
 366      >                    listar, listso )
 367 c
 368             do 312 , iaux = 1 , 8
 369               if ( tabaux(listso(iaux)).eq.0 ) then
 370                 goto 319
 371               endif
 372   312       continue
 373             if ( degre.eq.2 ) then
 374               do 313 , iaux = 1 , 12
 375                 if ( tabaux(np2are(listar(iaux))).eq.0 ) then
 376                   goto 319
 377                 endif
 378   313         continue
 379             endif
 380 c
 381             nbensc = nbensc + 1
 382 #ifdef _DEBUG_HOMARD_
 383             write (ulsort,texte(langue,8)) mess14(langue,1,6), lehexa
 384 #endif
 385 c
 386   319       continue
 387 c
 388 c 3.2. ==> On verifie que chaque face au bord est un element de calcul
 389 c
 390             if ( afaire ) then
 391 c
 392 cgn      write(ulsort,90002) 'faces', (quahex(lehexa,letet0),letet0=1,6)
 393               do 32 , iaux = 1 , 6
 394 c
 395                 lequad = quahex(lehexa,iaux)
 396                 if ( volqua(2,lequad).eq.0 ) then
 397 #ifdef _DEBUG_HOMARD_
 398               write (ulsort,texte(langue,6)) mess14(langue,1,4), lequad
 399 #endif
 400 c
 401                   aubord = .true.
 402                   if ( cfaqua(cotyel,famqua(lequad)).eq.0 ) then
 403                     nbensb = nbensb + 1
 404 #ifdef _DEBUG_HOMARD_
 405               write (ulsort,texte(langue,7)) mess14(langue,1,6), lehexa
 406 #endif
 407                     goto 329
 408                   endif
 409 c
 410                 endif
 411 c
 412    32         continue
 413 c
 414             endif
 415 c
 416   329       continue
 417 c
 418           endif
 419 c
 420     3   continue
 421 c
 422 c 3.3. ==> Impression
 423 c
 424 #ifdef _DEBUG_HOMARD_
 425       write (ulsort,texte(langue,3)) 'UTB17E', nompro
 426 #endif
 427         iaux = 6
 428         call utb17e ( iaux, nbensc, aubord, nbensb,
 429      >                ulbila,
 430      >                ulsort, langue, codret )
 431 c
 432       endif
 433 c
 434 c====
 435 c 4. Diagnostic sur les pyramides
 436 c====
 437 #ifdef _DEBUG_HOMARD_
 438       write (ulsort,90002) '4. pyramides, codret', codret
 439 #endif
 440 c
 441       if ( nbpyac.gt.0 ) then
 442 c
 443 #ifdef _DEBUG_HOMARD_
 444       write (ulsort,90002) 'nbpyto', nbpyto
 445       write (ulsort,90002) 'nbpycf', nbpycf
 446       write (ulsort,90002) 'nbpyca', nbpyca
 447 #endif
 448 c
 449         if ( nbpyca.eq.0 ) then
 450           afaire =.true.
 451         else
 452           afaire =.false.
 453         endif
 454 c
 455         nbensc = 0
 456         nbensb = 0
 457         aubord = .false.
 458 c
 459         do 4 , lapyr0 = 1, nbpyto
 460 c
 461           lapyra = lapyr0
 462 c
 463 #ifdef _DEBUG_HOMARD_
 464       write (ulsort,texte(langue,5)) mess14(langue,1,5), lapyra
 465 #endif
 466 c
 467           etat = mod( hetpyr(lapyra),100)
 468 c
 469           if ( etat.eq.0 ) then
 470 c
 471 c 4.1. ==> On regarde si tous les noeuds sont sur le bord
 472 c
 473             call utaspy ( lapyra,
 474      >                    nbtrto, nbpycf, nbpyca,
 475      >                    somare, aretri,
 476      >                    facpyr, cofapy, arepyr,
 477      >                    listar, listso )
 478 c
 479             do 411 , iaux = 1 , 5
 480               if ( tabaux(listso(iaux)).eq.0 ) then
 481                 goto 419
 482               endif
 483   411       continue
 484             if ( degre.eq.2 ) then
 485               do 412 , iaux = 1 , 8
 486                 if ( tabaux(np2are(listar(iaux))).eq.0 ) then
 487                   goto 419
 488                 endif
 489   412         continue
 490             endif
 491 c
 492             nbensc = nbensc + 1
 493 #ifdef _DEBUG_HOMARD_
 494             write (ulsort,texte(langue,8)) mess14(langue,1,5), lapyra
 495 #endif
 496 c
 497   419       continue
 498 c
 499 c 4.2. ==> On verifie que chaque face au bord est un element de calcul
 500 c
 501             if ( afaire ) then
 502 c
 503               do 42 , iaux = 1 , 4
 504 c
 505                 letria = facpyr(lapyra,iaux)
 506                 if ( voltri(2,letria).eq.0 ) then
 507 #ifdef _DEBUG_HOMARD_
 508               write (ulsort,texte(langue,6)) mess14(langue,1,2), letria
 509 #endif
 510 c
 511                   aubord = .true.
 512                   if ( cfatri(cotyel,famtri(letria)).eq.0 ) then
 513                     nbensb = nbensb + 1
 514 #ifdef _DEBUG_HOMARD_
 515               write (ulsort,texte(langue,7)) mess14(langue,1,5), lapyra
 516 #endif
 517                     goto 429
 518                   endif
 519 c
 520                 endif
 521 c
 522    42         continue
 523 c
 524               lequad = facpyr(lapyra,5)
 525               if ( volqua(2,lequad).eq.0 ) then
 526 #ifdef _DEBUG_HOMARD_
 527               write (ulsort,texte(langue,6)) mess14(langue,1,4), lequad
 528 #endif
 529 c
 530                 aubord = .true.
 531                 if ( cfaqua(cotyel,famqua(lequad)).eq.0 ) then
 532                   nbensb = nbensb + 1
 533 #ifdef _DEBUG_HOMARD_
 534               write (ulsort,texte(langue,7)) mess14(langue,1,5), lapyra
 535 #endif
 536                   goto 429
 537                 endif
 538 c
 539               endif
 540 c
 541   429         continue
 542 c
 543             endif
 544 c
 545           endif
 546 c
 547     4   continue
 548 c
 549 c 4.3. ==> Impression
 550 c
 551 #ifdef _DEBUG_HOMARD_
 552       write (ulsort,texte(langue,3)) 'UTB17E', nompro
 553 #endif
 554         iaux = 5
 555         call utb17e ( iaux, nbensc, aubord, nbensb,
 556      >                ulbila,
 557      >                ulsort, langue, codret )
 558 c
 559       endif
 560 c
 561 c====
 562 c 5. Diagnostic sur les pentaedres
 563 c====
 564 #ifdef _DEBUG_HOMARD_
 565       write (ulsort,90002) '5. pentaedres, codret', codret
 566 #endif
 567 c
 568       if ( nbpeac.gt.0 ) then
 569 c
 570 #ifdef _DEBUG_HOMARD_
 571       write (ulsort,90002) 'nbpeto', nbpeto
 572       write (ulsort,90002) 'nbpecf', nbpecf
 573       write (ulsort,90002) 'nbpeca', nbpeca
 574 #endif
 575 c
 576         if ( nbpeca.eq.0 ) then
 577           afaire =.true.
 578         else
 579           afaire =.false.
 580         endif
 581 c
 582         nbensc = 0
 583         nbensb = 0
 584         aubord = .false.
 585 c
 586         do 5 , lepen0 = 1, nbpeto
 587 c
 588           lepent = lepen0
 589 c
 590 #ifdef _DEBUG_HOMARD_
 591       write (ulsort,texte(langue,5)) mess14(langue,1,7), lepent
 592 #endif
 593 c
 594           etat = mod( hetpen(lepent),100)
 595 c
 596           if ( etat.eq.0 ) then
 597 c
 598 c 5.1. ==> On regarde si tous les noeuds sont sur le bord
 599 c
 600             call utaspe ( lepent,
 601      >                    nbquto, nbpecf, nbpeca,
 602      >                    somare, arequa,
 603      >                    facpen, cofape, arepen,
 604      >                    listar, listso )
 605 c
 606             do 511 , iaux = 1 , 6
 607               if ( tabaux(listso(iaux)).eq.0 ) then
 608                 goto 519
 609               endif
 610   511       continue
 611             if ( degre.eq.2 ) then
 612               do 512 , iaux = 1 , 9
 613                 if ( tabaux(np2are(listar(iaux))).eq.0 ) then
 614                   goto 519
 615                 endif
 616   512         continue
 617             endif
 618 c
 619             nbensc = nbensc + 1
 620 #ifdef _DEBUG_HOMARD_
 621             write (ulsort,texte(langue,8)) mess14(langue,1,7), lepent
 622 #endif
 623 c
 624   519       continue
 625 c
 626 c 5.2. ==> On verifie que chaque face au bord est un element de calcul
 627 c          . On regarde si la face est une maille de calcul
 628 c
 629             if ( afaire ) then
 630 c
 631               do 521 , iaux = 1 , 2
 632 c
 633                 letria = facpen(lepent,iaux)
 634                 if ( voltri(2,letria).eq.0 ) then
 635 #ifdef _DEBUG_HOMARD_
 636               write (ulsort,texte(langue,6)) mess14(langue,1,2), letria
 637 #endif
 638 c
 639                   aubord = .true.
 640                   if ( cfatri(cotyel,famtri(letria)).eq.0 ) then
 641                     nbensb = nbensb + 1
 642 #ifdef _DEBUG_HOMARD_
 643               write (ulsort,texte(langue,7)) mess14(langue,1,7), lepent
 644 #endif
 645                     goto 529
 646                   endif
 647 c
 648                 endif
 649 c
 650   521         continue
 651 c
 652               do 522 , iaux = 3 , 5
 653 c
 654                 lequad = facpen(lepent,iaux)
 655                 if ( volqua(2,lequad).eq.0 ) then
 656 #ifdef _DEBUG_HOMARD_
 657               write (ulsort,texte(langue,6)) mess14(langue,1,4), lequad
 658 #endif
 659 c
 660                   aubord = .true.
 661                   if ( cfaqua(cotyel,famqua(lequad)).eq.0 ) then
 662                     nbensb = nbensb + 1
 663 #ifdef _DEBUG_HOMARD_
 664               write (ulsort,texte(langue,7)) mess14(langue,1,7), lepent
 665 #endif
 666                     goto 529
 667                   endif
 668 c
 669                 endif
 670 c
 671   522         continue
 672 c
 673   529         continue
 674 c
 675             endif
 676 c
 677           endif
 678 c
 679     5   continue
 680 c
 681 c 5.3. ==> Impression
 682 c
 683 #ifdef _DEBUG_HOMARD_
 684       write (ulsort,texte(langue,3)) 'UTB17E', nompro
 685 #endif
 686         iaux = 7
 687         call utb17e ( iaux, nbensc, aubord, nbensb,
 688      >                ulbila,
 689      >                ulsort, langue, codret )
 690 c
 691       endif
 692 c
 693 c====
 694 c 6. La fin
 695 c====
 696 c
 697 #ifdef _DEBUG_HOMARD_
 698       write (ulsort,texte(langue,1)) 'Sortie', nompro
 699       call dmflsh (iaux)
 700 #endif
 701 c
 702       end