subroutine dedco1 ( tyconf,
     >                    decare, decfac,
     >                    posifa, facare,
     >                    hetare, merare,
     >                    hettri, aretri, nivtri,
     >                    hetqua, arequa, nivqua,
     >                    listfa,
     >                    ulsort, langue, codret )
c ______________________________________________________________________
c
c                             H O M A R D
c
c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
c
c Version originale enregistree le 18 juin 1996 sous le numero 96036
c aupres des huissiers de justice Simart et Lavoir a Clamart
c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
c aupres des huissiers de justice
c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
c
c    HOMARD est une marque deposee d'Electricite de France
c
c Copyright EDF 1996
c Copyright EDF 1998
c Copyright EDF 2002
c Copyright EDF 2020
c ______________________________________________________________________
c
c traitement des DEcisions - Deraffinement : COntamination - option 1
c                --          -               --                     -
c  cas sans homologues
c ______________________________________________________________________
c .        .     .        .                                            .
c .  nom   . e/s . taille .           description                      .
c .____________________________________________________________________.
c . tyconf . e   .   1    .  0 : conforme (defaut)                     .
c .        .     .        .  1 : non-conforme avec au minimum 2 aretes .
c .        .     .        .      non decoupees en 2 par face           .
c .        .     .        .  2 : non-conforme avec 1 seul noeud        .
c .        .     .        .      pendant par arete                     .
c .        .     .        .  3 : non-conforme fidele a l'indicateur    .
c .        .     .        . -1 : conforme, avec des boites pour les    .
c .        .     .        .      quadrangles, hexaedres et pentaedres  .
c .        .     .        . -2 : non-conforme avec au maximum 1 arete  .
c .        .     .        .      decoupee en 2 (boite pour les         .
c .        .     .        .      quadrangles, hexaedres et pentaedres) .
c . decare . e/s . nbarto . decisions des aretes                       .
c . decfac . e/s . -nbquto. decision sur les faces (quad. + tri.)      .
c .        .     . :nbtrto.                                            .
c . posifa . e   . nbarto . pointeur sur tableau facare                .
c . facare . e   . nbfaar . liste des faces contenant une arete        .
c . hetare . e   . nbarto . historique de l'etat des aretes            .
c . merare . e   . nbarto . mere des aretes                            .
c . hettri . e   . nbtrto . historique de l'etat des triangles         .
c . aretri . e   . nbtrto . numeros des 3 aretes des triangles         .
c . nivtri . e   . nbtrto . niveau des triangles                       .
c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
c . arequa . e   . nbquto . numeros des 4 aretes des quadrangles       .
c . nivqua . e   . nbquto . niveau des quadrangles                     .
c . listfa . t   .   *    . liste de faces a considerer                .
c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
c . langue . e   .    1   . langue des messages                        .
c .        .     .        . 1 : francais, 2 : anglais                  .
c . codret . es  .    1   . code de retour des modules                 .
c .        .     .        . 0 : pas de probleme                        .
c ______________________________________________________________________
c
c====
c 0. declarations et dimensionnement
c====
c
c 0.1. ==> generalites
c
      implicit none
      save
c
      character*6 nompro
      parameter ( nompro = 'DEDCO1' )
c
#include "nblang.h"
c
c 0.2. ==> communs
c
#include "envex1.h"
c
#include "envada.h"
#include "nombar.h"
#include "nombtr.h"
#include "nombqu.h"
#include "impr02.h"
c
c 0.3. ==> arguments
c
      integer tyconf
      integer decare(0:nbarto)
      integer decfac(-nbquto:nbtrto)
      integer posifa(0:nbarto), facare(nbfaar)
      integer hetare(nbarto), merare(nbarto)
      integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto)
      integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto)
      integer listfa(*)
c
      integer ulsort, langue, codret
c
c 0.4. ==> variables locales
c
      integer nivdeb, nivfin, niveau
      integer nbfali, laface, etatfa
      integer facact, iarelo, iarete, etatar
      integer nbaret, nbar00, anodec(4)
      integer iaux, ideb, ifin
      integer ipos, iface, ifacli, merear, jarelo
      integer jarete
      integer nbare1, liare1(4), nbare2, liare2(4)
#ifdef _DEBUG_HOMARD_
      integer jaux
      integer option
#endif
c
      integer nbmess
      parameter ( nbmess = 30 )
      character*80 texte(nblang,nbmess)
c
c 0.5. ==> initialisations
c ______________________________________________________________________
c
c====
c 1. messages
c====
c
#include "impr01.h"
c
#ifdef _DEBUG_HOMARD_
      write (ulsort,texte(langue,1)) 'Entree', nompro
      call dmflsh (iaux)
