src/tool/Decision/derco5.F

   1       subroutine derco5 ( tyconf, niveau,
   2      >                    decare, decfac,
   3      >                    hetare, filare, arehom,
   4      >                    hettri, aretri, filtri, nivtri, homtri,
   5      >                    voltri, pypetr,
   6      >                    hetqua, arequa, filqua, nivqua, quahom,
   7      >                    volqua, pypequ,
   8      >                    tritet,
   9      >                    quahex, coquhe,
  10      >                    facpyr, cofapy,
  11      >                    facpen, cofape,
  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 traitement des DEcisions - Raffinement : COntamination - option 2
  34 c                --          -             --                     -
  35 c Application de la regle des ecarts de niveau, tout type de raffinement
  36 c en presence d'aretes et/ou de faces homologues
  37 c ______________________________________________________________________
  38 c .        .     .        .                                            .
  39 c .  nom   . e/s . taille .           description                      .
  40 c .____________________________________________________________________.
  41 c . tyconf . e   .   1    .  0 : conforme (defaut)                     .
  42 c .        .     .        .  1 : non-conforme avec au minimum 2 aretes .
  43 c .        .     .        .      non decoupees en 2                    .
  44 c .        .     .        .  2 : non-conforme avec 1 seul noeud        .
  45 c .        .     .        .      pendant par arete                     .
  46 c .        .     .        .  3 : non-conforme fidele a l'indicateur    .
  47 c .        .     .        . -1 : conforme, avec des boites pour les    .
  48 c .        .     .        .      quadrangles, hexaedres et pentaedres  .
  49 c .        .     .        . -2 : non-conforme avec au maximum 1 arete  .
  50 c .        .     .        .      decoupee en 2 (boite pour les         .
  51 c .        .     .        .      quadrangles, hexaedres et pentaedres) .
  52 c .        .     .        . -2 : non-conforme avec au maximum 1 arete  .
  53 c .        .     .        .      decoupee en 2 (boite pour les         .
  54 c .        .     .        .      quadrangles, hexaedres et pentaedres) .
  55 c . niveau . e   .    1   . niveau en cours d'examen                   .
  56 c . decare . es  . nbarto . decisions des aretes                       .
  57 c . decfac . es  . -nbquto. decision sur les faces (quad. + tri.)      .
  58 c .        .     . :nbtrto.                                            .
  59 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  60 c . filare . e   . nbarto . premiere fille des aretes                  .
  61 c . arehom . e   . nbarto . ensemble des aretes homologues             .
  62 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  63 c . aretri . e   . nbtrto . numeros des 3 aretes des triangles         .
  64 c . filtri . e   . nbtrto . premier fils des triangles                 .
  65 c . nivtri . e   . nbtrto . niveau des triangles                       .
  66 c . homtri . e   . nbtrto . ensemble des triangles homologues          .
  67 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  68 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  69 c .        .     .        .   0 : pas de voisin                        .
  70 c .        .     .        . j>0 : tetraedre j                          .
  71 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  72 c . pypetr . e   .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
  73 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  74 c .        .     .        . pypetr(2,j) = numero du pentaedre voisin   .
  75 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  76 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  77 c . arequa . e   . nbquto . numeros des 4 aretes des quadrangles       .
  78 c . filqua . e   . nbquto . premier fils des quadrangles               .
  79 c . nivqua . e   . nbquto . niveau des quadrangles                     .
  80 c . quahom . e   . nbquto . ensemble des quadrangles homologues        .
  81 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
  82 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  83 c .        .     .        .   0 : pas de voisin                        .
  84 c .        .     .        . j>0 : hexaedre j                           .
  85 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  86 c . pypequ . e   .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
  87 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
  88 c .        .     .        . pypequ(2,j) = numero du pentaedre voisin   .
  89 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
  90 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  91 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  92 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  93 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  94 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  95 c . facpen . e   .nbpecf*5. numeros des faces des pentaedres           .
  96 c . cofape . e   .nbpecf*5. code des 5 faces des pentaedres            .
  97 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  98 c . langue . e   .    1   . langue des messages                        .
  99 c .        .     .        . 1 : francais, 2 : anglais                  .
 100 c . codret . es  .    1   . code de retour des modules                 .
 101 c .        .     .        . 0 : pas de probleme                        .
 102 c ______________________________________________________________________
 103 c
 104 c====
 105 c 0. declarations et dimensionnement
 106 c====
 107 c
 108 c 0.1. ==> generalites
 109 c
 110       implicit none
 111       save
 112 c
 113       character*6 nompro
 114       parameter ( nompro = 'DERCO5' )
 115 c
 116 #include "nblang.h"
 117 c
 118 c 0.2. ==> communs
 119 c
 120 #include "envex1.h"
 121 #include "nombar.h"
 122 #include "nombtr.h"
 123 #include "nombqu.h"
 124 #include "nombte.h"
 125 #include "nombpy.h"
 126 #include "nombhe.h"
 127 #include "nombpe.h"
 128 c
 129 c 0.3. ==> arguments
 130 c
 131       integer tyconf
 132       integer niveau
 133       integer decare(0:nbarto)
 134       integer decfac(-nbquto:nbtrto)
 135       integer hetare(nbarto), filare(nbarto)
 136       integer arehom(nbarto)
 137       integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto)
 138       integer nivtri(nbtrto), homtri(nbtrto)
 139       integer voltri(2,nbtrto), pypetr(2,*)
 140       integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto)
 141       integer nivqua(nbquto), quahom(nbquto)
 142       integer volqua(2,nbquto), pypequ(2,*)
 143       integer tritet(nbtecf,4)
 144       integer quahex(nbhecf,6), coquhe(nbhecf,6)
 145       integer facpyr(nbpycf,5), cofapy(nbpycf,5)
 146       integer facpen(nbpecf,5), cofape(nbpecf,5)
 147 c
 148       integer ulsort, langue, codret
 149 c
 150 c 0.4. ==> variables locales
 151 c
 152       integer iaux, jaux, kaux
 153       integer iarelo
 154       integer laface, lafac2
 155       integer larete
 156       integer etat
 157       integer nbaret, listar(12), nbface, listfa(12)
 158 cgn      integer nbareh, listah(4)
 159       integer nbvolu, listvo(2), typevo(2)
 160       integer nbvotr, nbvoqu, nbvoto
 161 c
 162       integer afaire
 163 c
 164       integer nbmess
 165       parameter ( nbmess = 30 )
 166       character*80 texte(nblang,nbmess)
 167 c
 168 c 0.5. ==> initialisations
 169 c ______________________________________________________________________
 170 c
 171 c====
 172 c 1. initialisations
 173 c====
 174 c
 175 #include "impr01.h"
 176 c
 177 #ifdef _DEBUG_HOMARD_
 178       write (ulsort,texte(langue,1)) 'Entree', nompro
 179       call dmflsh (iaux)
 180 #endif
 181 c
 182 #include "impr03.h"
 183 c
 184 #ifdef _DEBUG_HOMARD_
 185       write (ulsort,90002) 'tyconf', tyconf
 186 #endif
 187 c
 188 #include "derco1.h"
 189 c
 190 #ifdef _DEBUG_HOMARD_
 191       write (ulsort,texte(langue,12)) niveau
 192 #endif
 193 c
 194 #ifdef _DEBUG_HOMARD_
 195       write (ulsort,*) 'entree de ',nompro
 196       do 1105 , iaux = 1 , -nbquto
 197         write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux)
 198 cgn        write (ulsort,90001) 'quadrangle', iaux,
 199 cgn     >  arequa(iaux,1), arequa(iaux,2),
 200 cgn     >  arequa(iaux,3), arequa(iaux,4)
 201  1105 continue
 202       if ( nbquto.gt.0 ) then
 203         iaux = min(nbquto,12)
 204         write (ulsort,90001) 'quadrangle', iaux,
 205      >  arequa(iaux,1), arequa(iaux,2),
 206      >  arequa(iaux,3), arequa(iaux,4)
 207         write (ulsort,90001) 'quadrangle', iaux,
 208      >  decare(arequa(iaux,1)), decare(arequa(iaux,2)),
 209      >  decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux)
 210         iaux = min(nbquto,10)
 211         write (ulsort,90001) 'quadrangle', iaux,
 212      >  arequa(iaux,1), arequa(iaux,2),
 213      >  arequa(iaux,3), arequa(iaux,4)
 214         write (ulsort,90001) 'quadrangle', iaux,
 215      >  decare(arequa(iaux,1)), decare(arequa(iaux,2)),
 216      >  decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux)
 217         iaux = min(nbquto,19)
 218         write (ulsort,90001) 'quadrangle', iaux,
 219      >  arequa(iaux,1), arequa(iaux,2),
 220      >  arequa(iaux,3), arequa(iaux,4)
 221         write (ulsort,90001) 'quadrangle', iaux,
 222      >  decare(arequa(iaux,1)), decare(arequa(iaux,2)),
 223      >  decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux)
 224       endif
 225 #endif
 226 c
 227       codret = 0
 228 c
 229       nbvoto = nbteto + nbpyto + nbheto + nbpeto
 230 c
 231 c  nombre maximum de volumes par triangle ou quadrangle
 232 c
 233       if ( nbteto.eq.0 .and. nbpyto.eq.0 .and. nbpeto.eq.0 ) then
 234         nbvotr = 0
 235       else
 236         nbvotr = 2
 237       endif
 238 c
 239       if ( nbheto.eq.0 .and. nbpyto.eq.0 .and. nbpeto.eq.0 ) then
 240         nbvoqu = 0
 241       else
 242         nbvoqu = 2
 243       endif
 244 c
 245 c====
 246 c 2. Application de la regle des ecarts de niveau aux faces
 247 c====
 248 c
 249       do 2 , laface = -nbquto , nbtrto
 250 cgn      print *,'debut boucle 2 : decfac(',laface,') :',decfac(laface)
 251 c
 252 c 2.1. ==> On s'interesse aux faces du niveau courant :
 253 c             . actives a garder
 254 c          ou . inactives a garder et bord de volume
 255 c          ou . inactives a reactiver
 256 c
 257         if ( laface.gt.0 ) then
 258 c
 259           if ( nivtri(laface).eq.niveau ) then
 260             etat = mod( hettri(laface) , 10 )
 261 cgn            write (ulsort,texte(langue,29))'Triangle', laface,
 262 cgn     >      nivtri(laface), hettri(laface), decfac(laface)
 263           else
 264             goto 2
 265           endif
 266 c
 267         elseif ( laface.lt.0 ) then
 268 c
 269           iaux = -laface
 270           if ( nivqua(iaux).eq.niveau ) then
 271             etat = mod( hetqua(iaux) , 100 )
 272 cgn            write (ulsort,texte(langue,29))'Quadrangle', -laface,
 273 cgn     >      nivqua(-laface), hetqua(-laface), decfac(laface)
 274           else
 275             goto 2
 276           endif
 277 c
 278         else
 279 c
 280           goto 2
 281 c
 282         endif
 283 c
 284         afaire = 0
 285         if ( etat.eq.0  ) then
 286           if ( decfac(laface).eq.0 ) then
 287             afaire = 1
 288           endif
 289         elseif ( etat.eq.4 .or.
 290      >           etat.eq.6 .or. etat.eq.7 .or. etat.eq.8  ) then
 291           if ( decfac(laface).eq.0 .and. nbvoto.gt.0 ) then
 292             afaire = 3
 293           elseif ( decfac(laface).eq.-1 ) then
 294             if ( nbvoto.eq.0 ) then
 295               afaire = 2
 296             else
 297               afaire = 4
 298             endif
 299           endif
 300         endif
 301 cgn        write (ulsort,*) 'Face', laface, ', afaire = ', afaire
 302 c
 303 c 2.2. ==> Liste des aretes de la face
 304 c
 305         if ( afaire.gt.0 ) then
 306 c
 307           if ( laface.gt.0 ) then
 308             nbaret = 3
 309             do 221 , iarelo = 1 , nbaret
 310               listar(iarelo) = aretri(laface,iarelo)
 311   221       continue
 312           else
 313             nbaret = 4
 314             iaux = -laface
 315             do 222 , iarelo = 1 , nbaret
 316               listar(iarelo) = arequa(iaux,iarelo)
 317  222        continue
 318           endif
 319 c
 320 #ifdef _DEBUG_HOMARD_
 321         else
 322           write (ulsort,texte(langue,15))
 323 #endif
 324         endif
 325 c
 326 c 2.3. ==> Cas du raffinement a propager par voisinage
 327 c
 328         if ( afaire.eq.1 ) then
 329 c
 330 c 2.3.1. ==> Decompte des aretes coupees en 2 avec une fille a couper :
 331 c            . celles d'etat > 0
 332 c            . et avec une fille de decision > 0
 333 c            S'il n'y en a pas, rien n'est a faire
 334 c
 335           kaux = 0
 336           do 231, iaux = 1 , nbaret
 337             larete = listar(iaux)
 338 cgn      print *,'.... arete possible', larete
 339             if ( mod(hetare(larete),10).gt.0 ) then
 340               jaux = filare(larete)
 341               if ( decare(jaux).gt.0 .or. decare(jaux+1).gt.0 ) then
 342                 kaux = kaux + 1
 343               endif
 344             endif
 345   231     continue
 346 c
 347 c 2.3.2. ==> Propagation du raffinement sur la face et ses
 348 c            aretes actives
 349 c
 350           if ( kaux.gt.0 ) then
 351 c
 352 cgn            nbareh = 0
 353 c
 354             decfac(laface) = 4
 355 #ifdef _DEBUG_HOMARD_
 356       write (ulsort,texte(langue,30))'decfac', laface,decfac(laface),' '
 357 #endif
 358             do 232 , iaux = 1 , nbaret
 359               larete = listar(iaux)
 360               if ( decare(larete).eq.0 ) then
 361                 if ( mod(hetare(larete),10).eq.0 ) then
 362                   decare(larete) = 2
 363 #ifdef _DEBUG_HOMARD_
 364       write (ulsort,texte(langue,30))' decare',larete,decare(larete),' '
 365 #endif
 366 cgn                  if ( arehom(larete).ne.0 ) then
 367 cgn                    nbareh = nbareh + 1
 368 cgn                    listah(nbareh) = abs( arehom(larete) )
 369 cgn                  endif
 370                 endif
 371               endif
 372   232       continue
 373 cgn        write (ulsort,1000) nbareh,' aretes :',
 374 cgn     >      (listah(iaux),iaux=1,nbareh)
 375 cgn 1000 format(i2,a,12i5)
 376 c
 377           endif
 378 c
 379         endif
 380 c
 381 c 2.4. ==> Cas du deraffinement a inhiber par voisinage
 382 c
 383         if ( afaire.eq.2 .or. afaire.eq.4 ) then
 384 c
 385 c 2.4.1. ==> Decompte des aretes coupees en 2 avec une fille coupee
 386 c            qui ne reapparait pas
 387 c            S'il n'y en a pas, rien n'est a faire
 388 c
 389           kaux = 0
 390           do 241, iaux = 1 , nbaret
 391             larete = listar(iaux)
 392 cgn            write (ulsort,*) larete, decare(larete)
 393             jaux = filare(larete)
 394             if ( decare(jaux).gt.0 .or. decare(jaux+1).gt.0 ) then
 395               kaux = kaux + 1
 396             endif
 397   241     continue
 398 c
 399 c 2.4.2. ==> Inhibition du raffinement sur la face et ses aretes
 400 c
 401           if ( kaux.gt.0 ) then
 402 c
 403 cgn            nbareh = 0
 404 c
 405             decfac(laface) = 0
 406 #ifdef _DEBUG_HOMARD_
 407       write (ulsort,texte(langue,30))'decfac', laface,decfac(laface),' '
 408 #endif
 409             do 242 , iaux = 1 , nbaret
 410               larete = listar(iaux)
 411               if ( decare(larete).eq.-1 ) then
 412                 decare(larete) = 0
 413 #ifdef _DEBUG_HOMARD_
 414       write (ulsort,texte(langue,30))' decare',larete,decare(larete),' '
 415 #endif
 416 cgn                if ( arehom(larete).ne.0 ) then
 417 cgn                  nbareh = nbareh + 1
 418 cgn                  listah(nbareh) = abs( arehom(larete) )
 419 cgn                endif
 420               endif
 421   242       continue
 422 cgn        write (ulsort,1000) nbareh,' aretes :',
 423 cgn     >      (listah(iaux),iaux=1,nbareh)
 424 c
 425           endif
 426 c
 427         endif
 428 c
 429 c 2.5. ==> Cas du raffinement a propager ou du deraffinement a inhiber
 430 c          par l'interieur de volumes
 431 c
 432         if ( afaire.ge.3 ) then
 433 c
 434 c 2.5.1. ==> Pour chaque face, on regarde si une arete tracee sur
 435 c            la face va etre coupee.
 436 c            . Pour un triangle, ces aretes sont celles qui definissent
 437 c              la fille face centrale (cf. cmrdtr)
 438 c            . Pour un quadrangle, ces aretes sont la 2eme et le 3eme
 439 c              du premier et du troisieme fils (cf. cmrdqu)
 440 c            S'il n'y en a pas, rien n'est a faire
 441 c
 442           kaux = 0
 443 c
 444           if ( laface.gt.0 ) then
 445             jaux = filtri(laface)
 446             nbaret = 3
 447             do 2511 , iarelo = 1 , nbaret
 448               listar(iarelo) = aretri(jaux,iarelo)
 449  2511       continue
 450           else
 451             jaux = filqua(-laface)
 452             nbaret = 4
 453             listar(1) = arequa(jaux  ,2)
 454             listar(2) = arequa(jaux  ,3)
 455             listar(3) = arequa(jaux+2,2)
 456             listar(4) = arequa(jaux+2,3)
 457           endif
 458 c
 459           do 2513 , iarelo = 1 , nbaret
 460 cgn       write (ulsort,*) 'hetare, decare(',listar(iarelo),') =',
 461 cgn     >hetare(listar(iarelo)), decare(listar(iarelo))
 462             if ( decare(listar(iarelo)).gt.0 ) then
 463               kaux = kaux + 1
 464             endif
 465  2513     continue
 466 cgn         write (ulsort,*)'      kaux', kaux
 467 c
 468 c 2.5.2. ==> La face retenue borde-t-elle un volume ?
 469 c
 470           nbvolu = 0
 471 c
 472           if ( kaux.gt.0 ) then
 473 c
 474             if ( laface.gt.0 ) then
 475 c
 476               do 2521, iaux = 1 , nbvotr
 477                 jaux = voltri(iaux,laface)
 478                 if ( jaux.gt.0 ) then
 479                   nbvolu = nbvolu + 1
 480                   listvo(nbvolu) = jaux
 481                   typevo(nbvolu) = 3
 482                 elseif ( jaux.lt.0 ) then
 483                   if ( pypetr(1,-jaux).ne.0 ) then
 484                     nbvolu = nbvolu + 1
 485                     listvo(nbvolu) = pypetr(1,-jaux)
 486                     typevo(nbvolu) = 5
 487                   endif
 488                   if ( pypetr(2,-jaux).ne.0 ) then
 489                     nbvolu = nbvolu + 1
 490                     listvo(nbvolu) = pypetr(2,-jaux)
 491                     typevo(nbvolu) = 7
 492                   endif
 493                 endif
 494  2521         continue
 495 c
 496             else
 497 c
 498               do 2522, iaux = 1 , nbvoqu
 499                 jaux = volqua(iaux,-laface)
 500                 if ( jaux.gt.0 ) then
 501                   nbvolu = nbvolu + 1
 502                   listvo(nbvolu) = jaux
 503                   typevo(nbvolu) = 6
 504                 elseif ( jaux.lt.0 ) then
 505                   if ( pypequ(1,-jaux).ne.0 ) then
 506                     nbvolu = nbvolu + 1
 507                     listvo(nbvolu) = pypequ(1,-jaux)
 508                     typevo(nbvolu) = 5
 509                   endif
 510                   if ( pypequ(2,-jaux).ne.0 ) then
 511                     nbvolu = nbvolu + 1
 512                     listvo(nbvolu) = pypequ(2,-jaux)
 513                     typevo(nbvolu) = 7
 514                   endif
 515                 endif
 516  2522         continue
 517 c
 518             endif
 519 cgn       write (ulsort,*)nbvolu,'volumes', (listvo(iaux),iaux=1,nbvolu)
 520 cgn       write (ulsort,*)nbvolu,'types  ', (typevo(iaux),iaux=1,nbvolu)
 521 c
 522           endif
 523 c
 524 c 2.5.3. ==> Une des aretes tracees sur laface sera coupee. Il faut que
 525 c            le ou les volumes s'appuyant sur laface soient coupes
 526 c
 527           if ( nbvolu.gt.0 ) then
 528 c
 529 c 2.5.3. ==> Recherche des faces concernees
 530 c
 531             nbface = 0
 532             do 2531 , iaux = 1 , nbvolu
 533               jaux = listvo(iaux)
 534 cgn       write (ulsort,*)'Volume', jaux,' de type',typevo(iaux)
 535               if ( typevo(iaux).eq.3 ) then
 536                 do 25311 , kaux = 1 , 4
 537                   nbface = nbface + 1
 538                   listfa(nbface) = tritet(jaux,kaux)
 539 25311           continue
 540               elseif ( typevo(iaux).eq.5 ) then
 541                 listfa(1) =  facpyr(jaux,1)
 542                 listfa(2) =  facpyr(jaux,2)
 543                 listfa(3) =  facpyr(jaux,3)
 544                 listfa(4) =  facpyr(jaux,4)
 545                 listfa(5) = -facpyr(jaux,5)
 546                 nbface = 5
 547               elseif ( typevo(iaux).eq.6 ) then
 548                 do 25313 , kaux = 1 , 6
 549                   nbface = nbface + 1
 550                   listfa(nbface) = -quahex(jaux,kaux)
 551 25313           continue
 552               elseif ( typevo(iaux).eq.7 ) then
 553                 listfa(1) =  facpen(jaux,1)
 554                 listfa(2) =  facpen(jaux,2)
 555                 listfa(3) = -facpen(jaux,3)
 556                 listfa(4) = -facpen(jaux,4)
 557                 listfa(5) = -facpen(jaux,5)
 558                 nbface = 5
 559               endif
 560  2531       continue
 561 cgn        write (ulsort,1000)nbface,' faces :',
 562 cgn     >      (listfa(iaux),iaux=1,nbface)
 563 cgn 1000 format(i2,a,12i5)
 564 c
 565             do 2532 , iaux = 1 , nbface
 566 c
 567               lafac2 = listfa(iaux)
 568 cgn              if ( lafac2.gt.0 ) then
 569 cgn            write (ulsort,texte(langue,29))'Triangle', lafac2,
 570 cgn     >      nivtri(lafac2), hettri(lafac2), decfac(lafac2)
 571 cgn              else
 572 cgn            write (ulsort,texte(langue,29))'Quadrangle', -lafac2,
 573 cgn     >      nivqua(-lafac2), hetqua(-lafac2), decfac(lafac2)
 574 cgn              endif
 575               if ( decfac(lafac2).eq.-1 ) then
 576                 decfac(lafac2) = 0
 577 #ifdef _DEBUG_HOMARD_
 578       write (ulsort,texte(langue,30))'decfac', lafac2,decfac(lafac2),' '
 579 #endif
 580               elseif ( decfac(lafac2).eq.0 ) then
 581                 if ( lafac2.gt.0 ) then
 582                   if ( mod(hettri(lafac2),10).eq.0 ) then
 583                     decfac(lafac2) = 4
 584 #ifdef _DEBUG_HOMARD_
 585       write (ulsort,texte(langue,30))'decfac', lafac2,decfac(lafac2),' '
 586 #endif
 587                   endif
 588                 else
 589                   if ( mod(hetqua(-lafac2),100).eq.0 ) then
 590                     decfac(lafac2) = 4
 591 #ifdef _DEBUG_HOMARD_
 592       write (ulsort,texte(langue,30))'decfac', lafac2,decfac(lafac2),' '
 593 #endif
 594                   endif
 595                 endif
 596               endif
 597 c
 598               if ( lafac2.gt.0 ) then
 599                 nbaret = 3
 600                 do 2533 , iarelo = 1 , nbaret
 601                   listar(iarelo) = aretri(lafac2,iarelo)
 602  2533           continue
 603               else
 604                 nbaret = 4
 605                 do 2534 , iarelo = 1 , nbaret
 606                   listar(iarelo) = arequa(-lafac2,iarelo)
 607  2534           continue
 608               endif
 609 c
 610               do 2535 , jaux = 1 , nbaret
 611                 larete = listar(jaux)
 612                 if ( decare(larete).eq.0 ) then
 613                   if ( mod(hetare(larete),10).eq.0 ) then
 614                     decare(larete) = 2
 615 #ifdef _DEBUG_HOMARD_
 616       write (ulsort,texte(langue,30))' decare',larete,decare(larete),' '
 617 #endif
 618                     if ( arehom(larete).ne.0 ) then
 619                       decare(abs(arehom(larete))) = 2
 620 #ifdef _DEBUG_HOMARD_
 621       write (ulsort,texte(langue,30))' decare',
 622      >            abs(arehom(larete)),decare(abs(arehom(larete))),' '
 623 #endif
 624                     endif
 625                   endif
 626                 elseif ( decare(larete).eq.-1 ) then
 627                   decare(larete) = 0
 628 #ifdef _DEBUG_HOMARD_
 629       write (ulsort,texte(langue,30))' decare',larete,decare(larete),' '
 630 #endif
 631                   if ( arehom(larete).ne.0 ) then
 632                     decare(abs(arehom(larete))) = 0
 633 #ifdef _DEBUG_HOMARD_
 634       write (ulsort,texte(langue,30))' decare',
 635      >            abs(arehom(larete)),decare(abs(arehom(larete))),' '
 636 #endif
 637                   endif
 638                 endif
 639  2535         continue
 640 c
 641  2532       continue
 642 c
 643           endif
 644 c
 645         endif
 646 c
 647     2 continue
 648 c
 649 c====
 650 c 3. Transfert via les volumes ayant des quadrangles comme faces
 651 c    Si une fille de l'une de ses aretes est a couper, le volume
 652 c    doit l'etre entierement : on le declare par ses aretes.
 653 c====
 654 c
 655       if ( tyconf.eq.0 ) then
 656 c
 657         if ( codret.eq.0 ) then
 658 c
 659 #ifdef _DEBUG_HOMARD_
 660         write (ulsort,texte(langue,3)) 'DERCO9', nompro
 661 #endif
 662         call derco9 ( niveau,
 663      >                decare,
 664      >                hetare, filare,
 665      >                aretri, nivtri,
 666      >                arequa, nivqua,
 667      >                quahex, coquhe,
 668      >                facpyr, cofapy,
 669      >                facpen, cofape,
 670      >                ulsort, langue, codret )
 671 c
 672       endif
 673 c
 674       endif
 675 c
 676 #ifdef _DEBUG_HOMARD_
 677       write (ulsort,*) 'sortie de ',nompro
 678       do 1106 , iaux = 1 , nbquto
 679         write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux)
 680 cgn        write (ulsort,90001) 'quadrangle', iaux,
 681 cgn     >  arequa(iaux,1), arequa(iaux,2),
 682 cgn     >  arequa(iaux,3), arequa(iaux,4)
 683  1106 continue
 684       if ( nbquto.gt.0 ) then
 685         iaux = min(nbquto,12)
 686         write (ulsort,90001) 'quadrangle', iaux,
 687      >  arequa(iaux,1), arequa(iaux,2),
 688      >  arequa(iaux,3), arequa(iaux,4)
 689         write (ulsort,90001) 'quadrangle', iaux,
 690      >  decare(arequa(iaux,1)), decare(arequa(iaux,2)),
 691      >  decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux)
 692         iaux = min(nbquto,10)
 693         write (ulsort,90001) 'quadrangle', iaux,
 694      >  arequa(iaux,1), arequa(iaux,2),
 695      >  arequa(iaux,3), arequa(iaux,4)
 696         write (ulsort,90001) 'quadrangle', iaux,
 697      >  decare(arequa(iaux,1)), decare(arequa(iaux,2)),
 698      >  decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux)
 699         iaux = min(nbquto,19)
 700         write (ulsort,90001) 'quadrangle', iaux,
 701      >  arequa(iaux,1), arequa(iaux,2),
 702      >  arequa(iaux,3), arequa(iaux,4)
 703         write (ulsort,90001) 'quadrangle', iaux,
 704      >  decare(arequa(iaux,1)), decare(arequa(iaux,2)),
 705      >  decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux)
 706       endif
 707 #endif
 708 c
 709 c====
 710 c 3. la fin
 711 c====
 712 c
 713       if ( codret.ne.0 ) then
 714 c
 715 #include "envex2.h"
 716 c
 717       write (ulsort,texte(langue,1)) 'Sortie', nompro
 718       write (ulsort,texte(langue,2)) codret
 719 c
 720       endif
 721 c
 722 #ifdef _DEBUG_HOMARD_
 723       write (ulsort,texte(langue,1)) 'Sortie', nompro
 724       call dmflsh (iaux)
 725 #endif
 726 c
 727       end