src/tool/Utilitaire/utb3g0.F

   1       subroutine utb3g0 ( hetnoe, coonoe,
   2      >                    numcoi, coinpt, coinnn,
   3      >                    somare,
   4      >                    arequa,
   5      >                    hetpen, facpen, cofape, arepen, 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 G0
  29 c    --           -              -         --
  30 c ______________________________________________________________________
  31 c
  32 c but : controle l'interpenetration des pentaedres
  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 . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  46 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  47 c . cofape . e   .nbpecf*5. code des 5 faces des pentaedres            .
  48 c . arepen . e   .nbpeca*9. numeros des 9 aretes des pentaedres        .
  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 = 'UTB3G0' )
  72 c
  73       integer typenh
  74       parameter ( typenh = 7 )
  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 "nombpe.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 facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
  96       integer hetpen(nbpeto)
  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 lepent, lenoeu
 110       integer nucoin, ptcoin, ptcode, ptcofi
 111       integer sommet(15), nbsomm
 112       integer listar(9)
 113 #ifdef _DEBUG_HOMARD_
 114       integer glop
 115 #endif
 116 c
 117       double precision v0(5,3)
 118       double precision v1(3), v2(3), v3(3), v4(3), v5(3), v6(3)
 119       double precision v12(3), v13(3), v14(3)
 120       double precision v52(3), v54(3), v56(3)
 121       double precision vn(3)
 122       double precision xmax, xmin, ymax, ymin, zmax, zmin
 123       double precision prmito, prmilo
 124       double precision daux1
 125 c
 126       logical logaux(7)
 127 c
 128       integer nbmess
 129       parameter (nbmess = 10 )
 130       character*80 texte(nblang,nbmess)
 131 c
 132 c 0.5. ==> initialisations
 133 c ______________________________________________________________________
 134 c
 135 c====
 136 c 1. initialisations
 137 c====
 138 c
 139 c 1.1. ==> messages
 140 c
 141 #include "impr01.h"
 142 c
 143 #ifdef _DEBUG_HOMARD_
 144       write (ulsort,texte(langue,1)) 'Entree', nompro
 145       call dmflsh (iaux)
 146 #endif
 147 c
 148 #include "utb300.h"
 149 c
 150 #include "utb301.h"
 151 c
 152 c 1.2. ==> constantes
 153 c
 154       codret = 0
 155 c
 156       if ( degre.eq.1 ) then
 157         nbsomm = 6
 158       else
 159         nbsomm = 15
 160       endif
 161 c
 162 c====
 163 c 2. controle de la non-interpenetration des pentaedres
 164 c    remarque : on ne s'interesse qu'aux actifs car les autres sont
 165 c    censes avoir ete controles aux iterations anterieures
 166 c====
 167 cgn      call gtdems (92)
 168 c
 169       do 20 , lepent = 1 , nbpeto
 170 c
 171 #ifdef _DEBUG_HOMARD_
 172         if ( lepent.lt.0 ) then
 173           glop = 1
 174         else
 175           glop = 0
 176         endif
 177 #endif
 178 c
 179         if ( mod(hetpen(lepent),100).eq.0 ) then
 180 cgn      call gtdems (93)
 181 c
 182           if ( nbpbco(typenh).eq.-1 ) then
 183 #ifdef _DEBUG_HOMARD_
 184       write (ulsort,texte(langue,4)) mess14(langue,3,typenh)
 185 #endif
 186             nbpbco(typenh) = 0
 187           endif
 188 c
 189 #include "utb3g1.h"
 190 c
 191 #ifdef _DEBUG_HOMARD_
 192         if ( glop.ne.0 ) then
 193           write (ulsort,14203) sommet(1), v1(1), v1(2), v1(3)
 194           write (ulsort,14203) sommet(2), v2(1), v2(2), v2(3)
 195           write (ulsort,14203) sommet(3), v3(1), v3(2), v3(3)
 196           write (ulsort,14203) sommet(4), v4(1), v4(2), v4(3)
 197           write (ulsort,14203) sommet(5), v5(1), v5(2), v5(3)
 198           write (ulsort,14203) sommet(6), v6(1), v6(2), v6(3)
 199           write (ulsort,*) xmin, xmax
 200           write (ulsort,*) ymin, ymax
 201           write (ulsort,*) zmin, zmax
 202         endif
 203 #endif
 204 c
 205           do 23 , lenoeu = numip1, numap1
 206 c
 207 #include "utb304.h"
 208 c
 209 #include "utb305.h"
 210 c
 211 #include "utb306.h"
 212 c
 213 #include "utb3g2.h"
 214 c
 215 c 2.3.9. ==> si logaux(7) est encore vrai, c'est que le noeud est
 216 c            a l'interieur du pentaedre ... malaise ...
 217 c
 218             if ( logaux(7) ) then
 219 c
 220               iaux = lepent
 221 c
 222 #include "utb302.h"
 223 c
 224               write (ulbila,14203) sommet(1), v1(1), v1(2), v1(3)
 225               write (ulbila,14203) sommet(2), v2(1), v2(2), v2(3)
 226               write (ulbila,14203) sommet(3), v3(1), v3(2), v3(3)
 227               write (ulbila,14203) sommet(4), v4(1), v4(2), v4(3)
 228               write (ulbila,14203) sommet(5), v5(1), v5(2), v5(3)
 229               write (ulbila,14203) sommet(6), v6(1), v6(2), v6(3)
 230 c
 231               write (ulbila,10200)
 232 c
 233             endif
 234 c
 235    23     continue
 236 c
 237         endif
 238 c
 239    20 continue
 240 cgn      call gtfims (92)
 241 c
 242       end