src/tool/Decision/deiard.F

   1       subroutine deiard ( nivmin,
   2      >                    decare, decfac,
   3      >                    hetare, filare,
   4      >                    posifa, facare,
   5      >                    aretri, hettri, nivtri,
   6      >                    arequa, hetqua, nivqua,
   7      >                    arsupp, arindi,
   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 - Initialisation de l'indicateur entier
  30 c                --          -
  31 c                          - cas des ARetes - Deraffinement
  32 c                                    --       -
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . nivmin . e   .   1    . niveau min a ne pas depasser en deraffinemt.
  38 c . decare .  s  .0:nbarto. decisions des aretes                       .
  39 c . decfac .  s  . -nbquto. decision sur les faces (quad. + tri.)      .
  40 c .        .     . :nbtrto.                                            .
  41 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  42 c . filare . e   . nbarto . premiere fille des aretes                  .
  43 c . posifa . e   . nbarto . pointeur sur tableau facare                .
  44 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  45 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  46 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  47 c . nivtri . e   . nbtrto . niveau des triangles                       .
  48 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  49 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  50 c . nivqua . e   . nbquto . niveau des quadrangles                     .
  51 c . arsupp . e   . nbarto . support pour les aretes                    .
  52 c . arindi . e   . nbarto . valeurs entieres pour les aretes           .
  53 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  54 c . langue . e   .    1   . langue des messages                        .
  55 c .        .     .        . 1 : francais, 2 : anglais                  .
  56 c . codret . es  .    1   . code de retour des modules                 .
  57 c .        .     .        . 0 : pas de probleme                        .
  58 c .        .     .        . 2 : probleme dans le traitement            .
  59 c ______________________________________________________________________
  60 c
  61 c====
  62 c 0. declarations et dimensionnement
  63 c====
  64 c
  65 c 0.1. ==> generalites
  66 c
  67       implicit none
  68       save
  69 c
  70       character*6 nompro
  71       parameter ( nompro = 'DEIARD' )
  72 c
  73 #include "nblang.h"
  74 c
  75 c 0.2. ==> communs
  76 c
  77 #include "envex1.h"
  78 #include "nombar.h"
  79 #include "nombtr.h"
  80 #include "nombqu.h"
  81 #include "impr02.h"
  82 c
  83 c 0.3. ==> arguments
  84 c
  85       integer nivmin
  86       integer decare(0:nbarto), decfac(-nbquto:nbtrto)
  87       integer hetare(nbarto), filare(nbarto)
  88       integer posifa(0:nbarto), facare(nbfaar)
  89       integer aretri(nbtrto,3), hettri(nbtrto)
  90       integer nivtri(nbtrto)
  91       integer arequa(nbquto,4), hetqua(nbquto)
  92       integer nivqua(nbquto)
  93       integer arsupp(nbarto), arindi(nbarto)
  94 c
  95       integer ulsort, langue, codret
  96 c
  97 c 0.4. ==> variables locales
  98 c
  99       integer somdec, etat
 100       integer larete, letria, lequad
 101       integer fille1
 102       integer iaux, jaux, kaux, ideb, ifin
 103 c
 104       integer nbmess
 105       parameter (nbmess = 10 )
 106       character*80 texte(nblang,nbmess)
 107 c ______________________________________________________________________
 108 c
 109 c====
 110 c 1. initialisation
 111 c====
 112 c
 113 c 1.1. ==> Les messages
 114 c
 115 #include "impr01.h"
 116 c
 117 #ifdef _DEBUG_HOMARD_
 118       write (ulsort,texte(langue,1)) 'Entree', nompro
 119       call dmflsh (iaux)
 120 #endif
 121 c
 122 #include "impr05.h"
 123 c
 124       codret = 0
 125 c
 126 c====
 127 c 2. traitement des indicateurs portant sur les aretes
 128 c    pour le filtrage sur les niveaux, on tient compte du fait que
 129 c    le niveau d'une arete est identifie a celui de l'une quelconque de
 130 c    ses faces voisines quand elle en a. Sinon, on ne filtre pas.
 131 c====
 132 c
 133 #ifdef _DEBUG_HOMARD_
 134         write(ulsort,texte(langue,4)) mess14(langue,3,1)
 135 #endif
 136 c
 137 #ifdef _DEBUG_HOMARD_
 138         write(ulsort,texte(langue,6))
 139 #endif
 140 c
 141       iaux = 0
 142 c
 143       do 21 , larete = 1, nbarto
 144 c
 145         etat = mod(hetare(larete),10)
 146         if ( etat.ge.2 ) then
 147           fille1 = filare(larete)
 148           if ( arsupp(fille1)  .ne.0 .and.
 149      >         arsupp(fille1+1).ne.0 ) then
 150             if ( arindi(fille1)  .eq.-1 .and.
 151      >           arindi(fille1+1).eq.-1 ) then
 152               ideb = posifa(larete-1)+1
 153               ifin = posifa(larete)
 154               jaux = 0
 155               if ( ifin.ge.ideb ) then
 156                 if ( facare(ideb).gt.0 ) then
 157                   kaux = nivtri(facare(ideb))
 158                 else
 159                   kaux = nivqua(-facare(ideb))
 160                 endif
 161                 if ( kaux.lt.nivmin ) then
 162                   jaux = 1
 163                 endif
 164               endif
 165               if ( jaux.eq.0 ) then
 166                 decare(larete) = -1
 167 cgn          write(ulsort,*) 'mise a -1 de decare pour arete', larete,
 168 cgn     >                    ', de filles', fille1, fille1+1
 169               else
 170                 iaux = iaux + 1
 171               endif
 172             endif
 173           endif
 174         endif
 175 c
 176    21 continue
 177 c
 178       if ( iaux.ne.0 ) then
 179         write(ulsort,texte(langue,10))
 180         write(ulsort,texte(langue,4)) mess14(langue,3,1)
 181         write(ulsort,texte(langue,8)) nivmin
 182         write(ulsort,texte(langue,9)) iaux
 183       endif
 184 c
 185       do 22 , letria = 1, nbtrto
 186         etat = mod(hettri(letria),10)
 187         if ( etat.eq.4 .or.
 188      >       etat.eq.6 .or. etat.eq.7 .or. etat.eq.8 ) then
 189           somdec = decare(aretri(letria,1))
 190      >           + decare(aretri(letria,2))
 191      >           + decare(aretri(letria,3))
 192           if (somdec.eq.-3) then
 193 cgn        write(ulsort,*) 'Triangle', letria, ' a reactiver'
 194             decfac(letria) = -1
 195           endif
 196         endif
 197    22 continue
 198 c
 199       do 23 , lequad = 1, nbquto
 200         etat = mod(hetqua(lequad),100)
 201         if ( etat.eq.4 ) then
 202           somdec = decare(arequa(lequad,1))
 203      >           + decare(arequa(lequad,2))
 204      >           + decare(arequa(lequad,3))
 205      >           + decare(arequa(lequad,4))
 206           if (somdec.eq.-4) then
 207 cgn      write(ulsort,*) 'Quadrangle', lequad, ' a reactiver'
 208             decfac(-lequad) = -1
 209           endif
 210         endif
 211    23 continue
 212 c
 213 c====
 214 c 3. la fin
 215 c====
 216 c
 217       if ( codret.ne.0 ) then
 218 c
 219 #include "envex2.h"
 220 c
 221       write (ulsort,texte(langue,1)) 'Sortie', nompro
 222       write (ulsort,texte(langue,2)) codret
 223 c
 224       endif
 225 c
 226 #ifdef _DEBUG_HOMARD_
 227       write (ulsort,texte(langue,1)) 'Sortie', nompro
 228       call dmflsh (iaux)
 229 #endif
 230 c
 231       end