#endif
c
#include "impr03.h"
c
#include "derco1.h"
c
      codret = 0
c
#ifdef _DEBUG_HOMARD_
      write (ulsort,90002) 'tyconf', tyconf
#endif
c
#ifdef _DEBUG_HOMARD_
      write (ulsort,*) ' '
      write (ulsort,90003) 'Entree de ',nompro
      do 1106 , iaux = 1 , nbtrto, -1
        write (ulsort,90015) 'triangle', iaux, ' decision,niveau,etat',
     >  decfac(iaux), nivtri(iaux), hettri(iaux)
        write (ulsort,90002) 'aretes', aretri(iaux,1),
     >  aretri(iaux,2), aretri(iaux,3)
        write (ulsort,90002) 'decare', decare(aretri(iaux,1)),
     >  decare(aretri(iaux,2)), decare(aretri(iaux,3))
 1106 continue
      jaux=0
      do 1105 , iaux = 1 , nbquto
      if ( nivqua(iaux).eq.3 .and. decfac(-iaux).lt.0) then
        write (ulsort,90015) 'quadrangle', iaux, ' decision,niveau,etat',
     >  decfac(-iaux), nivqua(iaux), hetqua(iaux)
        write (ulsort,90002) 'aretes',
     >  arequa(iaux,1), arequa(iaux,2), arequa(iaux,3), arequa(iaux,4)
        write (ulsort,90002) 'decare',
     >  decare(arequa(iaux,1)), decare(arequa(iaux,2)),
     >  decare(arequa(iaux,3)), decare(arequa(iaux,4))
        jaux=jaux+1
        if ( jaux.eq.10) then
          goto 1115
        endif
        endif
 1105 continue
 1115 continue
      do 1104 , iaux = 1 , nbarto, -1
        write (ulsort,90001) 'decision arete', iaux, decare(iaux)
 1104 continue
c
      do 1108 , iaux = 1 , min(2,nbquto), -1
      write (ulsort,90001) 'decfac pour quadrangle         ', iaux,
     >decfac(-iaux)
      write (ulsort,90001) 'aretes du quadrangle         ', iaux,
     >arequa(iaux,1), arequa(iaux,2),
     >arequa(iaux,3), arequa(iaux,4)
      write (ulsort,90001) 'decare pour aretes quadrangle', iaux,
     >decare(arequa(iaux,1)), decare(arequa(iaux,2)),
     >decare(arequa(iaux,3)), decare(arequa(iaux,4))
 1108 continue
#endif
c
c====
c 2. algorithme : on regarde tous les niveaux dans l'ordre decroissant
c====
c
#ifdef _DEBUG_HOMARD_
      write (ulsort,90002) 'Etape 2', codret
#endif
c     initialisation vide de la liste de faces a examiner
c
      nbfali = 0
c
c     initialisation du nombre d'aretes decoupees possibles
c     pour un quadrangle dans le cas de l'adaptation conforme
      if ( tyconf.ge.0 ) then
        nbar00 = -2
      else
        nbar00 = 2
      endif
c
      nivdeb = nivsup - 1
      nivfin = max(nivinf-1,0)
      do 100 , niveau = nivdeb , nivfin , -1
c
#ifdef _DEBUG_HOMARD_
      write (ulsort,texte(langue,12)) niveau
#endif
c
c 2.1. ==> traitement des faces pour la regle des deux voisins
c          ===================================================
c          elle s'applique aux cas d'adaptation :
c    tyconf = 0 ; conforme
c    tyconf = 1 ; non-conforme avec au minimum 2 aretes non coupees
c    tyconf = -1 ; conforme avec boites
c    tyconf = -2 ; non-conforme avec au maximum 1 arete coupee
c
        if ( tyconf.le.1 ) then
c
        do 21 , laface = -nbquto , nbtrto
c
c         on regarde les faces meres d'actives du niveau courant
c
          etatfa = -1
          if ( laface.gt.0 ) then
            if ( nivtri(laface).eq.niveau ) then
              etatfa = mod( hettri(laface) , 10 )
            endif
          elseif ( laface.lt.0 ) then
            iaux = -laface
            if ( nivqua(iaux).eq.niveau ) then
              etatfa = mod( hetqua(iaux) , 100 )
            endif
          endif
c
#ifdef _DEBUG_HOMARD_
          if ( etatfa.gt.0 ) then
          if ( laface.gt.0 ) then
            option = 2
            iaux=nivtri(laface)
          else
            option = 4
            iaux=nivqua(-laface)
          endif
          if ( ( laface.ge.-144699 .and. laface.le.-144690 ) .or.
     >         ( laface.eq.-164226 ) ) then
          write (ulsort,texte(langue,29)) mess14(langue,1,option),
     >    abs(laface), iaux,etatfa, decfac(laface)
          endif
          endif
