src/tool/Decision/dedco2.F

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