src/tool/Utilitaire/utb3e0.F

   1       subroutine utb3e0 ( hetnoe, coonoe,
   2      >                    numcoi, coinpt, coinnn,
   3      >                    somare,
   4      >                    arequa,
   5      >                    hethex, quahex, coquhe, arehex, np2are,
   6      >                    nbpbco, mess08, mess54,
   7      >                    ulbila, ulsort, langue, codret )
   8 c ______________________________________________________________________
   9 c
  10 c                             H O M A R D
  11 c
  12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  13 c
  14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  15 c aupres des huissiers de justice Simart et Lavoir a Clamart
  16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  17 c aupres des huissiers de justice
  18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  19 c
  20 c    HOMARD est une marque deposee d'Electricite de France
  21 c
  22 c Copyright EDF 1996
  23 c Copyright EDF 1998
  24 c Copyright EDF 2002
  25 c Copyright EDF 2020
  26 c ______________________________________________________________________
  27 c
  28 c    UTilitaire - Bilan - option 3 - phase E0
  29 c    --           -              -         --
  30 c ______________________________________________________________________
  31 c
  32 c but : controle l'interpenetration des hexaedres
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . hetnoe . e   . nbnoto . historique de l'etat des noeuds            .
  38 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  39 c .        .     . * sdim .                                            .
  40 c . numcoi . e   . nbnoto . numero de la coincidence du noeud          .
  41 c . coinpt . e   .   *    . pointeur de la i-eme coincidence dans coinn.
  42 c . coinnn . e   .   *    . liste des noeuds coincidents               .
  43 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  44 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  45 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  46 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  47 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  48 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  49 c . np2are . e   . nbarto . noeud milieux des aretes                   .
  50 c . nbpbco . es  .  -1:7  . nombre de problemes de coincidences        .
  51 c . mess54 . e   .nblang,*. messages                                   .
  52 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
  53 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  54 c . langue . e   .    1   . langue des messages                        .
  55 c .        .     .        . 1 : francais, 2 : anglais                  .
  56 c . codret .  s  .    1   . code de retour des modules                 .
  57 c .        .     .        . 0 : pas de probleme                        .
  58 c .        .     .        . 1 : probleme                               .
  59 c .____________________________________________________________________.
  60 c
  61 c====
  62 c 0. declarations et dimensionnement
  63 c====
  64 c
  65 c 0.1. ==> generalites
  66 c
  67       implicit none
  68       save
  69 c
  70       character*6 nompro
  71       parameter ( nompro = 'UTB3E0' )
  72 c
  73       integer typenh
  74       parameter ( typenh = 6 )
  75 c
  76 #include "nblang.h"
  77 c
  78 c 0.2. ==> communs
  79 c
  80 #include "nombno.h"
  81 #include "nombar.h"
  82 #include "nombqu.h"
  83 #include "nombhe.h"
  84 #include "envca1.h"
  85 #include "impr02.h"
  86 c
  87 c 0.3. ==> arguments
  88 c
  89       double precision coonoe(nbnoto,sdim)
  90 c
  91       integer hetnoe(nbnoto)
  92       integer numcoi(nbnoto), coinpt(*), coinnn(*)
  93       integer somare(2,nbarto)
  94       integer arequa(nbquto,4)
  95       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
  96       integer hethex(nbheto)
  97       integer np2are(nbarto)
  98       integer nbpbco(-1:7)
  99 c
 100       character*08 mess08(nblang,*)
 101       character*54 mess54(nblang,*)
 102 c
 103       integer ulbila
 104       integer ulsort, langue, codret
 105 c
 106 c 0.4. ==> variables locales
 107 c
 108       integer iaux, jaux
 109       integer lehexa, lenoeu
 110       integer nucoin, ptcoin, ptcode, ptcofi
 111       integer sommet(20), nbsomm
 112       integer listar(12)
 113 c
 114       double precision v0(6,3)
 115       double precision v1(3), v2(3), v3(3), v4(3)
 116       double precision v5(3), v6(3), v7(3), v8(3)
 117       double precision v12(3), v14(3), v16(3)
 118       double precision v83(3), v85(3), v87(3)
 119       double precision vn(3)
 120       double precision xmax, xmin, ymax, ymin, zmax, zmin
 121       double precision prmito, prmilo
 122       double precision daux1
 123 c
 124       logical logaux(7)
 125 c
 126       integer nbmess
 127       parameter (nbmess = 10 )
 128       character*80 texte(nblang,nbmess)
 129 c
 130 c 0.5. ==> initialisations
 131 c
 132 #ifdef _DEBUG_HOMARD_
 133       integer glop
 134       data glop / 0 /
 135 #endif
 136 c ______________________________________________________________________
 137 c
 138 c====
 139 c 1. initialisations
 140 c====
 141 c
 142 c 1.1. ==> messages
 143 c
 144 #include "impr01.h"
 145 c
 146 #ifdef _DEBUG_HOMARD_
 147       write (ulsort,texte(langue,1)) 'Entree', nompro
 148       call dmflsh (iaux)
 149 #endif
 150 c
 151 #include "impr03.h"
 152 c
 153 #include "utb300.h"
 154 c
 155 #include "utb301.h"
 156 c
 157 #ifdef _DEBUG_HOMARD_
 158       write (ulsort,90002) 'nbpbco', nbpbco
 159 #endif
 160 c
 161 c 1.2. ==> constantes
 162 c
 163       codret = 0
 164 c
 165       if ( degre.eq.1 ) then
 166         nbsomm = 8
 167       else
 168         nbsomm = 20
 169       endif
 170 #ifdef _DEBUG_HOMARD_
 171       write (ulsort,90002) 'nbheto', nbheto
 172       write (ulsort,90002) 'nbhecf', nbhecf
 173       write (ulsort,90002) 'degre ', degre
 174 #endif
 175 c
 176 c====
 177 c 2. controle de la non-interpenetration des hexaedres
 178 c    remarque : on ne s'interesse qu'aux actifs car les autres sont
 179 c    censes avoir ete controles aux iterations anterieures
 180 c====
 181 cgn      call gtdems (92)
 182 c
 183       do 20 , lehexa = 1 , nbheto
 184 c
 185 #ifdef _DEBUG_HOMARD_
 186         if ( lehexa.lt.0 ) then
 187           glop = 1
 188       write (ulsort,*) ' '
 189       write (ulsort,90002) mess14(langue,1,typenh), lehexa
 190       write (ulsort,90112) 'etat', lehexa,hethex(lehexa)
 191 cgn      write (ulsort,90112) 'nbpbco', typenh,nbpbco(typenh)
 192         else
 193           glop = 0
 194         endif
 195 #endif
 196 c
 197         if ( mod(hethex(lehexa),1000).eq.0 ) then
 198 cgn      call gtdems (93)
 199 #ifdef _DEBUG_HOMARD_
 200         if ( glop.ne.0 ) then
 201       write (ulsort,90112) nompro//' quahex', lehexa,
 202      >                     (quahex(lehexa,iaux),iaux=1,6)
 203       write (ulsort,90112) nompro//' coquhe', lehexa,
 204      >                     (coquhe(lehexa,iaux),iaux=1,6)
 205         endif
 206 #endif
 207 c
 208           if ( nbpbco(typenh).eq.-1 ) then
 209 #ifdef _DEBUG_HOMARD_
 210       write (ulsort,texte(langue,4)) mess14(langue,3,typenh)
 211 #endif
 212             nbpbco(typenh) = 0
 213           endif
 214 c
 215 #include "utb3e1.h"
 216 c
 217 #ifdef _DEBUG_HOMARD_
 218         if ( glop.ne.0 ) then
 219           write (ulsort,14203) sommet(1), v1(1), v1(2), v1(3)
 220           write (ulsort,14203) sommet(2), v2(1), v2(2), v2(3)
 221           write (ulsort,14203) sommet(3), v3(1), v3(2), v3(3)
 222           write (ulsort,14203) sommet(4), v4(1), v4(2), v4(3)
 223           write (ulsort,14203) sommet(5), v5(1), v5(2), v5(3)
 224           write (ulsort,14203) sommet(6), v6(1), v6(2), v6(3)
 225           write (ulsort,14203) sommet(7), v7(1), v7(2), v7(3)
 226           write (ulsort,14203) sommet(8), v8(1), v8(2), v8(3)
 227           write (ulsort,90004) 'X min/max', xmin, xmax
 228           write (ulsort,90004) 'Y min/max', ymin, ymax
 229           write (ulsort,90004) 'Z min/max', zmin, zmax
 230           write (ulsort,90002) 'numip1, numap1',numip1, numap1
 231         endif
 232 #endif
 233 c
 234           do 23 , lenoeu = numip1, numap1
 235 c
 236 #include "utb304.h"
 237 #ifdef _DEBUG_HOMARD_
 238         if ( glop.ne.0 .and. lenoeu.lt.0 ) then
 239           write (ulsort,*) 'apres utb304', logaux(7)
 240           write (ulsort,90004) 'vn', vn
 241         endif
 242 #endif
 243 c
 244 #include "utb305.h"
 245 #ifdef _DEBUG_HOMARD_
 246         if ( glop.ne.0 .and. lenoeu.lt.0 ) then
 247           write (ulsort,*) 'apres utb305', logaux(7)
 248         endif
 249 #endif
 250 c
 251 #include "utb306.h"
 252 #ifdef _DEBUG_HOMARD_
 253         if ( glop.ne.0 .and. lenoeu.lt.0 ) then
 254           write (ulsort,*) 'apres utb306', logaux(7)
 255         endif
 256 #endif
 257 c
 258 #include "utb3e2.h"
 259 #ifdef _DEBUG_HOMARD_
 260         if ( glop.ne.0 .and. lenoeu.lt.0 ) then
 261           write (ulsort,*) 'apres utb3e2', logaux(7)
 262         endif
 263 #endif
 264 c
 265 c 2.3.9. ==> si logaux(7) est encore vrai, c'est que le noeud est
 266 c            a l'interieur de l'hexaedre ... malaise ...
 267 c
 268             if ( logaux(7) ) then
 269 c
 270               iaux = lehexa
 271 c
 272 #include "utb302.h"
 273 c
 274               write (ulbila,14203) sommet(1), v1(1), v1(2), v1(3)
 275               write (ulbila,14203) sommet(2), v2(1), v2(2), v2(3)
 276               write (ulbila,14203) sommet(3), v3(1), v3(2), v3(3)
 277               write (ulbila,14203) sommet(4), v4(1), v4(2), v4(3)
 278               write (ulbila,14203) sommet(5), v5(1), v5(2), v5(3)
 279               write (ulbila,14203) sommet(6), v6(1), v6(2), v6(3)
 280               write (ulbila,14203) sommet(7), v7(1), v7(2), v7(3)
 281               write (ulbila,14203) sommet(8), v8(1), v8(2), v8(3)
 282 c
 283               write (ulbila,10200)
 284 c
 285             endif
 286 c
 287    23     continue
 288 c
 289         endif
 290 c
 291    20 continue
 292 cgn      call gtfims (92)
 293 c
 294 c====
 295 c 3. la fin
 296 c====
 297 c
 298 #ifdef _DEBUG_HOMARD_
 299       write (ulsort,90002) 'nbpbco', nbpbco
 300 #endif
 301 c
 302 #ifdef _DEBUG_HOMARD_
 303       write (ulsort,texte(langue,1)) 'Sortie', nompro
 304       call dmflsh (iaux)
 305 #endif
 306 c
 307       end