src/tool/Utilitaire/utsute.F

   1       subroutine utsute ( distet,
   2      >                    hettet, pertet, filtet,
   3      >                    tritet, cotrte,
   4      >                    arenoe,
   5      >                    somare,
   6      >                    aretri,
   7      >                    anctet, noutet,
   8      >                    nbtere,
   9      >                    codret )
  10 c ______________________________________________________________________
  11 c
  12 c                             H O M A R D
  13 c
  14 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  15 c
  16 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  17 c aupres des huissiers de justice Simart et Lavoir a Clamart
  18 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  19 c aupres des huissiers de justice
  20 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  21 c
  22 c    HOMARD est une marque deposee d'Electricite de France
  23 c
  24 c Copyright EDF 1996
  25 c Copyright EDF 1998
  26 c Copyright EDF 2002
  27 c Copyright EDF 2020
  28 c ______________________________________________________________________
  29 c
  30 c    UTilitaire - SUppression des TEtraedres
  31 c    --           --              --
  32 c ______________________________________________________________________
  33 c .        .     .        .                                            .
  34 c .  nom   . e/s . taille .           description                      .
  35 c .____________________________________________________________________.
  36 c . distet . e   . nouvte . indicateurs de disparition des tetraedres  .
  37 c . hettet . es  . nouvte . historique de l'etat des tetraedres        .
  38 c . pertet . es  . nouvte . pere des tetraedres                        .
  39 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  40 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  41 c . filtet . es  . nouvte . premier fils des tetraedres                .
  42 c . tritet . es  .nouvtf*4. numeros des 4 triangles des tetraedres     .
  43 c . cotrte . es  .nouvtf*4. code des 4 triangles des tetraedres        .
  44 c . arenoe . es  . nouvno . arete liee a un nouveau noeud              .
  45 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  46 c . aretri . es  .nouvtr*3. numeros des 3 aretes des triangles         .
  47 c . anctet .   s . nouvte . anciens numeros des tetraedres conserves   .
  48 c . noutet .   s .0:nouvte. nouveaux numeros des tetraedres conserves  .
  49 c . nbtere .   s .   1    . nombre de tetraedres restants              .
  50 c . codret .   s .   1    . code de retour, 0 si ok, (no tetra) si pb  .
  51 c ______________________________________________________________________
  52 c
  53 c====
  54 c 0. declarations et dimensionnement
  55 c====
  56 c
  57 c 0.1. ==> generalites
  58 c
  59       implicit none
  60       save
  61 c
  62 cgn      character*6 nompro
  63 cgn      parameter ( nompro = 'UTSUTE' )
  64 c
  65 c 0.2. ==> communs
  66 c
  67 #include "nombte.h"
  68 #include "nouvnb.h"
  69 c
  70 c 0.3. ==> arguments
  71 c
  72       integer distet(nouvte)
  73       integer hettet(nouvte), pertet(nouvte), filtet(nouvte)
  74       integer tritet(nouvtf,4), cotrte(nouvtf,4)
  75       integer arenoe(nouvno)
  76       integer somare(2,nouvar)
  77       integer aretri(nouvtr,3)
  78       integer anctet(nouvte), noutet(0:nouvte)
  79       integer nbtere
  80       integer codret
  81 c
  82 c 0.4. ==> variables locales
  83 c
  84       integer letetr, gdpere, lepere, lefrer
  85       integer etgper, htfrer, etfrer, ardiag
  86       integer cmptr,  actifs, decoup
  87       integer iaux
  88 c
  89 c 0.5. ==> initialisations
  90 c
  91       codret = 0
  92 c ______________________________________________________________________
  93 c
  94 c====
  95 c 1. fabrication des tableaux anctet et noutet
  96 c====
  97 c
  98       cmptr = 0
  99       noutet(0) = 0
 100 c
 101 c 1.1 generation des tableaux reciproques
 102 c
 103       do 100 , letetr = 1 , nbtepe
 104 c
 105         if ( distet(letetr).eq.1 ) then
 106 c
 107           noutet(letetr) = 0
 108           hettet(letetr) = 100 * int( hettet(letetr)/100 ) + 55
 109 c
 110         else
 111 c
 112           cmptr = cmptr + 1
 113           anctet(cmptr)  = letetr
 114           noutet(letetr) = cmptr
 115 c
 116         endif
 117 c
 118   100 continue
 119 c
 120 c 1.2 nombre d'entites restantes apres suppression
 121 c     (pour la remise a jour du nombre d'entites du maillage)
 122 c
 123       nbtere = cmptr
 124 c
 125 c====
 126 c 2. modification des etats des peres des tetraedres
 127 c====
 128 c
 129       do 200 , letetr = 1 , nbtepe
 130 c
 131         if ( distet(letetr).eq.1 ) then
 132 c
 133 c         mise a zero de l'etat actuel du pere
 134 c
 135           lepere = pertet(letetr)
 136           hettet(lepere) = hettet(lepere) - mod(hettet(lepere),100)
 137 c
 138         endif
 139 c
 140   200 continue
 141 c
 142 c====
 143 c 3. modification des etats des grand-peres des tetraedres,
 144 c    s'ils existent
 145 c====
 146 c
 147       do 300 , letetr = 1 , nbtepe
 148 c
 149         if ( distet(letetr).eq.1 ) then
 150 c
 151 c 3.1     verification de l'etat du grand-pere
 152 c
 153           lepere = pertet(letetr)
 154           gdpere = pertet(lepere)
 155 c
 156           if ( gdpere.ne.0 ) then
 157 c
 158             iaux = mod(hettet(gdpere),100)
 159             etgper = (iaux-mod(iaux,10)) / 10
 160 c
 161             if ( etgper.ne.8 ) then
 162 c
 163 c 3.1.1     verification de l'etat des freres du pere
 164 c
 165               lefrer = filtet(gdpere)
 166               actifs = 1
 167 c
 168               do 310 , htfrer = lefrer , lefrer + 7
 169 c
 170                 etfrer = mod( hettet(htfrer) , 100)
 171 c
 172                 if ( etfrer.ne.0 ) then
 173                   actifs = 0
 174                 endif
 175 c
 176   310         continue
 177 c
 178               if ( actifs.eq.1 ) then
 179 c
 180 c 3.1.2       recherche de la diagonale de decoupe et de l'etat du
 181 c             tetraedre
 182 c
 183                 call utdiag (gdpere,
 184      >                       filtet, tritet, aretri,
 185      >                       arenoe, somare, cotrte,
 186      >                       ardiag, decoup, codret )
 187 c
 188                 if (codret.ne.0) then
 189                   goto 320
 190                 endif
 191 c
 192 c 3.1.3       attribution de l'etat de l'entite
 193 c
 194                 hettet(gdpere) = hettet(gdpere)
 195      >                         - mod(hettet(gdpere),100)
 196      >                         + decoup
 197 c
 198               endif
 199 c
 200             endif
 201 c
 202           endif
 203 c
 204         endif
 205 c
 206   300 continue
 207 c
 208   320 continue
 209 c
 210       end