src/tool/Decision/decfs3.F

   1       subroutine decfs3 ( hettri, filtri,
   2      >                    hetqua, filqua,
   3      >                    hettet, filtet,
   4      >                    hethex, filhex,
   5      >                    hetpen, filpen,
   6      >                    ulsort, langue, codret )
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c traitement des DEcisions - mise en ConFormite - Suppression
  28 c                --                  -  -         -
  29 c                            des fils
  30 c ______________________________________________________________________
  31 c On parcourt toutes les entites qui sont decoupees par conformite :
  32 c . on supprime la reference aux fils
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  38 c . filtri . e   . nbtrto . fils des triangles                         .
  39 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  40 c . filqua . e   . nbquto . premier fils des quadrangles               .
  41 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  42 c . filtet . e   . nbteto . premier fils des tetraedres                .
  43 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  44 c . filhex . e   . nbheto . fils des hexaedres                         .
  45 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  46 c . filpen . e   . nbpeto . premier fils des pentaedres                .
  47 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  48 c . langue . e   .    1   . langue des messages                        .
  49 c .        .     .        . 1 : francais, 2 : anglais                  .
  50 c . codret . es  .    1   . code de retour des modules                 .
  51 c .        .     .        . 0 : pas de probleme                        .
  52 c .        .     .        . sinon : nombre de tetraedres a problemes   .
  53 c ______________________________________________________________________
  54 c
  55 c====
  56 c 0. declarations et dimensionnement
  57 c====
  58 c
  59 c 0.1. ==> generalites
  60 c
  61       implicit none
  62       save
  63 c
  64       character*6 nompro
  65       parameter ( nompro = 'DECFS3' )
  66 c
  67 #include "nblang.h"
  68 c
  69 c 0.2. ==> communs
  70 c
  71 #include "envex1.h"
  72 #include "impr02.h"
  73 c
  74 #include "nombtr.h"
  75 #include "nombqu.h"
  76 #include "nombte.h"
  77 #include "nombhe.h"
  78 #include "nombpe.h"
  79 c
  80 c 0.3. ==> arguments
  81 c
  82       integer hettri(nbtrto), filtri(nbtrto)
  83       integer hetqua(nbquto), filqua(nbquto)
  84       integer hettet(nbteto), filtet(nbteto)
  85       integer hethex(nbheto), filhex(nbheto)
  86       integer hetpen(nbpeto), filpen(nbpeto)
  87 c
  88       integer ulsort, langue, codret
  89 c
  90 c 0.4. ==> variables locales
  91 c
  92       integer iaux
  93       integer etat
  94 c
  95       integer nbmess
  96       parameter ( nbmess = 10 )
  97       character*80 texte(nblang,nbmess)
  98 c
  99 c 0.5. ==> initialisations
 100 c ______________________________________________________________________
 101 c
 102 c====
 103 c 1. messages
 104 c====
 105 c
 106 #include "impr01.h"
 107 c
 108 #ifdef _DEBUG_HOMARD_
 109       write (ulsort,texte(langue,1)) 'Entree', nompro
 110       call dmflsh (iaux)
 111 #endif
 112 c
 113       texte(1,4) =
 114      > '(''Suppression des fils de conformites pour les '',a)'
 115 c
 116       texte(2,4) =
 117      > '(''Suppression of the sons for the conformities for '',a)'
 118 c
 119       codret = 0
 120 c
 121 c====
 122 c 2. les triangles
 123 c====
 124 c
 125       if ( nbtrto.ne.0 ) then
 126 c
 127 #ifdef _DEBUG_HOMARD_
 128       write (ulsort,texte(langue,4)) mess14(langue,3,2)
 129 #endif
 130 c
 131 cgn 1793 format('Etat du ',a,i10,' :',i4)
 132       do 22 , iaux = 1 , nbtrto
 133 c
 134         etat = mod(hettri(iaux),10)
 135 c
 136         if ( etat.ge.1 .and. etat.le.3 ) then
 137 cgn      write (ulsort,1793) mess14(langue,1,2), iaux, etat
 138 c
 139           filtri(iaux) = 0
 140 c
 141         endif
 142 c
 143    22 continue
 144 c
 145       endif
 146 c
 147 c====
 148 c 3. les quadrangles
 149 c====
 150 #ifdef _DEBUG_HOMARD_
 151       write (ulsort,*) '3. Quadrangles ; codret = ', codret
 152 #endif
 153 c
 154       if ( nbquto.ne.0 ) then
 155 c
 156 #ifdef _DEBUG_HOMARD_
 157       write (ulsort,texte(langue,4)) mess14(langue,3,4)
 158 #endif
 159 c
 160       do 32 , iaux = 1 , nbquto
 161 c
 162         etat = mod(hetqua(iaux),100)
 163 c
 164         if ( etat.eq.21 .or. etat.eq.22 .or.
 165      >       ( etat.ge.31 .and. etat.le.34 ) .or.
 166      >       ( etat.ge.41 .and. etat.le.44 ) ) then
 167 cgn      write (ulsort,1793) mess14(langue,1,4), iaux, etat
 168 c
 169           filqua(iaux) = 0
 170 c
 171         endif
 172 c
 173    32 continue
 174 c
 175       endif
 176 c
 177 c====
 178 c 4. les tetraedres
 179 c====
 180 #ifdef _DEBUG_HOMARD_
 181       write (ulsort,*) '4. Tetraedres ; codret = ', codret
 182 #endif
 183 c
 184       if ( nbteto.ne.0 ) then
 185 c
 186 #ifdef _DEBUG_HOMARD_
 187       write (ulsort,texte(langue,4)) mess14(langue,3,3)
 188 #endif
 189 c
 190       do 42 , iaux = 1 , nbteto
 191 c
 192         etat = mod(hettet(iaux),100)
 193 c
 194         if ( ( etat.ge.21 .and. etat.le.36 ) .or.
 195      >       ( etat.ge.41 .and. etat.le.47 ) ) then
 196 c
 197           filtet(iaux) = 0
 198 c
 199         endif
 200 c
 201    42 continue
 202 c
 203 cgn      write (ulsort,1790) (iaux,teindr(iaux),iaux = 1 , nbteto)
 204 cgn 1790 format(5(i4,' :',g12.5))
 205       endif
 206 c
 207 c====
 208 c 5. les hexaedres
 209 c====
 210 #ifdef _DEBUG_HOMARD_
 211       write (ulsort,*) '5. Hexaedres ; codret = ', codret
 212 #endif
 213 c
 214       if ( nbheto.ne.0 ) then
 215 c
 216 #ifdef _DEBUG_HOMARD_
 217       write (ulsort,texte(langue,4)) mess14(langue,3,6)
 218 #endif
 219 c
 220       do 52 , iaux = 1 , nbheto
 221 c
 222         etat = mod(hethex(iaux),1000)
 223 c
 224         if ( etat.ge.11 ) then
 225 c
 226           filhex(iaux) = 0
 227 c
 228         endif
 229 c
 230    52 continue
 231 c
 232       endif
 233 c
 234 c====
 235 c 6. les pentaedres
 236 c====
 237 #ifdef _DEBUG_HOMARD_
 238       write (ulsort,*) '6. Pentaedres ; codret = ', codret
 239 #endif
 240 c
 241       if ( nbpeto.ne.0 ) then
 242 c
 243 #ifdef _DEBUG_HOMARD_
 244       write (ulsort,texte(langue,4)) mess14(langue,3,7)
 245 #endif
 246 c
 247       do 62 , iaux = 1 , nbpeto
 248 c
 249         etat = mod(hetpen(iaux),100)
 250 c
 251         if ( ( etat.ge. 1 .and. etat.le. 6 ) .or.
 252      >       ( etat.ge.17 .and. etat.le.19 ) .or.
 253      >       ( etat.ge.21 .and. etat.le.26 ) .or.
 254      >       ( etat.ge.31 .and. etat.le.36 ) .or.
 255      >       ( etat.ge.43 .and. etat.le.45 ) .or.
 256      >       ( etat.ge.51 .and. etat.le.52 ) ) then
 257 c
 258           filpen(iaux) = 0
 259 c
 260         endif
 261 c
 262    62 continue
 263 c
 264       endif
 265 c
 266 c====
 267 c 7. la fin
 268 c====
 269 c
 270       if ( codret.ne.0 ) then
 271 c
 272 #include "envex2.h"
 273 c
 274       write (ulsort,texte(langue,1)) 'Sortie', nompro
 275       write (ulsort,texte(langue,2)) codret
 276       write (ulsort,texte(langue,6)) codret
 277 c
 278       endif
 279 c
 280 #ifdef _DEBUG_HOMARD_
 281       write (ulsort,texte(langue,1)) 'Sortie', nompro
 282       call dmflsh (iaux)
 283 #endif
 284 c
 285       end