#endif
c
          if ( etatfa.ge.4 .and. etatfa.le.8 ) then
c
            facact = laface
c
c           --------
  200       continue
c           --------
c         debut du traitement de la face courante
c         ***************************************
c
c           on ne regarde que les faces "a reactiver"
c
            if ( decfac(facact).eq.-1 ) then
c
#ifdef _DEBUG_HOMARD_
              if ( facact.gt.0 ) then
                option = 2
                iaux=nivtri(facact)
                ipos=hettri(facact)
              else
                option = 4
                iaux=nivqua(-facact)
                ipos=hetqua(-facact)
              endif
          if ( ( facact.ge.-144699 .and. facact.le.-144690 ) .or.
     >         ( facact.eq.-164226 ) ) then
              write (ulsort,texte(langue,29))
     >'. '//mess14(langue,1,option),abs(facact),iaux,ipos,decfac(facact)
          endif
#endif
c
c 2.1.1. ==> on compte les aretes inactives a garder
c
              if ( facact.gt.0 ) then
                nbare1 = 3
                do 2111 , iarelo = 1 , nbare1
                  liare1(iarelo) = aretri(facact,iarelo)
 2111           continue
              else
                nbare1 = 4
                iaux = -facact
                do 2112 , iarelo = 1 , nbare1
                  liare1(iarelo) = arequa(iaux,iarelo)
 2112           continue
              endif
#ifdef _DEBUG_HOMARD_
          if ( ( facact.ge.-144699 .and. facact.le.-144690 ) .or.
     >         ( facact.eq.-164226 ) ) then
            write (ulsort,90002) 'nbare1', nbare1
            write (ulsort,90002) 'liare1', liare1
          endif
#endif
c
c             nbaret = nombre d'aretes coupees en deux et a garder
c             nbare2 = nombre d'aretes a reactiver
c
              nbaret = 0
              nbare2 = 0
              do 2113 , iarelo = 1 , nbare1
                iarete = liare1(iarelo)
#ifdef _DEBUG_HOMARD_
          if ( ( facact.ge.-144699 .and. facact.le.-144690 ) .or.
     >         ( facact.eq.-164226 ) ) then
          write (ulsort,90001) '. decision arete', iarete,decare(iarete)
          write (ulsort,90001) '. etat     arete', iarete,hetare(iarete)
          endif
#endif
                if ( decare(iarete).eq.0 ) then
                  etatar = mod( hetare(iarete) , 10 )
                  if ( etatar.eq.2 .or. etatar.eq.9 ) then
                    nbaret = nbaret + 1
                  endif
                else
                  nbare2 = nbare2 + 1
                  anodec(nbare2) = iarete
                  liare2(nbare2) = iarelo
                endif
 2113         continue
#ifdef _DEBUG_HOMARD_
          if ( ( facact.ge.-144699 .and. facact.le.-144690 ) .or.
     >         ( facact.eq.-164226 ) ) then
              write (ulsort,texte(langue,22)) nbaret, nbare2
          endif
#endif
c
              if ( nbaret.eq.nbare1 ) then
c
c 2.1.2. ==> toutes les aretes sont coupees en deux et a garder
c            --------------------------------------------------
c               on declare la face "a garder"
c
                decfac(facact) = 0
c
#ifdef _DEBUG_HOMARD_
      write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
#endif
c
              elseif ( nbaret.eq.(nbare1-1) ) then
c
c 2.1.3. ==> toutes les aretes sauf une sont coupees en deux et a garder
c            -----------------------------------------------------------
c               on declare la face et la derniere arete "a garder"
c
                decfac(facact) = 0
                decare(anodec(1)) = 0
c
#ifdef _DEBUG_HOMARD_
      if ( anodec(1).eq.156780 ) then
      write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
      write (ulsort,texte(langue,30))'decare',
     >anodec(1),decare(anodec(1)),' (arete encore a reactiver)'
      endif
#endif
c
c               on regarde toutes les faces qui s'appuient sur cette
c               arete, on memorise celles qui sont non actives
c               "a reactiver"
c
                ideb = posifa(anodec(1)-1)+1
                ifin = posifa(anodec(1))
                do 2131 , ipos = ideb , ifin
                  iface = facare(ipos)
                  if ( decfac(iface).eq.-1 ) then
                    if ( iface.gt.0 ) then
                      etatfa = mod( hettri(iface) , 10 )
                    else
                      etatfa = mod( hetqua(-iface) , 100 )
                    endif
                    if ( etatfa.ge.4 .and. etatfa.le.8 ) then
                      do 2132 , ifacli = 1 , nbfali
                        if ( listfa(ifacli).eq.iface ) then
                          goto 2133
                        endif
 2132                 continue
                      nbfali = nbfali + 1
                      listfa(nbfali) = iface
 2133                 continue
                    endif
                  endif
 2131           continue
