src/tool/Creation_Maillage/cmch34.F

   1       subroutine cmch34 ( lehexa, listar, listso,
   2      >                    indnoe, indare, indtri, indtet, indpyr,
   3      >                    indptp,
   4      >                    coonoe, hetnoe, arenoe,
   5      >                    famnoe,
   6      >                    hetare, somare,
   7      >                    filare, merare, famare,
   8      >                    hettri, aretri,
   9      >                    filtri, pertri, famtri,
  10      >                    nivtri,
  11      >                    filqua,
  12      >                    hettet, tritet, cotrte,
  13      >                    filtet, pertet, famtet,
  14      >                    hetpyr, facpyr, cofapy,
  15      >                    filpyr, perpyr, fampyr,
  16      >                    quahex, coquhe,
  17      >                    famhex, cfahex,
  18      >                    ulsort, langue, codret )
  19 c ______________________________________________________________________
  20 c
  21 c                             H O M A R D
  22 c
  23 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  24 c
  25 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  26 c aupres des huissiers de justice Simart et Lavoir a Clamart
  27 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  28 c aupres des huissiers de justice
  29 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  30 c
  31 c    HOMARD est une marque deposee d'Electricite de France
  32 c
  33 c Copyright EDF 1996
  34 c Copyright EDF 1998
  35 c Copyright EDF 2002
  36 c Copyright EDF 2020
  37 c ______________________________________________________________________
  38 c
  39 c    Creation du Maillage - Conformite - decoupage des Hexaedres
  40 c    -           -          -                          -
  41 c                         - par 2 Aretes - etat 34
  42 c                                               --
  43 c    Decoupage par les aretes 4 et 9
  44 c ______________________________________________________________________
  45 c .        .     .        .                                            .
  46 c .  nom   . e/s . taille .           description                      .
  47 c .____________________________________________________________________.
  48 c . lehexa . e   .   1    . hexaedre a decouper                        .
  49 c . listar . e   .   12   . liste des aretes de l'hexaedre a decouper  .
  50 c . listso . e   .    8   . liste des sommets de l'hexaedre a decouper .
  51 c . indnoe . es  .   1    . indice du dernier noeud cree               .
  52 c . indare . es  .   1    . indice de la derniere arete creee          .
  53 c . indtri . es  .   1    . indice du dernier triangle cree            .
  54 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  55 c . indpyr . es  .   1    . indice de la derniere pyramide creee       .
  56 c . indptp . e   .   1    . indice du dernier pere enregistre          .
  57 c . coonoe . es  .nouvno*3. coordonnees des noeuds                     .
  58 c . hetnoe . es  . nouvno . historique de l'etat des noeuds            .
  59 c . arenoe . es  . nouvno . arete liee a un nouveau noeud              .
  60 c . famnoe . es  . nouvno . famille des noeuds                         .
  61 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  62 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  63 c . filare . es  . nouvar . premiere fille des aretes                  .
  64 c . merare . es  . nouvar . mere des aretes                            .
  65 c . famare .     . nouvar . famille des aretes                         .
  66 c . hettri . es  . nouvtr . historique de l'etat des triangles         .
  67 c . aretri . es  .nouvtr*3. numeros des 3 aretes des triangles         .
  68 c . filtri . es  . nouvtr . premier fils des triangles                 .
  69 c . pertri . es  . nouvtr . pere des triangles                         .
  70 c . famtri . es  . nouvtr . famille des triangles                      .
  71 c . nivtri . es  . nouvtr . niveau des triangles                       .
  72 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  73 c . hettet . es  . nouvte . historique de l'etat des tetraedres        .
  74 c . tritet . es  .nouvtf*4. numeros des 4 triangles des tetraedres     .
  75 c . cotrte . es  .nouvtf*4. code des 4 triangles des tetraedres        .
  76 c . filtet . es  . nouvte . premier fils des tetraedres                .
  77 c . pertet . es  . nouvte . pere des tetraedres                        .
  78 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  79 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  80 c . famtet . es  . nouvte . famille des tetraedres                     .
  81 c . hetpyr . es  . nouvpy . historique de l'etat des pyramides         .
  82 c . facpyr . es  .nouvyf*5. numeros des 5 faces des pyramides          .
  83 c . cofapy . es  .nouvyf*5. codes des faces des pyramides              .
  84 c . filpyr . es  . nouvpy . premier fils des pyramides                 .
  85 c . perpyr . es  . nouvpy . pere des pyramides                         .
  86 c .        .     .        . si perpyr(i) > 0 : numero de la pyramide   .
  87 c .        .     .        . si perpyr(i) < 0 : -numero dans pphepe     .
  88 c . fampyr . es  . nouvpy . famille des pyramides                      .
  89 c . quahex . e   .nouvhf*6. numeros des 6 quadrangles des hexaedres    .
  90 c . coquhe . e   .nouvhf*6. codes des 6 quadrangles des hexaedres      .
  91 c . famhex . e   . nouvhe . famille des hexaedres                      .
  92 c . cfahex .     . nctfhe. codes des familles des hexaedres            .
  93 c .        .     . nbfhex .   1 : famille MED                          .
  94 c .        .     .        .   2 : type d'hexaedres                     .
  95 c .        .     .        .   3 : famille des tetraedres de conformite .
  96 c .        .     .        .   4 : famille des pyramides de conformite  .
  97 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  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 : aucune arete ne correspond             .
 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 = 'CMCH34' )
 116 c
 117 #include "nblang.h"
 118 c
 119 c 0.2. ==> communs
 120 c
 121 #include "envex1.h"
 122 c
 123 #include "envca1.h"
 124 #include "dicfen.h"
 125 #include "nbfami.h"
 126 #include "nouvnb.h"
 127 c
 128 c 0.3. ==> arguments
 129 c
 130       integer lehexa
 131       integer listar(12), listso(8)
 132       integer indnoe, indare, indtri, indtet, indpyr
 133       integer indptp
 134       integer hetnoe(nouvno), arenoe(nouvno)
 135       integer famnoe(nouvno)
 136       integer hetare(nouvar), somare(2,nouvar)
 137       integer filare(nouvar), merare(nouvar), famare(nouvar)
 138       integer hettri(nouvtr), aretri(nouvtr,3)
 139       integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
 140       integer nivtri(nouvtr)
 141       integer filqua(nouvqu)
 142       integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
 143       integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
 144       integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
 145       integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
 146       integer quahex(nouvhf,6), coquhe(nouvhf,6)
 147       integer famhex(nouvhe), cfahex(nctfhe,nbfhex)
 148 c
 149       double precision coonoe(nouvno,sdim)
 150 c
 151       integer ulsort, langue, codret
 152 c
 153 c 0.4. ==> variables locales
 154 c
 155       integer nbsomm
 156       parameter ( nbsomm = 8 )
 157 c
 158       integer iaux
 159       integer lesnoe(10), lesare(10)
 160       integer tab1(4), tab2(4)
 161       integer nulofa(4)
 162       integer areint(10)
 163       integer areqtr(4,2)
 164       integer triint(22)
 165       integer trifad(4,0:2), cotrvo(4,0:2)
 166       integer niveau
 167 c
 168       integer nbmess
 169       parameter ( nbmess = 10 )
 170       character*80 texte(nblang,nbmess)
 171 c
 172 c 0.5. ==> initialisations
 173 c ______________________________________________________________________
 174 c
 175 c====
 176 c 1. initialisations
 177 c====
 178 c
 179 #include "impr01.h"
 180 c
 181 #ifdef _DEBUG_HOMARD_
 182       write (ulsort,texte(langue,1)) 'Entree', nompro
 183       call dmflsh (iaux)
 184 #endif
 185 c
 186       codret = 0
 187 c
 188 c====
 189 c 2. grandeurs dependant du cas traite
 190 c      lesnoe(1) = S4
 191 c      lesnoe(2) = S1
 192 c      lesnoe(3) = S6
 193 c      lesnoe(4) = S7
 194 c      lesnoe(5) = S3
 195 c      lesnoe(6) = S2
 196 c      lesnoe(7) = S5
 197 c      lesnoe(8) = S8
 198 c      lesnoe( 9) = N4
 199 c      lesnoe(10) = N9
 200 c====
 201 c     iaux = numero local de la 1ere arete coupee
 202       iaux = 4
 203 c
 204 c     lesnoe(9) = noeud milieu de la 1ere arete coupee
 205       lesnoe(9) = somare(2,filare(listar(iaux)))
 206 c
 207 c     iaux = numero local de la 2eme arete coupee
 208       iaux = 9
 209 c
 210 c     lesnoe(10) = noeud milieu de la 2eme arete coupee
 211       lesnoe(10) = somare(2,filare(listar(iaux)))
 212 c
 213 c     lesnoe(i) = sommet a joindre au centre de l'hexaedre pour
 214 c               definir la ieme arete interne
 215       lesnoe(1) = listso(4)
 216       lesnoe(2) = listso(1)
 217       lesnoe(3) = listso(6)
 218       lesnoe(4) = listso(7)
 219       lesnoe(5) = listso(3)
 220       lesnoe(6) = listso(2)
 221       lesnoe(7) = listso(5)
 222       lesnoe(8) = listso(8)
 223 #ifdef _DEBUG_HOMARD_
 224       write(ulsort,2000) 'listso', listso
 225       write(ulsort,2000) 'arete 1', listar(iaux)
 226       write(ulsort,2000) 'lesnoe(9)', lesnoe(9)
 227       write(ulsort,2000) 'arete 2', listar(iaux)
 228       write(ulsort,2000) 'lesnoe(10)', lesnoe(10)
 229       write(ulsort,2001) 'lesnoe(1)', lesnoe(1),'lesnoe(2)', lesnoe(2)
 230       write(ulsort,2001) 'lesnoe(3)', lesnoe(3),'lesnoe(4)', lesnoe(4)
 231       write(ulsort,2001) 'lesnoe(5)', lesnoe(5),'lesnoe(6)', lesnoe(6)
 232       write(ulsort,2001) 'lesnoe(7)', lesnoe(7),'lesnoe(8)', lesnoe(8)
 233  2000 format(a,10i10)
 234  2001 format(a,i10,', ',a,i10)
 235 #endif
 236 c
 237 c  Triangles et aretes tracees sur les faces coupees en 3
 238 c            La premiere pyramide s'appuie sur celle des 2 faces de
 239 c            l'hexaedre qui est non decoupee et de plus petit numero
 240 c            local. Le positionnement de la pyramide a defini une
 241 c            orientation de sa face quadrangulaire.
 242 c            On traite les faces de l'hexaedre coupees en 3 comme suit :
 243 c            . la 1ere et la 2eme partagent la 1ere arete coupee
 244 c            . la 3eme et la 4eme partagent la 2nde arete coupee
 245 c            Le choix de la 1ere est tel que l'ordre 1/2 corresponde a
 246 c            l'orientation de la pyramide numero 1. Idem pour 3/4.
 247 c     trifad(p,0) : triangle central de ce decoupage
 248 c     trifad(p,1) : triangle bordant la pyramide 1
 249 c     trifad(p,2) : triangle bordant la pyramide 2
 250 c     cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la
 251 c                       description du tetraedre voisin
 252 c     areqtr(p,1) : arete interne au quadrangle de bord et bordant le
 253 c                   triangle trifad(p,1)
 254 c     areqtr(p,2) : arete interne au quadrangle de bord et bordant le
 255 c                   triangle trifad(p,2)
 256 c
 257 c     trifad(1,0) = triangle central de la face 1 : FF5
 258 c     trifad(1,1) = triangle de la face 1 bordant PYR1 : FF5 + 1/2
 259 c     trifad(1,2) = triangle de la face 1 bordant PYR2 : FF5 + 2/1
 260 c     areqtr(1,1) : AS7N4
 261 c     areqtr(1,2) : AS8N4
 262 c
 263 c     trifad(2,0) = triangle central de la face 2 : FF1
 264 c     trifad(2,1) = triangle de la face 2 bordant PYR1 : FF1 + 2/1
 265 c     trifad(2,2) = triangle de la face 2 bordant PYR2 : FF1 + 1/2
 266 c     areqtr(2,1) : AS1N4
 267 c     areqtr(2,2) : AS2N4
 268 c
 269 c     trifad(3,0) = triangle central de la face 3 : FF2
 270 c     trifad(3,1) = triangle de la face 3 bordant PYR1 : FF2 + 1/2
 271 c     trifad(3,2) = triangle de la face 3 bordant PYR2 : FF2 + 2/1
 272 c     areqtr(3,1) : AS1N9
 273 c     areqtr(3,2) : AS2N9
 274 c
 275 c     trifad(4,0) = triangle central de la face 4 : FF6
 276 c     trifad(4,1) = triangle de la face 4 bordant PYR1 : FF6 + 2/1
 277 c     trifad(4,2) = triangle de la face 4 bordant PYR2 : FF6 + 1/2
 278 c     areqtr(4,1) : AS7N9
 279 c     areqtr(4,2) : AS8N9
 280 c
 281       nulofa(1) = 5
 282       nulofa(2) = 1
 283       nulofa(3) = 2
 284       nulofa(4) = 6
 285 c
 286       if ( codret.eq.0 ) then
 287 c
 288 #ifdef _DEBUG_HOMARD_
 289       write (ulsort,texte(langue,3)) 'CMCHAA', nompro
 290 #endif
 291       call cmchaa ( nulofa, lehexa,
 292      >              somare,
 293      >              aretri, nivtri,
 294      >              filqua,
 295      >              quahex, coquhe,
 296      >              niveau, areqtr,
 297      >              trifad, cotrvo,
 298      >              ulsort, langue, codret )
 299 c
 300       endif
 301 c
 302 c====
 303 c 3. Creation du noeud interne et des dix aretes internes
 304 c    noecen : N0
 305 c    areint(1) : AS4N0
 306 c    areint(2) : AS1N0
 307 c    areint(3) : AS6N0
 308 c    areint(4) : AS7N0
 309 c    areint(5) : AS3N0
 310 c    areint(6) : AS2N0
 311 c    areint(7) : AS5N0
 312 c    areint(8) : AS8N0
 313 c    areint( 9) : AN4N0
 314 c    areint(10) : AN9N0
 315 c====
 316 c
 317       if ( codret.eq.0 ) then
 318 c
 319 #ifdef _DEBUG_HOMARD_
 320       write (ulsort,texte(langue,3)) 'CMCHAB', nompro
 321       write (ulsort,3001) indnoe+1
 322  3001 format('.. noeud',i10)
 323       write (ulsort,3002) indare+1, indare+10
 324  3002 format('.. aretes de',i10,' a',i10)
 325 #endif
 326       iaux = 10
 327       call cmchpb ( indnoe, indare, iaux,
 328      >              nbsomm, lesnoe, areint,
 329      >              coonoe, hetnoe, arenoe,
 330      >              famnoe,
 331      >              hetare, somare,
 332      >              filare, merare, famare,
 333      >              ulsort, langue, codret )
 334 c
 335       endif
 336 c
 337 c====
 338 c 4. Creation des triangles internes
 339 c    triint(1) : FA7
 340 c    triint(2) : FA2
 341 c    triint(3) : FA5
 342 c    triint(4) : FA10
 343 c    triint(5) : FA8
 344 c    triint(6) : FA3
 345 c    triint(7) : FA6
 346 c    triint(8) : FA11
 347 c    triint(9) : FA1
 348 c    triint(10) : FA12
 349 c    triint(11) : FS7N4
 350 c    triint(12) : FS1N4
 351 c    triint(13) : FS1N9
 352 c    triint(14) : FS7N9
 353 c    triint(15) : FS8N4
 354 c    triint(16) : FS2N4
 355 c    triint(17) : FS2N9
 356 c    triint(18) : FS8N9
 357 c    triint(19) : FS4N4
 358 c    triint(20) : FS7N12
 359 c    triint(21) : FS3N4
 360 c    triint(22) : FS5N9
 361 c====
 362 c
 363       if ( codret.eq.0 ) then
 364 c
 365       lesare(1) = listar(7)
 366       lesare(2) = listar(2)
 367       lesare(3) = listar(5)
 368       lesare(4) = listar(10)
 369       lesare(5) = listar(8)
 370       lesare(6) = listar(3)
 371       lesare(7) = listar(6)
 372       lesare(8) = listar(11)
 373       lesare(9) = listar(1)
 374       lesare(10) = listar(12)
 375 c
 376       tab1(1) = areint(1)
 377       tab2(1) = areint(9)
 378       tab1(2) = areint(10)
 379       tab2(2) = areint(3)
 380       tab1(3) = areint(9)
 381       tab2(3) = areint(5)
 382       tab1(4) = areint(7)
 383       tab2(4) = areint(10)
 384 c
 385 #ifdef _DEBUG_HOMARD_
 386       write (ulsort,texte(langue,3)) 'CMCHAC', nompro
 387       write (ulsort,4000) indtri+1, indtri+10
 388  4000 format('.. triangles de',i10,' a',i10)
 389 #endif
 390       call cmchac ( indtri, triint,
 391      >              lesare, tab1, tab2,
 392      >              trifad, areint, areqtr, niveau,
 393      >              aretri, famtri, hettri,
 394      >              filtri, pertri, nivtri,
 395      >              ulsort, langue, codret )
 396 c
 397       endif
 398 c
 399 c====
 400 c 5. Creation des deux pyramides
 401 c====
 402 c
 403       if ( codret.eq.0 ) then
 404 c
 405       nulofa(1) = 3
 406       nulofa(2) = 4
 407       tab1(1) = 1
 408       tab1(2) = -5
 409 #ifdef _DEBUG_HOMARD_
 410       write (ulsort,texte(langue,3)) 'CMCHAD', nompro
 411       write (ulsort,5000) indpyr+1, indpyr+2
 412  5000 format('.. pyramides de',i10,' a',i10)
 413 #endif
 414       call cmchad ( nulofa, lehexa,
 415      >              indpyr, indptp,
 416      >              triint,   tab1,
 417      >              hetpyr, facpyr, cofapy,
 418      >              filpyr, perpyr, fampyr,
 419      >              quahex, coquhe,
 420      >              famhex, cfahex,
 421      >              ulsort, langue, codret )
 422 c
 423       endif
 424 c
 425 c====
 426 c 6. Creation des douze tetraedres dans l'ordre suivant :
 427 c  tetraedre 7
 428 c  tetraedre 9
 429 c  tetraedre 8
 430 c  tetraedre 1
 431 c  tetraedre 3
 432 c  tetraedre 2
 433 c  tetraedre 4
 434 c  tetraedre 6
 435 c  tetraedre 5
 436 c  tetraedre 10
 437 c  tetraedre 12
 438 c  tetraedre 11
 439 c====
 440 c
 441       if ( codret.eq.0 ) then
 442 c
 443 #ifdef _DEBUG_HOMARD_
 444       write (ulsort,texte(langue,3)) 'CMCHAE', nompro
 445       write (ulsort,6000) indtet+1, indtet+12
 446  6000 format('.. tetraedres de',i10,' a',i10)
 447 #endif
 448 c
 449       iaux = 2
 450       call cmchae ( lehexa, indtet, indptp,   iaux,
 451      >              trifad, cotrvo, triint,
 452      >              hettet, tritet, cotrte,
 453      >              filtet, pertet, famtet,
 454      >              famhex, cfahex,
 455      >              ulsort, langue, codret )
 456 c
 457       endif
 458 c
 459 c====
 460 c 7. la fin
 461 c====
 462 c
 463       if ( codret.ne.0 ) then
 464 c
 465 #include "envex2.h"
 466 c
 467       write (ulsort,texte(langue,1)) 'Sortie', nompro
 468       write (ulsort,texte(langue,2)) codret
 469 c
 470       endif
 471 c
 472 #ifdef _DEBUG_HOMARD_
 473       write (ulsort,texte(langue,1)) 'Sortie', nompro
 474       call dmflsh (iaux)
 475 #endif
 476 c
 477       end