src/tool/Utilitaire/utb3g1.F

   1       subroutine utb3g1 ( nbcoqu, nbcoar,
   2      >                    coonoe,
   3      >                    somare, filare, np2are,
   4      >                    cfaare, famare,
   5      >                    arequa, filqua,
   6      >                    cfaqua, famqua,
   7      >                    hetpen, facpen, cofape, arepen,
   8      >                    nbarfr, arefro,
   9      >                    nbqufr, quafro,
  10      >                    ulsort, langue, codret )
  11 c ______________________________________________________________________
  12 c
  13 c                             H O M A R D
  14 c
  15 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  16 c
  17 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  18 c aupres des huissiers de justice Simart et Lavoir a Clamart
  19 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  20 c aupres des huissiers de justice
  21 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  22 c
  23 c    HOMARD est une marque deposee d'Electricite de France
  24 c
  25 c Copyright EDF 1996
  26 c Copyright EDF 1998
  27 c Copyright EDF 2002
  28 c Copyright EDF 2020
  29 c ______________________________________________________________________
  30 c
  31 c    UTilitaire - Bilan - option 3 - phase G1
  32 c    --           -              -         --
  33 c ______________________________________________________________________
  34 c
  35 c but : controle la presence de noeuds dans les pentaedres
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . nbcoqu . es  .   1    . nombre de corrections pour les quadrangles .
  41 c . nbcoar . es  .   1    . nombre de corrections pour les aretes      .
  42 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  43 c .        .     . * sdim .                                            .
  44 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  45 c . filare . e   . nbarto . premiere fille des aretes                  .
  46 c . np2are . e   . nbarto . noeud milieux des aretes                   .
  47 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  48 c .        .     . nbfare .   1 : famille MED                          .
  49 c .        .     .        .   2 : type de segment                      .
  50 c .        .     .        .   3 : orientation                          .
  51 c .        .     .        .   4 : famille d'orientation inverse        .
  52 c .        .     .        .   5 : numero de ligne de frontiere         .
  53 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  54 c .        .     .        . <= 0 si non concernee                      .
  55 c .        .     .        .   6 : famille frontiere active/inactive    .
  56 c .        .     .        .   7 : numero de surface de frontiere       .
  57 c .        .     .        . + l : appartenance a l'equivalence l       .
  58 c . famare . e   . nbarto . famille des aretes                         .
  59 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  60 c . filqua . e   . nbquto . premier fils des quadrangles               .
  61 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  62 c .        .     . nbfqua .   1 : famille MED                          .
  63 c .        .     .        .   2 : type de quadrangle                   .
  64 c .        .     .        .   3 : numero de surface de frontiere       .
  65 c .        .     .        .   4 : famille des aretes internes apres raf.
  66 c .        .     .        .   5 : famille des triangles de conformite  .
  67 c .        .     .        .   6 : famille de sf active/inactive        .
  68 c .        .     .        . + l : appartenance a l'equivalence l       .
  69 c . famqua . e   . nbquto . famille des quadrangles                    .
  70 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  71 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  72 c . cofape . e   .nbpecf*5. code des 5 faces des pentaedres            .
  73 c . arepen . e   .nbpeca*9. numeros des 9 aretes des pentaedres        .
  74 c . nbarfr . e   .   1    . nombre d'aretes concernees                 .
  75 c . arefro . es  . nbarfr . liste des aretes concernees                .
  76 c . nbqufr . e   .   1    . nombre de quadrangles concernes            .
  77 c . quafro . es  . nbqufr . liste des quadrangles concernes            .
  78 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  79 c . langue . e   .    1   . langue des messages                        .
  80 c .        .     .        . 1 : francais, 2 : anglais                  .
  81 c . codret .  s  .    1   . code de retour des modules                 .
  82 c .        .     .        . 0 : pas de probleme                        .
  83 c .        .     .        . 1 : probleme                               .
  84 c .____________________________________________________________________.
  85 c
  86 c====
  87 c 0. declarations et dimensionnement
  88 c====
  89 c
  90 c 0.1. ==> generalites
  91 c
  92       implicit none
  93       save
  94 c
  95       character*6 nompro
  96       parameter ( nompro = 'UTB3G1' )
  97 c
  98       integer typenh
  99       parameter ( typenh = 7 )
 100 c
 101 #include "nblang.h"
 102 c
 103 c 0.2. ==> communs
 104 c
 105 #include "envex1.h"
 106 c
 107 #include "dicfen.h"
 108 #include "nbfami.h"
 109 #include "nombno.h"
 110 #include "nombar.h"
 111 #include "nombqu.h"
 112 #include "nombpe.h"
 113 #include "envca1.h"
 114 #include "impr02.h"
 115 c
 116 c 0.3. ==> arguments
 117 c
 118       double precision coonoe(nbnoto,sdim)
 119 c
 120       integer nbcoar, nbcoqu
 121       integer somare(2,nbarto), filare(nbarto), np2are(nbarto)
 122       integer cfaare(nctfar,nbfare), famare(nbarto)
 123       integer arequa(nbquto,4), filqua(nbquto)
 124       integer cfaqua(nctfqu,nbfqua), famqua(nbquto)
 125       integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
 126       integer hetpen(nbpeto)
 127       integer nbarfr, arefro(nbarfr)
 128       integer nbqufr, quafro(nbqufr)
 129 c
 130       integer ulsort, langue, codret
 131 c
 132 c 0.4. ==> variables locales
 133 c
 134       integer iaux, jaux
 135       integer lepent, lequad, larete, lenoeu
 136       integer nbexam, examno(2), examar(2)
 137       integer nuarfr, nuqufr
 138       integer sommet(15), nbsomm
 139       integer listar(9)
 140 #ifdef _DEBUG_HOMARD_
 141       integer glop
 142 #endif
 143 c
 144       double precision v0(5,3)
 145       double precision v1(3), v2(3), v3(3), v4(3), v5(3), v6(3)
 146       double precision v12(3), v13(3), v14(3)
 147       double precision v52(3), v54(3), v56(3)
 148       double precision vn(3)
 149       double precision xmax, xmin, ymax, ymin, zmax, zmin
 150       double precision prmito, prmilo
 151       double precision daux1
 152 c
 153       logical logaux(7)
 154 c
 155       integer nbmess
 156       parameter (nbmess = 10 )
 157       character*80 texte(nblang,nbmess)
 158 c
 159 c 0.5. ==> initialisations
 160 c ______________________________________________________________________
 161 c
 162 c====
 163 c 1. initialisations
 164 c====
 165 c
 166 c 1.1. ==> messages
 167 c
 168 #include "impr01.h"
 169 c
 170 #ifdef _DEBUG_HOMARD_
 171       write (ulsort,texte(langue,1)) 'Entree', nompro
 172       call dmflsh (iaux)
 173 #endif
 174 c
 175 #include "utb303.h"
 176 c
 177 c 1.2. ==> constantes
 178 c
 179       codret = 0
 180 c
 181       if ( degre.eq.1 ) then
 182         nbsomm = 6
 183       else
 184         nbsomm = 15
 185       endif
 186 c
 187       nbcoar = 0
 188       nbcoqu = 0
 189 c
 190 c====
 191 c 2. controle de la presence de noeuds dans les pentaedres
 192 c    remarque : on ne s'interesse qu'aux actifs car les autres sont
 193 c    censes avoir ete controles aux iterations anterieures
 194 c====
 195 cgn      call gtdems (92)
 196 c
 197       do 20 , lepent = 1 , nbpeto
 198 c
 199 #ifdef _DEBUG_HOMARD_
 200         if ( lepent.lt.0 ) then
 201           glop = 1
 202         else
 203           glop = 0
 204         endif
 205 #endif
 206 c
 207         if ( mod(hetpen(lepent),100).eq.0 ) then
 208 cgn      call gtdems (93)
 209 c
 210 #include "utb3g1.h"
 211 c
 212 c 2.1. ==> Les quadrangles
 213 c
 214           do 21 , nuqufr = 1 , nbqufr
 215 c
 216 c 2.1.1. ==> Elimination des situations ou il est inutile
 217 c          de controler car le quadrangle a deja ete ramene
 218 c
 219             lequad = quafro(nuqufr)
 220 c
 221             if ( lequad.le.0 ) then
 222               goto 21
 223             endif
 224 c
 225 c 2.1.2. ==> Reperage des situations a examiner :
 226 c          . le noeud central du quadrangle decoupe
 227 c          . les noeuds P2 courbes : a faire
 228 c          ce noeud central est la seconde extremite de la 2eme ou 3eme
 229 c          arete de l'un quelconque des quadrangles fils (cf. cmrdqu)
 230 c
 231             if ( codret.eq.0 ) then
 232 c
 233             if ( typsfr.le.2 ) then
 234               nbexam = 1
 235               larete = arequa(filqua(lequad),2)
 236               examno(1) = somare(2,larete)
 237             else
 238               codret = 212
 239             endif
 240 c
 241             endif
 242 c
 243 c 2.1.3. ==> Examen
 244 c
 245             if ( codret.eq.0 ) then
 246 c
 247 #ifdef _DEBUG_HOMARD_
 248       write (ulsort,texte(langue,4)) mess14(langue,1,4), lequad
 249 #endif
 250 c
 251             do 213 , jaux = 1 , nbexam
 252 c
 253               lenoeu = examno(jaux)
 254 c
 255 #include "utb304.h"
 256 c
 257 cgn              write(ulsort,1789) vn
 258 cgn              write(ulsort,1789) xmin,xmax
 259 cgn              write(ulsort,1789) ymin,ymax
 260 cgn              write(ulsort,1789) zmin,zmax
 261 cgn              write(ulsort,*) logaux(7)
 262 cgn 1789 format(3g12.5)
 263 c
 264 #include "utb3g2.h"
 265 c
 266 c 2.1.8. ==> si logaux(7) est encore vrai, c'est que le noeud est
 267 c            a l'interieur du pentaedre ... correction
 268 c
 269               if ( logaux(7) ) then
 270 c
 271                 if ( codret.eq.0 ) then
 272 c
 273 #ifdef _DEBUG_HOMARD_
 274       write (ulsort,texte(langue,8)) mess14(langue,1,-1), lenoeu
 275 #endif
 276 c
 277                 nbcoqu = nbcoqu + 1
 278                 quafro(nuqufr) = -lequad
 279 #ifdef _DEBUG_HOMARD_
 280       write (ulsort,texte(langue,3)) 'UTCORN_quadrangle', nompro
 281 #endif
 282                 call utcorn ( lenoeu, lequad, 0,
 283      >                        coonoe,
 284      >                        somare, filare,
 285      >                        cfaare, famare,
 286      >                        arequa, filqua,
 287      >                        cfaqua, famqua,
 288      >                        ulsort, langue, codret)
 289 c
 290                 endif
 291 c
 292               endif
 293 c
 294   213       continue
 295 c
 296             endif
 297 c
 298    21     continue
 299 c
 300 c 2.2. ==> Les aretes
 301 c
 302           do 22 , nuarfr = 1 , nbarfr
 303 c
 304 #include "utb308.h"
 305 c
 306 c 2.2.3. ==> Examen
 307 c
 308             if ( codret.eq.0 ) then
 309 c
 310 #ifdef _DEBUG_HOMARD_
 311       write (ulsort,texte(langue,4)) mess14(langue,1,1), larete
 312 #endif
 313 c
 314             do 223 , jaux = 1 , nbexam
 315 c
 316               lenoeu = examno(jaux)
 317 c
 318 #include "utb314.h"
 319 c
 320 cgn              write(ulsort,1789) vn
 321 cgn              write(ulsort,1789) xmin,xmax
 322 cgn              write(ulsort,1789) ymin,ymax
 323 cgn              write(ulsort,1789) zmin,zmax
 324 cgn              write(ulsort,*) logaux(7)
 325 cgn 1789 format(3g12.5)
 326 c
 327 #include "utb3g2.h"
 328 c
 329 c 2.2.8. ==> si logaux(7) est encore vrai, c'est que le noeud est
 330 c            a l'interieur du pentaedre ... correction
 331 c
 332               if ( logaux(7) ) then
 333 c
 334                 if ( codret.eq.0 ) then
 335 c
 336 #ifdef _DEBUG_HOMARD_
 337       write (ulsort,texte(langue,8)) mess14(langue,1,-1), lenoeu
 338 #endif
 339 c
 340                 nbcoar = nbcoar + 1
 341                 arefro(nuarfr) = -larete
 342 #ifdef _DEBUG_HOMARD_
 343       write (ulsort,texte(langue,3)) 'UTCORN_arete', nompro
 344 #endif
 345                 call utcorn ( lenoeu, 0, larete,
 346      >                        coonoe,
 347      >                        somare, filare,
 348      >                        cfaare, famare,
 349      >                        arequa, filqua,
 350      >                        cfaqua, famqua,
 351      >                        ulsort, langue, codret)
 352 c
 353                 endif
 354 c
 355               endif
 356 c
 357   223       continue
 358 c
 359             endif
 360 c
 361    22     continue
 362 c
 363         endif
 364 c
 365    20 continue
 366 cgn      call gtfims (92)
 367 c
 368 c====
 369 c 3. La fin
 370 c====
 371 c
 372 #include "utb307.h"
 373 c
 374       if ( codret.ne.0 ) then
 375 c
 376 #include "envex2.h"
 377 c
 378       write (ulsort,texte(langue,1)) 'Sortie', nompro
 379       write (ulsort,texte(langue,2)) codret
 380 c
 381       endif
 382 c
 383 #ifdef _DEBUG_HOMARD_
 384       write (ulsort,texte(langue,1)) 'Sortie', nompro
 385       call dmflsh (iaux)
 386 #endif
 387 c
 388       end