src/tool/Utilitaire/utb3d1.F

   1       subroutine utb3d1 ( nbcoqu, nbcoar,
   2      >                    coonoe,
   3      >                    somare, filare, np2are,
   4      >                    cfaare, famare,
   5      >                    aretri,
   6      >                    hettet, tritet, cotrte, aretet,
   7      >                    nbarfr, arefro,
   8      >                    nbqufr, quafro,
   9      >                    ulsort, langue, 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 - Bilan - option 3 - phase D1
  31 c    --           -              -         --
  32 c ______________________________________________________________________
  33 c
  34 c but : controle la presence de noeuds dans les tetraedres
  35 c ______________________________________________________________________
  36 c .        .     .        .                                            .
  37 c .  nom   . e/s . taille .           description                      .
  38 c .____________________________________________________________________.
  39 c . nbcoqu . es  .   1    . nombre de corrections pour les quadrangles .
  40 c . nbcoar . es  .   1    . nombre de corrections pour les aretes      .
  41 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  42 c .        .     . * sdim .                                            .
  43 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  44 c . filare . e   . nbarto . premiere fille des aretes                  .
  45 c . np2are . e   . nbarto . noeud milieux des aretes                   .
  46 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  47 c .        .     . nbfare .   1 : famille MED                          .
  48 c .        .     .        .   2 : type de segment                      .
  49 c .        .     .        .   3 : orientation                          .
  50 c .        .     .        .   4 : famille d'orientation inverse        .
  51 c .        .     .        .   5 : numero de ligne de frontiere         .
  52 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  53 c .        .     .        . <= 0 si non concernee                      .
  54 c .        .     .        .   6 : famille frontiere active/inactive    .
  55 c .        .     .        .   7 : numero de surface de frontiere       .
  56 c .        .     .        . + l : appartenance a l'equivalence l       .
  57 c . famare . e   . nbarto . famille des aretes                         .
  58 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  59 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  60 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  61 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  62 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  63 c . nbarfr . e   .   1    . nombre d'aretes concernees                 .
  64 c . arefro . es  . nbarfr . liste des aretes concernees                .
  65 c . nbqufr . e   .   1    . nombre de quadrangles concernes            .
  66 c . quafro . es  . nbqufr . liste des quadrangles concernes            .
  67 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  68 c . langue . e   .    1   . langue des messages                        .
  69 c .        .     .        . 1 : francais, 2 : anglais                  .
  70 c . codret .  s  .    1   . code de retour des modules                 .
  71 c .        .     .        . 0 : pas de probleme                        .
  72 c .        .     .        . 1 : probleme                               .
  73 c .____________________________________________________________________.
  74 c
  75 c====
  76 c 0. declarations et dimensionnement
  77 c====
  78 c
  79 c 0.1. ==> generalites
  80 c
  81       implicit none
  82       save
  83 c
  84       character*6 nompro
  85       parameter ( nompro = 'UTB3D1' )
  86 c
  87       integer typenh
  88       parameter ( typenh = 3 )
  89 c
  90 #include "nblang.h"
  91 c
  92 c 0.2. ==> communs
  93 c
  94 #include "envex1.h"
  95 c
  96 #include "dicfen.h"
  97 #include "nbfami.h"
  98 #include "nombno.h"
  99 #include "nombar.h"
 100 #include "nombtr.h"
 101 #include "nombte.h"
 102 #include "envca1.h"
 103 #include "impr02.h"
 104 c
 105 c 0.3. ==> arguments
 106 c
 107       double precision coonoe(nbnoto,sdim)
 108 c
 109       integer nbcoar, nbcoqu
 110       integer somare(2,nbarto), filare(nbarto), np2are(nbarto)
 111       integer cfaare(nctfar,nbfare), famare(nbarto)
 112       integer aretri(nbtrto,3)
 113       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 114       integer hettet(nbteto)
 115       integer nbarfr, arefro(nbarfr)
 116       integer nbqufr, quafro(nbqufr)
 117 c
 118       integer ulsort, langue, codret
 119 c
 120 c 0.4. ==> variables locales
 121 c
 122       integer iaux, jaux
 123       integer letetr, larete, lenoeu
 124       integer nuarfr
 125       integer nbexam, examno(2), examar(2)
 126       integer sommet(10), nbsomm
 127       integer listar(6)
 128       integer arequa(1,4), filqua(1)
 129       integer cfaqua(1,1), famqua(1)
 130 #ifdef _DEBUG_HOMARD_
 131       integer glop
 132 #endif
 133 c
 134       double precision v0(4,3)
 135       double precision v1(3), v2(3), v3(3), v4(3)
 136       double precision v21(3), v23(3), v24(3), v41(3), v43(3)
 137       double precision vn(3)
 138       double precision xmax, xmin, ymax, ymin, zmax, zmin
 139       double precision prmito, prmilo
 140       double precision daux1
 141 c
 142       logical logaux(7)
 143 c
 144       integer nbmess
 145       parameter (nbmess = 10 )
 146       character*80 texte(nblang,nbmess)
 147 c
 148 c 0.5. ==> initialisations
 149 c ______________________________________________________________________
 150 c
 151 c====
 152 c 1. initialisations
 153 c====
 154 c
 155 c 1.1. ==> messages
 156 c
 157 #include "impr01.h"
 158 c
 159 #ifdef _DEBUG_HOMARD_
 160       write (ulsort,texte(langue,1)) 'Entree', nompro
 161       call dmflsh (iaux)
 162 #endif
 163 c
 164 #include "utb303.h"
 165 c
 166 c 1.2. ==> constantes
 167 c
 168       codret = 0
 169 c
 170       if ( degre.eq.1 ) then
 171         nbsomm = 4
 172       else
 173         nbsomm = 10
 174       endif
 175 c
 176       nbcoar = 0
 177       nbcoqu = 0
 178 c
 179 c====
 180 c 2. controle de la penetration de noeuds dans les tetraedres
 181 c    remarque : on ne s'interesse qu'aux actifs car les autres sont
 182 c    censes avoir ete controles aux iterations anterieures
 183 c====
 184 cgn      call gtdems (92)
 185 c
 186       do 20 , letetr = 1 , nbteto
 187 c
 188 #ifdef _DEBUG_HOMARD_
 189         if ( letetr.lt.0 ) then
 190           glop = 1
 191         else
 192           glop = 0
 193         endif
 194 #endif
 195 c
 196         if ( mod(hettet(letetr),100).eq.0 ) then
 197 cgn      call gtdems (93)
 198 cgn        write (ulsort,*) '.. ', mess14(langue,2,3), letetr
 199 c
 200 #include "utb3d1.h"
 201 c
 202 c 2.2. ==> Les aretes
 203 c
 204           do 22 , nuarfr = 1 , nbarfr
 205 c
 206 #include "utb308.h"
 207 c
 208 c 2.2.3. ==> Examen
 209 c
 210             if ( codret.eq.0 ) then
 211 c
 212 #ifdef _DEBUG_HOMARD_
 213       write (ulsort,texte(langue,4)) mess14(langue,1,1), larete
 214 #endif
 215 c
 216             do 223 , jaux = 1 , nbexam
 217 c
 218               lenoeu = examno(jaux)
 219 c
 220 #include "utb304.h"
 221 c
 222 #include "utb3d2.h"
 223 c
 224 c 2.2.8. ==> si logaux(7) est encore vrai, c'est que le noeud est
 225 c            a l'interieur du tetraedre ... correction
 226 c
 227               if ( logaux(7) ) then
 228 c
 229                 if ( codret.eq.0 ) then
 230 c
 231 #ifdef _DEBUG_HOMARD_
 232       write (ulsort,texte(langue,8)) mess14(langue,1,-1), lenoeu
 233 #endif
 234 c
 235                 nbcoar = nbcoar + 1
 236                 arefro(nuarfr) = -larete
 237 #ifdef _DEBUG_HOMARD_
 238       write (ulsort,texte(langue,3)) 'UTCORN_arete', nompro
 239 #endif
 240                 call utcorn ( lenoeu, 0, larete,
 241      >                        coonoe,
 242      >                        somare, filare,
 243      >                        cfaare, famare,
 244      >                        arequa, filqua,
 245      >                        cfaqua, famqua,
 246      >                        ulsort, langue, codret)
 247 c
 248                 endif
 249 c
 250               endif
 251 c
 252   223       continue
 253 c
 254             endif
 255 c
 256    22     continue
 257 cgn      call gtfims (93)
 258 c
 259         endif
 260 c
 261    20 continue
 262 cgn      call gtfims (92)
 263 c
 264 c====
 265 c 3. La fin
 266 c====
 267 c
 268 #include "utb307.h"
 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 c
 277       endif
 278 c
 279 #ifdef _DEBUG_HOMARD_
 280       write (ulsort,texte(langue,1)) 'Sortie', nompro
 281       call dmflsh (iaux)
 282 #endif
 283 c
 284       end