src/tool/Utilitaire/utb3f0.F

   1       subroutine utb3f0 ( hetnoe, coonoe,
   2      >                    numcoi, coinpt, coinnn,
   3      >                    somare,
   4      >                    aretri,
   5      >                    hetpyr, facpyr, cofapy, arepyr, 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 F0
  29 c    --           -              -         --
  30 c ______________________________________________________________________
  31 c
  32 c but : controle l'interpenetration des pyramides
  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 . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  45 c . hetpyr . e   . nbpyto . historique de l'etat des pyramides         .
  46 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  47 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  48 c . arepyr . e   .nbpyca*8. numeros des 8 aretes des pyramides         .
  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 = 'UTB3F0' )
  72 c
  73       integer typenh
  74       parameter ( typenh = 5 )
  75 c
  76 #include "nblang.h"
  77 c
  78 c 0.2. ==> communs
  79 c
  80 #include "envex1.h"
  81 c
  82 #include "nombno.h"
  83 #include "nombar.h"
  84 #include "nombtr.h"
  85 #include "nombpy.h"
  86 #include "envca1.h"
  87 #include "impr02.h"
  88 c
  89 c 0.3. ==> arguments
  90 c
  91       double precision coonoe(nbnoto,sdim)
  92 c
  93       integer hetnoe(nbnoto)
  94       integer numcoi(nbnoto), coinpt(*), coinnn(*)
  95       integer somare(2,nbarto)
  96       integer aretri(nbtrto,3)
  97       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
  98       integer hetpyr(nbpyto)
  99       integer np2are(nbarto)
 100       integer nbpbco(-1:7)
 101 c
 102       character*08 mess08(nblang,*)
 103       character*54 mess54(nblang,*)
 104 c
 105       integer ulbila
 106       integer ulsort, langue, codret
 107 c
 108 c 0.4. ==> variables locales
 109 c
 110       integer iaux, jaux
 111       integer lapyra, lenoeu
 112       integer nucoin, ptcoin, ptcode, ptcofi
 113       integer sommet(13), nbsomm
 114       integer listar(8)
 115 c
 116       double precision v0(5,3)
 117       double precision v1(3), v2(3), v3(3), v4(3), v5(3)
 118       double precision v51(3), v52(3), v53(3), v54(3)
 119       double precision v12(3), v14(3)
 120       double precision v5n(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 #ifdef _DEBUG_HOMARD_
 135       integer glop
 136       data glop / 0 /
 137 #endif
 138 c ______________________________________________________________________
 139 c
 140 c====
 141 c 1. initialisations
 142 c====
 143 c
 144 c 1.1. ==> messages
 145 c
 146 #include "impr01.h"
 147 c
 148 #ifdef _DEBUG_HOMARD_
 149       write (ulsort,texte(langue,1)) 'Entree', nompro
 150       call dmflsh (iaux)
 151 #endif
 152 c
 153 #include "impr03.h"
 154 c
 155 #include "utb300.h"
 156 c
 157 #include "utb301.h"
 158 c
 159 c 1.2. ==> constantes
 160 c
 161 #ifdef _DEBUG_HOMARD_
 162       write(ulsort,90002) 'nbpyca', nbpyca
 163       write(ulsort,90002) 'nbpycf', nbpycf
 164       write(ulsort,90002) 'nbpyto', nbpyto
 165 #endif
 166 c
 167       codret = 0
 168 c
 169       if ( degre.eq.1 ) then
 170         nbsomm = 5
 171       else
 172         nbsomm = 13
 173       endif
 174 c
 175 c====
 176 c 2. controle de la non-interpenetration des pyramides
 177 c    remarque : on ne s'interesse qu'aux actives car les autres sont
 178 c    censees avoir ete controlees aux iterations anterieures
 179 c====
 180 cgn      call gtdems (92)
 181 c
 182       do 20 , lapyra = 1 , nbpyto
 183 c
 184 #ifdef _DEBUG_HOMARD_
 185         if ( lapyra.lt.0 ) then
 186           glop = 1
 187         else
 188           glop = 0
 189         endif
 190 #endif
 191 c
 192         if ( mod(hetpyr(lapyra),100).eq.0 ) then
 193 cgn      call gtdems (93)
 194 c
 195           if ( nbpbco(typenh).eq.-1 ) then
 196 #ifdef _DEBUG_HOMARD_
 197       write (ulsort,texte(langue,4)) mess14(langue,3,typenh)
 198 #endif
 199             nbpbco(typenh) = 0
 200           endif
 201 c
 202 #include "utb3f1.h"
 203 c
 204 #ifdef _DEBUG_HOMARD_
 205         if ( glop.ne.0 ) then
 206           write (ulbila,14203) sommet(1), v1(1), v1(2), v1(3)
 207           write (ulbila,14203) sommet(2), v2(1), v2(2), v2(3)
 208           write (ulbila,14203) sommet(3), v3(1), v3(2), v3(3)
 209           write (ulbila,14203) sommet(4), v4(1), v4(2), v4(3)
 210           write (ulbila,14203) sommet(5), v5(1), v5(2), v5(3)
 211         endif
 212 #endif
 213 c
 214           do 23 , lenoeu = numip1, numap1
 215 c
 216 #include "utb304.h"
 217 c
 218 #include "utb305.h"
 219 c
 220 #include "utb306.h"
 221 c
 222 #include "utb3f2.h"
 223 c
 224 c 2.3.8. ==> si logaux(7) est encore vrai, c'est que le noeud est
 225 c            a l'interieur de la pyramide ... malaise ...
 226 c
 227             if ( logaux(7) ) then
 228 c
 229               iaux = lapyra
 230 c
 231 #include "utb302.h"
 232 c
 233               write (ulbila,14203) sommet(1), v1(1), v1(2), v1(3)
 234               write (ulbila,14203) sommet(2), v2(1), v2(2), v2(3)
 235               write (ulbila,14203) sommet(3), v3(1), v3(2), v3(3)
 236               write (ulbila,14203) sommet(4), v4(1), v4(2), v4(3)
 237               write (ulbila,14203) sommet(5), v5(1), v5(2), v5(3)
 238 c
 239               write (ulbila,10200)
 240 c
 241             endif
 242 c
 243    23     continue
 244 c
 245         endif
 246 c
 247    20 continue
 248 cgn      call gtfims (92)
 249 c
 250 c====
 251 c 3. la fin
 252 c====
 253 c
 254       if ( codret.ne.0 ) then
 255 c
 256 #include "envex2.h"
 257 c
 258       write (ulsort,texte(langue,1)) 'Sortie', nompro
 259       write (ulsort,texte(langue,2)) codret
 260 c
 261       endif
 262 c
 263 #ifdef _DEBUG_HOMARD_
 264       write (ulsort,texte(langue,1)) 'Sortie', nompro
 265       call dmflsh (iaux)
 266 #endif
 267 c
 268       end