src/tool/Decision/dedco1.F

   1       subroutine dedco1 ( tyconf,
   2      >                    decare, decfac,
   3      >                    posifa, facare,
   4      >                    hetare, merare,
   5      >                    hettri, aretri, nivtri,
   6      >                    hetqua, arequa, nivqua,
   7      >                    listfa,
   8      >                    ulsort, langue, codret )
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c traitement des DEcisions - Deraffinement : COntamination - option 1
  30 c                --          -               --                     -
  31 c  cas sans homologues
  32 c ______________________________________________________________________
  33 c .        .     .        .                                            .
  34 c .  nom   . e/s . taille .           description                      .
  35 c .____________________________________________________________________.
  36 c . tyconf . e   .   1    .  0 : conforme (defaut)                     .
  37 c .        .     .        .  1 : non-conforme avec au minimum 2 aretes .
  38 c .        .     .        .      non decoupees en 2 par face           .
  39 c .        .     .        .  2 : non-conforme avec 1 seul noeud        .
  40 c .        .     .        .      pendant par arete                     .
  41 c .        .     .        .  3 : non-conforme fidele a l'indicateur    .
  42 c .        .     .        . -1 : conforme, avec des boites pour les    .
  43 c .        .     .        .      quadrangles, hexaedres et pentaedres  .
  44 c .        .     .        . -2 : non-conforme avec au maximum 1 arete  .
  45 c .        .     .        .      decoupee en 2 (boite pour les         .
  46 c .        .     .        .      quadrangles, hexaedres et pentaedres) .
  47 c . decare . e/s . nbarto . decisions des aretes                       .
  48 c . decfac . e/s . -nbquto. decision sur les faces (quad. + tri.)      .
  49 c .        .     . :nbtrto.                                            .
  50 c . posifa . e   . nbarto . pointeur sur tableau facare                .
  51 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  52 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  53 c . merare . e   . nbarto . mere des aretes                            .
  54 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  55 c . aretri . e   . nbtrto . numeros des 3 aretes des triangles         .
  56 c . nivtri . e   . nbtrto . niveau des triangles                       .
  57 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  58 c . arequa . e   . nbquto . numeros des 4 aretes des quadrangles       .
  59 c . nivqua . e   . nbquto . niveau des quadrangles                     .
  60 c . listfa . t   .   *    . liste de faces a considerer                .
  61 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  62 c . langue . e   .    1   . langue des messages                        .
  63 c .        .     .        . 1 : francais, 2 : anglais                  .
  64 c . codret . es  .    1   . code de retour des modules                 .
  65 c .        .     .        . 0 : pas de probleme                        .
  66 c ______________________________________________________________________
  67 c
  68 c====
  69 c 0. declarations et dimensionnement
  70 c====
  71 c
  72 c 0.1. ==> generalites
  73 c
  74       implicit none
  75       save
  76 c
  77       character*6 nompro
  78       parameter ( nompro = 'DEDCO1' )
  79 c
  80 #include "nblang.h"
  81 c
  82 c 0.2. ==> communs
  83 c
  84 #include "envex1.h"
  85 c
  86 #include "envada.h"
  87 #include "nombar.h"
  88 #include "nombtr.h"
  89 #include "nombqu.h"
  90 #include "impr02.h"
  91 c
  92 c 0.3. ==> arguments
  93 c
  94       integer tyconf
  95       integer decare(0:nbarto)
  96       integer decfac(-nbquto:nbtrto)
  97       integer posifa(0:nbarto), facare(nbfaar)
  98       integer hetare(nbarto), merare(nbarto)
  99       integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto)
 100       integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto)
 101       integer listfa(*)
 102 c
 103       integer ulsort, langue, codret
 104 c
 105 c 0.4. ==> variables locales
 106 c
 107       integer nivdeb, nivfin, niveau
 108       integer nbfali, laface, etatfa
 109       integer facact, iarelo, iarete, etatar
 110       integer nbaret, nbar00, anodec(4)
 111       integer iaux, ideb, ifin
 112       integer ipos, iface, ifacli, merear, jarelo
 113       integer jarete
 114       integer nbare1, liare1(4), nbare2, liare2(4)
 115 #ifdef _DEBUG_HOMARD_
 116       integer jaux
 117       integer option
 118 #endif
 119 c
 120       integer nbmess
 121       parameter ( nbmess = 30 )
 122       character*80 texte(nblang,nbmess)
 123 c
 124 c 0.5. ==> initialisations
 125 c ______________________________________________________________________
 126 c
 127 c====
 128 c 1. messages
 129 c====
 130 c
 131 #include "impr01.h"
 132 c
 133 #ifdef _DEBUG_HOMARD_
 134       write (ulsort,texte(langue,1)) 'Entree', nompro
 135       call dmflsh (iaux)
 136 #endif
 137 c
 138 #include "impr03.h"
 139 c
 140 #include "derco1.h"
 141 c
 142       codret = 0
 143 c
 144 #ifdef _DEBUG_HOMARD_
 145       write (ulsort,90002) 'tyconf', tyconf
 146 #endif
 147 c
 148 #ifdef _DEBUG_HOMARD_
 149       write (ulsort,*) ' '
 150       write (ulsort,90003) 'Entree de ',nompro
 151       do 1106 , iaux = 1 , nbtrto, -1
 152         write (ulsort,90015) 'triangle', iaux, ' decision,niveau,etat',
 153      >  decfac(iaux), nivtri(iaux), hettri(iaux)
 154         write (ulsort,90002) 'aretes', aretri(iaux,1),
 155      >  aretri(iaux,2), aretri(iaux,3)
 156         write (ulsort,90002) 'decare', decare(aretri(iaux,1)),
 157      >  decare(aretri(iaux,2)), decare(aretri(iaux,3))
 158  1106 continue
 159       jaux=0
 160       do 1105 , iaux = 1 , nbquto
 161       if ( nivqua(iaux).eq.3 .and. decfac(-iaux).lt.0) then
 162         write (ulsort,90015) 'quadrangle', iaux, ' decision,niveau,etat',
 163      >  decfac(-iaux), nivqua(iaux), hetqua(iaux)
 164         write (ulsort,90002) 'aretes',
 165      >  arequa(iaux,1), arequa(iaux,2), arequa(iaux,3), arequa(iaux,4)
 166         write (ulsort,90002) 'decare',
 167      >  decare(arequa(iaux,1)), decare(arequa(iaux,2)),
 168      >  decare(arequa(iaux,3)), decare(arequa(iaux,4))
 169         jaux=jaux+1
 170         if ( jaux.eq.10) then
 171           goto 1115
 172         endif
 173         endif
 174  1105 continue
 175  1115 continue
 176       do 1104 , iaux = 1 , nbarto, -1
 177         write (ulsort,90001) 'decision arete', iaux, decare(iaux)
 178  1104 continue
 179 c
 180       do 1108 , iaux = 1 , min(2,nbquto), -1
 181       write (ulsort,90001) 'decfac pour quadrangle         ', iaux,
 182      >decfac(-iaux)
 183       write (ulsort,90001) 'aretes du quadrangle         ', iaux,
 184      >arequa(iaux,1), arequa(iaux,2),
 185      >arequa(iaux,3), arequa(iaux,4)
 186       write (ulsort,90001) 'decare pour aretes quadrangle', iaux,
 187      >decare(arequa(iaux,1)), decare(arequa(iaux,2)),
 188      >decare(arequa(iaux,3)), decare(arequa(iaux,4))
 189  1108 continue
 190 #endif
 191 c
 192 c====
 193 c 2. algorithme : on regarde tous les niveaux dans l'ordre decroissant
 194 c====
 195 c
 196 #ifdef _DEBUG_HOMARD_
 197       write (ulsort,90002) 'Etape 2', codret
 198 #endif
 199 c     initialisation vide de la liste de faces a examiner
 200 c
 201       nbfali = 0
 202 c
 203 c     initialisation du nombre d'aretes decoupees possibles
 204 c     pour un quadrangle dans le cas de l'adaptation conforme
 205       if ( tyconf.ge.0 ) then
 206         nbar00 = -2
 207       else
 208         nbar00 = 2
 209       endif
 210 c
 211       nivdeb = nivsup - 1
 212       nivfin = max(nivinf-1,0)
 213       do 100 , niveau = nivdeb , nivfin , -1
 214 c
 215 #ifdef _DEBUG_HOMARD_
 216       write (ulsort,texte(langue,12)) niveau
 217 #endif
 218 c
 219 c 2.1. ==> traitement des faces pour la regle des deux voisins
 220 c          ===================================================
 221 c          elle s'applique aux cas d'adaptation :
 222 c    tyconf = 0 ; conforme
 223 c    tyconf = 1 ; non-conforme avec au minimum 2 aretes non coupees
 224 c    tyconf = -1 ; conforme avec boites
 225 c    tyconf = -2 ; non-conforme avec au maximum 1 arete coupee
 226 c
 227         if ( tyconf.le.1 ) then
 228 c
 229         do 21 , laface = -nbquto , nbtrto
 230 c
 231 c         on regarde les faces meres d'actives du niveau courant
 232 c
 233           etatfa = -1
 234           if ( laface.gt.0 ) then
 235             if ( nivtri(laface).eq.niveau ) then
 236               etatfa = mod( hettri(laface) , 10 )
 237             endif
 238           elseif ( laface.lt.0 ) then
 239             iaux = -laface
 240             if ( nivqua(iaux).eq.niveau ) then
 241               etatfa = mod( hetqua(iaux) , 100 )
 242             endif
 243           endif
 244 c
 245 #ifdef _DEBUG_HOMARD_
 246           if ( etatfa.gt.0 ) then
 247           if ( laface.gt.0 ) then
 248             option = 2
 249             iaux=nivtri(laface)
 250           else
 251             option = 4
 252             iaux=nivqua(-laface)
 253           endif
 254           if ( ( laface.ge.-144699 .and. laface.le.-144690 ) .or.
 255      >         ( laface.eq.-164226 ) ) then
 256           write (ulsort,texte(langue,29)) mess14(langue,1,option),
 257      >    abs(laface), iaux,etatfa, decfac(laface)
 258           endif
 259           endif
 260 #endif
 261 c
 262           if ( etatfa.ge.4 .and. etatfa.le.8 ) then
 263 c
 264             facact = laface
 265 c
 266 c           --------
 267   200       continue
 268 c           --------
 269 c         debut du traitement de la face courante
 270 c         ***************************************
 271 c
 272 c           on ne regarde que les faces "a reactiver"
 273 c
 274             if ( decfac(facact).eq.-1 ) then
 275 c
 276 #ifdef _DEBUG_HOMARD_
 277               if ( facact.gt.0 ) then
 278                 option = 2
 279                 iaux=nivtri(facact)
 280                 ipos=hettri(facact)
 281               else
 282                 option = 4
 283                 iaux=nivqua(-facact)
 284                 ipos=hetqua(-facact)
 285               endif
 286           if ( ( facact.ge.-144699 .and. facact.le.-144690 ) .or.
 287      >         ( facact.eq.-164226 ) ) then
 288               write (ulsort,texte(langue,29))
 289      >'. '//mess14(langue,1,option),abs(facact),iaux,ipos,decfac(facact)
 290           endif
 291 #endif
 292 c
 293 c 2.1.1. ==> on compte les aretes inactives a garder
 294 c
 295               if ( facact.gt.0 ) then
 296                 nbare1 = 3
 297                 do 2111 , iarelo = 1 , nbare1
 298                   liare1(iarelo) = aretri(facact,iarelo)
 299  2111           continue
 300               else
 301                 nbare1 = 4
 302                 iaux = -facact
 303                 do 2112 , iarelo = 1 , nbare1
 304                   liare1(iarelo) = arequa(iaux,iarelo)
 305  2112           continue
 306               endif
 307 #ifdef _DEBUG_HOMARD_
 308           if ( ( facact.ge.-144699 .and. facact.le.-144690 ) .or.
 309      >         ( facact.eq.-164226 ) ) then
 310             write (ulsort,90002) 'nbare1', nbare1
 311             write (ulsort,90002) 'liare1', liare1
 312           endif
 313 #endif
 314 c
 315 c             nbaret = nombre d'aretes coupees en deux et a garder
 316 c             nbare2 = nombre d'aretes a reactiver
 317 c
 318               nbaret = 0
 319               nbare2 = 0
 320               do 2113 , iarelo = 1 , nbare1
 321                 iarete = liare1(iarelo)
 322 #ifdef _DEBUG_HOMARD_
 323           if ( ( facact.ge.-144699 .and. facact.le.-144690 ) .or.
 324      >         ( facact.eq.-164226 ) ) then
 325           write (ulsort,90001) '. decision arete', iarete,decare(iarete)
 326           write (ulsort,90001) '. etat     arete', iarete,hetare(iarete)
 327           endif
 328 #endif
 329                 if ( decare(iarete).eq.0 ) then
 330                   etatar = mod( hetare(iarete) , 10 )
 331                   if ( etatar.eq.2 .or. etatar.eq.9 ) then
 332                     nbaret = nbaret + 1
 333                   endif
 334                 else
 335                   nbare2 = nbare2 + 1
 336                   anodec(nbare2) = iarete
 337                   liare2(nbare2) = iarelo
 338                 endif
 339  2113         continue
 340 #ifdef _DEBUG_HOMARD_
 341           if ( ( facact.ge.-144699 .and. facact.le.-144690 ) .or.
 342      >         ( facact.eq.-164226 ) ) then
 343               write (ulsort,texte(langue,22)) nbaret, nbare2
 344           endif
 345 #endif
 346 c
 347               if ( nbaret.eq.nbare1 ) then
 348 c
 349 c 2.1.2. ==> toutes les aretes sont coupees en deux et a garder
 350 c            --------------------------------------------------
 351 c               on declare la face "a garder"
 352 c
 353                 decfac(facact) = 0
 354 c
 355 #ifdef _DEBUG_HOMARD_
 356       write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
 357 #endif
 358 c
 359               elseif ( nbaret.eq.(nbare1-1) ) then
 360 c
 361 c 2.1.3. ==> toutes les aretes sauf une sont coupees en deux et a garder
 362 c            -----------------------------------------------------------
 363 c               on declare la face et la derniere arete "a garder"
 364 c
 365                 decfac(facact) = 0
 366                 decare(anodec(1)) = 0
 367 c
 368 #ifdef _DEBUG_HOMARD_
 369       if ( anodec(1).eq.156780 ) then
 370       write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
 371       write (ulsort,texte(langue,30))'decare',
 372      >anodec(1),decare(anodec(1)),' (arete encore a reactiver)'
 373       endif
 374 #endif
 375 c
 376 c               on regarde toutes les faces qui s'appuient sur cette
 377 c               arete, on memorise celles qui sont non actives
 378 c               "a reactiver"
 379 c
 380                 ideb = posifa(anodec(1)-1)+1
 381                 ifin = posifa(anodec(1))
 382                 do 2131 , ipos = ideb , ifin
 383                   iface = facare(ipos)
 384                   if ( decfac(iface).eq.-1 ) then
 385                     if ( iface.gt.0 ) then
 386                       etatfa = mod( hettri(iface) , 10 )
 387                     else
 388                       etatfa = mod( hetqua(-iface) , 100 )
 389                     endif
 390                     if ( etatfa.ge.4 .and. etatfa.le.8 ) then
 391                       do 2132 , ifacli = 1 , nbfali
 392                         if ( listfa(ifacli).eq.iface ) then
 393                           goto 2133
 394                         endif
 395  2132                 continue
 396                       nbfali = nbfali + 1
 397                       listfa(nbfali) = iface
 398  2133                 continue
 399                     endif
 400                   endif
 401  2131           continue
 402 c
 403               elseif ( facact.lt.0 ) then
 404 c
 405                 if ( nbaret.eq.nbar00 ) then
 406 c
 407 c 2.1.4. ==> pour un quadrangle, deux aretes sont
 408 c            ------------------------------------
 409 c            des actives a garder si on veut des boites
 410 c            ------------------------------------------
 411 c               on declare la face et les 2 dernieres aretes "a garder"
 412 c
 413                   decfac(facact) = 0
 414 c
 415 #ifdef _DEBUG_HOMARD_
 416       write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
 417 #endif
 418 c
 419                   do 214 , iaux = 1 , 2
 420 c
 421                     decare(anodec(iaux)) = 0
 422 c
 423 #ifdef _DEBUG_HOMARD_
 424       if ( anodec(iaux).eq.156780 ) then
 425       write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
 426       write (ulsort,texte(langue,30))'decare',
 427      >anodec(iaux),decare(anodec(iaux)),' (arete encore a reactiver)'
 428       endif
 429 #endif
 430 c
 431 c               on regarde toutes les faces qui s'appuient sur cette
 432 c               arete, on memorise celles qui sont non actives
 433 c               "a reactiver"
 434 c
 435                     ideb = posifa(anodec(iaux)-1)+1
 436                     ifin = posifa(anodec(iaux))
 437                     do 2141 , ipos = ideb , ifin
 438                       iface = facare(ipos)
 439                       if ( decfac(iface).eq.-1 ) then
 440                         if ( iface.gt.0 ) then
 441                           etatfa = mod( hettri(iface) , 10 )
 442                         else
 443                           etatfa = mod( hetqua(-iface) , 100 )
 444                         endif
 445                         if ( etatfa.ge.4 .and. etatfa.le.8 ) then
 446                           do 2142 , ifacli = 1 , nbfali
 447                             if ( listfa(ifacli).eq.iface ) then
 448                               goto 2143
 449                             endif
 450  2142                     continue
 451                           nbfali = nbfali + 1
 452                           listfa(nbfali) = iface
 453  2143                     continue
 454                         endif
 455                       endif
 456  2141               continue
 457 c
 458   214             continue
 459 c
 460                 endif
 461 c
 462 #ifdef _DEBUG_HOMARD_
 463 c 2.1.n. ==> toutes les aretes sont a reactiver : OK
 464 c
 465               elseif ( nbare2.eq.nbare1 ) then
 466 c
 467                 write (ulsort,texte(langue,15))
 468 #endif
 469 c
 470               endif
 471 c
 472             endif
 473 c
 474             if ( nbfali.gt.0 ) then
 475 c
 476 c             on passe a la face suivante de la liste
 477 c             ---------------------------------------
 478 c
 479 #ifdef _DEBUG_HOMARD_
 480               write (ulsort,texte(langue,21)) nbfali
 481               write (ulsort,*) (listfa(iaux),iaux=1,nbfali)
 482 #endif
 483 c
 484               facact = listfa(nbfali)
 485               nbfali = nbfali - 1
 486               goto 200
 487 c
 488             endif
 489 c
 490           endif
 491 c
 492    21   continue
 493 c
 494         endif
 495 c
 496 c 2.2. ==>  regle des ecarts de niveau
 497 c           ==========================
 498 c
 499 #ifdef _DEBUG_HOMARD_
 500       write (ulsort,texte(langue,13)) niveau, niveau-1
 501 #endif
 502 c
 503         do 22 , laface = -nbquto , nbtrto
 504 c
 505 c         on passe en revue les faces :
 506 c          . du niveau courant
 507 c          . actives
 508 c
 509           etatfa = -1
 510 c
 511           if ( laface.gt.0 ) then
 512 c
 513             if ( nivtri(laface).eq.niveau ) then
 514               etatfa = mod( hettri(laface) , 10 )
 515             endif
 516 c
 517           elseif ( laface.lt.0 ) then
 518 c
 519             iaux = -laface
 520             if ( nivqua(iaux).eq.niveau ) then
 521               etatfa = mod( hetqua(iaux) , 100 )
 522             endif
 523 c
 524           endif
 525 c
 526           if ( etatfa.eq.0 ) then
 527 c
 528 #ifdef _DEBUG_HOMARD_
 529           if ( laface.gt.0 ) then
 530             option = 2
 531           elseif ( laface.lt.0 ) then
 532             option = 4
 533           endif
 534           write (ulsort,texte(langue,29)) mess14(langue,1,option),
 535      >    abs(laface), niveau,etatfa, decfac(laface)
 536 #endif
 537 c
 538 c 2.2.1. ==> liste des aretes ayant une mere
 539 c
 540             if ( laface.gt.0 ) then
 541               nbare2 = 3
 542               do 2211 , iarelo = 1 , nbare2
 543                 liare2(iarelo) = aretri(laface,iarelo)
 544  2211         continue
 545             else
 546               nbare2 = 4
 547               iaux = -laface
 548               do 2212 , iarelo = 1 , nbare2
 549                 liare2(iarelo) = arequa(iaux,iarelo)
 550  2212         continue
 551             endif
 552 c
 553             nbare1 = 0
 554             do 2213 , iaux = 1 , nbare2
 555              if ( merare(liare2(iaux)).gt.0 ) then
 556                 nbare1 = nbare1 + 1
 557                 liare1(nbare1) = liare2(iaux)
 558               endif
 559  2213       continue
 560 c
 561 c 2.2.2. ==> on parcourt les aretes retenues
 562 c
 563             do 222 , iarelo = 1 , nbare1
 564 c
 565               iarete = liare1(iarelo)
 566               merear = merare(iarete)
 567 c
 568 #ifdef _DEBUG_HOMARD_
 569       write (ulsort,texte(langue,23)) iarete, decare(iarete), merear
 570 #endif
 571 c
 572 c             on regarde toutes les faces actives qui s'appuient
 573 c             sur cette arete, et on marque comme etant "a garder"
 574 c             celles qui sont "a reactiver"
 575 c
 576               ideb = posifa(merear - 1) + 1
 577               ifin = posifa(merear)
 578               do 2221 , ipos = ideb , ifin
 579 c
 580                 iface  = facare(ipos)
 581                 if ( decfac(iface).eq.-1 ) then
 582 c
 583                   if ( iface.gt.0 ) then
 584                     etatfa = mod( hettri(iface) , 10 )
 585                   else
 586                     etatfa = mod( hetqua(-iface) , 100 )
 587                   endif
 588                   if ( etatfa.eq.0 ) then
 589                     decfac(iface) = 0
 590 #ifdef _DEBUG_HOMARD_
 591       write (ulsort,texte(langue,30)) 'decfac',
 592      > iface, decfac(iface), ' (face voisine)'
 593 #endif
 594                     if ( iface.gt.0 ) then
 595                       do 2222 , jarelo = 1 , 3
 596                         jarete = aretri(iface,jarelo)
 597                         if ( decare(jarete).eq.-1 ) then
 598                           decare(jarete) = 0
 599 #ifdef _DEBUG_HOMARD_
 600       write (ulsort,texte(langue,30)) 'decare',jarete, decare(jarete)
 601 #endif
 602                         endif
 603  2222                 continue
 604                     else
 605                       iaux = -iface
 606                       do 2223 , jarelo = 1 , 4
 607                         jarete = arequa(iaux,jarelo)
 608                         if ( decare(jarete).eq.-1 ) then
 609                           decare(jarete) = 0
 610 #ifdef _DEBUG_HOMARD_
 611       write (ulsort,texte(langue,30)) 'decare',jarete, decare(jarete)
 612 #endif
 613                         endif
 614  2223                 continue
 615                     endif
 616 c
 617                   endif
 618 c
 619                 endif
 620 c
 621  2221         continue
 622 c
 623   222       continue
 624 c
 625           endif
 626 c
 627    22   continue
 628 c
 629   100 continue
 630 c
 631 #ifdef _DEBUG_HOMARD_
 632       write (ulsort,*) ' '
 633       write (ulsort,90003) 'Sortie de ',nompro
 634       do 9906 , iaux = 1 , nbtrto, -1
 635         write (ulsort,90001) 'decision triangle', iaux, decfac(iaux)
 636  9906 continue
 637       jaux=0
 638       do 9905 , iaux = 1 , nbquto
 639       if ( nivqua(iaux).eq.3 .and. decfac(-iaux).lt.0) then
 640         write (ulsort,90001) 'decision quadrangle', iaux, decfac(-iaux)
 641         write (ulsort,90002) 'aretes',
 642      >  arequa(iaux,1), arequa(iaux,2), arequa(iaux,3), arequa(iaux,4)
 643         write (ulsort,90002) 'decare',
 644      >  decare(arequa(iaux,1)), decare(arequa(iaux,2)),
 645      >  decare(arequa(iaux,3)), decare(arequa(iaux,4))
 646         jaux=jaux+1
 647         if ( jaux.eq.10) then
 648           goto 9995
 649         endif
 650         endif
 651  9905 continue
 652  9995 continue
 653       do 9904 , iaux = 1 , nbarto, -1
 654         write (ulsort,90001) 'decision arete', iaux,decare(iaux)
 655  9904 continue
 656 c
 657       do 9908 , iaux = 1 , min(2,nbquto), -1
 658       write (ulsort,90001) 'decfac pour quadrangle         ', iaux,
 659      >decfac(-iaux)
 660       write (ulsort,90001) 'aretes du quadrangle         ', iaux,
 661      >arequa(iaux,1), arequa(iaux,2),
 662      >arequa(iaux,3), arequa(iaux,4)
 663       write (ulsort,90001) 'decare pour aretes quadrangle', iaux,
 664      >decare(arequa(iaux,1)), decare(arequa(iaux,2)),
 665      >decare(arequa(iaux,3)), decare(arequa(iaux,4))
 666  9908 continue
 667 #endif
 668 c
 669 c====
 670 c 3. la fin
 671 c====
 672 c
 673       if ( codret.ne.0 ) then
 674 c
 675 #include "envex2.h"
 676 c
 677       write (ulsort,texte(langue,1)) 'Sortie', nompro
 678       write (ulsort,texte(langue,2)) codret
 679 c
 680       endif
 681 c
 682 #ifdef _DEBUG_HOMARD_
 683       write (ulsort,texte(langue,1)) 'Sortie', nompro
 684       call dmflsh (iaux)
 685 #endif
 686 c
 687       end