c
              elseif ( facact.lt.0 ) then
c
                if ( nbaret.eq.nbar00 ) then
c
c 2.1.4. ==> pour un quadrangle, deux aretes sont
c            ------------------------------------
c            des actives a garder si on veut des boites
c            ------------------------------------------
c               on declare la face et les 2 dernieres aretes "a garder"
c
                  decfac(facact) = 0
c
#ifdef _DEBUG_HOMARD_
      write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
#endif
c
                  do 214 , iaux = 1 , 2
c
                    decare(anodec(iaux)) = 0
c
#ifdef _DEBUG_HOMARD_
      if ( anodec(iaux).eq.156780 ) then
      write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' '
      write (ulsort,texte(langue,30))'decare',
     >anodec(iaux),decare(anodec(iaux)),' (arete encore a reactiver)'
      endif
#endif
c
c               on regarde toutes les faces qui s'appuient sur cette
c               arete, on memorise celles qui sont non actives
c               "a reactiver"
c
                    ideb = posifa(anodec(iaux)-1)+1
                    ifin = posifa(anodec(iaux))
                    do 2141 , ipos = ideb , ifin
                      iface = facare(ipos)
                      if ( decfac(iface).eq.-1 ) then
                        if ( iface.gt.0 ) then
                          etatfa = mod( hettri(iface) , 10 )
                        else
                          etatfa = mod( hetqua(-iface) , 100 )
                        endif
                        if ( etatfa.ge.4 .and. etatfa.le.8 ) then
                          do 2142 , ifacli = 1 , nbfali
                            if ( listfa(ifacli).eq.iface ) then
                              goto 2143
                            endif
 2142                     continue
                          nbfali = nbfali + 1
                          listfa(nbfali) = iface
 2143                     continue
                        endif
                      endif
 2141               continue
c
  214             continue
c
                endif
c
#ifdef _DEBUG_HOMARD_
c 2.1.n. ==> toutes les aretes sont a reactiver : OK
c
              elseif ( nbare2.eq.nbare1 ) then
c
                write (ulsort,texte(langue,15))
#endif
c
              endif
c
            endif
c
            if ( nbfali.gt.0 ) then
c
c             on passe a la face suivante de la liste
c             ---------------------------------------
c
#ifdef _DEBUG_HOMARD_
              write (ulsort,texte(langue,21)) nbfali
              write (ulsort,*) (listfa(iaux),iaux=1,nbfali)
#endif
c
              facact = listfa(nbfali)
              nbfali = nbfali - 1
              goto 200
c
            endif
c
          endif
c
   21   continue
c
        endif
c
c 2.2. ==>  regle des ecarts de niveau
c           ==========================
c
#ifdef _DEBUG_HOMARD_
      write (ulsort,texte(langue,13)) niveau, niveau-1
#endif
c
        do 22 , laface = -nbquto , nbtrto
c
c         on passe en revue les faces :
c          . du niveau courant
c          . actives
c
          etatfa = -1
c
          if ( laface.gt.0 ) then
c
            if ( nivtri(laface).eq.niveau ) then
              etatfa = mod( hettri(laface) , 10 )
            endif
c
          elseif ( laface.lt.0 ) then
c
            iaux = -laface
            if ( nivqua(iaux).eq.niveau ) then
              etatfa = mod( hetqua(iaux) , 100 )
            endif
c
          endif
c
          if ( etatfa.eq.0 ) then
c
#ifdef _DEBUG_HOMARD_
          if ( laface.gt.0 ) then
            option = 2
          elseif ( laface.lt.0 ) then
            option = 4
          endif
          write (ulsort,texte(langue,29)) mess14(langue,1,option),
     >    abs(laface), niveau,etatfa, decfac(laface)
#endif
c
c 2.2.1. ==> liste des aretes ayant une mere
c
            if ( laface.gt.0 ) then
              nbare2 = 3
              do 2211 , iarelo = 1 , nbare2
                liare2(iarelo) = aretri(laface,iarelo)
 2211         continue
            else
              nbare2 = 4
              iaux = -laface
              do 2212 , iarelo = 1 , nbare2
                liare2(iarelo) = arequa(iaux,iarelo)
 2212         continue
            endif
