src/tool/AP_Conversion/pcmex2.F

   1       subroutine pcmex2 ( indtri, indpen,
   2      >                    nouvar, nouvtr, nouvqu, nouvpe,
   3      >                    hettri, aretri,
   4      >                    filtri, pertri, nivtri,
   5      >                    famtri, cfatri, pentri,
   6      >                    arequa, nivqua,
   7      >                    famqua, cfaqua,
   8      >                    hetpen, facpen, cofape,
   9      >                    filpen, perpen,
  10      >                    fampen,
  11      >                    somare,
  12      >                    entxar,
  13      >                    ulsort, langue, codret )
  14 c ______________________________________________________________________
  15 c
  16 c                             H O M A R D
  17 c
  18 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  19 c
  20 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  21 c aupres des huissiers de justice Simart et Lavoir a Clamart
  22 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  23 c aupres des huissiers de justice
  24 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  25 c
  26 c    HOMARD est une marque deposee d'Electricite de France
  27 c
  28 c Copyright EDF 1996
  29 c Copyright EDF 1998
  30 c Copyright EDF 2002
  31 c Copyright EDF 2020
  32 c ______________________________________________________________________
  33 c
  34 c    aPres adaptation - Conversion de Maillage EXtrude - phase 2
  35 c     -                 -             -        --              -
  36 c    Duplication des triangles et creation des pentaedres
  37 c ______________________________________________________________________
  38 c .        .     .        .                                            .
  39 c .  nom   . e/s . taille .           description                      .
  40 c .____________________________________________________________________.
  41 c . indtri . es  . 1      . indice du dernier triangle cree            .
  42 c . indpen . es  .   1    . indice du dernier pentaedre cree           .
  43 c . nouvar . e   .   1    . nouveau nombre d'aretes                    .
  44 c . nouvtr . e   .   1    . nouveau nombre de triangles                .
  45 c . nouvqu . e   .   1    . nouveau nombre de quadrangles              .
  46 c . nouvpe . e   .   1    . nouveau nombre de pentaedres               .
  47 c . hettri . es  . nouvtr . historitre de l'etat des triangles         .
  48 c . aretri . es  .nouvtr*3. numeros des 3 aretes des triangles         .
  49 c . filtri . es  . nouvtr . premier fils des triangles                 .
  50 c . pertri . es  . nouvtr . pere des triangles                         .
  51 c . nivtri . es  . nouvtr . niveau des triangles                       .
  52 c . famtri . es  . nouvtr . famille des triangles                      .
  53 c . cfatri . e   . nctftr*. codes des familles des triangles           .
  54 c .        .     . nbftri .   1 : famille MED                          .
  55 c .        .     .        .   2 : type de triangle                     .
  56 c .        .     .        .   3 : numero de surface de frontiere       .
  57 c .        .     .        .   4 : famille des aretes internes apres raf.
  58 c .        .     .        . si extrusion :                             .
  59 c .        .     .        .   5 : famille du triangle extrude          .
  60 c .        .     .        .   6 : famille du pent. perpendiculaire     .
  61 c .        .     .        .   7 : code du triangle dans le pentaedre   .
  62 c .        .     .        .   8 : position du triangle                 .
  63 c .        .     .        . si equivalence :                           .
  64 c .        .     .        . + l : appartenance a l'equivalence l       .
  65 c . pentri .  s  . nbtrto . pentaedre sur un triangle de la face avant .
  66 c . arequa . es  .nouvqu*4. numeros des 4 aretes des quadrangles       .
  67 c . nivqua . es  . nouvqu . niveau des quadrangles                     .
  68 c . famqua . es  . nouvqu . famille des quadrangles                    .
  69 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  70 c .        .     . nbfqua .   1 : famille MED                          .
  71 c .        .     .        .   2 : type de quadrangle                   .
  72 c .        .     .        .   3 : numero de surface de frontiere       .
  73 c .        .     .        .   4 : famille des aretes internes apres raf.
  74 c .        .     .        .   5 : famille des triangles de conformite  .
  75 c .        .     .        .   6 : famille de sf active/inactive        .
  76 c .        .     .        . Pour un quadrangle a l'avant :             .
  77 c .        .     .        .   7 : famille du quadrangle extrude        .
  78 c .        .     .        .   8 : famille du volume perpendiculaire    .
  79 c .        .     .        . Pour un quadrangle perpendiculaire :       .
  80 c .        .     .        .   7 : sens de la 1ere compos. de la normale.
  81 c .        .     .        .   8 : sens de la 2eme compos. de la normale.
  82 c .        .     .        .   9 : code du quadrangle dans hexa ou penta.
  83 c .        .     .        .  10 : position du quadrangle               .
  84 c .        .     .        . si equivalence :                           .
  85 c .        .     .        . + l : appartenance a l'equivalence l       .
  86 c . hetpen . es  . nouvpe . historique de l'etat des pentaedres        .
  87 c . facpen . e   .nouvpf*5. numeros des faces des pentaedres           .
  88 c . cofape . e   .nouvpf*5. code des faces des pentaedres              .
  89 c . filpen . es  . nouvpe . premier fils des pentaedres                .
  90 c . perpen . e   . nouvpe . pere des pentaedres                        .
  91 c . fampen . es  . nouvpe . famille des pentaedres                     .
  92 c . somare . e   .2*nouvar. numeros des extremites d'arete             .
  93 c . entxar . e   .2*nbarto. entites liees a l'extrusion de l'arete     .
  94 c .        .     .        . 1 : l'arete                                .
  95 c .        .     .        . 2 : le quadrangle perpendiculaire          .
  96 c .        .     .        . 3 : la 2eme arete de ce quadrangle         .
  97 c . ulsort . e   .   1    . numero d'unite logitre de la liste standard.
  98 c . langue . e   .    1   . langue des messages                        .
  99 c .        .     .        . 1 : francais, 2 : anglais                  .
 100 c . codret . es  .    1   . code de retour des modules                 .
 101 c .        .     .        . 0 : pas de probleme                        .
 102 c .        .     .        . 1 : probleme                               .
 103 c ______________________________________________________________________
 104 c
 105 c====
 106 c 0. declarations et dimensionnement
 107 c====
 108 c
 109 c 0.1. ==> generalites
 110 c
 111       implicit none
 112       save
 113 c
 114       character*6 nompro
 115       parameter ( nompro = 'PCMEX2' )
 116 c
 117 #include "nblang.h"
 118 c
 119 c 0.2. ==> communs
 120 c
 121 #include "envex1.h"
 122 c
 123 #include "nbfami.h"
 124 #include "cofext.h"
 125 #include "cofexq.h"
 126 #include "dicfen.h"
 127 #include "nombar.h"
 128 #include "nombtr.h"
 129 c
 130 c 0.3. ==> arguments
 131 c
 132       integer indtri, indpen
 133       integer nouvar, nouvtr, nouvqu, nouvpe
 134 c
 135       integer hettri(nouvtr), aretri(nouvtr,3)
 136       integer filtri(nouvtr), pertri(nouvtr), nivtri(nouvtr)
 137       integer famtri(nouvtr), cfatri(nctftr,nbftri)
 138       integer pentri(nouvtr)
 139       integer arequa(nouvqu,4), nivqua(nouvqu)
 140       integer famqua(nouvqu), cfaqua(nctfqu,nbfqua)
 141       integer hetpen(nouvpe)
 142       integer facpen(nouvpe,5), cofape(nouvpe,5)
 143       integer filpen(nouvpe), perpen(nouvpe)
 144       integer fampen(nouvpe)
 145 c
 146       integer somare(2,nouvar)
 147       integer entxar(2,nbarto)
 148 c
 149       integer ulsort, langue, codret
 150 c
 151 c 0.4. ==> variables locales
 152 c
 153       integer iaux
 154       integer letria
 155       integer atrba1, atrba2, atrba3
 156       integer atrex1, atrex2, atrex3
 157       integer arepen(9)
 158       integer sompe1, sompe2, sompe3
 159 c
 160       logical oripos, oripox
 161 c
 162       integer nbmess
 163       parameter ( nbmess = 10 )
 164       character*80 texte(nblang,nbmess)
 165 c
 166 c 0.5. ==> initialisations
 167 c ______________________________________________________________________
 168 c
 169 c====
 170 c 1. messages
 171 c====
 172 c
 173 #include "impr01.h"
 174 c
 175 #ifdef _DEBUG_HOMARD_
 176       write (ulsort,texte(langue,1)) 'Entree', nompro
 177       call dmflsh (iaux)
 178 #endif
 179 c
 180       texte(1,4) = '(''Nombre de triangles actifs :'',i10)'
 181 c
 182       texte(2,4) = '(''Number of active triangles:'',i10)'
 183 c
 184 #include "impr03.h"
 185 c
 186       codret = 0
 187 c
 188 #ifdef _DEBUG_HOMARD_
 189       write (ulsort,texte(langue,4)) nbtrac
 190 #endif
 191 c
 192 c====
 193 c 2. parcours des triangles
 194 c====
 195 #ifdef _DEBUG_HOMARD_
 196       write (ulsort,90002) '2. parcours triangles ; codret', codret
 197 #endif
 198 c
 199       if ( codret.eq.0 ) then
 200 c
 201 #ifdef _DEBUG_HOMARD_
 202       write (ulsort,90002) 'nbtrto', nbtrto
 203       write (ulsort,90002) 'nouvtr', nouvtr
 204       write (ulsort,90002) 'nouvpe', nouvpe
 205 #endif
 206 c
 207       do 20 , letria = 1 , nbtrto
 208 c
 209         if ( mod(hettri(letria),10).eq.0 ) then
 210 c
 211 cgn        write (ulsort,*) ' '
 212 cgn        write (ulsort,90012) '.. Aretes du triangle de base',
 213 cgn     >                       letria, aretri(letria,1),
 214 cgn     >                       aretri(letria,2), aretri(letria,3)
 215 cgn        write (ulsort,90002) '.... Famille', famtri(letria)
 216 cgn        write (ulsort,90002) '.... codes',
 217 cgn     >             (cfatri(iaux,famtri(letria)),iaux=1,nctftr)
 218 c
 219 c 2.1. ==> Orientations
 220 c          oripo. est vrai si le triangle entre dans le volume
 221 c 2.1.1. ==> Orientation du triangle de base
 222 c
 223           if ( cfatri(cofxto,famtri(letria)).le.3 ) then
 224             oripos = .True.
 225           else
 226             oripos = .False.
 227           endif
 228 cgn        write (ulsort,99001) '.. La base entre dans le volume', oripos
 229 c
 230 c 2.1.2. ==> Orientation du triangle extrude
 231 c
 232           if ( cfatri(cofxto,cfatri(cofxtt,famtri(letria))).le.3 ) then
 233             oripox = .True.
 234           else
 235             oripox = .False.
 236           endif
 237 cgn        write (ulsort,99001) '.. L''extru entre dans le volume', oripox
 238 c
 239 c 2.2. ===> Creation du nouveau triangle
 240 c 2.2.1. ==> Aretes extrudees en tant que bord du triangle
 241 c
 242           atrex1 = entxar(1,aretri(letria,1))
 243           atrex2 = entxar(1,aretri(letria,2))
 244           atrex3 = entxar(1,aretri(letria,3))
 245 c
 246 c 2.2.2. ==> Creation
 247 c            Attention a garder la meme orientation qu'au depart
 248 c
 249           indtri = indtri + 1
 250 c
 251           aretri(indtri,1) = atrex1
 252           if ( (       oripos .and. .not. oripox ) .or.
 253      >         ( .not. oripos .and.       oripox ) ) then
 254             aretri(indtri,2) = atrex2
 255             aretri(indtri,3) = atrex3
 256           else
 257             aretri(indtri,2) = atrex3
 258             aretri(indtri,3) = atrex2
 259           endif
 260 cgn        write (ulsort,90012) '.. Aretes du triangle extrude',
 261 cgn     >                       indtri, aretri(indtri,1),
 262 cgn     >                       aretri(indtri,2), aretri(indtri,3)
 263           hettri(indtri) = 50
 264           filtri(indtri) = 0
 265           pertri(indtri) = 0
 266           nivtri(indtri) = nivtri(letria)
 267           famtri(indtri) = cfatri(cofxtt,famtri(letria))
 268 cgn      write (ulsort,90012) '.. Famille du triangle translate',
 269 cgn     >                       indtri, famtri(indtri)
 270 c
 271 c 2.3. ===> Creation du volume joignant ces deux triangles
 272 c       face 1 : on postule :
 273 c                - c'est le triangle a la base de l'extrusion
 274 c                - sa 1ere arete est la 1ere du pentaedre
 275 c                - il est positionne avec la meme orientation qu'au
 276 c                  depart
 277 c                On en deduit le code :
 278 c                . si l'orientation est positive, code 1 : (a1, a2, a3)
 279 c                . si l'orientation est negative, code 4 : (a1, a3, a2)
 280 c       face 2 : c'est le triangle qui est l'extrusion de la face 1.
 281 c                Ses aretes sont les extrudees des aretes de la face 1 :
 282 c                1ere arete = extrusion de a1 = a4
 283 c                On en deduit le code :
 284 c                . si la face 1 entre et la face 2 sort ou si la face 1
 285 c                  sort et la face 2 entre :
 286 c                  2eme arete = extrusion de a2 = a5
 287 c                  3eme arete = extrusion de a3 = a6
 288 c                  donc code 1
 289 c                . sinon, code 4
 290 c       face 3 : c'est le quadrangle qui est l'extrusion de l'arete 1
 291 c                du pentaedre.
 292 c                1ere arete = a1 = 1ere arete du triangle de base
 293 c                2eme arete = celle qui part du 1er sommet de a1
 294 c                3eme arete = extrusion de a1 = a4 = 1ere arete
 295 c                             du triangle extrude
 296 c                4eme arete = celle qui part du 2nd sommet de a1
 297 c                . si le 1er sommet de a1 est sommet de a2, la 2eme
 298 c                  arete du quadrangle est a7 ;
 299 c                  la face est (a1,a7,a4,a9) donc code 5
 300 c                . sinon, la 2eme arete du quadrangle est a9 ;
 301 c                  la face est (a1,a9,a4,a7) donc code 1
 302 c       face 4 : c'est le quadrangle qui est l'extrusion de l'arete 2
 303 c                du pentaedre.
 304 c                1ere arete = a2
 305 c                2eme arete = celle qui part du 1er sommet de a2
 306 c                3eme arete = extrusion de a2 = a5
 307 c                4eme arete = celle qui part du 2nd sommet de a2
 308 c                . si l'orientation est positive :
 309 c                  a2 = 2eme arete du triangle de base
 310 c                . sinon :
 311 c                  a2 = 3eme arete du triangle de base
 312 c                . si le 1er sommet de a2 est sommet de a3, la 2eme
 313 c                  arete du quadrangle est a8 ;
 314 c                  la face est (a2,a8,a5,a7) donc code 5
 315 c                . sinon, la face est (a2,a7,a5,a8) donc code 1
 316 c       face 5 : c'est le quadrangle qui est l'extrusion de l'arete 3
 317 c                de la face 1.
 318 c                1ere arete = a3
 319 c                2eme arete = celle qui part du 1er sommet de a3
 320 c                3eme arete = extrusion de a3 = a6
 321 c                4eme arete = celle qui part du 2nd sommet de a3
 322 c                . si l'orientation est positive :
 323 c                  a3 = 3eme arete du triangle
 324 c                . sinon :
 325 c                  a3 = 2eme arete du triangle de base
 326 c                . si le 1er sommet de a3 est sommet de a1, la 2eme
 327 c                  arete du quadrangle est a9 ;
 328 c                  la face est (a3,a9,a6,a8) donc code 5
 329 c                . sinon, la face est (a3,a8,a6,a9) donc code 1
 330 c
 331 c 2.3.1. ==> Triangle de base
 332 c
 333           atrba1 = aretri(letria,1)
 334           atrba2 = aretri(letria,2)
 335           atrba3 = aretri(letria,3)
 336 c
 337 cgn        write (ulsort,90002) '.... Fac ext',
 338 cgn     >        entxar(2,atrba1), entxar(2,atrba2), entxar(2,atrba3)
 339 c
 340 c 2.3.2. ==> Les aretes et les sommets du pentaedre
 341 c
 342           arepen(1) = atrba1
 343           if ( oripos ) then
 344             arepen(2) = atrba2
 345             arepen(3) = atrba3
 346           else
 347             arepen(2) = atrba3
 348             arepen(3) = atrba2
 349           endif
 350 cgn          write (ulsort,90002) '.... Ar. Pen',
 351 cgn     >                arepen(1), arepen(2), arepen(3)
 352 c
 353           call utsotr ( somare, arepen(1), arepen(2), arepen(3),
 354      >                  sompe1, sompe2, sompe3 )
 355 cgn        write (ulsort,90002) '.... So. Pen', sompe1, sompe2, sompe3
 356 c
 357 c 2.3.3. ==> Creation du pentaedre
 358 c
 359           indpen = indpen + 1
 360 cgn          write (ulsort,90002) '.... pentaedre ', indpen
 361 c
 362 c 2.3.3.1. ==> Face 1 : la base
 363 c
 364           facpen(indpen,1) = letria
 365           if ( oripos ) then
 366             cofape(indpen,1) = 1
 367           else
 368             cofape(indpen,1) = 4
 369           endif
 370 cgn        write (ulsort,90012) '.... code de la face 1',
 371 cgn     > facpen(indpen,1), cofape(indpen,1)
 372 c
 373 c 2.3.3.2. ==> Face 2 : le triangle extrude
 374 c
 375           facpen(indpen,2) = indtri
 376           if ( (       oripos .and. .not. oripox ) .or.
 377      >         ( .not. oripos .and.       oripox ) ) then
 378             cofape(indpen,2) = 1
 379           else
 380             cofape(indpen,2) = 4
 381           endif
 382 cgn        write (ulsort,90012) '.... code de la face 2',
 383 cgn     >  facpen(indpen,2), cofape(indpen,2)
 384 c
 385 c 2.3.3.3. ==> Face 3 : le quadrangle construit sur la 1ere arete
 386 c
 387           facpen(indpen,3) = entxar(2,arepen(1))
 388           iaux = somare(1,arequa(facpen(indpen,3),2))
 389 cgn        write (ulsort,90012) '.... 1er som de l''arete',
 390 cgn     >  arequa(facpen(indpen,3),2),iaux
 391           if ( iaux.eq.sompe1 ) then
 392             cofape(indpen,3) = 5
 393           else
 394             cofape(indpen,3) = 1
 395           endif
 396           nivqua(facpen(indpen,3)) = nivtri(letria)
 397 cgn        write (ulsort,90012) '.... code de la face 3',
 398 cgn     >  facpen(indpen,3),cofape(indpen,3)
 399 c
 400 c 2.3.3.4. ==> Face 4 : le quadrangle construit sur la 2eme arete
 401 c
 402           facpen(indpen,4) = entxar(2,arepen(2))
 403           iaux = somare(1,arequa(facpen(indpen,4),2))
 404 cgn        write (ulsort,90012) '.... 1er som de l''arete',
 405 cgn     >  arequa(facpen(indpen,4),2),iaux
 406           if ( iaux.eq.sompe2 ) then
 407             cofape(indpen,4) = 5
 408           else
 409             cofape(indpen,4) = 1
 410           endif
 411           nivqua(facpen(indpen,4)) = nivtri(letria)
 412 cgn        write (ulsort,90012) '.... code de la face 4',
 413 cgn     >  facpen(indpen,4),cofape(indpen,4)
 414 c
 415 c 2.3.3.5. ==> Face 5 : le quadrangle construit sur la 3eme arete
 416 c
 417           facpen(indpen,5) = entxar(2,arepen(3))
 418           iaux = somare(1,arequa(facpen(indpen,5),2))
 419 cgn        write (ulsort,90012) '.... 1er som de l''arete',
 420 cgn     >  arequa(facpen(indpen,5),2),iaux
 421           if ( iaux.eq.sompe3 ) then
 422             cofape(indpen,5) = 5
 423           else
 424             cofape(indpen,5) = 1
 425           endif
 426           nivqua(facpen(indpen,5)) = nivtri(letria)
 427 cgn        write (ulsort,90012) '.... code de la face 5',
 428 cgn     >  facpen(indpen,5),cofape(indpen,5)
 429 c
 430 c 2.3.3.6. ==> Caracteristiques generales
 431 c
 432 cgn        write (ulsort,90002) '.... Faces',(facpen(indpen,iaux),iaux=1,5)
 433 cgn        write (ulsort,90002) '.... Codes',(cofape(indpen,iaux),iaux=1,5)
 434           hetpen(indpen) = 5500
 435           filpen(indpen) = 0
 436           perpen(indpen) = 0
 437           fampen(indpen) = cfatri(cofxtx,famtri(letria))
 438 cgn        write (ulsort,90002) '.... Famille',fampen(indpen)
 439 c
 440         endif
 441 c
 442 c 2.3.4. ==> Correspondances
 443 c
 444         if ( mod(hettri(letria),10).eq.0 ) then
 445 c
 446           pentri(letria) = indpen
 447           pentri(indtri) = 0
 448 c
 449         else
 450 c
 451           pentri(letria) = 0
 452 c
 453         endif
 454 c
 455    20 continue
 456 c
 457 #ifdef _DEBUG_HOMARD_
 458       write (ulsort,90002) 'indtri', indtri
 459       write (ulsort,90002) 'indpen', indpen
 460 #endif
 461 c
 462       endif
 463 c
 464 c====
 465 c 3. la fin
 466 c====
 467 c
 468       if ( codret.ne.0 ) then
 469 c
 470 #include "envex2.h"
 471 c
 472       write (ulsort,texte(langue,1)) 'Sortie', nompro
 473       write (ulsort,texte(langue,2)) codret
 474       endif
 475 c
 476 #ifdef _DEBUG_HOMARD_
 477       write (ulsort,texte(langue,1)) 'Sortie', nompro
 478       call dmflsh (iaux)
 479 #endif
 480 c
 481       end