src/tool/Utilitaire/utsupe.F

   1       subroutine utsupe ( dispen,
   2      >                    hetpen, perpen, filpen,
   3      >                    ancpen, noupen,
   4      >                    nbpere )
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c    UTilitaire - SUppression des PEntaedres
  26 c    --           --              --
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . dispen . e   . nouvpe . indicateurs de disparition des pentaedres  .
  32 c . hetpen . es  . nouvpe . historique de l'etat des pentaedres        .
  33 c . perpen . es  . nouvpe . pere des pentaedres                        .
  34 c . filpen . es  . nouvpe . premier fils des pentaedres                .
  35 c . ancpen .   s . nouvpe . anciens numeros des pentaedres conserves   .
  36 c . noupen .   s .0:nouvpe. nouveaux numeros des pentaedres conserves  .
  37 c . nbpere .   s .   1    . nombre de pentaedres restants              .
  38 c ______________________________________________________________________
  39 c
  40 c====
  41 c 0. declarations et dimensionnement
  42 c====
  43 c
  44 c 0.1. ==> generalites
  45 c
  46       implicit none
  47       save
  48 c
  49 cgn      character*6 nompro
  50 cgn      parameter ( nompro = 'UTSUPE' )
  51 c
  52 c 0.2. ==> communs
  53 c
  54 #include "nombpe.h"
  55 #include "nouvnb.h"
  56 c
  57 c 0.3. ==> arguments
  58 c
  59       integer dispen(nouvpe)
  60       integer hetpen(nouvpe), perpen(nouvpe), filpen(nouvpe)
  61       integer ancpen(nouvpe), noupen(0:nouvpe)
  62       integer nbpere
  63 c
  64 c 0.4. ==> variables locales
  65 c
  66       integer lepent, gdpere, lepere, lefrer
  67       integer etgper, htfrer, etfrer
  68       integer cmptr,  actifs
  69       integer iaux
  70 c
  71 c 0.5. ==> initialisations
  72 c ______________________________________________________________________
  73 c
  74 c====
  75 c 1. fabrication des tableaux ancpen et noupen
  76 c====
  77 c
  78       cmptr = 0
  79       noupen(0) = 0
  80 c
  81 c 1.1 generation des tableaux reciproques
  82 c
  83       do 100 , lepent = 1 , nbpepe
  84 c
  85         if ( dispen(lepent).eq.1 ) then
  86 c
  87           noupen(lepent) = 0
  88           hetpen(lepent) = 100 * int( hetpen(lepent)/100 ) + 55
  89 c
  90         else
  91 c
  92           cmptr = cmptr + 1
  93           ancpen(cmptr)  = lepent
  94           noupen(lepent) = cmptr
  95 c
  96         endif
  97 c
  98   100 continue
  99 c
 100 c 1.2 nombre d'entites restantes apres suppression
 101 c     (pour la remise a jour du nombre d'entites du maillage)
 102 c
 103       nbpere = cmptr
 104 c
 105 c====
 106 c 2. modification des etats des peres des pentaedres
 107 c====
 108 c
 109       do 200 , lepent = 1 , nbpepe
 110 c
 111         if ( dispen(lepent).eq.1 ) then
 112 c
 113 c         mise a zero de l'etat actuel du pere
 114 c
 115           lepere = perpen(lepent)
 116           hetpen(lepere) = hetpen(lepere) - mod(hetpen(lepere),100)
 117 c
 118         endif
 119 c
 120   200 continue
 121 c
 122 c====
 123 c 3. modification des etats des grand-peres des pentaedres,
 124 c    s'ils existent
 125 c====
 126 c
 127       do 300 , lepent = 1 , nbpepe
 128 c
 129         if ( dispen(lepent).eq.1 ) then
 130 c
 131 c 3.1     verification de l'etat du grand-pere
 132 c
 133           lepere = perpen(lepent)
 134           gdpere = perpen(lepere)
 135 c
 136           if ( gdpere.ne.0 ) then
 137 c
 138             iaux = mod(hetpen(gdpere),100)
 139             etgper = (iaux-mod(iaux,10)) / 10
 140 c
 141             if ( etgper.ne.8 ) then
 142 c
 143 c 3.1.1     verification de l'etat des freres du pere
 144 c
 145               lefrer = filpen(gdpere)
 146               actifs = 1
 147 c
 148               do 310 , htfrer = lefrer , lefrer + 7
 149 c
 150                 etfrer = mod( hetpen(htfrer) , 100)
 151 c
 152                 if ( etfrer.ne.0 ) then
 153                   actifs = 0
 154                 endif
 155 c
 156   310         continue
 157 c
 158               if ( actifs.eq.1 ) then
 159 c
 160 c 3.1.3       attribution de l'etat de l'entite
 161 c
 162                 hetpen(gdpere) = hetpen(gdpere)
 163      >                         - mod(hetpen(gdpere),100)
 164      >                         + 80
 165 c
 166               endif
 167 c
 168             endif
 169 c
 170           endif
 171 c
 172         endif
 173 c
 174   300 continue
 175 c
 176       end