src/tool/Utilitaire/utsuar.F

   1       subroutine utsuar ( disare,
   2      >                    hetare, merare, filare,
   3      >                    ancare, nouare,
   4      >                    nbarre )
   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 ARetes
  26 c    --           --              --
  27 c ______________________________________________________________________
  28 c
  29 c   Attention : toutes les aretes n'ont pas forcement une mere !
  30 c               celles crees en interne a des tetraedres/triangles
  31 c               sont de la premiere generation, meme si elles
  32 c               sont a des niveaux > 1
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . disare . e   . nouvar . indicateurs de disparition des aretes      .
  38 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  39 c . merare . es  . nouvar . mere des aretes                            .
  40 c . filare . es  . nouvar . premiere fille des aretes                  .
  41 c . ancare .   s . nouvar . anciens numeros des aretes conservees      .
  42 c . nouare .   s .0:nouvar. nouveaux numeros des aretes conservees     .
  43 c . nbarre .   s .   1    . nombre d'aretes restantes                  .
  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 = 'UTSUAR' )
  57 c
  58 c 0.2. ==> communs
  59 c
  60 #include "nombar.h"
  61 #include "nouvnb.h"
  62 c
  63 c 0.3. ==> arguments
  64 c
  65       integer hetare(nouvar), merare(nouvar), filare(nouvar)
  66       integer disare(nouvar), ancare(nouvar)
  67       integer nouare(0:nouvar)
  68       integer nbarre
  69 c
  70 c 0.4. ==> variables locales
  71 c
  72       integer larete, lamere, gdmere, etgmer
  73       integer cmptr, e1, e2, et
  74 c ______________________________________________________________________
  75 c
  76 c====
  77 c 1. fabrication des tableaux ancare et nouare
  78 c====
  79 c
  80       cmptr = 0
  81       nouare(0) = 0
  82 c
  83 c 1.1 generation des tableaux reciproques
  84 c
  85       do 100 , larete = 1 , nbarpe
  86 c
  87         if ( disare(larete).ne.0 ) then
  88 c
  89           nouare(larete) = 0
  90           hetare(larete) = 10 * int( hetare(larete) / 10 ) + 5
  91 c
  92         else
  93 c
  94           cmptr = cmptr + 1
  95           ancare(cmptr)  = larete
  96           nouare(larete) = 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       nbarre = cmptr
 106 c
 107 c====
 108 c 2. modification des etats des meres eventuelles des aretes disparues
 109 c====
 110 c
 111       do 200 , larete = 1 , nbarpe
 112 c
 113         if ( disare(larete).ne.0 ) then
 114 c
 115 c         mise a zero de l'etat actuel de la mere
 116 c
 117           lamere = merare(larete)
 118 c
 119           if ( lamere.ne.0 ) then
 120             hetare(lamere) = hetare(lamere) - mod(hetare(lamere),10)
 121           endif
 122 c
 123         endif
 124 c
 125   200 continue
 126 c
 127 c====
 128 c 3. modification des etats des eventuelles grand-meres des aretes
 129 c====
 130 c
 131       do 300 , larete = 1 , nbarpe
 132 c
 133         if ( disare(larete).ne.0 ) then
 134 c
 135           lamere = merare(larete)
 136 c
 137           if ( lamere.ne.0 ) then
 138 c
 139             gdmere = merare(lamere)
 140 c
 141             if ( gdmere.ne.0 ) then
 142 c
 143 c 3.1     verification de l'etat de la grand-mere
 144 c
 145               etgmer = mod( hetare(gdmere) , 10 )
 146 c
 147               if ( etgmer.ne.2 ) then
 148 c
 149 c 3.1.1     verification de l'etat des soeurs de la mere
 150 c
 151                 e1 = mod( hetare(filare(gdmere))   , 10 )
 152                 e2 = mod( hetare(filare(gdmere)+1) , 10 )
 153                 et = e1 + e2
 154 c
 155 c 3.1.2       attribution de l'etat 'coupee en 2' a l'entite
 156 c
 157                 if ( et .eq. 0 ) then
 158                   hetare(gdmere) = hetare(gdmere)
 159      >                           - mod(hetare(gdmere),10)
 160      >                           + 2
 161                 endif
 162 c
 163               endif
 164 c
 165             endif
 166 c
 167           endif
 168 c
 169         endif
 170 c
 171   300 continue
 172 c
 173       end