src/tool/Utilitaire/utsuqu.F

   1       subroutine utsuqu ( disqua,
   2      >                    hetqua, perqua, filqua,
   3      >                    ancqua, nouqua,
   4      >                    nbqure )
   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 QUadrangles
  26 c    --           --              --
  27 c ______________________________________________________________________
  28 c
  29 c   Attention : tous les quadrangles n'ont pas forcement un pere !
  30 c               en effet ceux crees en interne a des volumes
  31 c               sont de la premiere generation, meme s'ils
  32 c               sont a des niveaux > 1
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . disqua . e   . nouvqu . indicateurs de disparition des quadrangles .
  38 c . hetqua . es  . nouvqu . historique de l'etat des quadrangles       .
  39 c . perqua . es  . nouvqu . pere des quadrangles                       .
  40 c . filqua . es  . nouvqu . premier fils des quadrangles               .
  41 c . ancqua .   s . nouvqu . anciens numeros des quadrangles conserves  .
  42 c . nouqua .   s .0:nouvqu. nouveaux numeros des quadrangles conserves .
  43 c . nbqure .   s .   1    . nombre de quadrangles restants             .
  44 c ______________________________________________________________________
  45 c
  46 c====
  47 c 0. declarations et dimensionnement
  48 c====
  49 c
  50 c 0.1. ==> generalites
  51 c
  52       implicit none
  53       save
  54 c
  55 cgn      character*6 nompro
  56 cgn      parameter ( nompro = 'UTSUQU' )
  57 c
  58 c 0.2. ==> communs
  59 c
  60 #include "nombqu.h"
  61 #include "nouvnb.h"
  62 c
  63 c 0.3. ==> arguments
  64 c
  65       integer disqua(nouvqu)
  66       integer hetqua(nouvqu), perqua(nouvqu), filqua(nouvqu)
  67       integer ancqua(nouvqu), nouqua(0:nouvqu)
  68       integer nbqure
  69 c
  70 c 0.4. ==> variables locales
  71 c
  72       integer lequad, lepere, gdpere, etgper, lefrer
  73       integer cmptr, e1, e2, e3, e4, et
  74 c ______________________________________________________________________
  75 c
  76 c====
  77 c 1. fabrication des tableaux ancqua et nouqua
  78 c====
  79 c
  80       cmptr = 0
  81       nouqua(0) = 0
  82 c
  83 c 1.1 generation des tableaux reciproques
  84 c
  85       do 100 , lequad = 1 , nbqupe
  86 c
  87         if ( disqua(lequad).ne.0 ) then
  88 c
  89           nouqua(lequad) = 0
  90           hetqua(lequad) = 100 * int( hetqua(lequad) / 100 ) + 55
  91 c
  92         else
  93 c
  94           cmptr = cmptr + 1
  95           ancqua(cmptr)  = lequad
  96           nouqua(lequad) = cmptr
  97 c
  98         endif
  99 c
 100   100 continue
 101 c
 102 c 1.2 nombre d'entites restantes apres suppression
 103 c     (pour la remise a jour du nombre d'entites du maillage)
 104 c
 105       nbqure = cmptr
 106 c
 107 c====
 108 c 2. modification des etats des peres eventuels des quadrangles disparus
 109 c    Remarque : si on est parti d'un macro-maillage non conforme,
 110 c               certains quadrangles ont des peres adoptifs de numero
 111 c               negatif. Il ne faut pas changer leur etat
 112 c====
 113 c
 114       do 200 , lequad = 1 , nbqupe
 115 c
 116         if ( disqua(lequad).ne.0 ) then
 117 c
 118 c         mise a zero de l'etat actuel du pere eventuel
 119 c
 120           lepere = perqua(lequad)
 121           if ( lepere.gt.0 ) then
 122             hetqua(lepere) = hetqua(lepere) - mod(hetqua(lepere),100)
 123           endif
 124 c
 125         endif
 126 c
 127   200 continue
 128 c
 129 c====
 130 c 3. modification des etats des eventuels grand-peres des quadrangles
 131 c    Remarque : si on est parti d'un macro-maillage non conforme,
 132 c               certains quadrangles ont des peres adoptifs de numero
 133 c               negatif. Il ne faut pas changer leur etat
 134 c====
 135 c
 136       do 300 , lequad = 1 , nbqupe
 137 c
 138         if ( disqua(lequad).ne.0 ) then
 139 c
 140           lepere = perqua(lequad)
 141 c
 142           if ( lepere.gt.0 ) then
 143 c
 144             gdpere = perqua(lepere)
 145 c
 146             if ( gdpere.gt.0 ) then
 147 c
 148 c 3.1     verification de l'etat du grand-pere
 149 c
 150               etgper = mod( hetqua(gdpere) , 100 )
 151 c
 152               if ( etgper.ne.4 ) then
 153 c
 154 c 3.1.1     verification de l'etat des freres du pere
 155 c
 156                 lefrer = filqua(gdpere)
 157                 e1 = mod( hetqua(lefrer) , 100 )
 158                 e2 = mod( hetqua(lefrer+1) , 100 )
 159                 e3 = mod( hetqua(lefrer+2) , 100 )
 160                 e4 = mod( hetqua(lefrer+3) , 100 )
 161                 et = e1 + e2 + e3 + e4
 162 c
 163 c 3.1.2     attribution de l'etat 'coupee en 4' a l'entite
 164 c
 165                 if ( et.eq.0 ) then
 166                   hetqua(gdpere) = hetqua(gdpere)
 167      >                           - mod(hetqua(gdpere),100)
 168      >                           + 4
 169                 endif
 170 c
 171               endif
 172 c
 173             endif
 174 c
 175           endif
 176 c
 177         endif
 178 c
 179   300 continue
 180 c
 181       end