subroutine derco4 ( tyconf,
     >                    niveau,
     >                    decare, decfac,
     >                    hetare, arehom,
     >                    posifa, facare,
     >                    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 - Raffinement : COntamination - option 4
c                --          -             --                     -
c Application de la regle des deux voisins :
c   pilraf = 1 ou 2. libre
c   pilraf = 3. non-conforme avec 1 arete decoupee unique par element
c en presence d'aretes et/ou de faces homologues :
c ______________________________________________________________________
c .        .     .        .                                            .
c .  nom   . e/s . taille .           description                      .
c .____________________________________________________________________.
c . tyconf . e   .   1    .  0 : conforme                              .
c .        .     .        .  1 : non-conforme avec au minimum 2 aretes .
c .        .     .        .      non decoupees en 2                    .
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 .        .     .        . -2 : non-conforme avec au maximum 1 arete  .
c .        .     .        .      decoupee en 2 (boite pour les         .
c .        .     .        .      quadrangles, hexaedres et pentaedres) .
c . niveau . e   .    1   . niveau en cours d'examen                   .
c . decare . es  . nbarto . decisions des aretes                       .
c . decfac . es  . -nbquto. decision sur les faces (quad. + tri.)      .
c .        .     . :nbtrto.                                            .
c . hetare . e   . nbarto . historique de l'etat des aretes            .
c . arehom . e   . nbarto . ensemble des aretes homologues             .
c . posifa . e   . nbarto . pointeur sur tableau facare                .
c . facare . e   . nbfaar . liste des faces contenant une arete        .
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 = 'DERCO4' )
c
#include "nblang.h"
c
c 0.2. ==> communs
c
#include "envex1.h"
#include "nombar.h"
#include "nombtr.h"
#include "nombqu.h"
c
c 0.3. ==> arguments
c
      integer tyconf
      integer niveau
      integer decare(0:nbarto)
      integer hetare(nbarto)
      integer decfac(-nbquto:nbtrto)
      integer posifa(0:nbarto), facare(nbfaar)
      integer arehom(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 facact, laface, nbfali
      integer ipos
      integer iaux, ideb, ifin, ifacli
      integer nbaret, nbar00, anodec(4)
      integer kaux
      integer iarelo, iarete, iface
      integer etatar, etatfa
      integer nbare1, liare1(4)
c
      integer nbmess
      parameter ( nbmess = 30 )
      character*80 texte(nblang,nbmess)
c
c 0.5. ==> initialisations
c ______________________________________________________________________
c
c====
c 1. initialisations
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
#ifdef _DEBUG_HOMARD_
      write (ulsort,texte(langue,12)) niveau
#endif
c
      codret = 0
c
c     initialisation vide de la liste de faces a examiner
c
      nbfali = 0
c
c     initialisation du nombre d'aretes autorisees pour un quadrangle
c
      if ( tyconf.eq.0 ) then
        nbar00 = -2
      else
        nbar00 = 2
      endif
c
c====
c 2. Application de la regle des deux voisins
c====
c
      do 2 , laface = -nbquto , nbtrto
c
c       on regarde toutes les faces 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
        if ( etatfa.eq.0 ) then
c
          facact = laface
c
c         debut du traitement de la face courante
c         ***************************************
c
c         --------
   20     continue
c         --------
c         on ne regarde que les faces "a garder"
c
          if ( decfac(facact).eq.0 ) then
c
c 2.1. ==> on compte les aretes actives a garder et les aretes
c          inactives a reactiver
c
            if ( facact.gt.0 ) then
              nbare1 = 3
              do 211 , iarelo = 1 , nbare1
                liare1(iarelo) = aretri(facact,iarelo)
  211         continue
            else
              nbare1 = 4
              iaux = -facact
              do 212 , iarelo = 1 , nbare1
                liare1(iarelo) = arequa(iaux,iarelo)
  212         continue
            endif
c
            nbaret = 0
            do 213 , iarelo = 1 , nbare1
              iarete = liare1(iarelo)
              if ( decare(iarete).eq.0 ) then
                etatar = mod( hetare(iarete) , 10 )
                if ( etatar.eq.0 ) then
                  nbaret = nbaret + 1
                  anodec(nbaret) = iarete
                endif
              elseif ( decare(iarete).eq.-1 ) then
                nbaret = nbaret + 1
                anodec(nbaret) = iarete
              endif
  213       continue
c
c 2.2. ==> aucune arete n'est une active a garder
c          ------------------------------------
c          ==> on declare la face "a couper"
c
            if ( nbaret.eq.0 ) then
c
              decfac(facact) = 4
c
c 2.3. ==> une seule arete est une active a garder
c          ---------------------------------------
c
            elseif ( nbaret.eq.1 ) then
c
c 2.3.1. ==>  on declare la face "a couper"
c             . si l'arete est active, on la declare "a couper"
c             . si l'arete est inactive, on la declare "a garder"
c
              decfac(facact) = 4
              if ( mod(hetare(anodec(1)),10).eq.0 ) then
                decare(anodec(1)) = 2
              else
                decare(anodec(1)) = 0
              endif
c
c             on regarde toutes les faces qui s'appuient sur cette
c             arete, on memorise celles qui sont actives "a garder"
c
              ideb = posifa(anodec(1)-1)+1
              ifin = posifa(anodec(1))
c
              do 231 , ipos = ideb , ifin
                iface = facare(ipos)
                if ( decfac(iface).eq.0 ) then
                  if ( iface.gt.0 ) then
                    etatfa = mod( hettri(iface) , 10 )
                  else
                    etatfa = mod( hetqua(-iface) , 100 )
                  endif
                  if ( etatfa.eq.0 ) then
                    do 2311 , ifacli = 1 , nbfali
                      if ( listfa(ifacli).eq.iface ) then
                        goto 2312
                      endif
 2311               continue
                    nbfali = nbfali + 1
                    listfa(nbfali) = iface
 2312               continue
                  endif
                endif
  231         continue
c
c 2.3.2. ==> on regarde si l'arete a une homologue
c
              if ( arehom(anodec(1)) .ne. 0 ) then
c
                kaux = abs( arehom(anodec(1)) )
c
c          . si l'arete homologue est active, on la declare "a couper"
c          . si l'arete homologue est inactive, on la declare "a garder"
c
                if ( mod(hetare(kaux),10).eq.0 ) then
                  decare(kaux) = 2
                else
                  decare(kaux) = 0
                endif
c
c               on regarde toutes les faces qui s'appuient sur cette
c               arete, on memorise celles qui sont actives a "garder"
c
                ideb = posifa(kaux-1) + 1
                ifin = posifa(kaux)
c
                do 232, ipos = ideb , ifin
                  iface = facare(ipos)
                  if ( decfac(iface).eq.0 ) then
                    if ( iface.gt.0 ) then
                      etatfa = mod( hettri(iface) , 10 )
                    else
                      etatfa = mod( hetqua(-iface) , 100 )
                    endif
                    if ( etatfa.eq.0 ) then
                      do 2321 , ifacli = 1 , nbfali
                        if ( listfa(ifacli).eq.iface ) then
                          goto 2322
                        endif
 2321                 continue
                      nbfali = nbfali + 1
                      listfa(nbfali) = iface
 2322                 continue
                    endif
                  endif
  232           continue
c
              endif
c
c 2.4. ==> pour un quadrangle, deux aretes sont
c          ------------------------------------
c          des actives a garder si on veut des boites
c          ------------------------------------------
c
            elseif ( facact.lt.0 ) then
c
              if ( nbaret.eq.nbar00 ) then
c
c             on declare la face "a couper"
c
                decfac(facact) = 4
c
                do 24 , iaux = 1 , 2
c
c 2.4.1. ==>  . si l'arete est active, on la declare "a couper"
c             . si l'arete est inactive, on la declare "a garder"
c
                  if ( mod(hetare(anodec(iaux)),10).eq.0 ) then
                    decare(anodec(iaux)) = 2
                  else
                    decare(anodec(iaux)) = 0
                  endif
c
c                 on regarde toutes les faces qui s'appuient sur cette
c                 arete, on memorise celles qui sont actives "a garder"
c
                  ideb = posifa(anodec(iaux)-1)+1
                  ifin = posifa(anodec(iaux))
c
                  do 241 , ipos = ideb , ifin
                    iface = facare(ipos)
                    if ( decfac(iface).eq.0 ) then
                      if ( iface.gt.0 ) then
                        etatfa = mod( hettri(iface) , 10 )
                      else
                        etatfa = mod( hetqua(-iface) , 100 )
                      endif
                      if ( etatfa.eq.0 ) then
                        do 2412 , ifacli = 1 , nbfali
                          if ( listfa(ifacli).eq.iface ) then
                            goto 2413
                          endif
 2412                  continue
                        nbfali = nbfali + 1
                        listfa(nbfali) = iface
 2413                  continue
                      endif
                    endif
  241             continue
c
c 2.4.2. ==>  . si l'arete a une homolgue
c
                  if ( arehom(anodec(iaux)) .ne. 0 ) then
c
                    kaux = abs( arehom(anodec(iaux)) )
c
c          . si l'arete homologue est active, on la declare "a couper"
c          . si l'arete homologue est inactive, on la declare "a garder"
c
                    if ( mod(hetare(kaux),10).eq.0 ) then
                      decare(kaux) = 2
                    else
                      decare(kaux) = 0
                    endif
c
c               on regarde toutes les faces qui s'appuient sur cette
c               arete, on memorise celles qui sont actives a "garder"
c
                    ideb = posifa(kaux-1) + 1
                    ifin = posifa(kaux)
c
                    do 242, ipos = ideb , ifin
                      iface = facare(ipos)
                      if ( decfac(iface).eq.0 ) then
                        if ( iface.gt.0 ) then
                          etatfa = mod( hettri(iface) , 10 )
                        else
                          etatfa = mod( hetqua(-iface) , 100 )
                        endif
                        if ( etatfa.eq.0 ) then
                          do 2421 , ifacli = 1 , nbfali
                            if ( listfa(ifacli).eq.iface ) then
                              goto 2422
                            endif
 2421                     continue
                          nbfali = nbfali + 1
                          listfa(nbfali) = iface
 2422                     continue
                        endif
                      endif
  242               continue
c
                  endif
c
   24           continue
c
              endif
c
            endif
c
          endif
c
c 2.5. ==> on passe a la face suivante de la liste
c          ---------------------------------------
c
          if ( nbfali .gt. 0 ) then
c
            facact = listfa(nbfali)
            nbfali = nbfali - 1
            goto 20
c
          endif
c
        endif
c
    2 continue
c
#ifdef _DEBUG_HOMARD_
c====
c 3. verification
c====
c
      if ( codret.eq.0 ) then
c
      call dehova ( arehom, decare,
     >              nompro, 1,
     >              ulsort, langue, codret )
c
      endif
#endif
c
c====
c 4. 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