src/tool/Creation_Maillage/cmch07.F

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