c
            nbare1 = 0
            do 2213 , iaux = 1 , nbare2
             if ( merare(liare2(iaux)).gt.0 ) then
                nbare1 = nbare1 + 1
                liare1(nbare1) = liare2(iaux)
              endif
 2213       continue
c
c 2.2.2. ==> on parcourt les aretes retenues
c
            do 222 , iarelo = 1 , nbare1
c
              iarete = liare1(iarelo)
              merear = merare(iarete)
c
#ifdef _DEBUG_HOMARD_
      write (ulsort,texte(langue,23)) iarete, decare(iarete), merear
#endif
c
c             on regarde toutes les faces actives qui s'appuient
c             sur cette arete, et on marque comme etant "a garder"
c             celles qui sont "a reactiver"
c
              ideb = posifa(merear - 1) + 1
              ifin = posifa(merear)
              do 2221 , ipos = ideb , ifin
c
                iface  = facare(ipos)
                if ( decfac(iface).eq.-1 ) then
c
                  if ( iface.gt.0 ) then
                    etatfa = mod( hettri(iface) , 10 )
                  else
                    etatfa = mod( hetqua(-iface) , 100 )
                  endif
                  if ( etatfa.eq.0 ) then
                    decfac(iface) = 0
#ifdef _DEBUG_HOMARD_
      write (ulsort,texte(langue,30)) 'decfac',
     > iface, decfac(iface), ' (face voisine)'
#endif
                    if ( iface.gt.0 ) then
                      do 2222 , jarelo = 1 , 3
                        jarete = aretri(iface,jarelo)
                        if ( decare(jarete).eq.-1 ) then
                          decare(jarete) = 0
#ifdef _DEBUG_HOMARD_
      write (ulsort,texte(langue,30)) 'decare',jarete, decare(jarete)
#endif
                        endif
 2222                 continue
                    else
                      iaux = -iface
                      do 2223 , jarelo = 1 , 4
                        jarete = arequa(iaux,jarelo)
                        if ( decare(jarete).eq.-1 ) then
                          decare(jarete) = 0
#ifdef _DEBUG_HOMARD_
      write (ulsort,texte(langue,30)) 'decare',jarete, decare(jarete)
#endif
                        endif
 2223                 continue
                    endif
c
                  endif
c
                endif
c
 2221         continue
c
  222       continue
c
          endif
c
   22   continue
c
  100 continue
c
#ifdef _DEBUG_HOMARD_
      write (ulsort,*) ' '
      write (ulsort,90003) 'Sortie de ',nompro
      do 9906 , iaux = 1 , nbtrto, -1
        write (ulsort,90001) 'decision triangle', iaux, decfac(iaux)
 9906 continue
      jaux=0
      do 9905 , iaux = 1 , nbquto
      if ( nivqua(iaux).eq.3 .and. decfac(-iaux).lt.0) then
        write (ulsort,90001) 'decision quadrangle', iaux, decfac(-iaux)
        write (ulsort,90002) 'aretes',
     >  arequa(iaux,1), arequa(iaux,2), arequa(iaux,3), arequa(iaux,4)
        write (ulsort,90002) 'decare',
     >  decare(arequa(iaux,1)), decare(arequa(iaux,2)),
     >  decare(arequa(iaux,3)), decare(arequa(iaux,4))
        jaux=jaux+1
        if ( jaux.eq.10) then
          goto 9995
        endif
        endif
 9905 continue
 9995 continue
      do 9904 , iaux = 1 , nbarto, -1
        write (ulsort,90001) 'decision arete', iaux,decare(iaux)
 9904 continue
c
      do 9908 , iaux = 1 , min(2,nbquto), -1
      write (ulsort,90001) 'decfac pour quadrangle         ', iaux,
     >decfac(-iaux)
      write (ulsort,90001) 'aretes du quadrangle         ', iaux,
     >arequa(iaux,1), arequa(iaux,2),
     >arequa(iaux,3), arequa(iaux,4)
      write (ulsort,90001) 'decare pour aretes quadrangle', iaux,
     >decare(arequa(iaux,1)), decare(arequa(iaux,2)),
     >decare(arequa(iaux,3)), decare(arequa(iaux,4))
 9908 continue
#endif
c
c====
c 3. la fin
c====
c
      if ( codret.ne.0 ) then
c
#include "envex2.h"
c
      write (ulsort,texte(langue,1)) 'Sortie', nompro
      write (ulsort,texte(langue,2)) codret
c
      endif
c
#ifdef _DEBUG_HOMARD_
      write (ulsort,texte(langue,1)) 'Sortie', nompro
      call dmflsh (iaux)
#endif
c
      end